1*> \brief \b DZSUM1 forms the 1-norm of the complex vector using the true absolute value.
2*
3*  =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6*            http://www.netlib.org/lapack/explore-html/
7*
8*> \htmlonly
9*> Download DZSUM1 + dependencies
10*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dzsum1.f">
11*> [TGZ]</a>
12*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dzsum1.f">
13*> [ZIP]</a>
14*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dzsum1.f">
15*> [TXT]</a>
16*> \endhtmlonly
17*
18*  Definition:
19*  ===========
20*
21*       DOUBLE PRECISION FUNCTION DZSUM1( N, CX, INCX )
22*
23*       .. Scalar Arguments ..
24*       INTEGER            INCX, N
25*       ..
26*       .. Array Arguments ..
27*       COMPLEX*16         CX( * )
28*       ..
29*
30*
31*> \par Purpose:
32*  =============
33*>
34*> \verbatim
35*>
36*> DZSUM1 takes the sum of the absolute values of a complex
37*> vector and returns a double precision result.
38*>
39*> Based on DZASUM from the Level 1 BLAS.
40*> The change is to use the 'genuine' absolute value.
41*> \endverbatim
42*
43*  Arguments:
44*  ==========
45*
46*> \param[in] N
47*> \verbatim
48*>          N is INTEGER
49*>          The number of elements in the vector CX.
50*> \endverbatim
51*>
52*> \param[in] CX
53*> \verbatim
54*>          CX is COMPLEX*16 array, dimension (N)
55*>          The vector whose elements will be summed.
56*> \endverbatim
57*>
58*> \param[in] INCX
59*> \verbatim
60*>          INCX is INTEGER
61*>          The spacing between successive values of CX.  INCX > 0.
62*> \endverbatim
63*
64*  Authors:
65*  ========
66*
67*> \author Univ. of Tennessee
68*> \author Univ. of California Berkeley
69*> \author Univ. of Colorado Denver
70*> \author NAG Ltd.
71*
72*> \date December 2016
73*
74*> \ingroup complex16OTHERauxiliary
75*
76*> \par Contributors:
77*  ==================
78*>
79*> Nick Higham for use with ZLACON.
80*
81*  =====================================================================
82      DOUBLE PRECISION FUNCTION DZSUM1( N, CX, INCX )
83*
84*  -- LAPACK auxiliary routine (version 3.7.0) --
85*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
86*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
87*     December 2016
88*
89*     .. Scalar Arguments ..
90      INTEGER            INCX, N
91*     ..
92*     .. Array Arguments ..
93      COMPLEX*16         CX( * )
94*     ..
95*
96*  =====================================================================
97*
98*     .. Local Scalars ..
99      INTEGER            I, NINCX
100      DOUBLE PRECISION   STEMP
101*     ..
102*     .. Intrinsic Functions ..
103      INTRINSIC          ABS
104*     ..
105*     .. Executable Statements ..
106*
107      DZSUM1 = 0.0D0
108      STEMP = 0.0D0
109      IF( N.LE.0 )
110     $   RETURN
111      IF( INCX.EQ.1 )
112     $   GO TO 20
113*
114*     CODE FOR INCREMENT NOT EQUAL TO 1
115*
116      NINCX = N*INCX
117      DO 10 I = 1, NINCX, INCX
118*
119*        NEXT LINE MODIFIED.
120*
121         STEMP = STEMP + ABS( CX( I ) )
122   10 CONTINUE
123      DZSUM1 = STEMP
124      RETURN
125*
126*     CODE FOR INCREMENT EQUAL TO 1
127*
128   20 CONTINUE
129      DO 30 I = 1, N
130*
131*        NEXT LINE MODIFIED.
132*
133         STEMP = STEMP + ABS( CX( I ) )
134   30 CONTINUE
135      DZSUM1 = STEMP
136      RETURN
137*
138*     End of DZSUM1
139*
140      END
141*> \brief \b ILAZLC scans a matrix for its last non-zero column.
142*
143*  =========== DOCUMENTATION ===========
144*
145* Online html documentation available at
146*            http://www.netlib.org/lapack/explore-html/
147*
148*> \htmlonly
149*> Download ILAZLC + dependencies
150*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ilazlc.f">
151*> [TGZ]</a>
152*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ilazlc.f">
153*> [ZIP]</a>
154*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ilazlc.f">
155*> [TXT]</a>
156*> \endhtmlonly
157*
158*  Definition:
159*  ===========
160*
161*       INTEGER FUNCTION ILAZLC( M, N, A, LDA )
162*
163*       .. Scalar Arguments ..
164*       INTEGER            M, N, LDA
165*       ..
166*       .. Array Arguments ..
167*       COMPLEX*16         A( LDA, * )
168*       ..
169*
170*
171*> \par Purpose:
172*  =============
173*>
174*> \verbatim
175*>
176*> ILAZLC scans A for its last non-zero column.
177*> \endverbatim
178*
179*  Arguments:
180*  ==========
181*
182*> \param[in] M
183*> \verbatim
184*>          M is INTEGER
185*>          The number of rows of the matrix A.
186*> \endverbatim
187*>
188*> \param[in] N
189*> \verbatim
190*>          N is INTEGER
191*>          The number of columns of the matrix A.
192*> \endverbatim
193*>
194*> \param[in] A
195*> \verbatim
196*>          A is COMPLEX*16 array, dimension (LDA,N)
197*>          The m by n matrix A.
198*> \endverbatim
199*>
200*> \param[in] LDA
201*> \verbatim
202*>          LDA is INTEGER
203*>          The leading dimension of the array A. LDA >= max(1,M).
204*> \endverbatim
205*
206*  Authors:
207*  ========
208*
209*> \author Univ. of Tennessee
210*> \author Univ. of California Berkeley
211*> \author Univ. of Colorado Denver
212*> \author NAG Ltd.
213*
214*> \date December 2016
215*
216*> \ingroup complex16OTHERauxiliary
217*
218*  =====================================================================
219      INTEGER FUNCTION ILAZLC( M, N, A, LDA )
220*
221*  -- LAPACK auxiliary routine (version 3.7.0) --
222*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
223*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
224*     December 2016
225*
226*     .. Scalar Arguments ..
227      INTEGER            M, N, LDA
228*     ..
229*     .. Array Arguments ..
230      COMPLEX*16         A( LDA, * )
231*     ..
232*
233*  =====================================================================
234*
235*     .. Parameters ..
236      COMPLEX*16       ZERO
237      PARAMETER ( ZERO = (0.0D+0, 0.0D+0) )
238*     ..
239*     .. Local Scalars ..
240      INTEGER I
241*     ..
242*     .. Executable Statements ..
243*
244*     Quick test for the common case where one corner is non-zero.
245      IF( N.EQ.0 ) THEN
246         ILAZLC = N
247      ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
248         ILAZLC = N
249      ELSE
250*     Now scan each column from the end, returning with the first non-zero.
251         DO ILAZLC = N, 1, -1
252            DO I = 1, M
253               IF( A(I, ILAZLC).NE.ZERO ) RETURN
254            END DO
255         END DO
256      END IF
257      RETURN
258      END
259*> \brief \b ILAZLR scans a matrix for its last non-zero row.
260*
261*  =========== DOCUMENTATION ===========
262*
263* Online html documentation available at
264*            http://www.netlib.org/lapack/explore-html/
265*
266*> \htmlonly
267*> Download ILAZLR + dependencies
268*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ilazlr.f">
269*> [TGZ]</a>
270*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ilazlr.f">
271*> [ZIP]</a>
272*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ilazlr.f">
273*> [TXT]</a>
274*> \endhtmlonly
275*
276*  Definition:
277*  ===========
278*
279*       INTEGER FUNCTION ILAZLR( M, N, A, LDA )
280*
281*       .. Scalar Arguments ..
282*       INTEGER            M, N, LDA
283*       ..
284*       .. Array Arguments ..
285*       COMPLEX*16         A( LDA, * )
286*       ..
287*
288*
289*> \par Purpose:
290*  =============
291*>
292*> \verbatim
293*>
294*> ILAZLR scans A for its last non-zero row.
295*> \endverbatim
296*
297*  Arguments:
298*  ==========
299*
300*> \param[in] M
301*> \verbatim
302*>          M is INTEGER
303*>          The number of rows of the matrix A.
304*> \endverbatim
305*>
306*> \param[in] N
307*> \verbatim
308*>          N is INTEGER
309*>          The number of columns of the matrix A.
310*> \endverbatim
311*>
312*> \param[in] A
313*> \verbatim
314*>          A is COMPLEX*16 array, dimension (LDA,N)
315*>          The m by n matrix A.
316*> \endverbatim
317*>
318*> \param[in] LDA
319*> \verbatim
320*>          LDA is INTEGER
321*>          The leading dimension of the array A. LDA >= max(1,M).
322*> \endverbatim
323*
324*  Authors:
325*  ========
326*
327*> \author Univ. of Tennessee
328*> \author Univ. of California Berkeley
329*> \author Univ. of Colorado Denver
330*> \author NAG Ltd.
331*
332*> \date December 2016
333*
334*> \ingroup complex16OTHERauxiliary
335*
336*  =====================================================================
337      INTEGER FUNCTION ILAZLR( M, N, A, LDA )
338*
339*  -- LAPACK auxiliary routine (version 3.7.0) --
340*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
341*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
342*     December 2016
343*
344*     .. Scalar Arguments ..
345      INTEGER            M, N, LDA
346*     ..
347*     .. Array Arguments ..
348      COMPLEX*16         A( LDA, * )
349*     ..
350*
351*  =====================================================================
352*
353*     .. Parameters ..
354      COMPLEX*16       ZERO
355      PARAMETER ( ZERO = (0.0D+0, 0.0D+0) )
356*     ..
357*     .. Local Scalars ..
358      INTEGER I, J
359*     ..
360*     .. Executable Statements ..
361*
362*     Quick test for the common case where one corner is non-zero.
363      IF( M.EQ.0 ) THEN
364         ILAZLR = M
365      ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
366         ILAZLR = M
367      ELSE
368*     Scan up each column tracking the last zero row seen.
369         ILAZLR = 0
370         DO J = 1, N
371            I=M
372            DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1))
373               I=I-1
374            ENDDO
375            ILAZLR = MAX( ILAZLR, I )
376         END DO
377      END IF
378      RETURN
379      END
380*> \brief \b IZMAX1 finds the index of the first vector element of maximum absolute value.
381*
382*  =========== DOCUMENTATION ===========
383*
384* Online html documentation available at
385*            http://www.netlib.org/lapack/explore-html/
386*
387*> \htmlonly
388*> Download IZMAX1 + dependencies
389*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/izmax1.f">
390*> [TGZ]</a>
391*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/izmax1.f">
392*> [ZIP]</a>
393*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/izmax1.f">
394*> [TXT]</a>
395*> \endhtmlonly
396*
397*  Definition:
398*  ===========
399*
400*       INTEGER          FUNCTION IZMAX1( N, ZX, INCX )
401*
402*       .. Scalar Arguments ..
403*       INTEGER            INCX, N
404*       ..
405*       .. Array Arguments ..
406*       COMPLEX*16         ZX( * )
407*       ..
408*
409*
410*> \par Purpose:
411*  =============
412*>
413*> \verbatim
414*>
415*> IZMAX1 finds the index of the first vector element of maximum absolute value.
416*>
417*> Based on IZAMAX from Level 1 BLAS.
418*> The change is to use the 'genuine' absolute value.
419*> \endverbatim
420*
421*  Arguments:
422*  ==========
423*
424*> \param[in] N
425*> \verbatim
426*>          N is INTEGER
427*>          The number of elements in the vector ZX.
428*> \endverbatim
429*>
430*> \param[in] ZX
431*> \verbatim
432*>          ZX is COMPLEX*16 array, dimension (N)
433*>          The vector ZX. The IZMAX1 function returns the index of its first
434*>          element of maximum absolute value.
435*> \endverbatim
436*>
437*> \param[in] INCX
438*> \verbatim
439*>          INCX is INTEGER
440*>          The spacing between successive values of ZX.  INCX >= 1.
441*> \endverbatim
442*
443*  Authors:
444*  ========
445*
446*> \author Univ. of Tennessee
447*> \author Univ. of California Berkeley
448*> \author Univ. of Colorado Denver
449*> \author NAG Ltd.
450*
451*> \date February 2014
452*
453*> \ingroup complexOTHERauxiliary
454*
455*> \par Contributors:
456*  ==================
457*>
458*> Nick Higham for use with ZLACON.
459*
460*  =====================================================================
461      INTEGER FUNCTION IZMAX1( N, ZX, INCX )
462*
463*  -- LAPACK auxiliary routine (version 3.7.0) --
464*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
465*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
466*     February 2014
467*
468*     .. Scalar Arguments ..
469      INTEGER            INCX, N
470*     ..
471*     .. Array Arguments ..
472      COMPLEX*16         ZX(*)
473*     ..
474*
475*  =====================================================================
476*
477*     .. Local Scalars ..
478      DOUBLE PRECISION   DMAX
479      INTEGER            I, IX
480*     ..
481*     .. Intrinsic Functions ..
482      INTRINSIC          ABS
483*     ..
484*     .. Executable Statements ..
485*
486      IZMAX1 = 0
487      IF (N.LT.1 .OR. INCX.LE.0) RETURN
488      IZMAX1 = 1
489      IF (N.EQ.1) RETURN
490      IF (INCX.EQ.1) THEN
491*
492*        code for increment equal to 1
493*
494         DMAX = ABS(ZX(1))
495         DO I = 2,N
496            IF (ABS(ZX(I)).GT.DMAX) THEN
497               IZMAX1 = I
498               DMAX = ABS(ZX(I))
499            END IF
500         END DO
501      ELSE
502*
503*        code for increment not equal to 1
504*
505         IX = 1
506         DMAX = ABS(ZX(1))
507         IX = IX + INCX
508         DO I = 2,N
509            IF (ABS(ZX(IX)).GT.DMAX) THEN
510               IZMAX1 = I
511               DMAX = ABS(ZX(IX))
512            END IF
513            IX = IX + INCX
514         END DO
515      END IF
516      RETURN
517*
518*     End of IZMAX1
519*
520      END
521*> \brief \b ZBDSQR
522*
523*  =========== DOCUMENTATION ===========
524*
525* Online html documentation available at
526*            http://www.netlib.org/lapack/explore-html/
527*
528*> \htmlonly
529*> Download ZBDSQR + dependencies
530*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zbdsqr.f">
531*> [TGZ]</a>
532*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zbdsqr.f">
533*> [ZIP]</a>
534*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zbdsqr.f">
535*> [TXT]</a>
536*> \endhtmlonly
537*
538*  Definition:
539*  ===========
540*
541*       SUBROUTINE ZBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U,
542*                          LDU, C, LDC, RWORK, INFO )
543*
544*       .. Scalar Arguments ..
545*       CHARACTER          UPLO
546*       INTEGER            INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU
547*       ..
548*       .. Array Arguments ..
549*       DOUBLE PRECISION   D( * ), E( * ), RWORK( * )
550*       COMPLEX*16         C( LDC, * ), U( LDU, * ), VT( LDVT, * )
551*       ..
552*
553*
554*> \par Purpose:
555*  =============
556*>
557*> \verbatim
558*>
559*> ZBDSQR computes the singular values and, optionally, the right and/or
560*> left singular vectors from the singular value decomposition (SVD) of
561*> a real N-by-N (upper or lower) bidiagonal matrix B using the implicit
562*> zero-shift QR algorithm.  The SVD of B has the form
563*>
564*>    B = Q * S * P**H
565*>
566*> where S is the diagonal matrix of singular values, Q is an orthogonal
567*> matrix of left singular vectors, and P is an orthogonal matrix of
568*> right singular vectors.  If left singular vectors are requested, this
569*> subroutine actually returns U*Q instead of Q, and, if right singular
570*> vectors are requested, this subroutine returns P**H*VT instead of
571*> P**H, for given complex input matrices U and VT.  When U and VT are
572*> the unitary matrices that reduce a general matrix A to bidiagonal
573*> form: A = U*B*VT, as computed by ZGEBRD, then
574*>
575*>    A = (U*Q) * S * (P**H*VT)
576*>
577*> is the SVD of A.  Optionally, the subroutine may also compute Q**H*C
578*> for a given complex input matrix C.
579*>
580*> See "Computing  Small Singular Values of Bidiagonal Matrices With
581*> Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,
582*> LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,
583*> no. 5, pp. 873-912, Sept 1990) and
584*> "Accurate singular values and differential qd algorithms," by
585*> B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics
586*> Department, University of California at Berkeley, July 1992
587*> for a detailed description of the algorithm.
588*> \endverbatim
589*
590*  Arguments:
591*  ==========
592*
593*> \param[in] UPLO
594*> \verbatim
595*>          UPLO is CHARACTER*1
596*>          = 'U':  B is upper bidiagonal;
597*>          = 'L':  B is lower bidiagonal.
598*> \endverbatim
599*>
600*> \param[in] N
601*> \verbatim
602*>          N is INTEGER
603*>          The order of the matrix B.  N >= 0.
604*> \endverbatim
605*>
606*> \param[in] NCVT
607*> \verbatim
608*>          NCVT is INTEGER
609*>          The number of columns of the matrix VT. NCVT >= 0.
610*> \endverbatim
611*>
612*> \param[in] NRU
613*> \verbatim
614*>          NRU is INTEGER
615*>          The number of rows of the matrix U. NRU >= 0.
616*> \endverbatim
617*>
618*> \param[in] NCC
619*> \verbatim
620*>          NCC is INTEGER
621*>          The number of columns of the matrix C. NCC >= 0.
622*> \endverbatim
623*>
624*> \param[in,out] D
625*> \verbatim
626*>          D is DOUBLE PRECISION array, dimension (N)
627*>          On entry, the n diagonal elements of the bidiagonal matrix B.
628*>          On exit, if INFO=0, the singular values of B in decreasing
629*>          order.
630*> \endverbatim
631*>
632*> \param[in,out] E
633*> \verbatim
634*>          E is DOUBLE PRECISION array, dimension (N-1)
635*>          On entry, the N-1 offdiagonal elements of the bidiagonal
636*>          matrix B.
637*>          On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E
638*>          will contain the diagonal and superdiagonal elements of a
639*>          bidiagonal matrix orthogonally equivalent to the one given
640*>          as input.
641*> \endverbatim
642*>
643*> \param[in,out] VT
644*> \verbatim
645*>          VT is COMPLEX*16 array, dimension (LDVT, NCVT)
646*>          On entry, an N-by-NCVT matrix VT.
647*>          On exit, VT is overwritten by P**H * VT.
648*>          Not referenced if NCVT = 0.
649*> \endverbatim
650*>
651*> \param[in] LDVT
652*> \verbatim
653*>          LDVT is INTEGER
654*>          The leading dimension of the array VT.
655*>          LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.
656*> \endverbatim
657*>
658*> \param[in,out] U
659*> \verbatim
660*>          U is COMPLEX*16 array, dimension (LDU, N)
661*>          On entry, an NRU-by-N matrix U.
662*>          On exit, U is overwritten by U * Q.
663*>          Not referenced if NRU = 0.
664*> \endverbatim
665*>
666*> \param[in] LDU
667*> \verbatim
668*>          LDU is INTEGER
669*>          The leading dimension of the array U.  LDU >= max(1,NRU).
670*> \endverbatim
671*>
672*> \param[in,out] C
673*> \verbatim
674*>          C is COMPLEX*16 array, dimension (LDC, NCC)
675*>          On entry, an N-by-NCC matrix C.
676*>          On exit, C is overwritten by Q**H * C.
677*>          Not referenced if NCC = 0.
678*> \endverbatim
679*>
680*> \param[in] LDC
681*> \verbatim
682*>          LDC is INTEGER
683*>          The leading dimension of the array C.
684*>          LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.
685*> \endverbatim
686*>
687*> \param[out] RWORK
688*> \verbatim
689*>          RWORK is DOUBLE PRECISION array, dimension (4*N)
690*> \endverbatim
691*>
692*> \param[out] INFO
693*> \verbatim
694*>          INFO is INTEGER
695*>          = 0:  successful exit
696*>          < 0:  If INFO = -i, the i-th argument had an illegal value
697*>          > 0:  the algorithm did not converge; D and E contain the
698*>                elements of a bidiagonal matrix which is orthogonally
699*>                similar to the input matrix B;  if INFO = i, i
700*>                elements of E have not converged to zero.
701*> \endverbatim
702*
703*> \par Internal Parameters:
704*  =========================
705*>
706*> \verbatim
707*>  TOLMUL  DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8)))
708*>          TOLMUL controls the convergence criterion of the QR loop.
709*>          If it is positive, TOLMUL*EPS is the desired relative
710*>             precision in the computed singular values.
711*>          If it is negative, abs(TOLMUL*EPS*sigma_max) is the
712*>             desired absolute accuracy in the computed singular
713*>             values (corresponds to relative accuracy
714*>             abs(TOLMUL*EPS) in the largest singular value.
715*>          abs(TOLMUL) should be between 1 and 1/EPS, and preferably
716*>             between 10 (for fast convergence) and .1/EPS
717*>             (for there to be some accuracy in the results).
718*>          Default is to lose at either one eighth or 2 of the
719*>             available decimal digits in each computed singular value
720*>             (whichever is smaller).
721*>
722*>  MAXITR  INTEGER, default = 6
723*>          MAXITR controls the maximum number of passes of the
724*>          algorithm through its inner loop. The algorithms stops
725*>          (and so fails to converge) if the number of passes
726*>          through the inner loop exceeds MAXITR*N**2.
727*> \endverbatim
728*
729*  Authors:
730*  ========
731*
732*> \author Univ. of Tennessee
733*> \author Univ. of California Berkeley
734*> \author Univ. of Colorado Denver
735*> \author NAG Ltd.
736*
737*> \date December 2016
738*
739*> \ingroup complex16OTHERcomputational
740*
741*  =====================================================================
742      SUBROUTINE ZBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U,
743     $                   LDU, C, LDC, RWORK, INFO )
744*
745*  -- LAPACK computational routine (version 3.7.0) --
746*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
747*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
748*     December 2016
749*
750*     .. Scalar Arguments ..
751      CHARACTER          UPLO
752      INTEGER            INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU
753*     ..
754*     .. Array Arguments ..
755      DOUBLE PRECISION   D( * ), E( * ), RWORK( * )
756      COMPLEX*16         C( LDC, * ), U( LDU, * ), VT( LDVT, * )
757*     ..
758*
759*  =====================================================================
760*
761*     .. Parameters ..
762      DOUBLE PRECISION   ZERO
763      PARAMETER          ( ZERO = 0.0D0 )
764      DOUBLE PRECISION   ONE
765      PARAMETER          ( ONE = 1.0D0 )
766      DOUBLE PRECISION   NEGONE
767      PARAMETER          ( NEGONE = -1.0D0 )
768      DOUBLE PRECISION   HNDRTH
769      PARAMETER          ( HNDRTH = 0.01D0 )
770      DOUBLE PRECISION   TEN
771      PARAMETER          ( TEN = 10.0D0 )
772      DOUBLE PRECISION   HNDRD
773      PARAMETER          ( HNDRD = 100.0D0 )
774      DOUBLE PRECISION   MEIGTH
775      PARAMETER          ( MEIGTH = -0.125D0 )
776      INTEGER            MAXITR
777      PARAMETER          ( MAXITR = 6 )
778*     ..
779*     .. Local Scalars ..
780      LOGICAL            LOWER, ROTATE
781      INTEGER            I, IDIR, ISUB, ITER, J, LL, LLL, M, MAXIT, NM1,
782     $                   NM12, NM13, OLDLL, OLDM
783      DOUBLE PRECISION   ABSE, ABSS, COSL, COSR, CS, EPS, F, G, H, MU,
784     $                   OLDCS, OLDSN, R, SHIFT, SIGMN, SIGMX, SINL,
785     $                   SINR, SLL, SMAX, SMIN, SMINL, SMINOA,
786     $                   SN, THRESH, TOL, TOLMUL, UNFL
787*     ..
788*     .. External Functions ..
789      LOGICAL            LSAME
790      DOUBLE PRECISION   DLAMCH
791      EXTERNAL           LSAME, DLAMCH
792*     ..
793*     .. External Subroutines ..
794      EXTERNAL           DLARTG, DLAS2, DLASQ1, DLASV2, XERBLA, ZDROT,
795     $                   ZDSCAL, ZLASR, ZSWAP
796*     ..
797*     .. Intrinsic Functions ..
798      INTRINSIC          ABS, DBLE, MAX, MIN, SIGN, SQRT
799*     ..
800*     .. Executable Statements ..
801*
802*     Test the input parameters.
803*
804      INFO = 0
805      LOWER = LSAME( UPLO, 'L' )
806      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LOWER ) THEN
807         INFO = -1
808      ELSE IF( N.LT.0 ) THEN
809         INFO = -2
810      ELSE IF( NCVT.LT.0 ) THEN
811         INFO = -3
812      ELSE IF( NRU.LT.0 ) THEN
813         INFO = -4
814      ELSE IF( NCC.LT.0 ) THEN
815         INFO = -5
816      ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR.
817     $         ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN
818         INFO = -9
819      ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN
820         INFO = -11
821      ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR.
822     $         ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN
823         INFO = -13
824      END IF
825      IF( INFO.NE.0 ) THEN
826         CALL XERBLA( 'ZBDSQR', -INFO )
827         RETURN
828      END IF
829      IF( N.EQ.0 )
830     $   RETURN
831      IF( N.EQ.1 )
832     $   GO TO 160
833*
834*     ROTATE is true if any singular vectors desired, false otherwise
835*
836      ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 )
837*
838*     If no singular vectors desired, use qd algorithm
839*
840      IF( .NOT.ROTATE ) THEN
841         CALL DLASQ1( N, D, E, RWORK, INFO )
842*
843*     If INFO equals 2, dqds didn't finish, try to finish
844*
845         IF( INFO .NE. 2 ) RETURN
846         INFO = 0
847      END IF
848*
849      NM1 = N - 1
850      NM12 = NM1 + NM1
851      NM13 = NM12 + NM1
852      IDIR = 0
853*
854*     Get machine constants
855*
856      EPS = DLAMCH( 'Epsilon' )
857      UNFL = DLAMCH( 'Safe minimum' )
858*
859*     If matrix lower bidiagonal, rotate to be upper bidiagonal
860*     by applying Givens rotations on the left
861*
862      IF( LOWER ) THEN
863         DO 10 I = 1, N - 1
864            CALL DLARTG( D( I ), E( I ), CS, SN, R )
865            D( I ) = R
866            E( I ) = SN*D( I+1 )
867            D( I+1 ) = CS*D( I+1 )
868            RWORK( I ) = CS
869            RWORK( NM1+I ) = SN
870   10    CONTINUE
871*
872*        Update singular vectors if desired
873*
874         IF( NRU.GT.0 )
875     $      CALL ZLASR( 'R', 'V', 'F', NRU, N, RWORK( 1 ), RWORK( N ),
876     $                  U, LDU )
877         IF( NCC.GT.0 )
878     $      CALL ZLASR( 'L', 'V', 'F', N, NCC, RWORK( 1 ), RWORK( N ),
879     $                  C, LDC )
880      END IF
881*
882*     Compute singular values to relative accuracy TOL
883*     (By setting TOL to be negative, algorithm will compute
884*     singular values to absolute accuracy ABS(TOL)*norm(input matrix))
885*
886      TOLMUL = MAX( TEN, MIN( HNDRD, EPS**MEIGTH ) )
887      TOL = TOLMUL*EPS
888*
889*     Compute approximate maximum, minimum singular values
890*
891      SMAX = ZERO
892      DO 20 I = 1, N
893         SMAX = MAX( SMAX, ABS( D( I ) ) )
894   20 CONTINUE
895      DO 30 I = 1, N - 1
896         SMAX = MAX( SMAX, ABS( E( I ) ) )
897   30 CONTINUE
898      SMINL = ZERO
899      IF( TOL.GE.ZERO ) THEN
900*
901*        Relative accuracy desired
902*
903         SMINOA = ABS( D( 1 ) )
904         IF( SMINOA.EQ.ZERO )
905     $      GO TO 50
906         MU = SMINOA
907         DO 40 I = 2, N
908            MU = ABS( D( I ) )*( MU / ( MU+ABS( E( I-1 ) ) ) )
909            SMINOA = MIN( SMINOA, MU )
910            IF( SMINOA.EQ.ZERO )
911     $         GO TO 50
912   40    CONTINUE
913   50    CONTINUE
914         SMINOA = SMINOA / SQRT( DBLE( N ) )
915         THRESH = MAX( TOL*SMINOA, MAXITR*N*N*UNFL )
916      ELSE
917*
918*        Absolute accuracy desired
919*
920         THRESH = MAX( ABS( TOL )*SMAX, MAXITR*N*N*UNFL )
921      END IF
922*
923*     Prepare for main iteration loop for the singular values
924*     (MAXIT is the maximum number of passes through the inner
925*     loop permitted before nonconvergence signalled.)
926*
927      MAXIT = MAXITR*N*N
928      ITER = 0
929      OLDLL = -1
930      OLDM = -1
931*
932*     M points to last element of unconverged part of matrix
933*
934      M = N
935*
936*     Begin main iteration loop
937*
938   60 CONTINUE
939*
940*     Check for convergence or exceeding iteration count
941*
942      IF( M.LE.1 )
943     $   GO TO 160
944      IF( ITER.GT.MAXIT )
945     $   GO TO 200
946*
947*     Find diagonal block of matrix to work on
948*
949      IF( TOL.LT.ZERO .AND. ABS( D( M ) ).LE.THRESH )
950     $   D( M ) = ZERO
951      SMAX = ABS( D( M ) )
952      SMIN = SMAX
953      DO 70 LLL = 1, M - 1
954         LL = M - LLL
955         ABSS = ABS( D( LL ) )
956         ABSE = ABS( E( LL ) )
957         IF( TOL.LT.ZERO .AND. ABSS.LE.THRESH )
958     $      D( LL ) = ZERO
959         IF( ABSE.LE.THRESH )
960     $      GO TO 80
961         SMIN = MIN( SMIN, ABSS )
962         SMAX = MAX( SMAX, ABSS, ABSE )
963   70 CONTINUE
964      LL = 0
965      GO TO 90
966   80 CONTINUE
967      E( LL ) = ZERO
968*
969*     Matrix splits since E(LL) = 0
970*
971      IF( LL.EQ.M-1 ) THEN
972*
973*        Convergence of bottom singular value, return to top of loop
974*
975         M = M - 1
976         GO TO 60
977      END IF
978   90 CONTINUE
979      LL = LL + 1
980*
981*     E(LL) through E(M-1) are nonzero, E(LL-1) is zero
982*
983      IF( LL.EQ.M-1 ) THEN
984*
985*        2 by 2 block, handle separately
986*
987         CALL DLASV2( D( M-1 ), E( M-1 ), D( M ), SIGMN, SIGMX, SINR,
988     $                COSR, SINL, COSL )
989         D( M-1 ) = SIGMX
990         E( M-1 ) = ZERO
991         D( M ) = SIGMN
992*
993*        Compute singular vectors, if desired
994*
995         IF( NCVT.GT.0 )
996     $      CALL ZDROT( NCVT, VT( M-1, 1 ), LDVT, VT( M, 1 ), LDVT,
997     $                  COSR, SINR )
998         IF( NRU.GT.0 )
999     $      CALL ZDROT( NRU, U( 1, M-1 ), 1, U( 1, M ), 1, COSL, SINL )
1000         IF( NCC.GT.0 )
1001     $      CALL ZDROT( NCC, C( M-1, 1 ), LDC, C( M, 1 ), LDC, COSL,
1002     $                  SINL )
1003         M = M - 2
1004         GO TO 60
1005      END IF
1006*
1007*     If working on new submatrix, choose shift direction
1008*     (from larger end diagonal element towards smaller)
1009*
1010      IF( LL.GT.OLDM .OR. M.LT.OLDLL ) THEN
1011         IF( ABS( D( LL ) ).GE.ABS( D( M ) ) ) THEN
1012*
1013*           Chase bulge from top (big end) to bottom (small end)
1014*
1015            IDIR = 1
1016         ELSE
1017*
1018*           Chase bulge from bottom (big end) to top (small end)
1019*
1020            IDIR = 2
1021         END IF
1022      END IF
1023*
1024*     Apply convergence tests
1025*
1026      IF( IDIR.EQ.1 ) THEN
1027*
1028*        Run convergence test in forward direction
1029*        First apply standard test to bottom of matrix
1030*
1031         IF( ABS( E( M-1 ) ).LE.ABS( TOL )*ABS( D( M ) ) .OR.
1032     $       ( TOL.LT.ZERO .AND. ABS( E( M-1 ) ).LE.THRESH ) ) THEN
1033            E( M-1 ) = ZERO
1034            GO TO 60
1035         END IF
1036*
1037         IF( TOL.GE.ZERO ) THEN
1038*
1039*           If relative accuracy desired,
1040*           apply convergence criterion forward
1041*
1042            MU = ABS( D( LL ) )
1043            SMINL = MU
1044            DO 100 LLL = LL, M - 1
1045               IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN
1046                  E( LLL ) = ZERO
1047                  GO TO 60
1048               END IF
1049               MU = ABS( D( LLL+1 ) )*( MU / ( MU+ABS( E( LLL ) ) ) )
1050               SMINL = MIN( SMINL, MU )
1051  100       CONTINUE
1052         END IF
1053*
1054      ELSE
1055*
1056*        Run convergence test in backward direction
1057*        First apply standard test to top of matrix
1058*
1059         IF( ABS( E( LL ) ).LE.ABS( TOL )*ABS( D( LL ) ) .OR.
1060     $       ( TOL.LT.ZERO .AND. ABS( E( LL ) ).LE.THRESH ) ) THEN
1061            E( LL ) = ZERO
1062            GO TO 60
1063         END IF
1064*
1065         IF( TOL.GE.ZERO ) THEN
1066*
1067*           If relative accuracy desired,
1068*           apply convergence criterion backward
1069*
1070            MU = ABS( D( M ) )
1071            SMINL = MU
1072            DO 110 LLL = M - 1, LL, -1
1073               IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN
1074                  E( LLL ) = ZERO
1075                  GO TO 60
1076               END IF
1077               MU = ABS( D( LLL ) )*( MU / ( MU+ABS( E( LLL ) ) ) )
1078               SMINL = MIN( SMINL, MU )
1079  110       CONTINUE
1080         END IF
1081      END IF
1082      OLDLL = LL
1083      OLDM = M
1084*
1085*     Compute shift.  First, test if shifting would ruin relative
1086*     accuracy, and if so set the shift to zero.
1087*
1088      IF( TOL.GE.ZERO .AND. N*TOL*( SMINL / SMAX ).LE.
1089     $    MAX( EPS, HNDRTH*TOL ) ) THEN
1090*
1091*        Use a zero shift to avoid loss of relative accuracy
1092*
1093         SHIFT = ZERO
1094      ELSE
1095*
1096*        Compute the shift from 2-by-2 block at end of matrix
1097*
1098         IF( IDIR.EQ.1 ) THEN
1099            SLL = ABS( D( LL ) )
1100            CALL DLAS2( D( M-1 ), E( M-1 ), D( M ), SHIFT, R )
1101         ELSE
1102            SLL = ABS( D( M ) )
1103            CALL DLAS2( D( LL ), E( LL ), D( LL+1 ), SHIFT, R )
1104         END IF
1105*
1106*        Test if shift negligible, and if so set to zero
1107*
1108         IF( SLL.GT.ZERO ) THEN
1109            IF( ( SHIFT / SLL )**2.LT.EPS )
1110     $         SHIFT = ZERO
1111         END IF
1112      END IF
1113*
1114*     Increment iteration count
1115*
1116      ITER = ITER + M - LL
1117*
1118*     If SHIFT = 0, do simplified QR iteration
1119*
1120      IF( SHIFT.EQ.ZERO ) THEN
1121         IF( IDIR.EQ.1 ) THEN
1122*
1123*           Chase bulge from top to bottom
1124*           Save cosines and sines for later singular vector updates
1125*
1126            CS = ONE
1127            OLDCS = ONE
1128            DO 120 I = LL, M - 1
1129               CALL DLARTG( D( I )*CS, E( I ), CS, SN, R )
1130               IF( I.GT.LL )
1131     $            E( I-1 ) = OLDSN*R
1132               CALL DLARTG( OLDCS*R, D( I+1 )*SN, OLDCS, OLDSN, D( I ) )
1133               RWORK( I-LL+1 ) = CS
1134               RWORK( I-LL+1+NM1 ) = SN
1135               RWORK( I-LL+1+NM12 ) = OLDCS
1136               RWORK( I-LL+1+NM13 ) = OLDSN
1137  120       CONTINUE
1138            H = D( M )*CS
1139            D( M ) = H*OLDCS
1140            E( M-1 ) = H*OLDSN
1141*
1142*           Update singular vectors
1143*
1144            IF( NCVT.GT.0 )
1145     $         CALL ZLASR( 'L', 'V', 'F', M-LL+1, NCVT, RWORK( 1 ),
1146     $                     RWORK( N ), VT( LL, 1 ), LDVT )
1147            IF( NRU.GT.0 )
1148     $         CALL ZLASR( 'R', 'V', 'F', NRU, M-LL+1, RWORK( NM12+1 ),
1149     $                     RWORK( NM13+1 ), U( 1, LL ), LDU )
1150            IF( NCC.GT.0 )
1151     $         CALL ZLASR( 'L', 'V', 'F', M-LL+1, NCC, RWORK( NM12+1 ),
1152     $                     RWORK( NM13+1 ), C( LL, 1 ), LDC )
1153*
1154*           Test convergence
1155*
1156            IF( ABS( E( M-1 ) ).LE.THRESH )
1157     $         E( M-1 ) = ZERO
1158*
1159         ELSE
1160*
1161*           Chase bulge from bottom to top
1162*           Save cosines and sines for later singular vector updates
1163*
1164            CS = ONE
1165            OLDCS = ONE
1166            DO 130 I = M, LL + 1, -1
1167               CALL DLARTG( D( I )*CS, E( I-1 ), CS, SN, R )
1168               IF( I.LT.M )
1169     $            E( I ) = OLDSN*R
1170               CALL DLARTG( OLDCS*R, D( I-1 )*SN, OLDCS, OLDSN, D( I ) )
1171               RWORK( I-LL ) = CS
1172               RWORK( I-LL+NM1 ) = -SN
1173               RWORK( I-LL+NM12 ) = OLDCS
1174               RWORK( I-LL+NM13 ) = -OLDSN
1175  130       CONTINUE
1176            H = D( LL )*CS
1177            D( LL ) = H*OLDCS
1178            E( LL ) = H*OLDSN
1179*
1180*           Update singular vectors
1181*
1182            IF( NCVT.GT.0 )
1183     $         CALL ZLASR( 'L', 'V', 'B', M-LL+1, NCVT, RWORK( NM12+1 ),
1184     $                     RWORK( NM13+1 ), VT( LL, 1 ), LDVT )
1185            IF( NRU.GT.0 )
1186     $         CALL ZLASR( 'R', 'V', 'B', NRU, M-LL+1, RWORK( 1 ),
1187     $                     RWORK( N ), U( 1, LL ), LDU )
1188            IF( NCC.GT.0 )
1189     $         CALL ZLASR( 'L', 'V', 'B', M-LL+1, NCC, RWORK( 1 ),
1190     $                     RWORK( N ), C( LL, 1 ), LDC )
1191*
1192*           Test convergence
1193*
1194            IF( ABS( E( LL ) ).LE.THRESH )
1195     $         E( LL ) = ZERO
1196         END IF
1197      ELSE
1198*
1199*        Use nonzero shift
1200*
1201         IF( IDIR.EQ.1 ) THEN
1202*
1203*           Chase bulge from top to bottom
1204*           Save cosines and sines for later singular vector updates
1205*
1206            F = ( ABS( D( LL ) )-SHIFT )*
1207     $          ( SIGN( ONE, D( LL ) )+SHIFT / D( LL ) )
1208            G = E( LL )
1209            DO 140 I = LL, M - 1
1210               CALL DLARTG( F, G, COSR, SINR, R )
1211               IF( I.GT.LL )
1212     $            E( I-1 ) = R
1213               F = COSR*D( I ) + SINR*E( I )
1214               E( I ) = COSR*E( I ) - SINR*D( I )
1215               G = SINR*D( I+1 )
1216               D( I+1 ) = COSR*D( I+1 )
1217               CALL DLARTG( F, G, COSL, SINL, R )
1218               D( I ) = R
1219               F = COSL*E( I ) + SINL*D( I+1 )
1220               D( I+1 ) = COSL*D( I+1 ) - SINL*E( I )
1221               IF( I.LT.M-1 ) THEN
1222                  G = SINL*E( I+1 )
1223                  E( I+1 ) = COSL*E( I+1 )
1224               END IF
1225               RWORK( I-LL+1 ) = COSR
1226               RWORK( I-LL+1+NM1 ) = SINR
1227               RWORK( I-LL+1+NM12 ) = COSL
1228               RWORK( I-LL+1+NM13 ) = SINL
1229  140       CONTINUE
1230            E( M-1 ) = F
1231*
1232*           Update singular vectors
1233*
1234            IF( NCVT.GT.0 )
1235     $         CALL ZLASR( 'L', 'V', 'F', M-LL+1, NCVT, RWORK( 1 ),
1236     $                     RWORK( N ), VT( LL, 1 ), LDVT )
1237            IF( NRU.GT.0 )
1238     $         CALL ZLASR( 'R', 'V', 'F', NRU, M-LL+1, RWORK( NM12+1 ),
1239     $                     RWORK( NM13+1 ), U( 1, LL ), LDU )
1240            IF( NCC.GT.0 )
1241     $         CALL ZLASR( 'L', 'V', 'F', M-LL+1, NCC, RWORK( NM12+1 ),
1242     $                     RWORK( NM13+1 ), C( LL, 1 ), LDC )
1243*
1244*           Test convergence
1245*
1246            IF( ABS( E( M-1 ) ).LE.THRESH )
1247     $         E( M-1 ) = ZERO
1248*
1249         ELSE
1250*
1251*           Chase bulge from bottom to top
1252*           Save cosines and sines for later singular vector updates
1253*
1254            F = ( ABS( D( M ) )-SHIFT )*( SIGN( ONE, D( M ) )+SHIFT /
1255     $          D( M ) )
1256            G = E( M-1 )
1257            DO 150 I = M, LL + 1, -1
1258               CALL DLARTG( F, G, COSR, SINR, R )
1259               IF( I.LT.M )
1260     $            E( I ) = R
1261               F = COSR*D( I ) + SINR*E( I-1 )
1262               E( I-1 ) = COSR*E( I-1 ) - SINR*D( I )
1263               G = SINR*D( I-1 )
1264               D( I-1 ) = COSR*D( I-1 )
1265               CALL DLARTG( F, G, COSL, SINL, R )
1266               D( I ) = R
1267               F = COSL*E( I-1 ) + SINL*D( I-1 )
1268               D( I-1 ) = COSL*D( I-1 ) - SINL*E( I-1 )
1269               IF( I.GT.LL+1 ) THEN
1270                  G = SINL*E( I-2 )
1271                  E( I-2 ) = COSL*E( I-2 )
1272               END IF
1273               RWORK( I-LL ) = COSR
1274               RWORK( I-LL+NM1 ) = -SINR
1275               RWORK( I-LL+NM12 ) = COSL
1276               RWORK( I-LL+NM13 ) = -SINL
1277  150       CONTINUE
1278            E( LL ) = F
1279*
1280*           Test convergence
1281*
1282            IF( ABS( E( LL ) ).LE.THRESH )
1283     $         E( LL ) = ZERO
1284*
1285*           Update singular vectors if desired
1286*
1287            IF( NCVT.GT.0 )
1288     $         CALL ZLASR( 'L', 'V', 'B', M-LL+1, NCVT, RWORK( NM12+1 ),
1289     $                     RWORK( NM13+1 ), VT( LL, 1 ), LDVT )
1290            IF( NRU.GT.0 )
1291     $         CALL ZLASR( 'R', 'V', 'B', NRU, M-LL+1, RWORK( 1 ),
1292     $                     RWORK( N ), U( 1, LL ), LDU )
1293            IF( NCC.GT.0 )
1294     $         CALL ZLASR( 'L', 'V', 'B', M-LL+1, NCC, RWORK( 1 ),
1295     $                     RWORK( N ), C( LL, 1 ), LDC )
1296         END IF
1297      END IF
1298*
1299*     QR iteration finished, go back and check convergence
1300*
1301      GO TO 60
1302*
1303*     All singular values converged, so make them positive
1304*
1305  160 CONTINUE
1306      DO 170 I = 1, N
1307         IF( D( I ).LT.ZERO ) THEN
1308            D( I ) = -D( I )
1309*
1310*           Change sign of singular vectors, if desired
1311*
1312            IF( NCVT.GT.0 )
1313     $         CALL ZDSCAL( NCVT, NEGONE, VT( I, 1 ), LDVT )
1314         END IF
1315  170 CONTINUE
1316*
1317*     Sort the singular values into decreasing order (insertion sort on
1318*     singular values, but only one transposition per singular vector)
1319*
1320      DO 190 I = 1, N - 1
1321*
1322*        Scan for smallest D(I)
1323*
1324         ISUB = 1
1325         SMIN = D( 1 )
1326         DO 180 J = 2, N + 1 - I
1327            IF( D( J ).LE.SMIN ) THEN
1328               ISUB = J
1329               SMIN = D( J )
1330            END IF
1331  180    CONTINUE
1332         IF( ISUB.NE.N+1-I ) THEN
1333*
1334*           Swap singular values and vectors
1335*
1336            D( ISUB ) = D( N+1-I )
1337            D( N+1-I ) = SMIN
1338            IF( NCVT.GT.0 )
1339     $         CALL ZSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( N+1-I, 1 ),
1340     $                     LDVT )
1341            IF( NRU.GT.0 )
1342     $         CALL ZSWAP( NRU, U( 1, ISUB ), 1, U( 1, N+1-I ), 1 )
1343            IF( NCC.GT.0 )
1344     $         CALL ZSWAP( NCC, C( ISUB, 1 ), LDC, C( N+1-I, 1 ), LDC )
1345         END IF
1346  190 CONTINUE
1347      GO TO 220
1348*
1349*     Maximum number of iterations exceeded, failure to converge
1350*
1351  200 CONTINUE
1352      INFO = 0
1353      DO 210 I = 1, N - 1
1354         IF( E( I ).NE.ZERO )
1355     $      INFO = INFO + 1
1356  210 CONTINUE
1357  220 CONTINUE
1358      RETURN
1359*
1360*     End of ZBDSQR
1361*
1362      END
1363*> \brief \b ZDRSCL multiplies a vector by the reciprocal of a real scalar.
1364*
1365*  =========== DOCUMENTATION ===========
1366*
1367* Online html documentation available at
1368*            http://www.netlib.org/lapack/explore-html/
1369*
1370*> \htmlonly
1371*> Download ZDRSCL + dependencies
1372*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zdrscl.f">
1373*> [TGZ]</a>
1374*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zdrscl.f">
1375*> [ZIP]</a>
1376*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zdrscl.f">
1377*> [TXT]</a>
1378*> \endhtmlonly
1379*
1380*  Definition:
1381*  ===========
1382*
1383*       SUBROUTINE ZDRSCL( N, SA, SX, INCX )
1384*
1385*       .. Scalar Arguments ..
1386*       INTEGER            INCX, N
1387*       DOUBLE PRECISION   SA
1388*       ..
1389*       .. Array Arguments ..
1390*       COMPLEX*16         SX( * )
1391*       ..
1392*
1393*
1394*> \par Purpose:
1395*  =============
1396*>
1397*> \verbatim
1398*>
1399*> ZDRSCL multiplies an n-element complex vector x by the real scalar
1400*> 1/a.  This is done without overflow or underflow as long as
1401*> the final result x/a does not overflow or underflow.
1402*> \endverbatim
1403*
1404*  Arguments:
1405*  ==========
1406*
1407*> \param[in] N
1408*> \verbatim
1409*>          N is INTEGER
1410*>          The number of components of the vector x.
1411*> \endverbatim
1412*>
1413*> \param[in] SA
1414*> \verbatim
1415*>          SA is DOUBLE PRECISION
1416*>          The scalar a which is used to divide each component of x.
1417*>          SA must be >= 0, or the subroutine will divide by zero.
1418*> \endverbatim
1419*>
1420*> \param[in,out] SX
1421*> \verbatim
1422*>          SX is COMPLEX*16 array, dimension
1423*>                         (1+(N-1)*abs(INCX))
1424*>          The n-element vector x.
1425*> \endverbatim
1426*>
1427*> \param[in] INCX
1428*> \verbatim
1429*>          INCX is INTEGER
1430*>          The increment between successive values of the vector SX.
1431*>          > 0:  SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i),     1< i<= n
1432*> \endverbatim
1433*
1434*  Authors:
1435*  ========
1436*
1437*> \author Univ. of Tennessee
1438*> \author Univ. of California Berkeley
1439*> \author Univ. of Colorado Denver
1440*> \author NAG Ltd.
1441*
1442*> \date December 2016
1443*
1444*> \ingroup complex16OTHERauxiliary
1445*
1446*  =====================================================================
1447      SUBROUTINE ZDRSCL( N, SA, SX, INCX )
1448*
1449*  -- LAPACK auxiliary routine (version 3.7.0) --
1450*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
1451*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
1452*     December 2016
1453*
1454*     .. Scalar Arguments ..
1455      INTEGER            INCX, N
1456      DOUBLE PRECISION   SA
1457*     ..
1458*     .. Array Arguments ..
1459      COMPLEX*16         SX( * )
1460*     ..
1461*
1462* =====================================================================
1463*
1464*     .. Parameters ..
1465      DOUBLE PRECISION   ZERO, ONE
1466      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
1467*     ..
1468*     .. Local Scalars ..
1469      LOGICAL            DONE
1470      DOUBLE PRECISION   BIGNUM, CDEN, CDEN1, CNUM, CNUM1, MUL, SMLNUM
1471*     ..
1472*     .. External Functions ..
1473      DOUBLE PRECISION   DLAMCH
1474      EXTERNAL           DLAMCH
1475*     ..
1476*     .. External Subroutines ..
1477      EXTERNAL           DLABAD, ZDSCAL
1478*     ..
1479*     .. Intrinsic Functions ..
1480      INTRINSIC          ABS
1481*     ..
1482*     .. Executable Statements ..
1483*
1484*     Quick return if possible
1485*
1486      IF( N.LE.0 )
1487     $   RETURN
1488*
1489*     Get machine parameters
1490*
1491      SMLNUM = DLAMCH( 'S' )
1492      BIGNUM = ONE / SMLNUM
1493      CALL DLABAD( SMLNUM, BIGNUM )
1494*
1495*     Initialize the denominator to SA and the numerator to 1.
1496*
1497      CDEN = SA
1498      CNUM = ONE
1499*
1500   10 CONTINUE
1501      CDEN1 = CDEN*SMLNUM
1502      CNUM1 = CNUM / BIGNUM
1503      IF( ABS( CDEN1 ).GT.ABS( CNUM ) .AND. CNUM.NE.ZERO ) THEN
1504*
1505*        Pre-multiply X by SMLNUM if CDEN is large compared to CNUM.
1506*
1507         MUL = SMLNUM
1508         DONE = .FALSE.
1509         CDEN = CDEN1
1510      ELSE IF( ABS( CNUM1 ).GT.ABS( CDEN ) ) THEN
1511*
1512*        Pre-multiply X by BIGNUM if CDEN is small compared to CNUM.
1513*
1514         MUL = BIGNUM
1515         DONE = .FALSE.
1516         CNUM = CNUM1
1517      ELSE
1518*
1519*        Multiply X by CNUM / CDEN and return.
1520*
1521         MUL = CNUM / CDEN
1522         DONE = .TRUE.
1523      END IF
1524*
1525*     Scale the vector X by MUL
1526*
1527      CALL ZDSCAL( N, MUL, SX, INCX )
1528*
1529      IF( .NOT.DONE )
1530     $   GO TO 10
1531*
1532      RETURN
1533*
1534*     End of ZDRSCL
1535*
1536      END
1537*> \brief \b ZGEBAK
1538*
1539*  =========== DOCUMENTATION ===========
1540*
1541* Online html documentation available at
1542*            http://www.netlib.org/lapack/explore-html/
1543*
1544*> \htmlonly
1545*> Download ZGEBAK + dependencies
1546*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgebak.f">
1547*> [TGZ]</a>
1548*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgebak.f">
1549*> [ZIP]</a>
1550*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgebak.f">
1551*> [TXT]</a>
1552*> \endhtmlonly
1553*
1554*  Definition:
1555*  ===========
1556*
1557*       SUBROUTINE ZGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV,
1558*                          INFO )
1559*
1560*       .. Scalar Arguments ..
1561*       CHARACTER          JOB, SIDE
1562*       INTEGER            IHI, ILO, INFO, LDV, M, N
1563*       ..
1564*       .. Array Arguments ..
1565*       DOUBLE PRECISION   SCALE( * )
1566*       COMPLEX*16         V( LDV, * )
1567*       ..
1568*
1569*
1570*> \par Purpose:
1571*  =============
1572*>
1573*> \verbatim
1574*>
1575*> ZGEBAK forms the right or left eigenvectors of a complex general
1576*> matrix by backward transformation on the computed eigenvectors of the
1577*> balanced matrix output by ZGEBAL.
1578*> \endverbatim
1579*
1580*  Arguments:
1581*  ==========
1582*
1583*> \param[in] JOB
1584*> \verbatim
1585*>          JOB is CHARACTER*1
1586*>          Specifies the type of backward transformation required:
1587*>          = 'N': do nothing, return immediately;
1588*>          = 'P': do backward transformation for permutation only;
1589*>          = 'S': do backward transformation for scaling only;
1590*>          = 'B': do backward transformations for both permutation and
1591*>                 scaling.
1592*>          JOB must be the same as the argument JOB supplied to ZGEBAL.
1593*> \endverbatim
1594*>
1595*> \param[in] SIDE
1596*> \verbatim
1597*>          SIDE is CHARACTER*1
1598*>          = 'R':  V contains right eigenvectors;
1599*>          = 'L':  V contains left eigenvectors.
1600*> \endverbatim
1601*>
1602*> \param[in] N
1603*> \verbatim
1604*>          N is INTEGER
1605*>          The number of rows of the matrix V.  N >= 0.
1606*> \endverbatim
1607*>
1608*> \param[in] ILO
1609*> \verbatim
1610*>          ILO is INTEGER
1611*> \endverbatim
1612*>
1613*> \param[in] IHI
1614*> \verbatim
1615*>          IHI is INTEGER
1616*>          The integers ILO and IHI determined by ZGEBAL.
1617*>          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
1618*> \endverbatim
1619*>
1620*> \param[in] SCALE
1621*> \verbatim
1622*>          SCALE is DOUBLE PRECISION array, dimension (N)
1623*>          Details of the permutation and scaling factors, as returned
1624*>          by ZGEBAL.
1625*> \endverbatim
1626*>
1627*> \param[in] M
1628*> \verbatim
1629*>          M is INTEGER
1630*>          The number of columns of the matrix V.  M >= 0.
1631*> \endverbatim
1632*>
1633*> \param[in,out] V
1634*> \verbatim
1635*>          V is COMPLEX*16 array, dimension (LDV,M)
1636*>          On entry, the matrix of right or left eigenvectors to be
1637*>          transformed, as returned by ZHSEIN or ZTREVC.
1638*>          On exit, V is overwritten by the transformed eigenvectors.
1639*> \endverbatim
1640*>
1641*> \param[in] LDV
1642*> \verbatim
1643*>          LDV is INTEGER
1644*>          The leading dimension of the array V. LDV >= max(1,N).
1645*> \endverbatim
1646*>
1647*> \param[out] INFO
1648*> \verbatim
1649*>          INFO is INTEGER
1650*>          = 0:  successful exit
1651*>          < 0:  if INFO = -i, the i-th argument had an illegal value.
1652*> \endverbatim
1653*
1654*  Authors:
1655*  ========
1656*
1657*> \author Univ. of Tennessee
1658*> \author Univ. of California Berkeley
1659*> \author Univ. of Colorado Denver
1660*> \author NAG Ltd.
1661*
1662*> \date December 2016
1663*
1664*> \ingroup complex16GEcomputational
1665*
1666*  =====================================================================
1667      SUBROUTINE ZGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV,
1668     $                   INFO )
1669*
1670*  -- LAPACK computational routine (version 3.7.0) --
1671*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
1672*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
1673*     December 2016
1674*
1675*     .. Scalar Arguments ..
1676      CHARACTER          JOB, SIDE
1677      INTEGER            IHI, ILO, INFO, LDV, M, N
1678*     ..
1679*     .. Array Arguments ..
1680      DOUBLE PRECISION   SCALE( * )
1681      COMPLEX*16         V( LDV, * )
1682*     ..
1683*
1684*  =====================================================================
1685*
1686*     .. Parameters ..
1687      DOUBLE PRECISION   ONE
1688      PARAMETER          ( ONE = 1.0D+0 )
1689*     ..
1690*     .. Local Scalars ..
1691      LOGICAL            LEFTV, RIGHTV
1692      INTEGER            I, II, K
1693      DOUBLE PRECISION   S
1694*     ..
1695*     .. External Functions ..
1696      LOGICAL            LSAME
1697      EXTERNAL           LSAME
1698*     ..
1699*     .. External Subroutines ..
1700      EXTERNAL           XERBLA, ZDSCAL, ZSWAP
1701*     ..
1702*     .. Intrinsic Functions ..
1703      INTRINSIC          MAX, MIN
1704*     ..
1705*     .. Executable Statements ..
1706*
1707*     Decode and Test the input parameters
1708*
1709      RIGHTV = LSAME( SIDE, 'R' )
1710      LEFTV = LSAME( SIDE, 'L' )
1711*
1712      INFO = 0
1713      IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND.
1714     $    .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
1715         INFO = -1
1716      ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
1717         INFO = -2
1718      ELSE IF( N.LT.0 ) THEN
1719         INFO = -3
1720      ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
1721         INFO = -4
1722      ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
1723         INFO = -5
1724      ELSE IF( M.LT.0 ) THEN
1725         INFO = -7
1726      ELSE IF( LDV.LT.MAX( 1, N ) ) THEN
1727         INFO = -9
1728      END IF
1729      IF( INFO.NE.0 ) THEN
1730         CALL XERBLA( 'ZGEBAK', -INFO )
1731         RETURN
1732      END IF
1733*
1734*     Quick return if possible
1735*
1736      IF( N.EQ.0 )
1737     $   RETURN
1738      IF( M.EQ.0 )
1739     $   RETURN
1740      IF( LSAME( JOB, 'N' ) )
1741     $   RETURN
1742*
1743      IF( ILO.EQ.IHI )
1744     $   GO TO 30
1745*
1746*     Backward balance
1747*
1748      IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN
1749*
1750         IF( RIGHTV ) THEN
1751            DO 10 I = ILO, IHI
1752               S = SCALE( I )
1753               CALL ZDSCAL( M, S, V( I, 1 ), LDV )
1754   10       CONTINUE
1755         END IF
1756*
1757         IF( LEFTV ) THEN
1758            DO 20 I = ILO, IHI
1759               S = ONE / SCALE( I )
1760               CALL ZDSCAL( M, S, V( I, 1 ), LDV )
1761   20       CONTINUE
1762         END IF
1763*
1764      END IF
1765*
1766*     Backward permutation
1767*
1768*     For  I = ILO-1 step -1 until 1,
1769*              IHI+1 step 1 until N do --
1770*
1771   30 CONTINUE
1772      IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN
1773         IF( RIGHTV ) THEN
1774            DO 40 II = 1, N
1775               I = II
1776               IF( I.GE.ILO .AND. I.LE.IHI )
1777     $            GO TO 40
1778               IF( I.LT.ILO )
1779     $            I = ILO - II
1780               K = SCALE( I )
1781               IF( K.EQ.I )
1782     $            GO TO 40
1783               CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
1784   40       CONTINUE
1785         END IF
1786*
1787         IF( LEFTV ) THEN
1788            DO 50 II = 1, N
1789               I = II
1790               IF( I.GE.ILO .AND. I.LE.IHI )
1791     $            GO TO 50
1792               IF( I.LT.ILO )
1793     $            I = ILO - II
1794               K = SCALE( I )
1795               IF( K.EQ.I )
1796     $            GO TO 50
1797               CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
1798   50       CONTINUE
1799         END IF
1800      END IF
1801*
1802      RETURN
1803*
1804*     End of ZGEBAK
1805*
1806      END
1807*> \brief \b ZGEBAL
1808*
1809*  =========== DOCUMENTATION ===========
1810*
1811* Online html documentation available at
1812*            http://www.netlib.org/lapack/explore-html/
1813*
1814*> \htmlonly
1815*> Download ZGEBAL + dependencies
1816*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgebal.f">
1817*> [TGZ]</a>
1818*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgebal.f">
1819*> [ZIP]</a>
1820*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgebal.f">
1821*> [TXT]</a>
1822*> \endhtmlonly
1823*
1824*  Definition:
1825*  ===========
1826*
1827*       SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )
1828*
1829*       .. Scalar Arguments ..
1830*       CHARACTER          JOB
1831*       INTEGER            IHI, ILO, INFO, LDA, N
1832*       ..
1833*       .. Array Arguments ..
1834*       DOUBLE PRECISION   SCALE( * )
1835*       COMPLEX*16         A( LDA, * )
1836*       ..
1837*
1838*
1839*> \par Purpose:
1840*  =============
1841*>
1842*> \verbatim
1843*>
1844*> ZGEBAL balances a general complex matrix A.  This involves, first,
1845*> permuting A by a similarity transformation to isolate eigenvalues
1846*> in the first 1 to ILO-1 and last IHI+1 to N elements on the
1847*> diagonal; and second, applying a diagonal similarity transformation
1848*> to rows and columns ILO to IHI to make the rows and columns as
1849*> close in norm as possible.  Both steps are optional.
1850*>
1851*> Balancing may reduce the 1-norm of the matrix, and improve the
1852*> accuracy of the computed eigenvalues and/or eigenvectors.
1853*> \endverbatim
1854*
1855*  Arguments:
1856*  ==========
1857*
1858*> \param[in] JOB
1859*> \verbatim
1860*>          JOB is CHARACTER*1
1861*>          Specifies the operations to be performed on A:
1862*>          = 'N':  none:  simply set ILO = 1, IHI = N, SCALE(I) = 1.0
1863*>                  for i = 1,...,N;
1864*>          = 'P':  permute only;
1865*>          = 'S':  scale only;
1866*>          = 'B':  both permute and scale.
1867*> \endverbatim
1868*>
1869*> \param[in] N
1870*> \verbatim
1871*>          N is INTEGER
1872*>          The order of the matrix A.  N >= 0.
1873*> \endverbatim
1874*>
1875*> \param[in,out] A
1876*> \verbatim
1877*>          A is COMPLEX*16 array, dimension (LDA,N)
1878*>          On entry, the input matrix A.
1879*>          On exit,  A is overwritten by the balanced matrix.
1880*>          If JOB = 'N', A is not referenced.
1881*>          See Further Details.
1882*> \endverbatim
1883*>
1884*> \param[in] LDA
1885*> \verbatim
1886*>          LDA is INTEGER
1887*>          The leading dimension of the array A.  LDA >= max(1,N).
1888*> \endverbatim
1889*>
1890*> \param[out] ILO
1891*> \verbatim
1892*>          ILO is INTEGER
1893*> \endverbatim
1894*>
1895*> \param[out] IHI
1896*> \verbatim
1897*>          IHI is INTEGER
1898*>          ILO and IHI are set to INTEGER such that on exit
1899*>          A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.
1900*>          If JOB = 'N' or 'S', ILO = 1 and IHI = N.
1901*> \endverbatim
1902*>
1903*> \param[out] SCALE
1904*> \verbatim
1905*>          SCALE is DOUBLE PRECISION array, dimension (N)
1906*>          Details of the permutations and scaling factors applied to
1907*>          A.  If P(j) is the index of the row and column interchanged
1908*>          with row and column j and D(j) is the scaling factor
1909*>          applied to row and column j, then
1910*>          SCALE(j) = P(j)    for j = 1,...,ILO-1
1911*>                   = D(j)    for j = ILO,...,IHI
1912*>                   = P(j)    for j = IHI+1,...,N.
1913*>          The order in which the interchanges are made is N to IHI+1,
1914*>          then 1 to ILO-1.
1915*> \endverbatim
1916*>
1917*> \param[out] INFO
1918*> \verbatim
1919*>          INFO is INTEGER
1920*>          = 0:  successful exit.
1921*>          < 0:  if INFO = -i, the i-th argument had an illegal value.
1922*> \endverbatim
1923*
1924*  Authors:
1925*  ========
1926*
1927*> \author Univ. of Tennessee
1928*> \author Univ. of California Berkeley
1929*> \author Univ. of Colorado Denver
1930*> \author NAG Ltd.
1931*
1932*> \date June 2017
1933*
1934*> \ingroup complex16GEcomputational
1935*
1936*> \par Further Details:
1937*  =====================
1938*>
1939*> \verbatim
1940*>
1941*>  The permutations consist of row and column interchanges which put
1942*>  the matrix in the form
1943*>
1944*>             ( T1   X   Y  )
1945*>     P A P = (  0   B   Z  )
1946*>             (  0   0   T2 )
1947*>
1948*>  where T1 and T2 are upper triangular matrices whose eigenvalues lie
1949*>  along the diagonal.  The column indices ILO and IHI mark the starting
1950*>  and ending columns of the submatrix B. Balancing consists of applying
1951*>  a diagonal similarity transformation inv(D) * B * D to make the
1952*>  1-norms of each row of B and its corresponding column nearly equal.
1953*>  The output matrix is
1954*>
1955*>     ( T1     X*D          Y    )
1956*>     (  0  inv(D)*B*D  inv(D)*Z ).
1957*>     (  0      0           T2   )
1958*>
1959*>  Information about the permutations P and the diagonal matrix D is
1960*>  returned in the vector SCALE.
1961*>
1962*>  This subroutine is based on the EISPACK routine CBAL.
1963*>
1964*>  Modified by Tzu-Yi Chen, Computer Science Division, University of
1965*>    California at Berkeley, USA
1966*> \endverbatim
1967*>
1968*  =====================================================================
1969      SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )
1970*
1971*  -- LAPACK computational routine (version 3.7.1) --
1972*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
1973*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
1974*     June 2017
1975*
1976*     .. Scalar Arguments ..
1977      CHARACTER          JOB
1978      INTEGER            IHI, ILO, INFO, LDA, N
1979*     ..
1980*     .. Array Arguments ..
1981      DOUBLE PRECISION   SCALE( * )
1982      COMPLEX*16         A( LDA, * )
1983*     ..
1984*
1985*  =====================================================================
1986*
1987*     .. Parameters ..
1988      DOUBLE PRECISION   ZERO, ONE
1989      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
1990      DOUBLE PRECISION   SCLFAC
1991      PARAMETER          ( SCLFAC = 2.0D+0 )
1992      DOUBLE PRECISION   FACTOR
1993      PARAMETER          ( FACTOR = 0.95D+0 )
1994*     ..
1995*     .. Local Scalars ..
1996      LOGICAL            NOCONV
1997      INTEGER            I, ICA, IEXC, IRA, J, K, L, M
1998      DOUBLE PRECISION   C, CA, F, G, R, RA, S, SFMAX1, SFMAX2, SFMIN1,
1999     $                   SFMIN2
2000*     ..
2001*     .. External Functions ..
2002      LOGICAL            DISNAN, LSAME
2003      INTEGER            IZAMAX
2004      DOUBLE PRECISION   DLAMCH, DZNRM2
2005      EXTERNAL           DISNAN, LSAME, IZAMAX, DLAMCH, DZNRM2
2006*     ..
2007*     .. External Subroutines ..
2008      EXTERNAL           XERBLA, ZDSCAL, ZSWAP
2009*     ..
2010*     .. Intrinsic Functions ..
2011      INTRINSIC          ABS, DBLE, DIMAG, MAX, MIN
2012*
2013*     Test the input parameters
2014*
2015      INFO = 0
2016      IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND.
2017     $    .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
2018         INFO = -1
2019      ELSE IF( N.LT.0 ) THEN
2020         INFO = -2
2021      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
2022         INFO = -4
2023      END IF
2024      IF( INFO.NE.0 ) THEN
2025         CALL XERBLA( 'ZGEBAL', -INFO )
2026         RETURN
2027      END IF
2028*
2029      K = 1
2030      L = N
2031*
2032      IF( N.EQ.0 )
2033     $   GO TO 210
2034*
2035      IF( LSAME( JOB, 'N' ) ) THEN
2036         DO 10 I = 1, N
2037            SCALE( I ) = ONE
2038   10    CONTINUE
2039         GO TO 210
2040      END IF
2041*
2042      IF( LSAME( JOB, 'S' ) )
2043     $   GO TO 120
2044*
2045*     Permutation to isolate eigenvalues if possible
2046*
2047      GO TO 50
2048*
2049*     Row and column exchange.
2050*
2051   20 CONTINUE
2052      SCALE( M ) = J
2053      IF( J.EQ.M )
2054     $   GO TO 30
2055*
2056      CALL ZSWAP( L, A( 1, J ), 1, A( 1, M ), 1 )
2057      CALL ZSWAP( N-K+1, A( J, K ), LDA, A( M, K ), LDA )
2058*
2059   30 CONTINUE
2060      GO TO ( 40, 80 )IEXC
2061*
2062*     Search for rows isolating an eigenvalue and push them down.
2063*
2064   40 CONTINUE
2065      IF( L.EQ.1 )
2066     $   GO TO 210
2067      L = L - 1
2068*
2069   50 CONTINUE
2070      DO 70 J = L, 1, -1
2071*
2072         DO 60 I = 1, L
2073            IF( I.EQ.J )
2074     $         GO TO 60
2075            IF( DBLE( A( J, I ) ).NE.ZERO .OR. DIMAG( A( J, I ) ).NE.
2076     $          ZERO )GO TO 70
2077   60    CONTINUE
2078*
2079         M = L
2080         IEXC = 1
2081         GO TO 20
2082   70 CONTINUE
2083*
2084      GO TO 90
2085*
2086*     Search for columns isolating an eigenvalue and push them left.
2087*
2088   80 CONTINUE
2089      K = K + 1
2090*
2091   90 CONTINUE
2092      DO 110 J = K, L
2093*
2094         DO 100 I = K, L
2095            IF( I.EQ.J )
2096     $         GO TO 100
2097            IF( DBLE( A( I, J ) ).NE.ZERO .OR. DIMAG( A( I, J ) ).NE.
2098     $          ZERO )GO TO 110
2099  100    CONTINUE
2100*
2101         M = K
2102         IEXC = 2
2103         GO TO 20
2104  110 CONTINUE
2105*
2106  120 CONTINUE
2107      DO 130 I = K, L
2108         SCALE( I ) = ONE
2109  130 CONTINUE
2110*
2111      IF( LSAME( JOB, 'P' ) )
2112     $   GO TO 210
2113*
2114*     Balance the submatrix in rows K to L.
2115*
2116*     Iterative loop for norm reduction
2117*
2118      SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' )
2119      SFMAX1 = ONE / SFMIN1
2120      SFMIN2 = SFMIN1*SCLFAC
2121      SFMAX2 = ONE / SFMIN2
2122  140 CONTINUE
2123      NOCONV = .FALSE.
2124*
2125      DO 200 I = K, L
2126*
2127         C = DZNRM2( L-K+1, A( K, I ), 1 )
2128         R = DZNRM2( L-K+1, A( I, K ), LDA )
2129         ICA = IZAMAX( L, A( 1, I ), 1 )
2130         CA = ABS( A( ICA, I ) )
2131         IRA = IZAMAX( N-K+1, A( I, K ), LDA )
2132         RA = ABS( A( I, IRA+K-1 ) )
2133*
2134*        Guard against zero C or R due to underflow.
2135*
2136         IF( C.EQ.ZERO .OR. R.EQ.ZERO )
2137     $      GO TO 200
2138         G = R / SCLFAC
2139         F = ONE
2140         S = C + R
2141  160    CONTINUE
2142         IF( C.GE.G .OR. MAX( F, C, CA ).GE.SFMAX2 .OR.
2143     $       MIN( R, G, RA ).LE.SFMIN2 )GO TO 170
2144            IF( DISNAN( C+F+CA+R+G+RA ) ) THEN
2145*
2146*           Exit if NaN to avoid infinite loop
2147*
2148            INFO = -3
2149            CALL XERBLA( 'ZGEBAL', -INFO )
2150            RETURN
2151         END IF
2152         F = F*SCLFAC
2153         C = C*SCLFAC
2154         CA = CA*SCLFAC
2155         R = R / SCLFAC
2156         G = G / SCLFAC
2157         RA = RA / SCLFAC
2158         GO TO 160
2159*
2160  170    CONTINUE
2161         G = C / SCLFAC
2162  180    CONTINUE
2163         IF( G.LT.R .OR. MAX( R, RA ).GE.SFMAX2 .OR.
2164     $       MIN( F, C, G, CA ).LE.SFMIN2 )GO TO 190
2165         F = F / SCLFAC
2166         C = C / SCLFAC
2167         G = G / SCLFAC
2168         CA = CA / SCLFAC
2169         R = R*SCLFAC
2170         RA = RA*SCLFAC
2171         GO TO 180
2172*
2173*        Now balance.
2174*
2175  190    CONTINUE
2176         IF( ( C+R ).GE.FACTOR*S )
2177     $      GO TO 200
2178         IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN
2179            IF( F*SCALE( I ).LE.SFMIN1 )
2180     $         GO TO 200
2181         END IF
2182         IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN
2183            IF( SCALE( I ).GE.SFMAX1 / F )
2184     $         GO TO 200
2185         END IF
2186         G = ONE / F
2187         SCALE( I ) = SCALE( I )*F
2188         NOCONV = .TRUE.
2189*
2190         CALL ZDSCAL( N-K+1, G, A( I, K ), LDA )
2191         CALL ZDSCAL( L, F, A( 1, I ), 1 )
2192*
2193  200 CONTINUE
2194*
2195      IF( NOCONV )
2196     $   GO TO 140
2197*
2198  210 CONTINUE
2199      ILO = K
2200      IHI = L
2201*
2202      RETURN
2203*
2204*     End of ZGEBAL
2205*
2206      END
2207*> \brief \b ZGEBD2 reduces a general matrix to bidiagonal form using an unblocked algorithm.
2208*
2209*  =========== DOCUMENTATION ===========
2210*
2211* Online html documentation available at
2212*            http://www.netlib.org/lapack/explore-html/
2213*
2214*> \htmlonly
2215*> Download ZGEBD2 + dependencies
2216*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgebd2.f">
2217*> [TGZ]</a>
2218*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgebd2.f">
2219*> [ZIP]</a>
2220*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgebd2.f">
2221*> [TXT]</a>
2222*> \endhtmlonly
2223*
2224*  Definition:
2225*  ===========
2226*
2227*       SUBROUTINE ZGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
2228*
2229*       .. Scalar Arguments ..
2230*       INTEGER            INFO, LDA, M, N
2231*       ..
2232*       .. Array Arguments ..
2233*       DOUBLE PRECISION   D( * ), E( * )
2234*       COMPLEX*16         A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * )
2235*       ..
2236*
2237*
2238*> \par Purpose:
2239*  =============
2240*>
2241*> \verbatim
2242*>
2243*> ZGEBD2 reduces a complex general m by n matrix A to upper or lower
2244*> real bidiagonal form B by a unitary transformation: Q**H * A * P = B.
2245*>
2246*> If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
2247*> \endverbatim
2248*
2249*  Arguments:
2250*  ==========
2251*
2252*> \param[in] M
2253*> \verbatim
2254*>          M is INTEGER
2255*>          The number of rows in the matrix A.  M >= 0.
2256*> \endverbatim
2257*>
2258*> \param[in] N
2259*> \verbatim
2260*>          N is INTEGER
2261*>          The number of columns in the matrix A.  N >= 0.
2262*> \endverbatim
2263*>
2264*> \param[in,out] A
2265*> \verbatim
2266*>          A is COMPLEX*16 array, dimension (LDA,N)
2267*>          On entry, the m by n general matrix to be reduced.
2268*>          On exit,
2269*>          if m >= n, the diagonal and the first superdiagonal are
2270*>            overwritten with the upper bidiagonal matrix B; the
2271*>            elements below the diagonal, with the array TAUQ, represent
2272*>            the unitary matrix Q as a product of elementary
2273*>            reflectors, and the elements above the first superdiagonal,
2274*>            with the array TAUP, represent the unitary matrix P as
2275*>            a product of elementary reflectors;
2276*>          if m < n, the diagonal and the first subdiagonal are
2277*>            overwritten with the lower bidiagonal matrix B; the
2278*>            elements below the first subdiagonal, with the array TAUQ,
2279*>            represent the unitary matrix Q as a product of
2280*>            elementary reflectors, and the elements above the diagonal,
2281*>            with the array TAUP, represent the unitary matrix P as
2282*>            a product of elementary reflectors.
2283*>          See Further Details.
2284*> \endverbatim
2285*>
2286*> \param[in] LDA
2287*> \verbatim
2288*>          LDA is INTEGER
2289*>          The leading dimension of the array A.  LDA >= max(1,M).
2290*> \endverbatim
2291*>
2292*> \param[out] D
2293*> \verbatim
2294*>          D is DOUBLE PRECISION array, dimension (min(M,N))
2295*>          The diagonal elements of the bidiagonal matrix B:
2296*>          D(i) = A(i,i).
2297*> \endverbatim
2298*>
2299*> \param[out] E
2300*> \verbatim
2301*>          E is DOUBLE PRECISION array, dimension (min(M,N)-1)
2302*>          The off-diagonal elements of the bidiagonal matrix B:
2303*>          if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
2304*>          if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
2305*> \endverbatim
2306*>
2307*> \param[out] TAUQ
2308*> \verbatim
2309*>          TAUQ is COMPLEX*16 array, dimension (min(M,N))
2310*>          The scalar factors of the elementary reflectors which
2311*>          represent the unitary matrix Q. See Further Details.
2312*> \endverbatim
2313*>
2314*> \param[out] TAUP
2315*> \verbatim
2316*>          TAUP is COMPLEX*16 array, dimension (min(M,N))
2317*>          The scalar factors of the elementary reflectors which
2318*>          represent the unitary matrix P. See Further Details.
2319*> \endverbatim
2320*>
2321*> \param[out] WORK
2322*> \verbatim
2323*>          WORK is COMPLEX*16 array, dimension (max(M,N))
2324*> \endverbatim
2325*>
2326*> \param[out] INFO
2327*> \verbatim
2328*>          INFO is INTEGER
2329*>          = 0: successful exit
2330*>          < 0: if INFO = -i, the i-th argument had an illegal value.
2331*> \endverbatim
2332*
2333*  Authors:
2334*  ========
2335*
2336*> \author Univ. of Tennessee
2337*> \author Univ. of California Berkeley
2338*> \author Univ. of Colorado Denver
2339*> \author NAG Ltd.
2340*
2341*> \date June 2017
2342*
2343*> \ingroup complex16GEcomputational
2344*
2345*> \par Further Details:
2346*  =====================
2347*>
2348*> \verbatim
2349*>
2350*>  The matrices Q and P are represented as products of elementary
2351*>  reflectors:
2352*>
2353*>  If m >= n,
2354*>
2355*>     Q = H(1) H(2) . . . H(n)  and  P = G(1) G(2) . . . G(n-1)
2356*>
2357*>  Each H(i) and G(i) has the form:
2358*>
2359*>     H(i) = I - tauq * v * v**H  and G(i) = I - taup * u * u**H
2360*>
2361*>  where tauq and taup are complex scalars, and v and u are complex
2362*>  vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in
2363*>  A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in
2364*>  A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
2365*>
2366*>  If m < n,
2367*>
2368*>     Q = H(1) H(2) . . . H(m-1)  and  P = G(1) G(2) . . . G(m)
2369*>
2370*>  Each H(i) and G(i) has the form:
2371*>
2372*>     H(i) = I - tauq * v * v**H  and G(i) = I - taup * u * u**H
2373*>
2374*>  where tauq and taup are complex scalars, v and u are complex vectors;
2375*>  v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);
2376*>  u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);
2377*>  tauq is stored in TAUQ(i) and taup in TAUP(i).
2378*>
2379*>  The contents of A on exit are illustrated by the following examples:
2380*>
2381*>  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n):
2382*>
2383*>    (  d   e   u1  u1  u1 )           (  d   u1  u1  u1  u1  u1 )
2384*>    (  v1  d   e   u2  u2 )           (  e   d   u2  u2  u2  u2 )
2385*>    (  v1  v2  d   e   u3 )           (  v1  e   d   u3  u3  u3 )
2386*>    (  v1  v2  v3  d   e  )           (  v1  v2  e   d   u4  u4 )
2387*>    (  v1  v2  v3  v4  d  )           (  v1  v2  v3  e   d   u5 )
2388*>    (  v1  v2  v3  v4  v5 )
2389*>
2390*>  where d and e denote diagonal and off-diagonal elements of B, vi
2391*>  denotes an element of the vector defining H(i), and ui an element of
2392*>  the vector defining G(i).
2393*> \endverbatim
2394*>
2395*  =====================================================================
2396      SUBROUTINE ZGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
2397*
2398*  -- LAPACK computational routine (version 3.7.1) --
2399*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
2400*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
2401*     June 2017
2402*
2403*     .. Scalar Arguments ..
2404      INTEGER            INFO, LDA, M, N
2405*     ..
2406*     .. Array Arguments ..
2407      DOUBLE PRECISION   D( * ), E( * )
2408      COMPLEX*16         A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * )
2409*     ..
2410*
2411*  =====================================================================
2412*
2413*     .. Parameters ..
2414      COMPLEX*16         ZERO, ONE
2415      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ),
2416     $                   ONE = ( 1.0D+0, 0.0D+0 ) )
2417*     ..
2418*     .. Local Scalars ..
2419      INTEGER            I
2420      COMPLEX*16         ALPHA
2421*     ..
2422*     .. External Subroutines ..
2423      EXTERNAL           XERBLA, ZLACGV, ZLARF, ZLARFG
2424*     ..
2425*     .. Intrinsic Functions ..
2426      INTRINSIC          DCONJG, MAX, MIN
2427*     ..
2428*     .. Executable Statements ..
2429*
2430*     Test the input parameters
2431*
2432      INFO = 0
2433      IF( M.LT.0 ) THEN
2434         INFO = -1
2435      ELSE IF( N.LT.0 ) THEN
2436         INFO = -2
2437      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
2438         INFO = -4
2439      END IF
2440      IF( INFO.LT.0 ) THEN
2441         CALL XERBLA( 'ZGEBD2', -INFO )
2442         RETURN
2443      END IF
2444*
2445      IF( M.GE.N ) THEN
2446*
2447*        Reduce to upper bidiagonal form
2448*
2449         DO 10 I = 1, N
2450*
2451*           Generate elementary reflector H(i) to annihilate A(i+1:m,i)
2452*
2453            ALPHA = A( I, I )
2454            CALL ZLARFG( M-I+1, ALPHA, A( MIN( I+1, M ), I ), 1,
2455     $                   TAUQ( I ) )
2456            D( I ) = ALPHA
2457            A( I, I ) = ONE
2458*
2459*           Apply H(i)**H to A(i:m,i+1:n) from the left
2460*
2461            IF( I.LT.N )
2462     $         CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1,
2463     $                     DCONJG( TAUQ( I ) ), A( I, I+1 ), LDA, WORK )
2464            A( I, I ) = D( I )
2465*
2466            IF( I.LT.N ) THEN
2467*
2468*              Generate elementary reflector G(i) to annihilate
2469*              A(i,i+2:n)
2470*
2471               CALL ZLACGV( N-I, A( I, I+1 ), LDA )
2472               ALPHA = A( I, I+1 )
2473               CALL ZLARFG( N-I, ALPHA, A( I, MIN( I+2, N ) ), LDA,
2474     $                      TAUP( I ) )
2475               E( I ) = ALPHA
2476               A( I, I+1 ) = ONE
2477*
2478*              Apply G(i) to A(i+1:m,i+1:n) from the right
2479*
2480               CALL ZLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA,
2481     $                     TAUP( I ), A( I+1, I+1 ), LDA, WORK )
2482               CALL ZLACGV( N-I, A( I, I+1 ), LDA )
2483               A( I, I+1 ) = E( I )
2484            ELSE
2485               TAUP( I ) = ZERO
2486            END IF
2487   10    CONTINUE
2488      ELSE
2489*
2490*        Reduce to lower bidiagonal form
2491*
2492         DO 20 I = 1, M
2493*
2494*           Generate elementary reflector G(i) to annihilate A(i,i+1:n)
2495*
2496            CALL ZLACGV( N-I+1, A( I, I ), LDA )
2497            ALPHA = A( I, I )
2498            CALL ZLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA,
2499     $                   TAUP( I ) )
2500            D( I ) = ALPHA
2501            A( I, I ) = ONE
2502*
2503*           Apply G(i) to A(i+1:m,i:n) from the right
2504*
2505            IF( I.LT.M )
2506     $         CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
2507     $                     TAUP( I ), A( I+1, I ), LDA, WORK )
2508            CALL ZLACGV( N-I+1, A( I, I ), LDA )
2509            A( I, I ) = D( I )
2510*
2511            IF( I.LT.M ) THEN
2512*
2513*              Generate elementary reflector H(i) to annihilate
2514*              A(i+2:m,i)
2515*
2516               ALPHA = A( I+1, I )
2517               CALL ZLARFG( M-I, ALPHA, A( MIN( I+2, M ), I ), 1,
2518     $                      TAUQ( I ) )
2519               E( I ) = ALPHA
2520               A( I+1, I ) = ONE
2521*
2522*              Apply H(i)**H to A(i+1:m,i+1:n) from the left
2523*
2524               CALL ZLARF( 'Left', M-I, N-I, A( I+1, I ), 1,
2525     $                     DCONJG( TAUQ( I ) ), A( I+1, I+1 ), LDA,
2526     $                     WORK )
2527               A( I+1, I ) = E( I )
2528            ELSE
2529               TAUQ( I ) = ZERO
2530            END IF
2531   20    CONTINUE
2532      END IF
2533      RETURN
2534*
2535*     End of ZGEBD2
2536*
2537      END
2538*> \brief \b ZGEBRD
2539*
2540*  =========== DOCUMENTATION ===========
2541*
2542* Online html documentation available at
2543*            http://www.netlib.org/lapack/explore-html/
2544*
2545*> \htmlonly
2546*> Download ZGEBRD + dependencies
2547*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgebrd.f">
2548*> [TGZ]</a>
2549*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgebrd.f">
2550*> [ZIP]</a>
2551*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgebrd.f">
2552*> [TXT]</a>
2553*> \endhtmlonly
2554*
2555*  Definition:
2556*  ===========
2557*
2558*       SUBROUTINE ZGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK,
2559*                          INFO )
2560*
2561*       .. Scalar Arguments ..
2562*       INTEGER            INFO, LDA, LWORK, M, N
2563*       ..
2564*       .. Array Arguments ..
2565*       DOUBLE PRECISION   D( * ), E( * )
2566*       COMPLEX*16         A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * )
2567*       ..
2568*
2569*
2570*> \par Purpose:
2571*  =============
2572*>
2573*> \verbatim
2574*>
2575*> ZGEBRD reduces a general complex M-by-N matrix A to upper or lower
2576*> bidiagonal form B by a unitary transformation: Q**H * A * P = B.
2577*>
2578*> If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
2579*> \endverbatim
2580*
2581*  Arguments:
2582*  ==========
2583*
2584*> \param[in] M
2585*> \verbatim
2586*>          M is INTEGER
2587*>          The number of rows in the matrix A.  M >= 0.
2588*> \endverbatim
2589*>
2590*> \param[in] N
2591*> \verbatim
2592*>          N is INTEGER
2593*>          The number of columns in the matrix A.  N >= 0.
2594*> \endverbatim
2595*>
2596*> \param[in,out] A
2597*> \verbatim
2598*>          A is COMPLEX*16 array, dimension (LDA,N)
2599*>          On entry, the M-by-N general matrix to be reduced.
2600*>          On exit,
2601*>          if m >= n, the diagonal and the first superdiagonal are
2602*>            overwritten with the upper bidiagonal matrix B; the
2603*>            elements below the diagonal, with the array TAUQ, represent
2604*>            the unitary matrix Q as a product of elementary
2605*>            reflectors, and the elements above the first superdiagonal,
2606*>            with the array TAUP, represent the unitary matrix P as
2607*>            a product of elementary reflectors;
2608*>          if m < n, the diagonal and the first subdiagonal are
2609*>            overwritten with the lower bidiagonal matrix B; the
2610*>            elements below the first subdiagonal, with the array TAUQ,
2611*>            represent the unitary matrix Q as a product of
2612*>            elementary reflectors, and the elements above the diagonal,
2613*>            with the array TAUP, represent the unitary matrix P as
2614*>            a product of elementary reflectors.
2615*>          See Further Details.
2616*> \endverbatim
2617*>
2618*> \param[in] LDA
2619*> \verbatim
2620*>          LDA is INTEGER
2621*>          The leading dimension of the array A.  LDA >= max(1,M).
2622*> \endverbatim
2623*>
2624*> \param[out] D
2625*> \verbatim
2626*>          D is DOUBLE PRECISION array, dimension (min(M,N))
2627*>          The diagonal elements of the bidiagonal matrix B:
2628*>          D(i) = A(i,i).
2629*> \endverbatim
2630*>
2631*> \param[out] E
2632*> \verbatim
2633*>          E is DOUBLE PRECISION array, dimension (min(M,N)-1)
2634*>          The off-diagonal elements of the bidiagonal matrix B:
2635*>          if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
2636*>          if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
2637*> \endverbatim
2638*>
2639*> \param[out] TAUQ
2640*> \verbatim
2641*>          TAUQ is COMPLEX*16 array, dimension (min(M,N))
2642*>          The scalar factors of the elementary reflectors which
2643*>          represent the unitary matrix Q. See Further Details.
2644*> \endverbatim
2645*>
2646*> \param[out] TAUP
2647*> \verbatim
2648*>          TAUP is COMPLEX*16 array, dimension (min(M,N))
2649*>          The scalar factors of the elementary reflectors which
2650*>          represent the unitary matrix P. See Further Details.
2651*> \endverbatim
2652*>
2653*> \param[out] WORK
2654*> \verbatim
2655*>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
2656*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
2657*> \endverbatim
2658*>
2659*> \param[in] LWORK
2660*> \verbatim
2661*>          LWORK is INTEGER
2662*>          The length of the array WORK.  LWORK >= max(1,M,N).
2663*>          For optimum performance LWORK >= (M+N)*NB, where NB
2664*>          is the optimal blocksize.
2665*>
2666*>          If LWORK = -1, then a workspace query is assumed; the routine
2667*>          only calculates the optimal size of the WORK array, returns
2668*>          this value as the first entry of the WORK array, and no error
2669*>          message related to LWORK is issued by XERBLA.
2670*> \endverbatim
2671*>
2672*> \param[out] INFO
2673*> \verbatim
2674*>          INFO is INTEGER
2675*>          = 0:  successful exit.
2676*>          < 0:  if INFO = -i, the i-th argument had an illegal value.
2677*> \endverbatim
2678*
2679*  Authors:
2680*  ========
2681*
2682*> \author Univ. of Tennessee
2683*> \author Univ. of California Berkeley
2684*> \author Univ. of Colorado Denver
2685*> \author NAG Ltd.
2686*
2687*> \date November 2017
2688*
2689*> \ingroup complex16GEcomputational
2690*
2691*> \par Further Details:
2692*  =====================
2693*>
2694*> \verbatim
2695*>
2696*>  The matrices Q and P are represented as products of elementary
2697*>  reflectors:
2698*>
2699*>  If m >= n,
2700*>
2701*>     Q = H(1) H(2) . . . H(n)  and  P = G(1) G(2) . . . G(n-1)
2702*>
2703*>  Each H(i) and G(i) has the form:
2704*>
2705*>     H(i) = I - tauq * v * v**H  and G(i) = I - taup * u * u**H
2706*>
2707*>  where tauq and taup are complex scalars, and v and u are complex
2708*>  vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in
2709*>  A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in
2710*>  A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
2711*>
2712*>  If m < n,
2713*>
2714*>     Q = H(1) H(2) . . . H(m-1)  and  P = G(1) G(2) . . . G(m)
2715*>
2716*>  Each H(i) and G(i) has the form:
2717*>
2718*>     H(i) = I - tauq * v * v**H  and G(i) = I - taup * u * u**H
2719*>
2720*>  where tauq and taup are complex scalars, and v and u are complex
2721*>  vectors; v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in
2722*>  A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in
2723*>  A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
2724*>
2725*>  The contents of A on exit are illustrated by the following examples:
2726*>
2727*>  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n):
2728*>
2729*>    (  d   e   u1  u1  u1 )           (  d   u1  u1  u1  u1  u1 )
2730*>    (  v1  d   e   u2  u2 )           (  e   d   u2  u2  u2  u2 )
2731*>    (  v1  v2  d   e   u3 )           (  v1  e   d   u3  u3  u3 )
2732*>    (  v1  v2  v3  d   e  )           (  v1  v2  e   d   u4  u4 )
2733*>    (  v1  v2  v3  v4  d  )           (  v1  v2  v3  e   d   u5 )
2734*>    (  v1  v2  v3  v4  v5 )
2735*>
2736*>  where d and e denote diagonal and off-diagonal elements of B, vi
2737*>  denotes an element of the vector defining H(i), and ui an element of
2738*>  the vector defining G(i).
2739*> \endverbatim
2740*>
2741*  =====================================================================
2742      SUBROUTINE ZGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK,
2743     $                   INFO )
2744*
2745*  -- LAPACK computational routine (version 3.8.0) --
2746*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
2747*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
2748*     November 2017
2749*
2750*     .. Scalar Arguments ..
2751      INTEGER            INFO, LDA, LWORK, M, N
2752*     ..
2753*     .. Array Arguments ..
2754      DOUBLE PRECISION   D( * ), E( * )
2755      COMPLEX*16         A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * )
2756*     ..
2757*
2758*  =====================================================================
2759*
2760*     .. Parameters ..
2761      COMPLEX*16         ONE
2762      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
2763*     ..
2764*     .. Local Scalars ..
2765      LOGICAL            LQUERY
2766      INTEGER            I, IINFO, J, LDWRKX, LDWRKY, LWKOPT, MINMN, NB,
2767     $                   NBMIN, NX, WS
2768*     ..
2769*     .. External Subroutines ..
2770      EXTERNAL           XERBLA, ZGEBD2, ZGEMM, ZLABRD
2771*     ..
2772*     .. Intrinsic Functions ..
2773      INTRINSIC          DBLE, MAX, MIN
2774*     ..
2775*     .. External Functions ..
2776      INTEGER            ILAENV
2777      EXTERNAL           ILAENV
2778*     ..
2779*     .. Executable Statements ..
2780*
2781*     Test the input parameters
2782*
2783      INFO = 0
2784      NB = MAX( 1, ILAENV( 1, 'ZGEBRD', ' ', M, N, -1, -1 ) )
2785      LWKOPT = ( M+N )*NB
2786      WORK( 1 ) = DBLE( LWKOPT )
2787      LQUERY = ( LWORK.EQ.-1 )
2788      IF( M.LT.0 ) THEN
2789         INFO = -1
2790      ELSE IF( N.LT.0 ) THEN
2791         INFO = -2
2792      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
2793         INFO = -4
2794      ELSE IF( LWORK.LT.MAX( 1, M, N ) .AND. .NOT.LQUERY ) THEN
2795         INFO = -10
2796      END IF
2797      IF( INFO.LT.0 ) THEN
2798         CALL XERBLA( 'ZGEBRD', -INFO )
2799         RETURN
2800      ELSE IF( LQUERY ) THEN
2801         RETURN
2802      END IF
2803*
2804*     Quick return if possible
2805*
2806      MINMN = MIN( M, N )
2807      IF( MINMN.EQ.0 ) THEN
2808         WORK( 1 ) = 1
2809         RETURN
2810      END IF
2811*
2812      WS = MAX( M, N )
2813      LDWRKX = M
2814      LDWRKY = N
2815*
2816      IF( NB.GT.1 .AND. NB.LT.MINMN ) THEN
2817*
2818*        Set the crossover point NX.
2819*
2820         NX = MAX( NB, ILAENV( 3, 'ZGEBRD', ' ', M, N, -1, -1 ) )
2821*
2822*        Determine when to switch from blocked to unblocked code.
2823*
2824         IF( NX.LT.MINMN ) THEN
2825            WS = ( M+N )*NB
2826            IF( LWORK.LT.WS ) THEN
2827*
2828*              Not enough work space for the optimal NB, consider using
2829*              a smaller block size.
2830*
2831               NBMIN = ILAENV( 2, 'ZGEBRD', ' ', M, N, -1, -1 )
2832               IF( LWORK.GE.( M+N )*NBMIN ) THEN
2833                  NB = LWORK / ( M+N )
2834               ELSE
2835                  NB = 1
2836                  NX = MINMN
2837               END IF
2838            END IF
2839         END IF
2840      ELSE
2841         NX = MINMN
2842      END IF
2843*
2844      DO 30 I = 1, MINMN - NX, NB
2845*
2846*        Reduce rows and columns i:i+ib-1 to bidiagonal form and return
2847*        the matrices X and Y which are needed to update the unreduced
2848*        part of the matrix
2849*
2850         CALL ZLABRD( M-I+1, N-I+1, NB, A( I, I ), LDA, D( I ), E( I ),
2851     $                TAUQ( I ), TAUP( I ), WORK, LDWRKX,
2852     $                WORK( LDWRKX*NB+1 ), LDWRKY )
2853*
2854*        Update the trailing submatrix A(i+ib:m,i+ib:n), using
2855*        an update of the form  A := A - V*Y**H - X*U**H
2856*
2857         CALL ZGEMM( 'No transpose', 'Conjugate transpose', M-I-NB+1,
2858     $               N-I-NB+1, NB, -ONE, A( I+NB, I ), LDA,
2859     $               WORK( LDWRKX*NB+NB+1 ), LDWRKY, ONE,
2860     $               A( I+NB, I+NB ), LDA )
2861         CALL ZGEMM( 'No transpose', 'No transpose', M-I-NB+1, N-I-NB+1,
2862     $               NB, -ONE, WORK( NB+1 ), LDWRKX, A( I, I+NB ), LDA,
2863     $               ONE, A( I+NB, I+NB ), LDA )
2864*
2865*        Copy diagonal and off-diagonal elements of B back into A
2866*
2867         IF( M.GE.N ) THEN
2868            DO 10 J = I, I + NB - 1
2869               A( J, J ) = D( J )
2870               A( J, J+1 ) = E( J )
2871   10       CONTINUE
2872         ELSE
2873            DO 20 J = I, I + NB - 1
2874               A( J, J ) = D( J )
2875               A( J+1, J ) = E( J )
2876   20       CONTINUE
2877         END IF
2878   30 CONTINUE
2879*
2880*     Use unblocked code to reduce the remainder of the matrix
2881*
2882      CALL ZGEBD2( M-I+1, N-I+1, A( I, I ), LDA, D( I ), E( I ),
2883     $             TAUQ( I ), TAUP( I ), WORK, IINFO )
2884      WORK( 1 ) = WS
2885      RETURN
2886*
2887*     End of ZGEBRD
2888*
2889      END
2890*> \brief \b ZGECON
2891*
2892*  =========== DOCUMENTATION ===========
2893*
2894* Online html documentation available at
2895*            http://www.netlib.org/lapack/explore-html/
2896*
2897*> \htmlonly
2898*> Download ZGECON + dependencies
2899*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgecon.f">
2900*> [TGZ]</a>
2901*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgecon.f">
2902*> [ZIP]</a>
2903*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgecon.f">
2904*> [TXT]</a>
2905*> \endhtmlonly
2906*
2907*  Definition:
2908*  ===========
2909*
2910*       SUBROUTINE ZGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, RWORK,
2911*                          INFO )
2912*
2913*       .. Scalar Arguments ..
2914*       CHARACTER          NORM
2915*       INTEGER            INFO, LDA, N
2916*       DOUBLE PRECISION   ANORM, RCOND
2917*       ..
2918*       .. Array Arguments ..
2919*       DOUBLE PRECISION   RWORK( * )
2920*       COMPLEX*16         A( LDA, * ), WORK( * )
2921*       ..
2922*
2923*
2924*> \par Purpose:
2925*  =============
2926*>
2927*> \verbatim
2928*>
2929*> ZGECON estimates the reciprocal of the condition number of a general
2930*> complex matrix A, in either the 1-norm or the infinity-norm, using
2931*> the LU factorization computed by ZGETRF.
2932*>
2933*> An estimate is obtained for norm(inv(A)), and the reciprocal of the
2934*> condition number is computed as
2935*>    RCOND = 1 / ( norm(A) * norm(inv(A)) ).
2936*> \endverbatim
2937*
2938*  Arguments:
2939*  ==========
2940*
2941*> \param[in] NORM
2942*> \verbatim
2943*>          NORM is CHARACTER*1
2944*>          Specifies whether the 1-norm condition number or the
2945*>          infinity-norm condition number is required:
2946*>          = '1' or 'O':  1-norm;
2947*>          = 'I':         Infinity-norm.
2948*> \endverbatim
2949*>
2950*> \param[in] N
2951*> \verbatim
2952*>          N is INTEGER
2953*>          The order of the matrix A.  N >= 0.
2954*> \endverbatim
2955*>
2956*> \param[in] A
2957*> \verbatim
2958*>          A is COMPLEX*16 array, dimension (LDA,N)
2959*>          The factors L and U from the factorization A = P*L*U
2960*>          as computed by ZGETRF.
2961*> \endverbatim
2962*>
2963*> \param[in] LDA
2964*> \verbatim
2965*>          LDA is INTEGER
2966*>          The leading dimension of the array A.  LDA >= max(1,N).
2967*> \endverbatim
2968*>
2969*> \param[in] ANORM
2970*> \verbatim
2971*>          ANORM is DOUBLE PRECISION
2972*>          If NORM = '1' or 'O', the 1-norm of the original matrix A.
2973*>          If NORM = 'I', the infinity-norm of the original matrix A.
2974*> \endverbatim
2975*>
2976*> \param[out] RCOND
2977*> \verbatim
2978*>          RCOND is DOUBLE PRECISION
2979*>          The reciprocal of the condition number of the matrix A,
2980*>          computed as RCOND = 1/(norm(A) * norm(inv(A))).
2981*> \endverbatim
2982*>
2983*> \param[out] WORK
2984*> \verbatim
2985*>          WORK is COMPLEX*16 array, dimension (2*N)
2986*> \endverbatim
2987*>
2988*> \param[out] RWORK
2989*> \verbatim
2990*>          RWORK is DOUBLE PRECISION array, dimension (2*N)
2991*> \endverbatim
2992*>
2993*> \param[out] INFO
2994*> \verbatim
2995*>          INFO is INTEGER
2996*>          = 0:  successful exit
2997*>          < 0:  if INFO = -i, the i-th argument had an illegal value
2998*> \endverbatim
2999*
3000*  Authors:
3001*  ========
3002*
3003*> \author Univ. of Tennessee
3004*> \author Univ. of California Berkeley
3005*> \author Univ. of Colorado Denver
3006*> \author NAG Ltd.
3007*
3008*> \date December 2016
3009*
3010*> \ingroup complex16GEcomputational
3011*
3012*  =====================================================================
3013      SUBROUTINE ZGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, RWORK,
3014     $                   INFO )
3015*
3016*  -- LAPACK computational routine (version 3.7.0) --
3017*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
3018*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
3019*     December 2016
3020*
3021*     .. Scalar Arguments ..
3022      CHARACTER          NORM
3023      INTEGER            INFO, LDA, N
3024      DOUBLE PRECISION   ANORM, RCOND
3025*     ..
3026*     .. Array Arguments ..
3027      DOUBLE PRECISION   RWORK( * )
3028      COMPLEX*16         A( LDA, * ), WORK( * )
3029*     ..
3030*
3031*  =====================================================================
3032*
3033*     .. Parameters ..
3034      DOUBLE PRECISION   ONE, ZERO
3035      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
3036*     ..
3037*     .. Local Scalars ..
3038      LOGICAL            ONENRM
3039      CHARACTER          NORMIN
3040      INTEGER            IX, KASE, KASE1
3041      DOUBLE PRECISION   AINVNM, SCALE, SL, SMLNUM, SU
3042      COMPLEX*16         ZDUM
3043*     ..
3044*     .. Local Arrays ..
3045      INTEGER            ISAVE( 3 )
3046*     ..
3047*     .. External Functions ..
3048      LOGICAL            LSAME
3049      INTEGER            IZAMAX
3050      DOUBLE PRECISION   DLAMCH
3051      EXTERNAL           LSAME, IZAMAX, DLAMCH
3052*     ..
3053*     .. External Subroutines ..
3054      EXTERNAL           XERBLA, ZDRSCL, ZLACN2, ZLATRS
3055*     ..
3056*     .. Intrinsic Functions ..
3057      INTRINSIC          ABS, DBLE, DIMAG, MAX
3058*     ..
3059*     .. Statement Functions ..
3060      DOUBLE PRECISION   CABS1
3061*     ..
3062*     .. Statement Function definitions ..
3063      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
3064*     ..
3065*     .. Executable Statements ..
3066*
3067*     Test the input parameters.
3068*
3069      INFO = 0
3070      ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
3071      IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
3072         INFO = -1
3073      ELSE IF( N.LT.0 ) THEN
3074         INFO = -2
3075      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
3076         INFO = -4
3077      ELSE IF( ANORM.LT.ZERO ) THEN
3078         INFO = -5
3079      END IF
3080      IF( INFO.NE.0 ) THEN
3081         CALL XERBLA( 'ZGECON', -INFO )
3082         RETURN
3083      END IF
3084*
3085*     Quick return if possible
3086*
3087      RCOND = ZERO
3088      IF( N.EQ.0 ) THEN
3089         RCOND = ONE
3090         RETURN
3091      ELSE IF( ANORM.EQ.ZERO ) THEN
3092         RETURN
3093      END IF
3094*
3095      SMLNUM = DLAMCH( 'Safe minimum' )
3096*
3097*     Estimate the norm of inv(A).
3098*
3099      AINVNM = ZERO
3100      NORMIN = 'N'
3101      IF( ONENRM ) THEN
3102         KASE1 = 1
3103      ELSE
3104         KASE1 = 2
3105      END IF
3106      KASE = 0
3107   10 CONTINUE
3108      CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
3109      IF( KASE.NE.0 ) THEN
3110         IF( KASE.EQ.KASE1 ) THEN
3111*
3112*           Multiply by inv(L).
3113*
3114            CALL ZLATRS( 'Lower', 'No transpose', 'Unit', NORMIN, N, A,
3115     $                   LDA, WORK, SL, RWORK, INFO )
3116*
3117*           Multiply by inv(U).
3118*
3119            CALL ZLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
3120     $                   A, LDA, WORK, SU, RWORK( N+1 ), INFO )
3121         ELSE
3122*
3123*           Multiply by inv(U**H).
3124*
3125            CALL ZLATRS( 'Upper', 'Conjugate transpose', 'Non-unit',
3126     $                   NORMIN, N, A, LDA, WORK, SU, RWORK( N+1 ),
3127     $                   INFO )
3128*
3129*           Multiply by inv(L**H).
3130*
3131            CALL ZLATRS( 'Lower', 'Conjugate transpose', 'Unit', NORMIN,
3132     $                   N, A, LDA, WORK, SL, RWORK, INFO )
3133         END IF
3134*
3135*        Divide X by 1/(SL*SU) if doing so will not cause overflow.
3136*
3137         SCALE = SL*SU
3138         NORMIN = 'Y'
3139         IF( SCALE.NE.ONE ) THEN
3140            IX = IZAMAX( N, WORK, 1 )
3141            IF( SCALE.LT.CABS1( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
3142     $         GO TO 20
3143            CALL ZDRSCL( N, SCALE, WORK, 1 )
3144         END IF
3145         GO TO 10
3146      END IF
3147*
3148*     Compute the estimate of the reciprocal condition number.
3149*
3150      IF( AINVNM.NE.ZERO )
3151     $   RCOND = ( ONE / AINVNM ) / ANORM
3152*
3153   20 CONTINUE
3154      RETURN
3155*
3156*     End of ZGECON
3157*
3158      END
3159*> \brief \b ZGEEQU
3160*
3161*  =========== DOCUMENTATION ===========
3162*
3163* Online html documentation available at
3164*            http://www.netlib.org/lapack/explore-html/
3165*
3166*> \htmlonly
3167*> Download ZGEEQU + dependencies
3168*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgeequ.f">
3169*> [TGZ]</a>
3170*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgeequ.f">
3171*> [ZIP]</a>
3172*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgeequ.f">
3173*> [TXT]</a>
3174*> \endhtmlonly
3175*
3176*  Definition:
3177*  ===========
3178*
3179*       SUBROUTINE ZGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX,
3180*                          INFO )
3181*
3182*       .. Scalar Arguments ..
3183*       INTEGER            INFO, LDA, M, N
3184*       DOUBLE PRECISION   AMAX, COLCND, ROWCND
3185*       ..
3186*       .. Array Arguments ..
3187*       DOUBLE PRECISION   C( * ), R( * )
3188*       COMPLEX*16         A( LDA, * )
3189*       ..
3190*
3191*
3192*> \par Purpose:
3193*  =============
3194*>
3195*> \verbatim
3196*>
3197*> ZGEEQU computes row and column scalings intended to equilibrate an
3198*> M-by-N matrix A and reduce its condition number.  R returns the row
3199*> scale factors and C the column scale factors, chosen to try to make
3200*> the largest element in each row and column of the matrix B with
3201*> elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
3202*>
3203*> R(i) and C(j) are restricted to be between SMLNUM = smallest safe
3204*> number and BIGNUM = largest safe number.  Use of these scaling
3205*> factors is not guaranteed to reduce the condition number of A but
3206*> works well in practice.
3207*> \endverbatim
3208*
3209*  Arguments:
3210*  ==========
3211*
3212*> \param[in] M
3213*> \verbatim
3214*>          M is INTEGER
3215*>          The number of rows of the matrix A.  M >= 0.
3216*> \endverbatim
3217*>
3218*> \param[in] N
3219*> \verbatim
3220*>          N is INTEGER
3221*>          The number of columns of the matrix A.  N >= 0.
3222*> \endverbatim
3223*>
3224*> \param[in] A
3225*> \verbatim
3226*>          A is COMPLEX*16 array, dimension (LDA,N)
3227*>          The M-by-N matrix whose equilibration factors are
3228*>          to be computed.
3229*> \endverbatim
3230*>
3231*> \param[in] LDA
3232*> \verbatim
3233*>          LDA is INTEGER
3234*>          The leading dimension of the array A.  LDA >= max(1,M).
3235*> \endverbatim
3236*>
3237*> \param[out] R
3238*> \verbatim
3239*>          R is DOUBLE PRECISION array, dimension (M)
3240*>          If INFO = 0 or INFO > M, R contains the row scale factors
3241*>          for A.
3242*> \endverbatim
3243*>
3244*> \param[out] C
3245*> \verbatim
3246*>          C is DOUBLE PRECISION array, dimension (N)
3247*>          If INFO = 0,  C contains the column scale factors for A.
3248*> \endverbatim
3249*>
3250*> \param[out] ROWCND
3251*> \verbatim
3252*>          ROWCND is DOUBLE PRECISION
3253*>          If INFO = 0 or INFO > M, ROWCND contains the ratio of the
3254*>          smallest R(i) to the largest R(i).  If ROWCND >= 0.1 and
3255*>          AMAX is neither too large nor too small, it is not worth
3256*>          scaling by R.
3257*> \endverbatim
3258*>
3259*> \param[out] COLCND
3260*> \verbatim
3261*>          COLCND is DOUBLE PRECISION
3262*>          If INFO = 0, COLCND contains the ratio of the smallest
3263*>          C(i) to the largest C(i).  If COLCND >= 0.1, it is not
3264*>          worth scaling by C.
3265*> \endverbatim
3266*>
3267*> \param[out] AMAX
3268*> \verbatim
3269*>          AMAX is DOUBLE PRECISION
3270*>          Absolute value of largest matrix element.  If AMAX is very
3271*>          close to overflow or very close to underflow, the matrix
3272*>          should be scaled.
3273*> \endverbatim
3274*>
3275*> \param[out] INFO
3276*> \verbatim
3277*>          INFO is INTEGER
3278*>          = 0:  successful exit
3279*>          < 0:  if INFO = -i, the i-th argument had an illegal value
3280*>          > 0:  if INFO = i,  and i is
3281*>                <= M:  the i-th row of A is exactly zero
3282*>                >  M:  the (i-M)-th column of A is exactly zero
3283*> \endverbatim
3284*
3285*  Authors:
3286*  ========
3287*
3288*> \author Univ. of Tennessee
3289*> \author Univ. of California Berkeley
3290*> \author Univ. of Colorado Denver
3291*> \author NAG Ltd.
3292*
3293*> \date December 2016
3294*
3295*> \ingroup complex16GEcomputational
3296*
3297*  =====================================================================
3298      SUBROUTINE ZGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX,
3299     $                   INFO )
3300*
3301*  -- LAPACK computational routine (version 3.7.0) --
3302*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
3303*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
3304*     December 2016
3305*
3306*     .. Scalar Arguments ..
3307      INTEGER            INFO, LDA, M, N
3308      DOUBLE PRECISION   AMAX, COLCND, ROWCND
3309*     ..
3310*     .. Array Arguments ..
3311      DOUBLE PRECISION   C( * ), R( * )
3312      COMPLEX*16         A( LDA, * )
3313*     ..
3314*
3315*  =====================================================================
3316*
3317*     .. Parameters ..
3318      DOUBLE PRECISION   ONE, ZERO
3319      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
3320*     ..
3321*     .. Local Scalars ..
3322      INTEGER            I, J
3323      DOUBLE PRECISION   BIGNUM, RCMAX, RCMIN, SMLNUM
3324      COMPLEX*16         ZDUM
3325*     ..
3326*     .. External Functions ..
3327      DOUBLE PRECISION   DLAMCH
3328      EXTERNAL           DLAMCH
3329*     ..
3330*     .. External Subroutines ..
3331      EXTERNAL           XERBLA
3332*     ..
3333*     .. Intrinsic Functions ..
3334      INTRINSIC          ABS, DBLE, DIMAG, MAX, MIN
3335*     ..
3336*     .. Statement Functions ..
3337      DOUBLE PRECISION   CABS1
3338*     ..
3339*     .. Statement Function definitions ..
3340      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
3341*     ..
3342*     .. Executable Statements ..
3343*
3344*     Test the input parameters.
3345*
3346      INFO = 0
3347      IF( M.LT.0 ) THEN
3348         INFO = -1
3349      ELSE IF( N.LT.0 ) THEN
3350         INFO = -2
3351      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
3352         INFO = -4
3353      END IF
3354      IF( INFO.NE.0 ) THEN
3355         CALL XERBLA( 'ZGEEQU', -INFO )
3356         RETURN
3357      END IF
3358*
3359*     Quick return if possible
3360*
3361      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
3362         ROWCND = ONE
3363         COLCND = ONE
3364         AMAX = ZERO
3365         RETURN
3366      END IF
3367*
3368*     Get machine constants.
3369*
3370      SMLNUM = DLAMCH( 'S' )
3371      BIGNUM = ONE / SMLNUM
3372*
3373*     Compute row scale factors.
3374*
3375      DO 10 I = 1, M
3376         R( I ) = ZERO
3377   10 CONTINUE
3378*
3379*     Find the maximum element in each row.
3380*
3381      DO 30 J = 1, N
3382         DO 20 I = 1, M
3383            R( I ) = MAX( R( I ), CABS1( A( I, J ) ) )
3384   20    CONTINUE
3385   30 CONTINUE
3386*
3387*     Find the maximum and minimum scale factors.
3388*
3389      RCMIN = BIGNUM
3390      RCMAX = ZERO
3391      DO 40 I = 1, M
3392         RCMAX = MAX( RCMAX, R( I ) )
3393         RCMIN = MIN( RCMIN, R( I ) )
3394   40 CONTINUE
3395      AMAX = RCMAX
3396*
3397      IF( RCMIN.EQ.ZERO ) THEN
3398*
3399*        Find the first zero scale factor and return an error code.
3400*
3401         DO 50 I = 1, M
3402            IF( R( I ).EQ.ZERO ) THEN
3403               INFO = I
3404               RETURN
3405            END IF
3406   50    CONTINUE
3407      ELSE
3408*
3409*        Invert the scale factors.
3410*
3411         DO 60 I = 1, M
3412            R( I ) = ONE / MIN( MAX( R( I ), SMLNUM ), BIGNUM )
3413   60    CONTINUE
3414*
3415*        Compute ROWCND = min(R(I)) / max(R(I))
3416*
3417         ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
3418      END IF
3419*
3420*     Compute column scale factors
3421*
3422      DO 70 J = 1, N
3423         C( J ) = ZERO
3424   70 CONTINUE
3425*
3426*     Find the maximum element in each column,
3427*     assuming the row scaling computed above.
3428*
3429      DO 90 J = 1, N
3430         DO 80 I = 1, M
3431            C( J ) = MAX( C( J ), CABS1( A( I, J ) )*R( I ) )
3432   80    CONTINUE
3433   90 CONTINUE
3434*
3435*     Find the maximum and minimum scale factors.
3436*
3437      RCMIN = BIGNUM
3438      RCMAX = ZERO
3439      DO 100 J = 1, N
3440         RCMIN = MIN( RCMIN, C( J ) )
3441         RCMAX = MAX( RCMAX, C( J ) )
3442  100 CONTINUE
3443*
3444      IF( RCMIN.EQ.ZERO ) THEN
3445*
3446*        Find the first zero scale factor and return an error code.
3447*
3448         DO 110 J = 1, N
3449            IF( C( J ).EQ.ZERO ) THEN
3450               INFO = M + J
3451               RETURN
3452            END IF
3453  110    CONTINUE
3454      ELSE
3455*
3456*        Invert the scale factors.
3457*
3458         DO 120 J = 1, N
3459            C( J ) = ONE / MIN( MAX( C( J ), SMLNUM ), BIGNUM )
3460  120    CONTINUE
3461*
3462*        Compute COLCND = min(C(J)) / max(C(J))
3463*
3464         COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
3465      END IF
3466*
3467      RETURN
3468*
3469*     End of ZGEEQU
3470*
3471      END
3472*> \brief <b> ZGEES computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE matrices</b>
3473*
3474*  =========== DOCUMENTATION ===========
3475*
3476* Online html documentation available at
3477*            http://www.netlib.org/lapack/explore-html/
3478*
3479*> \htmlonly
3480*> Download ZGEES + dependencies
3481*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgees.f">
3482*> [TGZ]</a>
3483*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgees.f">
3484*> [ZIP]</a>
3485*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgees.f">
3486*> [TXT]</a>
3487*> \endhtmlonly
3488*
3489*  Definition:
3490*  ===========
3491*
3492*       SUBROUTINE ZGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, W, VS,
3493*                         LDVS, WORK, LWORK, RWORK, BWORK, INFO )
3494*
3495*       .. Scalar Arguments ..
3496*       CHARACTER          JOBVS, SORT
3497*       INTEGER            INFO, LDA, LDVS, LWORK, N, SDIM
3498*       ..
3499*       .. Array Arguments ..
3500*       LOGICAL            BWORK( * )
3501*       DOUBLE PRECISION   RWORK( * )
3502*       COMPLEX*16         A( LDA, * ), VS( LDVS, * ), W( * ), WORK( * )
3503*       ..
3504*       .. Function Arguments ..
3505*       LOGICAL            SELECT
3506*       EXTERNAL           SELECT
3507*       ..
3508*
3509*
3510*> \par Purpose:
3511*  =============
3512*>
3513*> \verbatim
3514*>
3515*> ZGEES computes for an N-by-N complex nonsymmetric matrix A, the
3516*> eigenvalues, the Schur form T, and, optionally, the matrix of Schur
3517*> vectors Z.  This gives the Schur factorization A = Z*T*(Z**H).
3518*>
3519*> Optionally, it also orders the eigenvalues on the diagonal of the
3520*> Schur form so that selected eigenvalues are at the top left.
3521*> The leading columns of Z then form an orthonormal basis for the
3522*> invariant subspace corresponding to the selected eigenvalues.
3523*>
3524*> A complex matrix is in Schur form if it is upper triangular.
3525*> \endverbatim
3526*
3527*  Arguments:
3528*  ==========
3529*
3530*> \param[in] JOBVS
3531*> \verbatim
3532*>          JOBVS is CHARACTER*1
3533*>          = 'N': Schur vectors are not computed;
3534*>          = 'V': Schur vectors are computed.
3535*> \endverbatim
3536*>
3537*> \param[in] SORT
3538*> \verbatim
3539*>          SORT is CHARACTER*1
3540*>          Specifies whether or not to order the eigenvalues on the
3541*>          diagonal of the Schur form.
3542*>          = 'N': Eigenvalues are not ordered:
3543*>          = 'S': Eigenvalues are ordered (see SELECT).
3544*> \endverbatim
3545*>
3546*> \param[in] SELECT
3547*> \verbatim
3548*>          SELECT is a LOGICAL FUNCTION of one COMPLEX*16 argument
3549*>          SELECT must be declared EXTERNAL in the calling subroutine.
3550*>          If SORT = 'S', SELECT is used to select eigenvalues to order
3551*>          to the top left of the Schur form.
3552*>          IF SORT = 'N', SELECT is not referenced.
3553*>          The eigenvalue W(j) is selected if SELECT(W(j)) is true.
3554*> \endverbatim
3555*>
3556*> \param[in] N
3557*> \verbatim
3558*>          N is INTEGER
3559*>          The order of the matrix A. N >= 0.
3560*> \endverbatim
3561*>
3562*> \param[in,out] A
3563*> \verbatim
3564*>          A is COMPLEX*16 array, dimension (LDA,N)
3565*>          On entry, the N-by-N matrix A.
3566*>          On exit, A has been overwritten by its Schur form T.
3567*> \endverbatim
3568*>
3569*> \param[in] LDA
3570*> \verbatim
3571*>          LDA is INTEGER
3572*>          The leading dimension of the array A.  LDA >= max(1,N).
3573*> \endverbatim
3574*>
3575*> \param[out] SDIM
3576*> \verbatim
3577*>          SDIM is INTEGER
3578*>          If SORT = 'N', SDIM = 0.
3579*>          If SORT = 'S', SDIM = number of eigenvalues for which
3580*>                         SELECT is true.
3581*> \endverbatim
3582*>
3583*> \param[out] W
3584*> \verbatim
3585*>          W is COMPLEX*16 array, dimension (N)
3586*>          W contains the computed eigenvalues, in the same order that
3587*>          they appear on the diagonal of the output Schur form T.
3588*> \endverbatim
3589*>
3590*> \param[out] VS
3591*> \verbatim
3592*>          VS is COMPLEX*16 array, dimension (LDVS,N)
3593*>          If JOBVS = 'V', VS contains the unitary matrix Z of Schur
3594*>          vectors.
3595*>          If JOBVS = 'N', VS is not referenced.
3596*> \endverbatim
3597*>
3598*> \param[in] LDVS
3599*> \verbatim
3600*>          LDVS is INTEGER
3601*>          The leading dimension of the array VS.  LDVS >= 1; if
3602*>          JOBVS = 'V', LDVS >= N.
3603*> \endverbatim
3604*>
3605*> \param[out] WORK
3606*> \verbatim
3607*>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
3608*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
3609*> \endverbatim
3610*>
3611*> \param[in] LWORK
3612*> \verbatim
3613*>          LWORK is INTEGER
3614*>          The dimension of the array WORK.  LWORK >= max(1,2*N).
3615*>          For good performance, LWORK must generally be larger.
3616*>
3617*>          If LWORK = -1, then a workspace query is assumed; the routine
3618*>          only calculates the optimal size of the WORK array, returns
3619*>          this value as the first entry of the WORK array, and no error
3620*>          message related to LWORK is issued by XERBLA.
3621*> \endverbatim
3622*>
3623*> \param[out] RWORK
3624*> \verbatim
3625*>          RWORK is DOUBLE PRECISION array, dimension (N)
3626*> \endverbatim
3627*>
3628*> \param[out] BWORK
3629*> \verbatim
3630*>          BWORK is LOGICAL array, dimension (N)
3631*>          Not referenced if SORT = 'N'.
3632*> \endverbatim
3633*>
3634*> \param[out] INFO
3635*> \verbatim
3636*>          INFO is INTEGER
3637*>          = 0: successful exit
3638*>          < 0: if INFO = -i, the i-th argument had an illegal value.
3639*>          > 0: if INFO = i, and i is
3640*>               <= N:  the QR algorithm failed to compute all the
3641*>                      eigenvalues; elements 1:ILO-1 and i+1:N of W
3642*>                      contain those eigenvalues which have converged;
3643*>                      if JOBVS = 'V', VS contains the matrix which
3644*>                      reduces A to its partially converged Schur form.
3645*>               = N+1: the eigenvalues could not be reordered because
3646*>                      some eigenvalues were too close to separate (the
3647*>                      problem is very ill-conditioned);
3648*>               = N+2: after reordering, roundoff changed values of
3649*>                      some complex eigenvalues so that leading
3650*>                      eigenvalues in the Schur form no longer satisfy
3651*>                      SELECT = .TRUE..  This could also be caused by
3652*>                      underflow due to scaling.
3653*> \endverbatim
3654*
3655*  Authors:
3656*  ========
3657*
3658*> \author Univ. of Tennessee
3659*> \author Univ. of California Berkeley
3660*> \author Univ. of Colorado Denver
3661*> \author NAG Ltd.
3662*
3663*> \date December 2016
3664*
3665*> \ingroup complex16GEeigen
3666*
3667*  =====================================================================
3668      SUBROUTINE ZGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, W, VS,
3669     $                  LDVS, WORK, LWORK, RWORK, BWORK, INFO )
3670*
3671*  -- LAPACK driver routine (version 3.7.0) --
3672*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
3673*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
3674*     December 2016
3675*
3676*     .. Scalar Arguments ..
3677      CHARACTER          JOBVS, SORT
3678      INTEGER            INFO, LDA, LDVS, LWORK, N, SDIM
3679*     ..
3680*     .. Array Arguments ..
3681      LOGICAL            BWORK( * )
3682      DOUBLE PRECISION   RWORK( * )
3683      COMPLEX*16         A( LDA, * ), VS( LDVS, * ), W( * ), WORK( * )
3684*     ..
3685*     .. Function Arguments ..
3686      LOGICAL            SELECT
3687      EXTERNAL           SELECT
3688*     ..
3689*
3690*  =====================================================================
3691*
3692*     .. Parameters ..
3693      DOUBLE PRECISION   ZERO, ONE
3694      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
3695*     ..
3696*     .. Local Scalars ..
3697      LOGICAL            LQUERY, SCALEA, WANTST, WANTVS
3698      INTEGER            HSWORK, I, IBAL, ICOND, IERR, IEVAL, IHI, ILO,
3699     $                   ITAU, IWRK, MAXWRK, MINWRK
3700      DOUBLE PRECISION   ANRM, BIGNUM, CSCALE, EPS, S, SEP, SMLNUM
3701*     ..
3702*     .. Local Arrays ..
3703      DOUBLE PRECISION   DUM( 1 )
3704*     ..
3705*     .. External Subroutines ..
3706      EXTERNAL           DLABAD, XERBLA, ZCOPY, ZGEBAK, ZGEBAL, ZGEHRD,
3707     $                   ZHSEQR, ZLACPY, ZLASCL, ZTRSEN, ZUNGHR
3708*     ..
3709*     .. External Functions ..
3710      LOGICAL            LSAME
3711      INTEGER            ILAENV
3712      DOUBLE PRECISION   DLAMCH, ZLANGE
3713      EXTERNAL           LSAME, ILAENV, DLAMCH, ZLANGE
3714*     ..
3715*     .. Intrinsic Functions ..
3716      INTRINSIC          MAX, SQRT
3717*     ..
3718*     .. Executable Statements ..
3719*
3720*     Test the input arguments
3721*
3722      INFO = 0
3723      LQUERY = ( LWORK.EQ.-1 )
3724      WANTVS = LSAME( JOBVS, 'V' )
3725      WANTST = LSAME( SORT, 'S' )
3726      IF( ( .NOT.WANTVS ) .AND. ( .NOT.LSAME( JOBVS, 'N' ) ) ) THEN
3727         INFO = -1
3728      ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN
3729         INFO = -2
3730      ELSE IF( N.LT.0 ) THEN
3731         INFO = -4
3732      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
3733         INFO = -6
3734      ELSE IF( LDVS.LT.1 .OR. ( WANTVS .AND. LDVS.LT.N ) ) THEN
3735         INFO = -10
3736      END IF
3737*
3738*     Compute workspace
3739*      (Note: Comments in the code beginning "Workspace:" describe the
3740*       minimal amount of workspace needed at that point in the code,
3741*       as well as the preferred amount for good performance.
3742*       CWorkspace refers to complex workspace, and RWorkspace to real
3743*       workspace. NB refers to the optimal block size for the
3744*       immediately following subroutine, as returned by ILAENV.
3745*       HSWORK refers to the workspace preferred by ZHSEQR, as
3746*       calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
3747*       the worst case.)
3748*
3749      IF( INFO.EQ.0 ) THEN
3750         IF( N.EQ.0 ) THEN
3751            MINWRK = 1
3752            MAXWRK = 1
3753         ELSE
3754            MAXWRK = N + N*ILAENV( 1, 'ZGEHRD', ' ', N, 1, N, 0 )
3755            MINWRK = 2*N
3756*
3757            CALL ZHSEQR( 'S', JOBVS, N, 1, N, A, LDA, W, VS, LDVS,
3758     $             WORK, -1, IEVAL )
3759            HSWORK = WORK( 1 )
3760*
3761            IF( .NOT.WANTVS ) THEN
3762               MAXWRK = MAX( MAXWRK, HSWORK )
3763            ELSE
3764               MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'ZUNGHR',
3765     $                       ' ', N, 1, N, -1 ) )
3766               MAXWRK = MAX( MAXWRK, HSWORK )
3767            END IF
3768         END IF
3769         WORK( 1 ) = MAXWRK
3770*
3771         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
3772            INFO = -12
3773         END IF
3774      END IF
3775*
3776      IF( INFO.NE.0 ) THEN
3777         CALL XERBLA( 'ZGEES ', -INFO )
3778         RETURN
3779      ELSE IF( LQUERY ) THEN
3780         RETURN
3781      END IF
3782*
3783*     Quick return if possible
3784*
3785      IF( N.EQ.0 ) THEN
3786         SDIM = 0
3787         RETURN
3788      END IF
3789*
3790*     Get machine constants
3791*
3792      EPS = DLAMCH( 'P' )
3793      SMLNUM = DLAMCH( 'S' )
3794      BIGNUM = ONE / SMLNUM
3795      CALL DLABAD( SMLNUM, BIGNUM )
3796      SMLNUM = SQRT( SMLNUM ) / EPS
3797      BIGNUM = ONE / SMLNUM
3798*
3799*     Scale A if max element outside range [SMLNUM,BIGNUM]
3800*
3801      ANRM = ZLANGE( 'M', N, N, A, LDA, DUM )
3802      SCALEA = .FALSE.
3803      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
3804         SCALEA = .TRUE.
3805         CSCALE = SMLNUM
3806      ELSE IF( ANRM.GT.BIGNUM ) THEN
3807         SCALEA = .TRUE.
3808         CSCALE = BIGNUM
3809      END IF
3810      IF( SCALEA )
3811     $   CALL ZLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
3812*
3813*     Permute the matrix to make it more nearly triangular
3814*     (CWorkspace: none)
3815*     (RWorkspace: need N)
3816*
3817      IBAL = 1
3818      CALL ZGEBAL( 'P', N, A, LDA, ILO, IHI, RWORK( IBAL ), IERR )
3819*
3820*     Reduce to upper Hessenberg form
3821*     (CWorkspace: need 2*N, prefer N+N*NB)
3822*     (RWorkspace: none)
3823*
3824      ITAU = 1
3825      IWRK = N + ITAU
3826      CALL ZGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ),
3827     $             LWORK-IWRK+1, IERR )
3828*
3829      IF( WANTVS ) THEN
3830*
3831*        Copy Householder vectors to VS
3832*
3833         CALL ZLACPY( 'L', N, N, A, LDA, VS, LDVS )
3834*
3835*        Generate unitary matrix in VS
3836*        (CWorkspace: need 2*N-1, prefer N+(N-1)*NB)
3837*        (RWorkspace: none)
3838*
3839         CALL ZUNGHR( N, ILO, IHI, VS, LDVS, WORK( ITAU ), WORK( IWRK ),
3840     $                LWORK-IWRK+1, IERR )
3841      END IF
3842*
3843      SDIM = 0
3844*
3845*     Perform QR iteration, accumulating Schur vectors in VS if desired
3846*     (CWorkspace: need 1, prefer HSWORK (see comments) )
3847*     (RWorkspace: none)
3848*
3849      IWRK = ITAU
3850      CALL ZHSEQR( 'S', JOBVS, N, ILO, IHI, A, LDA, W, VS, LDVS,
3851     $             WORK( IWRK ), LWORK-IWRK+1, IEVAL )
3852      IF( IEVAL.GT.0 )
3853     $   INFO = IEVAL
3854*
3855*     Sort eigenvalues if desired
3856*
3857      IF( WANTST .AND. INFO.EQ.0 ) THEN
3858         IF( SCALEA )
3859     $      CALL ZLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, W, N, IERR )
3860         DO 10 I = 1, N
3861            BWORK( I ) = SELECT( W( I ) )
3862   10    CONTINUE
3863*
3864*        Reorder eigenvalues and transform Schur vectors
3865*        (CWorkspace: none)
3866*        (RWorkspace: none)
3867*
3868         CALL ZTRSEN( 'N', JOBVS, BWORK, N, A, LDA, VS, LDVS, W, SDIM,
3869     $                S, SEP, WORK( IWRK ), LWORK-IWRK+1, ICOND )
3870      END IF
3871*
3872      IF( WANTVS ) THEN
3873*
3874*        Undo balancing
3875*        (CWorkspace: none)
3876*        (RWorkspace: need N)
3877*
3878         CALL ZGEBAK( 'P', 'R', N, ILO, IHI, RWORK( IBAL ), N, VS, LDVS,
3879     $                IERR )
3880      END IF
3881*
3882      IF( SCALEA ) THEN
3883*
3884*        Undo scaling for the Schur form of A
3885*
3886         CALL ZLASCL( 'U', 0, 0, CSCALE, ANRM, N, N, A, LDA, IERR )
3887         CALL ZCOPY( N, A, LDA+1, W, 1 )
3888      END IF
3889*
3890      WORK( 1 ) = MAXWRK
3891      RETURN
3892*
3893*     End of ZGEES
3894*
3895      END
3896*> \brief <b> ZGEEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices</b>
3897*
3898*  =========== DOCUMENTATION ===========
3899*
3900* Online html documentation available at
3901*            http://www.netlib.org/lapack/explore-html/
3902*
3903*> \htmlonly
3904*> Download ZGEEV + dependencies
3905*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgeev.f">
3906*> [TGZ]</a>
3907*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgeev.f">
3908*> [ZIP]</a>
3909*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgeev.f">
3910*> [TXT]</a>
3911*> \endhtmlonly
3912*
3913*  Definition:
3914*  ===========
3915*
3916*       SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR,
3917*                         WORK, LWORK, RWORK, INFO )
3918*
3919*       .. Scalar Arguments ..
3920*       CHARACTER          JOBVL, JOBVR
3921*       INTEGER            INFO, LDA, LDVL, LDVR, LWORK, N
3922*       ..
3923*       .. Array Arguments ..
3924*       DOUBLE PRECISION   RWORK( * )
3925*       COMPLEX*16         A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ),
3926*      $                   W( * ), WORK( * )
3927*       ..
3928*
3929*
3930*> \par Purpose:
3931*  =============
3932*>
3933*> \verbatim
3934*>
3935*> ZGEEV computes for an N-by-N complex nonsymmetric matrix A, the
3936*> eigenvalues and, optionally, the left and/or right eigenvectors.
3937*>
3938*> The right eigenvector v(j) of A satisfies
3939*>                  A * v(j) = lambda(j) * v(j)
3940*> where lambda(j) is its eigenvalue.
3941*> The left eigenvector u(j) of A satisfies
3942*>               u(j)**H * A = lambda(j) * u(j)**H
3943*> where u(j)**H denotes the conjugate transpose of u(j).
3944*>
3945*> The computed eigenvectors are normalized to have Euclidean norm
3946*> equal to 1 and largest component real.
3947*> \endverbatim
3948*
3949*  Arguments:
3950*  ==========
3951*
3952*> \param[in] JOBVL
3953*> \verbatim
3954*>          JOBVL is CHARACTER*1
3955*>          = 'N': left eigenvectors of A are not computed;
3956*>          = 'V': left eigenvectors of are computed.
3957*> \endverbatim
3958*>
3959*> \param[in] JOBVR
3960*> \verbatim
3961*>          JOBVR is CHARACTER*1
3962*>          = 'N': right eigenvectors of A are not computed;
3963*>          = 'V': right eigenvectors of A are computed.
3964*> \endverbatim
3965*>
3966*> \param[in] N
3967*> \verbatim
3968*>          N is INTEGER
3969*>          The order of the matrix A. N >= 0.
3970*> \endverbatim
3971*>
3972*> \param[in,out] A
3973*> \verbatim
3974*>          A is COMPLEX*16 array, dimension (LDA,N)
3975*>          On entry, the N-by-N matrix A.
3976*>          On exit, A has been overwritten.
3977*> \endverbatim
3978*>
3979*> \param[in] LDA
3980*> \verbatim
3981*>          LDA is INTEGER
3982*>          The leading dimension of the array A.  LDA >= max(1,N).
3983*> \endverbatim
3984*>
3985*> \param[out] W
3986*> \verbatim
3987*>          W is COMPLEX*16 array, dimension (N)
3988*>          W contains the computed eigenvalues.
3989*> \endverbatim
3990*>
3991*> \param[out] VL
3992*> \verbatim
3993*>          VL is COMPLEX*16 array, dimension (LDVL,N)
3994*>          If JOBVL = 'V', the left eigenvectors u(j) are stored one
3995*>          after another in the columns of VL, in the same order
3996*>          as their eigenvalues.
3997*>          If JOBVL = 'N', VL is not referenced.
3998*>          u(j) = VL(:,j), the j-th column of VL.
3999*> \endverbatim
4000*>
4001*> \param[in] LDVL
4002*> \verbatim
4003*>          LDVL is INTEGER
4004*>          The leading dimension of the array VL.  LDVL >= 1; if
4005*>          JOBVL = 'V', LDVL >= N.
4006*> \endverbatim
4007*>
4008*> \param[out] VR
4009*> \verbatim
4010*>          VR is COMPLEX*16 array, dimension (LDVR,N)
4011*>          If JOBVR = 'V', the right eigenvectors v(j) are stored one
4012*>          after another in the columns of VR, in the same order
4013*>          as their eigenvalues.
4014*>          If JOBVR = 'N', VR is not referenced.
4015*>          v(j) = VR(:,j), the j-th column of VR.
4016*> \endverbatim
4017*>
4018*> \param[in] LDVR
4019*> \verbatim
4020*>          LDVR is INTEGER
4021*>          The leading dimension of the array VR.  LDVR >= 1; if
4022*>          JOBVR = 'V', LDVR >= N.
4023*> \endverbatim
4024*>
4025*> \param[out] WORK
4026*> \verbatim
4027*>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
4028*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
4029*> \endverbatim
4030*>
4031*> \param[in] LWORK
4032*> \verbatim
4033*>          LWORK is INTEGER
4034*>          The dimension of the array WORK.  LWORK >= max(1,2*N).
4035*>          For good performance, LWORK must generally be larger.
4036*>
4037*>          If LWORK = -1, then a workspace query is assumed; the routine
4038*>          only calculates the optimal size of the WORK array, returns
4039*>          this value as the first entry of the WORK array, and no error
4040*>          message related to LWORK is issued by XERBLA.
4041*> \endverbatim
4042*>
4043*> \param[out] RWORK
4044*> \verbatim
4045*>          RWORK is DOUBLE PRECISION array, dimension (2*N)
4046*> \endverbatim
4047*>
4048*> \param[out] INFO
4049*> \verbatim
4050*>          INFO is INTEGER
4051*>          = 0:  successful exit
4052*>          < 0:  if INFO = -i, the i-th argument had an illegal value.
4053*>          > 0:  if INFO = i, the QR algorithm failed to compute all the
4054*>                eigenvalues, and no eigenvectors have been computed;
4055*>                elements i+1:N of W contain eigenvalues which have
4056*>                converged.
4057*> \endverbatim
4058*
4059*  Authors:
4060*  ========
4061*
4062*> \author Univ. of Tennessee
4063*> \author Univ. of California Berkeley
4064*> \author Univ. of Colorado Denver
4065*> \author NAG Ltd.
4066*
4067*> \date June 2016
4068*
4069*  @precisions fortran z -> c
4070*
4071*> \ingroup complex16GEeigen
4072*
4073*  =====================================================================
4074      SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR,
4075     $                  WORK, LWORK, RWORK, INFO )
4076      implicit none
4077*
4078*  -- LAPACK driver routine (version 3.7.0) --
4079*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
4080*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
4081*     June 2016
4082*
4083*     .. Scalar Arguments ..
4084      CHARACTER          JOBVL, JOBVR
4085      INTEGER            INFO, LDA, LDVL, LDVR, LWORK, N
4086*     ..
4087*     .. Array Arguments ..
4088      DOUBLE PRECISION   RWORK( * )
4089      COMPLEX*16         A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ),
4090     $                   W( * ), WORK( * )
4091*     ..
4092*
4093*  =====================================================================
4094*
4095*     .. Parameters ..
4096      DOUBLE PRECISION   ZERO, ONE
4097      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
4098*     ..
4099*     .. Local Scalars ..
4100      LOGICAL            LQUERY, SCALEA, WANTVL, WANTVR
4101      CHARACTER          SIDE
4102      INTEGER            HSWORK, I, IBAL, IERR, IHI, ILO, IRWORK, ITAU,
4103     $                   IWRK, K, LWORK_TREVC, MAXWRK, MINWRK, NOUT
4104      DOUBLE PRECISION   ANRM, BIGNUM, CSCALE, EPS, SCL, SMLNUM
4105      COMPLEX*16         TMP
4106*     ..
4107*     .. Local Arrays ..
4108      LOGICAL            SELECT( 1 )
4109      DOUBLE PRECISION   DUM( 1 )
4110*     ..
4111*     .. External Subroutines ..
4112      EXTERNAL           DLABAD, XERBLA, ZDSCAL, ZGEBAK, ZGEBAL, ZGEHRD,
4113     $                   ZHSEQR, ZLACPY, ZLASCL, ZSCAL, ZTREVC3, ZUNGHR
4114*     ..
4115*     .. External Functions ..
4116      LOGICAL            LSAME
4117      INTEGER            IDAMAX, ILAENV
4118      DOUBLE PRECISION   DLAMCH, DZNRM2, ZLANGE
4119      EXTERNAL           LSAME, IDAMAX, ILAENV, DLAMCH, DZNRM2, ZLANGE
4120*     ..
4121*     .. Intrinsic Functions ..
4122      INTRINSIC          DBLE, DCMPLX, CONJG, AIMAG, MAX, SQRT
4123*     ..
4124*     .. Executable Statements ..
4125*
4126*     Test the input arguments
4127*
4128      INFO = 0
4129      LQUERY = ( LWORK.EQ.-1 )
4130      WANTVL = LSAME( JOBVL, 'V' )
4131      WANTVR = LSAME( JOBVR, 'V' )
4132      IF( ( .NOT.WANTVL ) .AND. ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN
4133         INFO = -1
4134      ELSE IF( ( .NOT.WANTVR ) .AND. ( .NOT.LSAME( JOBVR, 'N' ) ) ) THEN
4135         INFO = -2
4136      ELSE IF( N.LT.0 ) THEN
4137         INFO = -3
4138      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
4139         INFO = -5
4140      ELSE IF( LDVL.LT.1 .OR. ( WANTVL .AND. LDVL.LT.N ) ) THEN
4141         INFO = -8
4142      ELSE IF( LDVR.LT.1 .OR. ( WANTVR .AND. LDVR.LT.N ) ) THEN
4143         INFO = -10
4144      END IF
4145*
4146*     Compute workspace
4147*      (Note: Comments in the code beginning "Workspace:" describe the
4148*       minimal amount of workspace needed at that point in the code,
4149*       as well as the preferred amount for good performance.
4150*       CWorkspace refers to complex workspace, and RWorkspace to real
4151*       workspace. NB refers to the optimal block size for the
4152*       immediately following subroutine, as returned by ILAENV.
4153*       HSWORK refers to the workspace preferred by ZHSEQR, as
4154*       calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
4155*       the worst case.)
4156*
4157      IF( INFO.EQ.0 ) THEN
4158         IF( N.EQ.0 ) THEN
4159            MINWRK = 1
4160            MAXWRK = 1
4161         ELSE
4162            MAXWRK = N + N*ILAENV( 1, 'ZGEHRD', ' ', N, 1, N, 0 )
4163            MINWRK = 2*N
4164            IF( WANTVL ) THEN
4165               MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'ZUNGHR',
4166     $                       ' ', N, 1, N, -1 ) )
4167               CALL ZTREVC3( 'L', 'B', SELECT, N, A, LDA,
4168     $                       VL, LDVL, VR, LDVR,
4169     $                       N, NOUT, WORK, -1, RWORK, -1, IERR )
4170               LWORK_TREVC = INT( WORK(1) )
4171               MAXWRK = MAX( MAXWRK, N + LWORK_TREVC )
4172               CALL ZHSEQR( 'S', 'V', N, 1, N, A, LDA, W, VL, LDVL,
4173     $                      WORK, -1, INFO )
4174            ELSE IF( WANTVR ) THEN
4175               MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'ZUNGHR',
4176     $                       ' ', N, 1, N, -1 ) )
4177               CALL ZTREVC3( 'R', 'B', SELECT, N, A, LDA,
4178     $                       VL, LDVL, VR, LDVR,
4179     $                       N, NOUT, WORK, -1, RWORK, -1, IERR )
4180               LWORK_TREVC = INT( WORK(1) )
4181               MAXWRK = MAX( MAXWRK, N + LWORK_TREVC )
4182               CALL ZHSEQR( 'S', 'V', N, 1, N, A, LDA, W, VR, LDVR,
4183     $                      WORK, -1, INFO )
4184            ELSE
4185               CALL ZHSEQR( 'E', 'N', N, 1, N, A, LDA, W, VR, LDVR,
4186     $                      WORK, -1, INFO )
4187            END IF
4188            HSWORK = INT( WORK(1) )
4189            MAXWRK = MAX( MAXWRK, HSWORK, MINWRK )
4190         END IF
4191         WORK( 1 ) = MAXWRK
4192*
4193         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
4194            INFO = -12
4195         END IF
4196      END IF
4197*
4198      IF( INFO.NE.0 ) THEN
4199         CALL XERBLA( 'ZGEEV ', -INFO )
4200         RETURN
4201      ELSE IF( LQUERY ) THEN
4202         RETURN
4203      END IF
4204*
4205*     Quick return if possible
4206*
4207      IF( N.EQ.0 )
4208     $   RETURN
4209*
4210*     Get machine constants
4211*
4212      EPS = DLAMCH( 'P' )
4213      SMLNUM = DLAMCH( 'S' )
4214      BIGNUM = ONE / SMLNUM
4215      CALL DLABAD( SMLNUM, BIGNUM )
4216      SMLNUM = SQRT( SMLNUM ) / EPS
4217      BIGNUM = ONE / SMLNUM
4218*
4219*     Scale A if max element outside range [SMLNUM,BIGNUM]
4220*
4221      ANRM = ZLANGE( 'M', N, N, A, LDA, DUM )
4222      SCALEA = .FALSE.
4223      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
4224         SCALEA = .TRUE.
4225         CSCALE = SMLNUM
4226      ELSE IF( ANRM.GT.BIGNUM ) THEN
4227         SCALEA = .TRUE.
4228         CSCALE = BIGNUM
4229      END IF
4230      IF( SCALEA )
4231     $   CALL ZLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
4232*
4233*     Balance the matrix
4234*     (CWorkspace: none)
4235*     (RWorkspace: need N)
4236*
4237      IBAL = 1
4238      CALL ZGEBAL( 'B', N, A, LDA, ILO, IHI, RWORK( IBAL ), IERR )
4239*
4240*     Reduce to upper Hessenberg form
4241*     (CWorkspace: need 2*N, prefer N+N*NB)
4242*     (RWorkspace: none)
4243*
4244      ITAU = 1
4245      IWRK = ITAU + N
4246      CALL ZGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ),
4247     $             LWORK-IWRK+1, IERR )
4248*
4249      IF( WANTVL ) THEN
4250*
4251*        Want left eigenvectors
4252*        Copy Householder vectors to VL
4253*
4254         SIDE = 'L'
4255         CALL ZLACPY( 'L', N, N, A, LDA, VL, LDVL )
4256*
4257*        Generate unitary matrix in VL
4258*        (CWorkspace: need 2*N-1, prefer N+(N-1)*NB)
4259*        (RWorkspace: none)
4260*
4261         CALL ZUNGHR( N, ILO, IHI, VL, LDVL, WORK( ITAU ), WORK( IWRK ),
4262     $                LWORK-IWRK+1, IERR )
4263*
4264*        Perform QR iteration, accumulating Schur vectors in VL
4265*        (CWorkspace: need 1, prefer HSWORK (see comments) )
4266*        (RWorkspace: none)
4267*
4268         IWRK = ITAU
4269         CALL ZHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, W, VL, LDVL,
4270     $                WORK( IWRK ), LWORK-IWRK+1, INFO )
4271*
4272         IF( WANTVR ) THEN
4273*
4274*           Want left and right eigenvectors
4275*           Copy Schur vectors to VR
4276*
4277            SIDE = 'B'
4278            CALL ZLACPY( 'F', N, N, VL, LDVL, VR, LDVR )
4279         END IF
4280*
4281      ELSE IF( WANTVR ) THEN
4282*
4283*        Want right eigenvectors
4284*        Copy Householder vectors to VR
4285*
4286         SIDE = 'R'
4287         CALL ZLACPY( 'L', N, N, A, LDA, VR, LDVR )
4288*
4289*        Generate unitary matrix in VR
4290*        (CWorkspace: need 2*N-1, prefer N+(N-1)*NB)
4291*        (RWorkspace: none)
4292*
4293         CALL ZUNGHR( N, ILO, IHI, VR, LDVR, WORK( ITAU ), WORK( IWRK ),
4294     $                LWORK-IWRK+1, IERR )
4295*
4296*        Perform QR iteration, accumulating Schur vectors in VR
4297*        (CWorkspace: need 1, prefer HSWORK (see comments) )
4298*        (RWorkspace: none)
4299*
4300         IWRK = ITAU
4301         CALL ZHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, W, VR, LDVR,
4302     $                WORK( IWRK ), LWORK-IWRK+1, INFO )
4303*
4304      ELSE
4305*
4306*        Compute eigenvalues only
4307*        (CWorkspace: need 1, prefer HSWORK (see comments) )
4308*        (RWorkspace: none)
4309*
4310         IWRK = ITAU
4311         CALL ZHSEQR( 'E', 'N', N, ILO, IHI, A, LDA, W, VR, LDVR,
4312     $                WORK( IWRK ), LWORK-IWRK+1, INFO )
4313      END IF
4314*
4315*     If INFO .NE. 0 from ZHSEQR, then quit
4316*
4317      IF( INFO.NE.0 )
4318     $   GO TO 50
4319*
4320      IF( WANTVL .OR. WANTVR ) THEN
4321*
4322*        Compute left and/or right eigenvectors
4323*        (CWorkspace: need 2*N, prefer N + 2*N*NB)
4324*        (RWorkspace: need 2*N)
4325*
4326         IRWORK = IBAL + N
4327         CALL ZTREVC3( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR,
4328     $                 N, NOUT, WORK( IWRK ), LWORK-IWRK+1,
4329     $                 RWORK( IRWORK ), N, IERR )
4330      END IF
4331*
4332      IF( WANTVL ) THEN
4333*
4334*        Undo balancing of left eigenvectors
4335*        (CWorkspace: none)
4336*        (RWorkspace: need N)
4337*
4338         CALL ZGEBAK( 'B', 'L', N, ILO, IHI, RWORK( IBAL ), N, VL, LDVL,
4339     $                IERR )
4340*
4341*        Normalize left eigenvectors and make largest component real
4342*
4343         DO 20 I = 1, N
4344            SCL = ONE / DZNRM2( N, VL( 1, I ), 1 )
4345            CALL ZDSCAL( N, SCL, VL( 1, I ), 1 )
4346            DO 10 K = 1, N
4347               RWORK( IRWORK+K-1 ) = DBLE( VL( K, I ) )**2 +
4348     $                               AIMAG( VL( K, I ) )**2
4349   10       CONTINUE
4350            K = IDAMAX( N, RWORK( IRWORK ), 1 )
4351            TMP = CONJG( VL( K, I ) ) / SQRT( RWORK( IRWORK+K-1 ) )
4352            CALL ZSCAL( N, TMP, VL( 1, I ), 1 )
4353            VL( K, I ) = DCMPLX( DBLE( VL( K, I ) ), ZERO )
4354   20    CONTINUE
4355      END IF
4356*
4357      IF( WANTVR ) THEN
4358*
4359*        Undo balancing of right eigenvectors
4360*        (CWorkspace: none)
4361*        (RWorkspace: need N)
4362*
4363         CALL ZGEBAK( 'B', 'R', N, ILO, IHI, RWORK( IBAL ), N, VR, LDVR,
4364     $                IERR )
4365*
4366*        Normalize right eigenvectors and make largest component real
4367*
4368         DO 40 I = 1, N
4369            SCL = ONE / DZNRM2( N, VR( 1, I ), 1 )
4370            CALL ZDSCAL( N, SCL, VR( 1, I ), 1 )
4371            DO 30 K = 1, N
4372               RWORK( IRWORK+K-1 ) = DBLE( VR( K, I ) )**2 +
4373     $                               AIMAG( VR( K, I ) )**2
4374   30       CONTINUE
4375            K = IDAMAX( N, RWORK( IRWORK ), 1 )
4376            TMP = CONJG( VR( K, I ) ) / SQRT( RWORK( IRWORK+K-1 ) )
4377            CALL ZSCAL( N, TMP, VR( 1, I ), 1 )
4378            VR( K, I ) = DCMPLX( DBLE( VR( K, I ) ), ZERO )
4379   40    CONTINUE
4380      END IF
4381*
4382*     Undo scaling if necessary
4383*
4384   50 CONTINUE
4385      IF( SCALEA ) THEN
4386         CALL ZLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, W( INFO+1 ),
4387     $                MAX( N-INFO, 1 ), IERR )
4388         IF( INFO.GT.0 ) THEN
4389            CALL ZLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, W, N, IERR )
4390         END IF
4391      END IF
4392*
4393      WORK( 1 ) = MAXWRK
4394      RETURN
4395*
4396*     End of ZGEEV
4397*
4398      END
4399*> \brief \b ZGEHD2 reduces a general square matrix to upper Hessenberg form using an unblocked algorithm.
4400*
4401*  =========== DOCUMENTATION ===========
4402*
4403* Online html documentation available at
4404*            http://www.netlib.org/lapack/explore-html/
4405*
4406*> \htmlonly
4407*> Download ZGEHD2 + dependencies
4408*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgehd2.f">
4409*> [TGZ]</a>
4410*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgehd2.f">
4411*> [ZIP]</a>
4412*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgehd2.f">
4413*> [TXT]</a>
4414*> \endhtmlonly
4415*
4416*  Definition:
4417*  ===========
4418*
4419*       SUBROUTINE ZGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
4420*
4421*       .. Scalar Arguments ..
4422*       INTEGER            IHI, ILO, INFO, LDA, N
4423*       ..
4424*       .. Array Arguments ..
4425*       COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
4426*       ..
4427*
4428*
4429*> \par Purpose:
4430*  =============
4431*>
4432*> \verbatim
4433*>
4434*> ZGEHD2 reduces a complex general matrix A to upper Hessenberg form H
4435*> by a unitary similarity transformation:  Q**H * A * Q = H .
4436*> \endverbatim
4437*
4438*  Arguments:
4439*  ==========
4440*
4441*> \param[in] N
4442*> \verbatim
4443*>          N is INTEGER
4444*>          The order of the matrix A.  N >= 0.
4445*> \endverbatim
4446*>
4447*> \param[in] ILO
4448*> \verbatim
4449*>          ILO is INTEGER
4450*> \endverbatim
4451*>
4452*> \param[in] IHI
4453*> \verbatim
4454*>          IHI is INTEGER
4455*>
4456*>          It is assumed that A is already upper triangular in rows
4457*>          and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
4458*>          set by a previous call to ZGEBAL; otherwise they should be
4459*>          set to 1 and N respectively. See Further Details.
4460*>          1 <= ILO <= IHI <= max(1,N).
4461*> \endverbatim
4462*>
4463*> \param[in,out] A
4464*> \verbatim
4465*>          A is COMPLEX*16 array, dimension (LDA,N)
4466*>          On entry, the n by n general matrix to be reduced.
4467*>          On exit, the upper triangle and the first subdiagonal of A
4468*>          are overwritten with the upper Hessenberg matrix H, and the
4469*>          elements below the first subdiagonal, with the array TAU,
4470*>          represent the unitary matrix Q as a product of elementary
4471*>          reflectors. See Further Details.
4472*> \endverbatim
4473*>
4474*> \param[in] LDA
4475*> \verbatim
4476*>          LDA is INTEGER
4477*>          The leading dimension of the array A.  LDA >= max(1,N).
4478*> \endverbatim
4479*>
4480*> \param[out] TAU
4481*> \verbatim
4482*>          TAU is COMPLEX*16 array, dimension (N-1)
4483*>          The scalar factors of the elementary reflectors (see Further
4484*>          Details).
4485*> \endverbatim
4486*>
4487*> \param[out] WORK
4488*> \verbatim
4489*>          WORK is COMPLEX*16 array, dimension (N)
4490*> \endverbatim
4491*>
4492*> \param[out] INFO
4493*> \verbatim
4494*>          INFO is INTEGER
4495*>          = 0:  successful exit
4496*>          < 0:  if INFO = -i, the i-th argument had an illegal value.
4497*> \endverbatim
4498*
4499*  Authors:
4500*  ========
4501*
4502*> \author Univ. of Tennessee
4503*> \author Univ. of California Berkeley
4504*> \author Univ. of Colorado Denver
4505*> \author NAG Ltd.
4506*
4507*> \date December 2016
4508*
4509*> \ingroup complex16GEcomputational
4510*
4511*> \par Further Details:
4512*  =====================
4513*>
4514*> \verbatim
4515*>
4516*>  The matrix Q is represented as a product of (ihi-ilo) elementary
4517*>  reflectors
4518*>
4519*>     Q = H(ilo) H(ilo+1) . . . H(ihi-1).
4520*>
4521*>  Each H(i) has the form
4522*>
4523*>     H(i) = I - tau * v * v**H
4524*>
4525*>  where tau is a complex scalar, and v is a complex vector with
4526*>  v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
4527*>  exit in A(i+2:ihi,i), and tau in TAU(i).
4528*>
4529*>  The contents of A are illustrated by the following example, with
4530*>  n = 7, ilo = 2 and ihi = 6:
4531*>
4532*>  on entry,                        on exit,
4533*>
4534*>  ( a   a   a   a   a   a   a )    (  a   a   h   h   h   h   a )
4535*>  (     a   a   a   a   a   a )    (      a   h   h   h   h   a )
4536*>  (     a   a   a   a   a   a )    (      h   h   h   h   h   h )
4537*>  (     a   a   a   a   a   a )    (      v2  h   h   h   h   h )
4538*>  (     a   a   a   a   a   a )    (      v2  v3  h   h   h   h )
4539*>  (     a   a   a   a   a   a )    (      v2  v3  v4  h   h   h )
4540*>  (                         a )    (                          a )
4541*>
4542*>  where a denotes an element of the original matrix A, h denotes a
4543*>  modified element of the upper Hessenberg matrix H, and vi denotes an
4544*>  element of the vector defining H(i).
4545*> \endverbatim
4546*>
4547*  =====================================================================
4548      SUBROUTINE ZGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
4549*
4550*  -- LAPACK computational routine (version 3.7.0) --
4551*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
4552*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
4553*     December 2016
4554*
4555*     .. Scalar Arguments ..
4556      INTEGER            IHI, ILO, INFO, LDA, N
4557*     ..
4558*     .. Array Arguments ..
4559      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
4560*     ..
4561*
4562*  =====================================================================
4563*
4564*     .. Parameters ..
4565      COMPLEX*16         ONE
4566      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
4567*     ..
4568*     .. Local Scalars ..
4569      INTEGER            I
4570      COMPLEX*16         ALPHA
4571*     ..
4572*     .. External Subroutines ..
4573      EXTERNAL           XERBLA, ZLARF, ZLARFG
4574*     ..
4575*     .. Intrinsic Functions ..
4576      INTRINSIC          DCONJG, MAX, MIN
4577*     ..
4578*     .. Executable Statements ..
4579*
4580*     Test the input parameters
4581*
4582      INFO = 0
4583      IF( N.LT.0 ) THEN
4584         INFO = -1
4585      ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
4586         INFO = -2
4587      ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
4588         INFO = -3
4589      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
4590         INFO = -5
4591      END IF
4592      IF( INFO.NE.0 ) THEN
4593         CALL XERBLA( 'ZGEHD2', -INFO )
4594         RETURN
4595      END IF
4596*
4597      DO 10 I = ILO, IHI - 1
4598*
4599*        Compute elementary reflector H(i) to annihilate A(i+2:ihi,i)
4600*
4601         ALPHA = A( I+1, I )
4602         CALL ZLARFG( IHI-I, ALPHA, A( MIN( I+2, N ), I ), 1, TAU( I ) )
4603         A( I+1, I ) = ONE
4604*
4605*        Apply H(i) to A(1:ihi,i+1:ihi) from the right
4606*
4607         CALL ZLARF( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ),
4608     $               A( 1, I+1 ), LDA, WORK )
4609*
4610*        Apply H(i)**H to A(i+1:ihi,i+1:n) from the left
4611*
4612         CALL ZLARF( 'Left', IHI-I, N-I, A( I+1, I ), 1,
4613     $               DCONJG( TAU( I ) ), A( I+1, I+1 ), LDA, WORK )
4614*
4615         A( I+1, I ) = ALPHA
4616   10 CONTINUE
4617*
4618      RETURN
4619*
4620*     End of ZGEHD2
4621*
4622      END
4623*> \brief \b ZGEHRD
4624*
4625*  =========== DOCUMENTATION ===========
4626*
4627* Online html documentation available at
4628*            http://www.netlib.org/lapack/explore-html/
4629*
4630*> \htmlonly
4631*> Download ZGEHRD + dependencies
4632*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgehrd.f">
4633*> [TGZ]</a>
4634*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgehrd.f">
4635*> [ZIP]</a>
4636*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgehrd.f">
4637*> [TXT]</a>
4638*> \endhtmlonly
4639*
4640*  Definition:
4641*  ===========
4642*
4643*       SUBROUTINE ZGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
4644*
4645*       .. Scalar Arguments ..
4646*       INTEGER            IHI, ILO, INFO, LDA, LWORK, N
4647*       ..
4648*       .. Array Arguments ..
4649*       COMPLEX*16        A( LDA, * ), TAU( * ), WORK( * )
4650*       ..
4651*
4652*
4653*> \par Purpose:
4654*  =============
4655*>
4656*> \verbatim
4657*>
4658*> ZGEHRD reduces a complex general matrix A to upper Hessenberg form H by
4659*> an unitary similarity transformation:  Q**H * A * Q = H .
4660*> \endverbatim
4661*
4662*  Arguments:
4663*  ==========
4664*
4665*> \param[in] N
4666*> \verbatim
4667*>          N is INTEGER
4668*>          The order of the matrix A.  N >= 0.
4669*> \endverbatim
4670*>
4671*> \param[in] ILO
4672*> \verbatim
4673*>          ILO is INTEGER
4674*> \endverbatim
4675*>
4676*> \param[in] IHI
4677*> \verbatim
4678*>          IHI is INTEGER
4679*>
4680*>          It is assumed that A is already upper triangular in rows
4681*>          and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
4682*>          set by a previous call to ZGEBAL; otherwise they should be
4683*>          set to 1 and N respectively. See Further Details.
4684*>          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
4685*> \endverbatim
4686*>
4687*> \param[in,out] A
4688*> \verbatim
4689*>          A is COMPLEX*16 array, dimension (LDA,N)
4690*>          On entry, the N-by-N general matrix to be reduced.
4691*>          On exit, the upper triangle and the first subdiagonal of A
4692*>          are overwritten with the upper Hessenberg matrix H, and the
4693*>          elements below the first subdiagonal, with the array TAU,
4694*>          represent the unitary matrix Q as a product of elementary
4695*>          reflectors. See Further Details.
4696*> \endverbatim
4697*>
4698*> \param[in] LDA
4699*> \verbatim
4700*>          LDA is INTEGER
4701*>          The leading dimension of the array A.  LDA >= max(1,N).
4702*> \endverbatim
4703*>
4704*> \param[out] TAU
4705*> \verbatim
4706*>          TAU is COMPLEX*16 array, dimension (N-1)
4707*>          The scalar factors of the elementary reflectors (see Further
4708*>          Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to
4709*>          zero.
4710*> \endverbatim
4711*>
4712*> \param[out] WORK
4713*> \verbatim
4714*>          WORK is COMPLEX*16 array, dimension (LWORK)
4715*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
4716*> \endverbatim
4717*>
4718*> \param[in] LWORK
4719*> \verbatim
4720*>          LWORK is INTEGER
4721*>          The length of the array WORK.  LWORK >= max(1,N).
4722*>          For good performance, LWORK should generally be larger.
4723*>
4724*>          If LWORK = -1, then a workspace query is assumed; the routine
4725*>          only calculates the optimal size of the WORK array, returns
4726*>          this value as the first entry of the WORK array, and no error
4727*>          message related to LWORK is issued by XERBLA.
4728*> \endverbatim
4729*>
4730*> \param[out] INFO
4731*> \verbatim
4732*>          INFO is INTEGER
4733*>          = 0:  successful exit
4734*>          < 0:  if INFO = -i, the i-th argument had an illegal value.
4735*> \endverbatim
4736*
4737*  Authors:
4738*  ========
4739*
4740*> \author Univ. of Tennessee
4741*> \author Univ. of California Berkeley
4742*> \author Univ. of Colorado Denver
4743*> \author NAG Ltd.
4744*
4745*> \date December 2016
4746*
4747*> \ingroup complex16GEcomputational
4748*
4749*> \par Further Details:
4750*  =====================
4751*>
4752*> \verbatim
4753*>
4754*>  The matrix Q is represented as a product of (ihi-ilo) elementary
4755*>  reflectors
4756*>
4757*>     Q = H(ilo) H(ilo+1) . . . H(ihi-1).
4758*>
4759*>  Each H(i) has the form
4760*>
4761*>     H(i) = I - tau * v * v**H
4762*>
4763*>  where tau is a complex scalar, and v is a complex vector with
4764*>  v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
4765*>  exit in A(i+2:ihi,i), and tau in TAU(i).
4766*>
4767*>  The contents of A are illustrated by the following example, with
4768*>  n = 7, ilo = 2 and ihi = 6:
4769*>
4770*>  on entry,                        on exit,
4771*>
4772*>  ( a   a   a   a   a   a   a )    (  a   a   h   h   h   h   a )
4773*>  (     a   a   a   a   a   a )    (      a   h   h   h   h   a )
4774*>  (     a   a   a   a   a   a )    (      h   h   h   h   h   h )
4775*>  (     a   a   a   a   a   a )    (      v2  h   h   h   h   h )
4776*>  (     a   a   a   a   a   a )    (      v2  v3  h   h   h   h )
4777*>  (     a   a   a   a   a   a )    (      v2  v3  v4  h   h   h )
4778*>  (                         a )    (                          a )
4779*>
4780*>  where a denotes an element of the original matrix A, h denotes a
4781*>  modified element of the upper Hessenberg matrix H, and vi denotes an
4782*>  element of the vector defining H(i).
4783*>
4784*>  This file is a slight modification of LAPACK-3.0's DGEHRD
4785*>  subroutine incorporating improvements proposed by Quintana-Orti and
4786*>  Van de Geijn (2006). (See DLAHR2.)
4787*> \endverbatim
4788*>
4789*  =====================================================================
4790      SUBROUTINE ZGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
4791*
4792*  -- LAPACK computational routine (version 3.7.0) --
4793*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
4794*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
4795*     December 2016
4796*
4797*     .. Scalar Arguments ..
4798      INTEGER            IHI, ILO, INFO, LDA, LWORK, N
4799*     ..
4800*     .. Array Arguments ..
4801      COMPLEX*16        A( LDA, * ), TAU( * ), WORK( * )
4802*     ..
4803*
4804*  =====================================================================
4805*
4806*     .. Parameters ..
4807      INTEGER            NBMAX, LDT, TSIZE
4808      PARAMETER          ( NBMAX = 64, LDT = NBMAX+1,
4809     $                     TSIZE = LDT*NBMAX )
4810      COMPLEX*16        ZERO, ONE
4811      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ),
4812     $                     ONE = ( 1.0D+0, 0.0D+0 ) )
4813*     ..
4814*     .. Local Scalars ..
4815      LOGICAL            LQUERY
4816      INTEGER            I, IB, IINFO, IWT, J, LDWORK, LWKOPT, NB,
4817     $                   NBMIN, NH, NX
4818      COMPLEX*16        EI
4819*     ..
4820*     .. External Subroutines ..
4821      EXTERNAL           ZAXPY, ZGEHD2, ZGEMM, ZLAHR2, ZLARFB, ZTRMM,
4822     $                   XERBLA
4823*     ..
4824*     .. Intrinsic Functions ..
4825      INTRINSIC          MAX, MIN
4826*     ..
4827*     .. External Functions ..
4828      INTEGER            ILAENV
4829      EXTERNAL           ILAENV
4830*     ..
4831*     .. Executable Statements ..
4832*
4833*     Test the input parameters
4834*
4835      INFO = 0
4836      LQUERY = ( LWORK.EQ.-1 )
4837      IF( N.LT.0 ) THEN
4838         INFO = -1
4839      ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
4840         INFO = -2
4841      ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
4842         INFO = -3
4843      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
4844         INFO = -5
4845      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
4846         INFO = -8
4847      END IF
4848*
4849      IF( INFO.EQ.0 ) THEN
4850*
4851*        Compute the workspace requirements
4852*
4853         NB = MIN( NBMAX, ILAENV( 1, 'ZGEHRD', ' ', N, ILO, IHI, -1 ) )
4854         LWKOPT = N*NB + TSIZE
4855         WORK( 1 ) = LWKOPT
4856      ENDIF
4857*
4858      IF( INFO.NE.0 ) THEN
4859         CALL XERBLA( 'ZGEHRD', -INFO )
4860         RETURN
4861      ELSE IF( LQUERY ) THEN
4862         RETURN
4863      END IF
4864*
4865*     Set elements 1:ILO-1 and IHI:N-1 of TAU to zero
4866*
4867      DO 10 I = 1, ILO - 1
4868         TAU( I ) = ZERO
4869   10 CONTINUE
4870      DO 20 I = MAX( 1, IHI ), N - 1
4871         TAU( I ) = ZERO
4872   20 CONTINUE
4873*
4874*     Quick return if possible
4875*
4876      NH = IHI - ILO + 1
4877      IF( NH.LE.1 ) THEN
4878         WORK( 1 ) = 1
4879         RETURN
4880      END IF
4881*
4882*     Determine the block size
4883*
4884      NB = MIN( NBMAX, ILAENV( 1, 'ZGEHRD', ' ', N, ILO, IHI, -1 ) )
4885      NBMIN = 2
4886      IF( NB.GT.1 .AND. NB.LT.NH ) THEN
4887*
4888*        Determine when to cross over from blocked to unblocked code
4889*        (last block is always handled by unblocked code)
4890*
4891         NX = MAX( NB, ILAENV( 3, 'ZGEHRD', ' ', N, ILO, IHI, -1 ) )
4892         IF( NX.LT.NH ) THEN
4893*
4894*           Determine if workspace is large enough for blocked code
4895*
4896            IF( LWORK.LT.N*NB+TSIZE ) THEN
4897*
4898*              Not enough workspace to use optimal NB:  determine the
4899*              minimum value of NB, and reduce NB or force use of
4900*              unblocked code
4901*
4902               NBMIN = MAX( 2, ILAENV( 2, 'ZGEHRD', ' ', N, ILO, IHI,
4903     $                 -1 ) )
4904               IF( LWORK.GE.(N*NBMIN + TSIZE) ) THEN
4905                  NB = (LWORK-TSIZE) / N
4906               ELSE
4907                  NB = 1
4908               END IF
4909            END IF
4910         END IF
4911      END IF
4912      LDWORK = N
4913*
4914      IF( NB.LT.NBMIN .OR. NB.GE.NH ) THEN
4915*
4916*        Use unblocked code below
4917*
4918         I = ILO
4919*
4920      ELSE
4921*
4922*        Use blocked code
4923*
4924         IWT = 1 + N*NB
4925         DO 40 I = ILO, IHI - 1 - NX, NB
4926            IB = MIN( NB, IHI-I )
4927*
4928*           Reduce columns i:i+ib-1 to Hessenberg form, returning the
4929*           matrices V and T of the block reflector H = I - V*T*V**H
4930*           which performs the reduction, and also the matrix Y = A*V*T
4931*
4932            CALL ZLAHR2( IHI, I, IB, A( 1, I ), LDA, TAU( I ),
4933     $                   WORK( IWT ), LDT, WORK, LDWORK )
4934*
4935*           Apply the block reflector H to A(1:ihi,i+ib:ihi) from the
4936*           right, computing  A := A - Y * V**H. V(i+ib,ib-1) must be set
4937*           to 1
4938*
4939            EI = A( I+IB, I+IB-1 )
4940            A( I+IB, I+IB-1 ) = ONE
4941            CALL ZGEMM( 'No transpose', 'Conjugate transpose',
4942     $                  IHI, IHI-I-IB+1,
4943     $                  IB, -ONE, WORK, LDWORK, A( I+IB, I ), LDA, ONE,
4944     $                  A( 1, I+IB ), LDA )
4945            A( I+IB, I+IB-1 ) = EI
4946*
4947*           Apply the block reflector H to A(1:i,i+1:i+ib-1) from the
4948*           right
4949*
4950            CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
4951     $                  'Unit', I, IB-1,
4952     $                  ONE, A( I+1, I ), LDA, WORK, LDWORK )
4953            DO 30 J = 0, IB-2
4954               CALL ZAXPY( I, -ONE, WORK( LDWORK*J+1 ), 1,
4955     $                     A( 1, I+J+1 ), 1 )
4956   30       CONTINUE
4957*
4958*           Apply the block reflector H to A(i+1:ihi,i+ib:n) from the
4959*           left
4960*
4961            CALL ZLARFB( 'Left', 'Conjugate transpose', 'Forward',
4962     $                   'Columnwise',
4963     $                   IHI-I, N-I-IB+1, IB, A( I+1, I ), LDA,
4964     $                   WORK( IWT ), LDT, A( I+1, I+IB ), LDA,
4965     $                   WORK, LDWORK )
4966   40    CONTINUE
4967      END IF
4968*
4969*     Use unblocked code to reduce the rest of the matrix
4970*
4971      CALL ZGEHD2( N, I, IHI, A, LDA, TAU, WORK, IINFO )
4972      WORK( 1 ) = LWKOPT
4973*
4974      RETURN
4975*
4976*     End of ZGEHRD
4977*
4978      END
4979*> \brief \b ZGELQ2 computes the LQ factorization of a general rectangular matrix using an unblocked algorithm.
4980*
4981*  =========== DOCUMENTATION ===========
4982*
4983* Online html documentation available at
4984*            http://www.netlib.org/lapack/explore-html/
4985*
4986*> \htmlonly
4987*> Download ZGELQ2 + dependencies
4988*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgelq2.f">
4989*> [TGZ]</a>
4990*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgelq2.f">
4991*> [ZIP]</a>
4992*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgelq2.f">
4993*> [TXT]</a>
4994*> \endhtmlonly
4995*
4996*  Definition:
4997*  ===========
4998*
4999*       SUBROUTINE ZGELQ2( M, N, A, LDA, TAU, WORK, INFO )
5000*
5001*       .. Scalar Arguments ..
5002*       INTEGER            INFO, LDA, M, N
5003*       ..
5004*       .. Array Arguments ..
5005*       COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
5006*       ..
5007*
5008*
5009*> \par Purpose:
5010*  =============
5011*>
5012*> \verbatim
5013*>
5014*> ZGELQ2 computes an LQ factorization of a complex m-by-n matrix A:
5015*>
5016*>    A = ( L 0 ) *  Q
5017*>
5018*> where:
5019*>
5020*>    Q is a n-by-n orthogonal matrix;
5021*>    L is an lower-triangular m-by-m matrix;
5022*>    0 is a m-by-(n-m) zero matrix, if m < n.
5023*>
5024*> \endverbatim
5025*
5026*  Arguments:
5027*  ==========
5028*
5029*> \param[in] M
5030*> \verbatim
5031*>          M is INTEGER
5032*>          The number of rows of the matrix A.  M >= 0.
5033*> \endverbatim
5034*>
5035*> \param[in] N
5036*> \verbatim
5037*>          N is INTEGER
5038*>          The number of columns of the matrix A.  N >= 0.
5039*> \endverbatim
5040*>
5041*> \param[in,out] A
5042*> \verbatim
5043*>          A is COMPLEX*16 array, dimension (LDA,N)
5044*>          On entry, the m by n matrix A.
5045*>          On exit, the elements on and below the diagonal of the array
5046*>          contain the m by min(m,n) lower trapezoidal matrix L (L is
5047*>          lower triangular if m <= n); the elements above the diagonal,
5048*>          with the array TAU, represent the unitary matrix Q as a
5049*>          product of elementary reflectors (see Further Details).
5050*> \endverbatim
5051*>
5052*> \param[in] LDA
5053*> \verbatim
5054*>          LDA is INTEGER
5055*>          The leading dimension of the array A.  LDA >= max(1,M).
5056*> \endverbatim
5057*>
5058*> \param[out] TAU
5059*> \verbatim
5060*>          TAU is COMPLEX*16 array, dimension (min(M,N))
5061*>          The scalar factors of the elementary reflectors (see Further
5062*>          Details).
5063*> \endverbatim
5064*>
5065*> \param[out] WORK
5066*> \verbatim
5067*>          WORK is COMPLEX*16 array, dimension (M)
5068*> \endverbatim
5069*>
5070*> \param[out] INFO
5071*> \verbatim
5072*>          INFO is INTEGER
5073*>          = 0: successful exit
5074*>          < 0: if INFO = -i, the i-th argument had an illegal value
5075*> \endverbatim
5076*
5077*  Authors:
5078*  ========
5079*
5080*> \author Univ. of Tennessee
5081*> \author Univ. of California Berkeley
5082*> \author Univ. of Colorado Denver
5083*> \author NAG Ltd.
5084*
5085*> \date November 2019
5086*
5087*> \ingroup complex16GEcomputational
5088*
5089*> \par Further Details:
5090*  =====================
5091*>
5092*> \verbatim
5093*>
5094*>  The matrix Q is represented as a product of elementary reflectors
5095*>
5096*>     Q = H(k)**H . . . H(2)**H H(1)**H, where k = min(m,n).
5097*>
5098*>  Each H(i) has the form
5099*>
5100*>     H(i) = I - tau * v * v**H
5101*>
5102*>  where tau is a complex scalar, and v is a complex vector with
5103*>  v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in
5104*>  A(i,i+1:n), and tau in TAU(i).
5105*> \endverbatim
5106*>
5107*  =====================================================================
5108      SUBROUTINE ZGELQ2( M, N, A, LDA, TAU, WORK, INFO )
5109*
5110*  -- LAPACK computational routine (version 3.9.0) --
5111*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
5112*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
5113*     November 2019
5114*
5115*     .. Scalar Arguments ..
5116      INTEGER            INFO, LDA, M, N
5117*     ..
5118*     .. Array Arguments ..
5119      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
5120*     ..
5121*
5122*  =====================================================================
5123*
5124*     .. Parameters ..
5125      COMPLEX*16         ONE
5126      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
5127*     ..
5128*     .. Local Scalars ..
5129      INTEGER            I, K
5130      COMPLEX*16         ALPHA
5131*     ..
5132*     .. External Subroutines ..
5133      EXTERNAL           XERBLA, ZLACGV, ZLARF, ZLARFG
5134*     ..
5135*     .. Intrinsic Functions ..
5136      INTRINSIC          MAX, MIN
5137*     ..
5138*     .. Executable Statements ..
5139*
5140*     Test the input arguments
5141*
5142      INFO = 0
5143      IF( M.LT.0 ) THEN
5144         INFO = -1
5145      ELSE IF( N.LT.0 ) THEN
5146         INFO = -2
5147      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
5148         INFO = -4
5149      END IF
5150      IF( INFO.NE.0 ) THEN
5151         CALL XERBLA( 'ZGELQ2', -INFO )
5152         RETURN
5153      END IF
5154*
5155      K = MIN( M, N )
5156*
5157      DO 10 I = 1, K
5158*
5159*        Generate elementary reflector H(i) to annihilate A(i,i+1:n)
5160*
5161         CALL ZLACGV( N-I+1, A( I, I ), LDA )
5162         ALPHA = A( I, I )
5163         CALL ZLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA,
5164     $                TAU( I ) )
5165         IF( I.LT.M ) THEN
5166*
5167*           Apply H(i) to A(i+1:m,i:n) from the right
5168*
5169            A( I, I ) = ONE
5170            CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAU( I ),
5171     $                  A( I+1, I ), LDA, WORK )
5172         END IF
5173         A( I, I ) = ALPHA
5174         CALL ZLACGV( N-I+1, A( I, I ), LDA )
5175   10 CONTINUE
5176      RETURN
5177*
5178*     End of ZGELQ2
5179*
5180      END
5181*> \brief \b ZGELQF
5182*
5183*  =========== DOCUMENTATION ===========
5184*
5185* Online html documentation available at
5186*            http://www.netlib.org/lapack/explore-html/
5187*
5188*> \htmlonly
5189*> Download ZGELQF + dependencies
5190*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgelqf.f">
5191*> [TGZ]</a>
5192*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgelqf.f">
5193*> [ZIP]</a>
5194*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgelqf.f">
5195*> [TXT]</a>
5196*> \endhtmlonly
5197*
5198*  Definition:
5199*  ===========
5200*
5201*       SUBROUTINE ZGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
5202*
5203*       .. Scalar Arguments ..
5204*       INTEGER            INFO, LDA, LWORK, M, N
5205*       ..
5206*       .. Array Arguments ..
5207*       COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
5208*       ..
5209*
5210*
5211*> \par Purpose:
5212*  =============
5213*>
5214*> \verbatim
5215*>
5216*> ZGELQF computes an LQ factorization of a complex M-by-N matrix A:
5217*>
5218*>    A = ( L 0 ) *  Q
5219*>
5220*> where:
5221*>
5222*>    Q is a N-by-N orthogonal matrix;
5223*>    L is an lower-triangular M-by-M matrix;
5224*>    0 is a M-by-(N-M) zero matrix, if M < N.
5225*>
5226*> \endverbatim
5227*
5228*  Arguments:
5229*  ==========
5230*
5231*> \param[in] M
5232*> \verbatim
5233*>          M is INTEGER
5234*>          The number of rows of the matrix A.  M >= 0.
5235*> \endverbatim
5236*>
5237*> \param[in] N
5238*> \verbatim
5239*>          N is INTEGER
5240*>          The number of columns of the matrix A.  N >= 0.
5241*> \endverbatim
5242*>
5243*> \param[in,out] A
5244*> \verbatim
5245*>          A is COMPLEX*16 array, dimension (LDA,N)
5246*>          On entry, the M-by-N matrix A.
5247*>          On exit, the elements on and below the diagonal of the array
5248*>          contain the m-by-min(m,n) lower trapezoidal matrix L (L is
5249*>          lower triangular if m <= n); the elements above the diagonal,
5250*>          with the array TAU, represent the unitary matrix Q as a
5251*>          product of elementary reflectors (see Further Details).
5252*> \endverbatim
5253*>
5254*> \param[in] LDA
5255*> \verbatim
5256*>          LDA is INTEGER
5257*>          The leading dimension of the array A.  LDA >= max(1,M).
5258*> \endverbatim
5259*>
5260*> \param[out] TAU
5261*> \verbatim
5262*>          TAU is COMPLEX*16 array, dimension (min(M,N))
5263*>          The scalar factors of the elementary reflectors (see Further
5264*>          Details).
5265*> \endverbatim
5266*>
5267*> \param[out] WORK
5268*> \verbatim
5269*>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
5270*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
5271*> \endverbatim
5272*>
5273*> \param[in] LWORK
5274*> \verbatim
5275*>          LWORK is INTEGER
5276*>          The dimension of the array WORK.  LWORK >= max(1,M).
5277*>          For optimum performance LWORK >= M*NB, where NB is the
5278*>          optimal blocksize.
5279*>
5280*>          If LWORK = -1, then a workspace query is assumed; the routine
5281*>          only calculates the optimal size of the WORK array, returns
5282*>          this value as the first entry of the WORK array, and no error
5283*>          message related to LWORK is issued by XERBLA.
5284*> \endverbatim
5285*>
5286*> \param[out] INFO
5287*> \verbatim
5288*>          INFO is INTEGER
5289*>          = 0:  successful exit
5290*>          < 0:  if INFO = -i, the i-th argument had an illegal value
5291*> \endverbatim
5292*
5293*  Authors:
5294*  ========
5295*
5296*> \author Univ. of Tennessee
5297*> \author Univ. of California Berkeley
5298*> \author Univ. of Colorado Denver
5299*> \author NAG Ltd.
5300*
5301*> \date November 2019
5302*
5303*> \ingroup complex16GEcomputational
5304*
5305*> \par Further Details:
5306*  =====================
5307*>
5308*> \verbatim
5309*>
5310*>  The matrix Q is represented as a product of elementary reflectors
5311*>
5312*>     Q = H(k)**H . . . H(2)**H H(1)**H, where k = min(m,n).
5313*>
5314*>  Each H(i) has the form
5315*>
5316*>     H(i) = I - tau * v * v**H
5317*>
5318*>  where tau is a complex scalar, and v is a complex vector with
5319*>  v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in
5320*>  A(i,i+1:n), and tau in TAU(i).
5321*> \endverbatim
5322*>
5323*  =====================================================================
5324      SUBROUTINE ZGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
5325*
5326*  -- LAPACK computational routine (version 3.9.0) --
5327*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
5328*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
5329*     November 2019
5330*
5331*     .. Scalar Arguments ..
5332      INTEGER            INFO, LDA, LWORK, M, N
5333*     ..
5334*     .. Array Arguments ..
5335      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
5336*     ..
5337*
5338*  =====================================================================
5339*
5340*     .. Local Scalars ..
5341      LOGICAL            LQUERY
5342      INTEGER            I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,
5343     $                   NBMIN, NX
5344*     ..
5345*     .. External Subroutines ..
5346      EXTERNAL           XERBLA, ZGELQ2, ZLARFB, ZLARFT
5347*     ..
5348*     .. Intrinsic Functions ..
5349      INTRINSIC          MAX, MIN
5350*     ..
5351*     .. External Functions ..
5352      INTEGER            ILAENV
5353      EXTERNAL           ILAENV
5354*     ..
5355*     .. Executable Statements ..
5356*
5357*     Test the input arguments
5358*
5359      INFO = 0
5360      NB = ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 )
5361      LWKOPT = M*NB
5362      WORK( 1 ) = LWKOPT
5363      LQUERY = ( LWORK.EQ.-1 )
5364      IF( M.LT.0 ) THEN
5365         INFO = -1
5366      ELSE IF( N.LT.0 ) THEN
5367         INFO = -2
5368      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
5369         INFO = -4
5370      ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
5371         INFO = -7
5372      END IF
5373      IF( INFO.NE.0 ) THEN
5374         CALL XERBLA( 'ZGELQF', -INFO )
5375         RETURN
5376      ELSE IF( LQUERY ) THEN
5377         RETURN
5378      END IF
5379*
5380*     Quick return if possible
5381*
5382      K = MIN( M, N )
5383      IF( K.EQ.0 ) THEN
5384         WORK( 1 ) = 1
5385         RETURN
5386      END IF
5387*
5388      NBMIN = 2
5389      NX = 0
5390      IWS = M
5391      IF( NB.GT.1 .AND. NB.LT.K ) THEN
5392*
5393*        Determine when to cross over from blocked to unblocked code.
5394*
5395         NX = MAX( 0, ILAENV( 3, 'ZGELQF', ' ', M, N, -1, -1 ) )
5396         IF( NX.LT.K ) THEN
5397*
5398*           Determine if workspace is large enough for blocked code.
5399*
5400            LDWORK = M
5401            IWS = LDWORK*NB
5402            IF( LWORK.LT.IWS ) THEN
5403*
5404*              Not enough workspace to use optimal NB:  reduce NB and
5405*              determine the minimum value of NB.
5406*
5407               NB = LWORK / LDWORK
5408               NBMIN = MAX( 2, ILAENV( 2, 'ZGELQF', ' ', M, N, -1,
5409     $                 -1 ) )
5410            END IF
5411         END IF
5412      END IF
5413*
5414      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
5415*
5416*        Use blocked code initially
5417*
5418         DO 10 I = 1, K - NX, NB
5419            IB = MIN( K-I+1, NB )
5420*
5421*           Compute the LQ factorization of the current block
5422*           A(i:i+ib-1,i:n)
5423*
5424            CALL ZGELQ2( IB, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
5425     $                   IINFO )
5426            IF( I+IB.LE.M ) THEN
5427*
5428*              Form the triangular factor of the block reflector
5429*              H = H(i) H(i+1) . . . H(i+ib-1)
5430*
5431               CALL ZLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ),
5432     $                      LDA, TAU( I ), WORK, LDWORK )
5433*
5434*              Apply H to A(i+ib:m,i:n) from the right
5435*
5436               CALL ZLARFB( 'Right', 'No transpose', 'Forward',
5437     $                      'Rowwise', M-I-IB+1, N-I+1, IB, A( I, I ),
5438     $                      LDA, WORK, LDWORK, A( I+IB, I ), LDA,
5439     $                      WORK( IB+1 ), LDWORK )
5440            END IF
5441   10    CONTINUE
5442      ELSE
5443         I = 1
5444      END IF
5445*
5446*     Use unblocked code to factor the last or only block.
5447*
5448      IF( I.LE.K )
5449     $   CALL ZGELQ2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
5450     $                IINFO )
5451*
5452      WORK( 1 ) = IWS
5453      RETURN
5454*
5455*     End of ZGELQF
5456*
5457      END
5458*> \brief <b> ZGELS solves overdetermined or underdetermined systems for GE matrices</b>
5459*
5460*  =========== DOCUMENTATION ===========
5461*
5462* Online html documentation available at
5463*            http://www.netlib.org/lapack/explore-html/
5464*
5465*> \htmlonly
5466*> Download ZGELS + dependencies
5467*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgels.f">
5468*> [TGZ]</a>
5469*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgels.f">
5470*> [ZIP]</a>
5471*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgels.f">
5472*> [TXT]</a>
5473*> \endhtmlonly
5474*
5475*  Definition:
5476*  ===========
5477*
5478*       SUBROUTINE ZGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK,
5479*                         INFO )
5480*
5481*       .. Scalar Arguments ..
5482*       CHARACTER          TRANS
5483*       INTEGER            INFO, LDA, LDB, LWORK, M, N, NRHS
5484*       ..
5485*       .. Array Arguments ..
5486*       COMPLEX*16         A( LDA, * ), B( LDB, * ), WORK( * )
5487*       ..
5488*
5489*
5490*> \par Purpose:
5491*  =============
5492*>
5493*> \verbatim
5494*>
5495*> ZGELS solves overdetermined or underdetermined complex linear systems
5496*> involving an M-by-N matrix A, or its conjugate-transpose, using a QR
5497*> or LQ factorization of A.  It is assumed that A has full rank.
5498*>
5499*> The following options are provided:
5500*>
5501*> 1. If TRANS = 'N' and m >= n:  find the least squares solution of
5502*>    an overdetermined system, i.e., solve the least squares problem
5503*>                 minimize || B - A*X ||.
5504*>
5505*> 2. If TRANS = 'N' and m < n:  find the minimum norm solution of
5506*>    an underdetermined system A * X = B.
5507*>
5508*> 3. If TRANS = 'C' and m >= n:  find the minimum norm solution of
5509*>    an underdetermined system A**H * X = B.
5510*>
5511*> 4. If TRANS = 'C' and m < n:  find the least squares solution of
5512*>    an overdetermined system, i.e., solve the least squares problem
5513*>                 minimize || B - A**H * X ||.
5514*>
5515*> Several right hand side vectors b and solution vectors x can be
5516*> handled in a single call; they are stored as the columns of the
5517*> M-by-NRHS right hand side matrix B and the N-by-NRHS solution
5518*> matrix X.
5519*> \endverbatim
5520*
5521*  Arguments:
5522*  ==========
5523*
5524*> \param[in] TRANS
5525*> \verbatim
5526*>          TRANS is CHARACTER*1
5527*>          = 'N': the linear system involves A;
5528*>          = 'C': the linear system involves A**H.
5529*> \endverbatim
5530*>
5531*> \param[in] M
5532*> \verbatim
5533*>          M is INTEGER
5534*>          The number of rows of the matrix A.  M >= 0.
5535*> \endverbatim
5536*>
5537*> \param[in] N
5538*> \verbatim
5539*>          N is INTEGER
5540*>          The number of columns of the matrix A.  N >= 0.
5541*> \endverbatim
5542*>
5543*> \param[in] NRHS
5544*> \verbatim
5545*>          NRHS is INTEGER
5546*>          The number of right hand sides, i.e., the number of
5547*>          columns of the matrices B and X. NRHS >= 0.
5548*> \endverbatim
5549*>
5550*> \param[in,out] A
5551*> \verbatim
5552*>          A is COMPLEX*16 array, dimension (LDA,N)
5553*>          On entry, the M-by-N matrix A.
5554*>            if M >= N, A is overwritten by details of its QR
5555*>                       factorization as returned by ZGEQRF;
5556*>            if M <  N, A is overwritten by details of its LQ
5557*>                       factorization as returned by ZGELQF.
5558*> \endverbatim
5559*>
5560*> \param[in] LDA
5561*> \verbatim
5562*>          LDA is INTEGER
5563*>          The leading dimension of the array A.  LDA >= max(1,M).
5564*> \endverbatim
5565*>
5566*> \param[in,out] B
5567*> \verbatim
5568*>          B is COMPLEX*16 array, dimension (LDB,NRHS)
5569*>          On entry, the matrix B of right hand side vectors, stored
5570*>          columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS
5571*>          if TRANS = 'C'.
5572*>          On exit, if INFO = 0, B is overwritten by the solution
5573*>          vectors, stored columnwise:
5574*>          if TRANS = 'N' and m >= n, rows 1 to n of B contain the least
5575*>          squares solution vectors; the residual sum of squares for the
5576*>          solution in each column is given by the sum of squares of the
5577*>          modulus of elements N+1 to M in that column;
5578*>          if TRANS = 'N' and m < n, rows 1 to N of B contain the
5579*>          minimum norm solution vectors;
5580*>          if TRANS = 'C' and m >= n, rows 1 to M of B contain the
5581*>          minimum norm solution vectors;
5582*>          if TRANS = 'C' and m < n, rows 1 to M of B contain the
5583*>          least squares solution vectors; the residual sum of squares
5584*>          for the solution in each column is given by the sum of
5585*>          squares of the modulus of elements M+1 to N in that column.
5586*> \endverbatim
5587*>
5588*> \param[in] LDB
5589*> \verbatim
5590*>          LDB is INTEGER
5591*>          The leading dimension of the array B. LDB >= MAX(1,M,N).
5592*> \endverbatim
5593*>
5594*> \param[out] WORK
5595*> \verbatim
5596*>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
5597*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
5598*> \endverbatim
5599*>
5600*> \param[in] LWORK
5601*> \verbatim
5602*>          LWORK is INTEGER
5603*>          The dimension of the array WORK.
5604*>          LWORK >= max( 1, MN + max( MN, NRHS ) ).
5605*>          For optimal performance,
5606*>          LWORK >= max( 1, MN + max( MN, NRHS )*NB ).
5607*>          where MN = min(M,N) and NB is the optimum block size.
5608*>
5609*>          If LWORK = -1, then a workspace query is assumed; the routine
5610*>          only calculates the optimal size of the WORK array, returns
5611*>          this value as the first entry of the WORK array, and no error
5612*>          message related to LWORK is issued by XERBLA.
5613*> \endverbatim
5614*>
5615*> \param[out] INFO
5616*> \verbatim
5617*>          INFO is INTEGER
5618*>          = 0:  successful exit
5619*>          < 0:  if INFO = -i, the i-th argument had an illegal value
5620*>          > 0:  if INFO =  i, the i-th diagonal element of the
5621*>                triangular factor of A is zero, so that A does not have
5622*>                full rank; the least squares solution could not be
5623*>                computed.
5624*> \endverbatim
5625*
5626*  Authors:
5627*  ========
5628*
5629*> \author Univ. of Tennessee
5630*> \author Univ. of California Berkeley
5631*> \author Univ. of Colorado Denver
5632*> \author NAG Ltd.
5633*
5634*> \date December 2016
5635*
5636*> \ingroup complex16GEsolve
5637*
5638*  =====================================================================
5639      SUBROUTINE ZGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK,
5640     $                  INFO )
5641*
5642*  -- LAPACK driver routine (version 3.7.0) --
5643*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
5644*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
5645*     December 2016
5646*
5647*     .. Scalar Arguments ..
5648      CHARACTER          TRANS
5649      INTEGER            INFO, LDA, LDB, LWORK, M, N, NRHS
5650*     ..
5651*     .. Array Arguments ..
5652      COMPLEX*16         A( LDA, * ), B( LDB, * ), WORK( * )
5653*     ..
5654*
5655*  =====================================================================
5656*
5657*     .. Parameters ..
5658      DOUBLE PRECISION   ZERO, ONE
5659      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
5660      COMPLEX*16         CZERO
5661      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ) )
5662*     ..
5663*     .. Local Scalars ..
5664      LOGICAL            LQUERY, TPSD
5665      INTEGER            BROW, I, IASCL, IBSCL, J, MN, NB, SCLLEN, WSIZE
5666      DOUBLE PRECISION   ANRM, BIGNUM, BNRM, SMLNUM
5667*     ..
5668*     .. Local Arrays ..
5669      DOUBLE PRECISION   RWORK( 1 )
5670*     ..
5671*     .. External Functions ..
5672      LOGICAL            LSAME
5673      INTEGER            ILAENV
5674      DOUBLE PRECISION   DLAMCH, ZLANGE
5675      EXTERNAL           LSAME, ILAENV, DLAMCH, ZLANGE
5676*     ..
5677*     .. External Subroutines ..
5678      EXTERNAL           DLABAD, XERBLA, ZGELQF, ZGEQRF, ZLASCL, ZLASET,
5679     $                   ZTRTRS, ZUNMLQ, ZUNMQR
5680*     ..
5681*     .. Intrinsic Functions ..
5682      INTRINSIC          DBLE, MAX, MIN
5683*     ..
5684*     .. Executable Statements ..
5685*
5686*     Test the input arguments.
5687*
5688      INFO = 0
5689      MN = MIN( M, N )
5690      LQUERY = ( LWORK.EQ.-1 )
5691      IF( .NOT.( LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'C' ) ) ) THEN
5692         INFO = -1
5693      ELSE IF( M.LT.0 ) THEN
5694         INFO = -2
5695      ELSE IF( N.LT.0 ) THEN
5696         INFO = -3
5697      ELSE IF( NRHS.LT.0 ) THEN
5698         INFO = -4
5699      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
5700         INFO = -6
5701      ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
5702         INFO = -8
5703      ELSE IF( LWORK.LT.MAX( 1, MN+MAX( MN, NRHS ) ) .AND. .NOT.LQUERY )
5704     $          THEN
5705         INFO = -10
5706      END IF
5707*
5708*     Figure out optimal block size
5709*
5710      IF( INFO.EQ.0 .OR. INFO.EQ.-10 ) THEN
5711*
5712         TPSD = .TRUE.
5713         IF( LSAME( TRANS, 'N' ) )
5714     $      TPSD = .FALSE.
5715*
5716         IF( M.GE.N ) THEN
5717            NB = ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 )
5718            IF( TPSD ) THEN
5719               NB = MAX( NB, ILAENV( 1, 'ZUNMQR', 'LN', M, NRHS, N,
5720     $              -1 ) )
5721            ELSE
5722               NB = MAX( NB, ILAENV( 1, 'ZUNMQR', 'LC', M, NRHS, N,
5723     $              -1 ) )
5724            END IF
5725         ELSE
5726            NB = ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 )
5727            IF( TPSD ) THEN
5728               NB = MAX( NB, ILAENV( 1, 'ZUNMLQ', 'LC', N, NRHS, M,
5729     $              -1 ) )
5730            ELSE
5731               NB = MAX( NB, ILAENV( 1, 'ZUNMLQ', 'LN', N, NRHS, M,
5732     $              -1 ) )
5733            END IF
5734         END IF
5735*
5736         WSIZE = MAX( 1, MN+MAX( MN, NRHS )*NB )
5737         WORK( 1 ) = DBLE( WSIZE )
5738*
5739      END IF
5740*
5741      IF( INFO.NE.0 ) THEN
5742         CALL XERBLA( 'ZGELS ', -INFO )
5743         RETURN
5744      ELSE IF( LQUERY ) THEN
5745         RETURN
5746      END IF
5747*
5748*     Quick return if possible
5749*
5750      IF( MIN( M, N, NRHS ).EQ.0 ) THEN
5751         CALL ZLASET( 'Full', MAX( M, N ), NRHS, CZERO, CZERO, B, LDB )
5752         RETURN
5753      END IF
5754*
5755*     Get machine parameters
5756*
5757      SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' )
5758      BIGNUM = ONE / SMLNUM
5759      CALL DLABAD( SMLNUM, BIGNUM )
5760*
5761*     Scale A, B if max element outside range [SMLNUM,BIGNUM]
5762*
5763      ANRM = ZLANGE( 'M', M, N, A, LDA, RWORK )
5764      IASCL = 0
5765      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
5766*
5767*        Scale matrix norm up to SMLNUM
5768*
5769         CALL ZLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
5770         IASCL = 1
5771      ELSE IF( ANRM.GT.BIGNUM ) THEN
5772*
5773*        Scale matrix norm down to BIGNUM
5774*
5775         CALL ZLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
5776         IASCL = 2
5777      ELSE IF( ANRM.EQ.ZERO ) THEN
5778*
5779*        Matrix all zero. Return zero solution.
5780*
5781         CALL ZLASET( 'F', MAX( M, N ), NRHS, CZERO, CZERO, B, LDB )
5782         GO TO 50
5783      END IF
5784*
5785      BROW = M
5786      IF( TPSD )
5787     $   BROW = N
5788      BNRM = ZLANGE( 'M', BROW, NRHS, B, LDB, RWORK )
5789      IBSCL = 0
5790      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
5791*
5792*        Scale matrix norm up to SMLNUM
5793*
5794         CALL ZLASCL( 'G', 0, 0, BNRM, SMLNUM, BROW, NRHS, B, LDB,
5795     $                INFO )
5796         IBSCL = 1
5797      ELSE IF( BNRM.GT.BIGNUM ) THEN
5798*
5799*        Scale matrix norm down to BIGNUM
5800*
5801         CALL ZLASCL( 'G', 0, 0, BNRM, BIGNUM, BROW, NRHS, B, LDB,
5802     $                INFO )
5803         IBSCL = 2
5804      END IF
5805*
5806      IF( M.GE.N ) THEN
5807*
5808*        compute QR factorization of A
5809*
5810         CALL ZGEQRF( M, N, A, LDA, WORK( 1 ), WORK( MN+1 ), LWORK-MN,
5811     $                INFO )
5812*
5813*        workspace at least N, optimally N*NB
5814*
5815         IF( .NOT.TPSD ) THEN
5816*
5817*           Least-Squares Problem min || A * X - B ||
5818*
5819*           B(1:M,1:NRHS) := Q**H * B(1:M,1:NRHS)
5820*
5821            CALL ZUNMQR( 'Left', 'Conjugate transpose', M, NRHS, N, A,
5822     $                   LDA, WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
5823     $                   INFO )
5824*
5825*           workspace at least NRHS, optimally NRHS*NB
5826*
5827*           B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS)
5828*
5829            CALL ZTRTRS( 'Upper', 'No transpose', 'Non-unit', N, NRHS,
5830     $                   A, LDA, B, LDB, INFO )
5831*
5832            IF( INFO.GT.0 ) THEN
5833               RETURN
5834            END IF
5835*
5836            SCLLEN = N
5837*
5838         ELSE
5839*
5840*           Underdetermined system of equations A**T * X = B
5841*
5842*           B(1:N,1:NRHS) := inv(R**H) * B(1:N,1:NRHS)
5843*
5844            CALL ZTRTRS( 'Upper', 'Conjugate transpose','Non-unit',
5845     $                   N, NRHS, A, LDA, B, LDB, INFO )
5846*
5847            IF( INFO.GT.0 ) THEN
5848               RETURN
5849            END IF
5850*
5851*           B(N+1:M,1:NRHS) = ZERO
5852*
5853            DO 20 J = 1, NRHS
5854               DO 10 I = N + 1, M
5855                  B( I, J ) = CZERO
5856   10          CONTINUE
5857   20       CONTINUE
5858*
5859*           B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS)
5860*
5861            CALL ZUNMQR( 'Left', 'No transpose', M, NRHS, N, A, LDA,
5862     $                   WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
5863     $                   INFO )
5864*
5865*           workspace at least NRHS, optimally NRHS*NB
5866*
5867            SCLLEN = M
5868*
5869         END IF
5870*
5871      ELSE
5872*
5873*        Compute LQ factorization of A
5874*
5875         CALL ZGELQF( M, N, A, LDA, WORK( 1 ), WORK( MN+1 ), LWORK-MN,
5876     $                INFO )
5877*
5878*        workspace at least M, optimally M*NB.
5879*
5880         IF( .NOT.TPSD ) THEN
5881*
5882*           underdetermined system of equations A * X = B
5883*
5884*           B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS)
5885*
5886            CALL ZTRTRS( 'Lower', 'No transpose', 'Non-unit', M, NRHS,
5887     $                   A, LDA, B, LDB, INFO )
5888*
5889            IF( INFO.GT.0 ) THEN
5890               RETURN
5891            END IF
5892*
5893*           B(M+1:N,1:NRHS) = 0
5894*
5895            DO 40 J = 1, NRHS
5896               DO 30 I = M + 1, N
5897                  B( I, J ) = CZERO
5898   30          CONTINUE
5899   40       CONTINUE
5900*
5901*           B(1:N,1:NRHS) := Q(1:N,:)**H * B(1:M,1:NRHS)
5902*
5903            CALL ZUNMLQ( 'Left', 'Conjugate transpose', N, NRHS, M, A,
5904     $                   LDA, WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
5905     $                   INFO )
5906*
5907*           workspace at least NRHS, optimally NRHS*NB
5908*
5909            SCLLEN = N
5910*
5911         ELSE
5912*
5913*           overdetermined system min || A**H * X - B ||
5914*
5915*           B(1:N,1:NRHS) := Q * B(1:N,1:NRHS)
5916*
5917            CALL ZUNMLQ( 'Left', 'No transpose', N, NRHS, M, A, LDA,
5918     $                   WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
5919     $                   INFO )
5920*
5921*           workspace at least NRHS, optimally NRHS*NB
5922*
5923*           B(1:M,1:NRHS) := inv(L**H) * B(1:M,1:NRHS)
5924*
5925            CALL ZTRTRS( 'Lower', 'Conjugate transpose', 'Non-unit',
5926     $                   M, NRHS, A, LDA, B, LDB, INFO )
5927*
5928            IF( INFO.GT.0 ) THEN
5929               RETURN
5930            END IF
5931*
5932            SCLLEN = M
5933*
5934         END IF
5935*
5936      END IF
5937*
5938*     Undo scaling
5939*
5940      IF( IASCL.EQ.1 ) THEN
5941         CALL ZLASCL( 'G', 0, 0, ANRM, SMLNUM, SCLLEN, NRHS, B, LDB,
5942     $                INFO )
5943      ELSE IF( IASCL.EQ.2 ) THEN
5944         CALL ZLASCL( 'G', 0, 0, ANRM, BIGNUM, SCLLEN, NRHS, B, LDB,
5945     $                INFO )
5946      END IF
5947      IF( IBSCL.EQ.1 ) THEN
5948         CALL ZLASCL( 'G', 0, 0, SMLNUM, BNRM, SCLLEN, NRHS, B, LDB,
5949     $                INFO )
5950      ELSE IF( IBSCL.EQ.2 ) THEN
5951         CALL ZLASCL( 'G', 0, 0, BIGNUM, BNRM, SCLLEN, NRHS, B, LDB,
5952     $                INFO )
5953      END IF
5954*
5955   50 CONTINUE
5956      WORK( 1 ) = DBLE( WSIZE )
5957*
5958      RETURN
5959*
5960*     End of ZGELS
5961*
5962      END
5963*> \brief <b> ZGELSD computes the minimum-norm solution to a linear least squares problem for GE matrices</b>
5964*
5965*  =========== DOCUMENTATION ===========
5966*
5967* Online html documentation available at
5968*            http://www.netlib.org/lapack/explore-html/
5969*
5970*> \htmlonly
5971*> Download ZGELSD + dependencies
5972*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgelsd.f">
5973*> [TGZ]</a>
5974*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgelsd.f">
5975*> [ZIP]</a>
5976*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgelsd.f">
5977*> [TXT]</a>
5978*> \endhtmlonly
5979*
5980*  Definition:
5981*  ===========
5982*
5983*       SUBROUTINE ZGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK,
5984*                          WORK, LWORK, RWORK, IWORK, INFO )
5985*
5986*       .. Scalar Arguments ..
5987*       INTEGER            INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
5988*       DOUBLE PRECISION   RCOND
5989*       ..
5990*       .. Array Arguments ..
5991*       INTEGER            IWORK( * )
5992*       DOUBLE PRECISION   RWORK( * ), S( * )
5993*       COMPLEX*16         A( LDA, * ), B( LDB, * ), WORK( * )
5994*       ..
5995*
5996*
5997*> \par Purpose:
5998*  =============
5999*>
6000*> \verbatim
6001*>
6002*> ZGELSD computes the minimum-norm solution to a real linear least
6003*> squares problem:
6004*>     minimize 2-norm(| b - A*x |)
6005*> using the singular value decomposition (SVD) of A. A is an M-by-N
6006*> matrix which may be rank-deficient.
6007*>
6008*> Several right hand side vectors b and solution vectors x can be
6009*> handled in a single call; they are stored as the columns of the
6010*> M-by-NRHS right hand side matrix B and the N-by-NRHS solution
6011*> matrix X.
6012*>
6013*> The problem is solved in three steps:
6014*> (1) Reduce the coefficient matrix A to bidiagonal form with
6015*>     Householder transformations, reducing the original problem
6016*>     into a "bidiagonal least squares problem" (BLS)
6017*> (2) Solve the BLS using a divide and conquer approach.
6018*> (3) Apply back all the Householder transformations to solve
6019*>     the original least squares problem.
6020*>
6021*> The effective rank of A is determined by treating as zero those
6022*> singular values which are less than RCOND times the largest singular
6023*> value.
6024*>
6025*> The divide and conquer algorithm makes very mild assumptions about
6026*> floating point arithmetic. It will work on machines with a guard
6027*> digit in add/subtract, or on those binary machines without guard
6028*> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
6029*> Cray-2. It could conceivably fail on hexadecimal or decimal machines
6030*> without guard digits, but we know of none.
6031*> \endverbatim
6032*
6033*  Arguments:
6034*  ==========
6035*
6036*> \param[in] M
6037*> \verbatim
6038*>          M is INTEGER
6039*>          The number of rows of the matrix A. M >= 0.
6040*> \endverbatim
6041*>
6042*> \param[in] N
6043*> \verbatim
6044*>          N is INTEGER
6045*>          The number of columns of the matrix A. N >= 0.
6046*> \endverbatim
6047*>
6048*> \param[in] NRHS
6049*> \verbatim
6050*>          NRHS is INTEGER
6051*>          The number of right hand sides, i.e., the number of columns
6052*>          of the matrices B and X. NRHS >= 0.
6053*> \endverbatim
6054*>
6055*> \param[in,out] A
6056*> \verbatim
6057*>          A is COMPLEX*16 array, dimension (LDA,N)
6058*>          On entry, the M-by-N matrix A.
6059*>          On exit, A has been destroyed.
6060*> \endverbatim
6061*>
6062*> \param[in] LDA
6063*> \verbatim
6064*>          LDA is INTEGER
6065*>          The leading dimension of the array A. LDA >= max(1,M).
6066*> \endverbatim
6067*>
6068*> \param[in,out] B
6069*> \verbatim
6070*>          B is COMPLEX*16 array, dimension (LDB,NRHS)
6071*>          On entry, the M-by-NRHS right hand side matrix B.
6072*>          On exit, B is overwritten by the N-by-NRHS solution matrix X.
6073*>          If m >= n and RANK = n, the residual sum-of-squares for
6074*>          the solution in the i-th column is given by the sum of
6075*>          squares of the modulus of elements n+1:m in that column.
6076*> \endverbatim
6077*>
6078*> \param[in] LDB
6079*> \verbatim
6080*>          LDB is INTEGER
6081*>          The leading dimension of the array B.  LDB >= max(1,M,N).
6082*> \endverbatim
6083*>
6084*> \param[out] S
6085*> \verbatim
6086*>          S is DOUBLE PRECISION array, dimension (min(M,N))
6087*>          The singular values of A in decreasing order.
6088*>          The condition number of A in the 2-norm = S(1)/S(min(m,n)).
6089*> \endverbatim
6090*>
6091*> \param[in] RCOND
6092*> \verbatim
6093*>          RCOND is DOUBLE PRECISION
6094*>          RCOND is used to determine the effective rank of A.
6095*>          Singular values S(i) <= RCOND*S(1) are treated as zero.
6096*>          If RCOND < 0, machine precision is used instead.
6097*> \endverbatim
6098*>
6099*> \param[out] RANK
6100*> \verbatim
6101*>          RANK is INTEGER
6102*>          The effective rank of A, i.e., the number of singular values
6103*>          which are greater than RCOND*S(1).
6104*> \endverbatim
6105*>
6106*> \param[out] WORK
6107*> \verbatim
6108*>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
6109*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
6110*> \endverbatim
6111*>
6112*> \param[in] LWORK
6113*> \verbatim
6114*>          LWORK is INTEGER
6115*>          The dimension of the array WORK. LWORK must be at least 1.
6116*>          The exact minimum amount of workspace needed depends on M,
6117*>          N and NRHS. As long as LWORK is at least
6118*>              2*N + N*NRHS
6119*>          if M is greater than or equal to N or
6120*>              2*M + M*NRHS
6121*>          if M is less than N, the code will execute correctly.
6122*>          For good performance, LWORK should generally be larger.
6123*>
6124*>          If LWORK = -1, then a workspace query is assumed; the routine
6125*>          only calculates the optimal size of the array WORK and the
6126*>          minimum sizes of the arrays RWORK and IWORK, and returns
6127*>          these values as the first entries of the WORK, RWORK and
6128*>          IWORK arrays, and no error message related to LWORK is issued
6129*>          by XERBLA.
6130*> \endverbatim
6131*>
6132*> \param[out] RWORK
6133*> \verbatim
6134*>          RWORK is DOUBLE PRECISION array, dimension (MAX(1,LRWORK))
6135*>          LRWORK >=
6136*>             10*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS +
6137*>             MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS )
6138*>          if M is greater than or equal to N or
6139*>             10*M + 2*M*SMLSIZ + 8*M*NLVL + 3*SMLSIZ*NRHS +
6140*>             MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS )
6141*>          if M is less than N, the code will execute correctly.
6142*>          SMLSIZ is returned by ILAENV and is equal to the maximum
6143*>          size of the subproblems at the bottom of the computation
6144*>          tree (usually about 25), and
6145*>             NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )
6146*>          On exit, if INFO = 0, RWORK(1) returns the minimum LRWORK.
6147*> \endverbatim
6148*>
6149*> \param[out] IWORK
6150*> \verbatim
6151*>          IWORK is INTEGER array, dimension (MAX(1,LIWORK))
6152*>          LIWORK >= max(1, 3*MINMN*NLVL + 11*MINMN),
6153*>          where MINMN = MIN( M,N ).
6154*>          On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.
6155*> \endverbatim
6156*>
6157*> \param[out] INFO
6158*> \verbatim
6159*>          INFO is INTEGER
6160*>          = 0: successful exit
6161*>          < 0: if INFO = -i, the i-th argument had an illegal value.
6162*>          > 0:  the algorithm for computing the SVD failed to converge;
6163*>                if INFO = i, i off-diagonal elements of an intermediate
6164*>                bidiagonal form did not converge to zero.
6165*> \endverbatim
6166*
6167*  Authors:
6168*  ========
6169*
6170*> \author Univ. of Tennessee
6171*> \author Univ. of California Berkeley
6172*> \author Univ. of Colorado Denver
6173*> \author NAG Ltd.
6174*
6175*> \date June 2017
6176*
6177*> \ingroup complex16GEsolve
6178*
6179*> \par Contributors:
6180*  ==================
6181*>
6182*>     Ming Gu and Ren-Cang Li, Computer Science Division, University of
6183*>       California at Berkeley, USA \n
6184*>     Osni Marques, LBNL/NERSC, USA \n
6185*
6186*  =====================================================================
6187      SUBROUTINE ZGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK,
6188     $                   WORK, LWORK, RWORK, IWORK, INFO )
6189*
6190*  -- LAPACK driver routine (version 3.7.1) --
6191*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
6192*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
6193*     June 2017
6194*
6195*     .. Scalar Arguments ..
6196      INTEGER            INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
6197      DOUBLE PRECISION   RCOND
6198*     ..
6199*     .. Array Arguments ..
6200      INTEGER            IWORK( * )
6201      DOUBLE PRECISION   RWORK( * ), S( * )
6202      COMPLEX*16         A( LDA, * ), B( LDB, * ), WORK( * )
6203*     ..
6204*
6205*  =====================================================================
6206*
6207*     .. Parameters ..
6208      DOUBLE PRECISION   ZERO, ONE, TWO
6209      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
6210      COMPLEX*16         CZERO
6211      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ) )
6212*     ..
6213*     .. Local Scalars ..
6214      LOGICAL            LQUERY
6215      INTEGER            IASCL, IBSCL, IE, IL, ITAU, ITAUP, ITAUQ,
6216     $                   LDWORK, LIWORK, LRWORK, MAXMN, MAXWRK, MINMN,
6217     $                   MINWRK, MM, MNTHR, NLVL, NRWORK, NWORK, SMLSIZ
6218      DOUBLE PRECISION   ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM
6219*     ..
6220*     .. External Subroutines ..
6221      EXTERNAL           DLABAD, DLASCL, DLASET, XERBLA, ZGEBRD, ZGELQF,
6222     $                   ZGEQRF, ZLACPY, ZLALSD, ZLASCL, ZLASET, ZUNMBR,
6223     $                   ZUNMLQ, ZUNMQR
6224*     ..
6225*     .. External Functions ..
6226      INTEGER            ILAENV
6227      DOUBLE PRECISION   DLAMCH, ZLANGE
6228      EXTERNAL           ILAENV, DLAMCH, ZLANGE
6229*     ..
6230*     .. Intrinsic Functions ..
6231      INTRINSIC          INT, LOG, MAX, MIN, DBLE
6232*     ..
6233*     .. Executable Statements ..
6234*
6235*     Test the input arguments.
6236*
6237      INFO = 0
6238      MINMN = MIN( M, N )
6239      MAXMN = MAX( M, N )
6240      LQUERY = ( LWORK.EQ.-1 )
6241      IF( M.LT.0 ) THEN
6242         INFO = -1
6243      ELSE IF( N.LT.0 ) THEN
6244         INFO = -2
6245      ELSE IF( NRHS.LT.0 ) THEN
6246         INFO = -3
6247      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
6248         INFO = -5
6249      ELSE IF( LDB.LT.MAX( 1, MAXMN ) ) THEN
6250         INFO = -7
6251      END IF
6252*
6253*     Compute workspace.
6254*     (Note: Comments in the code beginning "Workspace:" describe the
6255*     minimal amount of workspace needed at that point in the code,
6256*     as well as the preferred amount for good performance.
6257*     NB refers to the optimal block size for the immediately
6258*     following subroutine, as returned by ILAENV.)
6259*
6260      IF( INFO.EQ.0 ) THEN
6261         MINWRK = 1
6262         MAXWRK = 1
6263         LIWORK = 1
6264         LRWORK = 1
6265         IF( MINMN.GT.0 ) THEN
6266            SMLSIZ = ILAENV( 9, 'ZGELSD', ' ', 0, 0, 0, 0 )
6267            MNTHR = ILAENV( 6, 'ZGELSD', ' ', M, N, NRHS, -1 )
6268            NLVL = MAX( INT( LOG( DBLE( MINMN ) / DBLE( SMLSIZ + 1 ) ) /
6269     $                  LOG( TWO ) ) + 1, 0 )
6270            LIWORK = 3*MINMN*NLVL + 11*MINMN
6271            MM = M
6272            IF( M.GE.N .AND. M.GE.MNTHR ) THEN
6273*
6274*              Path 1a - overdetermined, with many more rows than
6275*                        columns.
6276*
6277               MM = N
6278               MAXWRK = MAX( MAXWRK, N*ILAENV( 1, 'ZGEQRF', ' ', M, N,
6279     $                       -1, -1 ) )
6280               MAXWRK = MAX( MAXWRK, NRHS*ILAENV( 1, 'ZUNMQR', 'LC', M,
6281     $                       NRHS, N, -1 ) )
6282            END IF
6283            IF( M.GE.N ) THEN
6284*
6285*              Path 1 - overdetermined or exactly determined.
6286*
6287               LRWORK = 10*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS +
6288     $                  MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS )
6289               MAXWRK = MAX( MAXWRK, 2*N + ( MM + N )*ILAENV( 1,
6290     $                       'ZGEBRD', ' ', MM, N, -1, -1 ) )
6291               MAXWRK = MAX( MAXWRK, 2*N + NRHS*ILAENV( 1, 'ZUNMBR',
6292     $                       'QLC', MM, NRHS, N, -1 ) )
6293               MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1,
6294     $                       'ZUNMBR', 'PLN', N, NRHS, N, -1 ) )
6295               MAXWRK = MAX( MAXWRK, 2*N + N*NRHS )
6296               MINWRK = MAX( 2*N + MM, 2*N + N*NRHS )
6297            END IF
6298            IF( N.GT.M ) THEN
6299               LRWORK = 10*M + 2*M*SMLSIZ + 8*M*NLVL + 3*SMLSIZ*NRHS +
6300     $                  MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS )
6301               IF( N.GE.MNTHR ) THEN
6302*
6303*                 Path 2a - underdetermined, with many more columns
6304*                           than rows.
6305*
6306                  MAXWRK = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1,
6307     $                     -1 )
6308                  MAXWRK = MAX( MAXWRK, M*M + 4*M + 2*M*ILAENV( 1,
6309     $                          'ZGEBRD', ' ', M, M, -1, -1 ) )
6310                  MAXWRK = MAX( MAXWRK, M*M + 4*M + NRHS*ILAENV( 1,
6311     $                          'ZUNMBR', 'QLC', M, NRHS, M, -1 ) )
6312                  MAXWRK = MAX( MAXWRK, M*M + 4*M + ( M - 1 )*ILAENV( 1,
6313     $                          'ZUNMLQ', 'LC', N, NRHS, M, -1 ) )
6314                  IF( NRHS.GT.1 ) THEN
6315                     MAXWRK = MAX( MAXWRK, M*M + M + M*NRHS )
6316                  ELSE
6317                     MAXWRK = MAX( MAXWRK, M*M + 2*M )
6318                  END IF
6319                  MAXWRK = MAX( MAXWRK, M*M + 4*M + M*NRHS )
6320!     XXX: Ensure the Path 2a case below is triggered.  The workspace
6321!     calculation should use queries for all routines eventually.
6322                  MAXWRK = MAX( MAXWRK,
6323     $                 4*M+M*M+MAX( M, 2*M-4, NRHS, N-3*M ) )
6324               ELSE
6325*
6326*                 Path 2 - underdetermined.
6327*
6328                  MAXWRK = 2*M + ( N + M )*ILAENV( 1, 'ZGEBRD', ' ', M,
6329     $                     N, -1, -1 )
6330                  MAXWRK = MAX( MAXWRK, 2*M + NRHS*ILAENV( 1, 'ZUNMBR',
6331     $                          'QLC', M, NRHS, M, -1 ) )
6332                  MAXWRK = MAX( MAXWRK, 2*M + M*ILAENV( 1, 'ZUNMBR',
6333     $                          'PLN', N, NRHS, M, -1 ) )
6334                  MAXWRK = MAX( MAXWRK, 2*M + M*NRHS )
6335               END IF
6336               MINWRK = MAX( 2*M + N, 2*M + M*NRHS )
6337            END IF
6338         END IF
6339         MINWRK = MIN( MINWRK, MAXWRK )
6340         WORK( 1 ) = MAXWRK
6341         IWORK( 1 ) = LIWORK
6342         RWORK( 1 ) = LRWORK
6343*
6344         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
6345            INFO = -12
6346         END IF
6347      END IF
6348*
6349      IF( INFO.NE.0 ) THEN
6350         CALL XERBLA( 'ZGELSD', -INFO )
6351         RETURN
6352      ELSE IF( LQUERY ) THEN
6353         RETURN
6354      END IF
6355*
6356*     Quick return if possible.
6357*
6358      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
6359         RANK = 0
6360         RETURN
6361      END IF
6362*
6363*     Get machine parameters.
6364*
6365      EPS = DLAMCH( 'P' )
6366      SFMIN = DLAMCH( 'S' )
6367      SMLNUM = SFMIN / EPS
6368      BIGNUM = ONE / SMLNUM
6369      CALL DLABAD( SMLNUM, BIGNUM )
6370*
6371*     Scale A if max entry outside range [SMLNUM,BIGNUM].
6372*
6373      ANRM = ZLANGE( 'M', M, N, A, LDA, RWORK )
6374      IASCL = 0
6375      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
6376*
6377*        Scale matrix norm up to SMLNUM
6378*
6379         CALL ZLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
6380         IASCL = 1
6381      ELSE IF( ANRM.GT.BIGNUM ) THEN
6382*
6383*        Scale matrix norm down to BIGNUM.
6384*
6385         CALL ZLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
6386         IASCL = 2
6387      ELSE IF( ANRM.EQ.ZERO ) THEN
6388*
6389*        Matrix all zero. Return zero solution.
6390*
6391         CALL ZLASET( 'F', MAX( M, N ), NRHS, CZERO, CZERO, B, LDB )
6392         CALL DLASET( 'F', MINMN, 1, ZERO, ZERO, S, 1 )
6393         RANK = 0
6394         GO TO 10
6395      END IF
6396*
6397*     Scale B if max entry outside range [SMLNUM,BIGNUM].
6398*
6399      BNRM = ZLANGE( 'M', M, NRHS, B, LDB, RWORK )
6400      IBSCL = 0
6401      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
6402*
6403*        Scale matrix norm up to SMLNUM.
6404*
6405         CALL ZLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
6406         IBSCL = 1
6407      ELSE IF( BNRM.GT.BIGNUM ) THEN
6408*
6409*        Scale matrix norm down to BIGNUM.
6410*
6411         CALL ZLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
6412         IBSCL = 2
6413      END IF
6414*
6415*     If M < N make sure B(M+1:N,:) = 0
6416*
6417      IF( M.LT.N )
6418     $   CALL ZLASET( 'F', N-M, NRHS, CZERO, CZERO, B( M+1, 1 ), LDB )
6419*
6420*     Overdetermined case.
6421*
6422      IF( M.GE.N ) THEN
6423*
6424*        Path 1 - overdetermined or exactly determined.
6425*
6426         MM = M
6427         IF( M.GE.MNTHR ) THEN
6428*
6429*           Path 1a - overdetermined, with many more rows than columns
6430*
6431            MM = N
6432            ITAU = 1
6433            NWORK = ITAU + N
6434*
6435*           Compute A=Q*R.
6436*           (RWorkspace: need N)
6437*           (CWorkspace: need N, prefer N*NB)
6438*
6439            CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
6440     $                   LWORK-NWORK+1, INFO )
6441*
6442*           Multiply B by transpose(Q).
6443*           (RWorkspace: need N)
6444*           (CWorkspace: need NRHS, prefer NRHS*NB)
6445*
6446            CALL ZUNMQR( 'L', 'C', M, NRHS, N, A, LDA, WORK( ITAU ), B,
6447     $                   LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
6448*
6449*           Zero out below R.
6450*
6451            IF( N.GT.1 ) THEN
6452               CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, A( 2, 1 ),
6453     $                      LDA )
6454            END IF
6455         END IF
6456*
6457         ITAUQ = 1
6458         ITAUP = ITAUQ + N
6459         NWORK = ITAUP + N
6460         IE = 1
6461         NRWORK = IE + N
6462*
6463*        Bidiagonalize R in A.
6464*        (RWorkspace: need N)
6465*        (CWorkspace: need 2*N+MM, prefer 2*N+(MM+N)*NB)
6466*
6467         CALL ZGEBRD( MM, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
6468     $                WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
6469     $                INFO )
6470*
6471*        Multiply B by transpose of left bidiagonalizing vectors of R.
6472*        (CWorkspace: need 2*N+NRHS, prefer 2*N+NRHS*NB)
6473*
6474         CALL ZUNMBR( 'Q', 'L', 'C', MM, NRHS, N, A, LDA, WORK( ITAUQ ),
6475     $                B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
6476*
6477*        Solve the bidiagonal least squares problem.
6478*
6479         CALL ZLALSD( 'U', SMLSIZ, N, NRHS, S, RWORK( IE ), B, LDB,
6480     $                RCOND, RANK, WORK( NWORK ), RWORK( NRWORK ),
6481     $                IWORK, INFO )
6482         IF( INFO.NE.0 ) THEN
6483            GO TO 10
6484         END IF
6485*
6486*        Multiply B by right bidiagonalizing vectors of R.
6487*
6488         CALL ZUNMBR( 'P', 'L', 'N', N, NRHS, N, A, LDA, WORK( ITAUP ),
6489     $                B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
6490*
6491      ELSE IF( N.GE.MNTHR .AND. LWORK.GE.4*M+M*M+
6492     $         MAX( M, 2*M-4, NRHS, N-3*M ) ) THEN
6493*
6494*        Path 2a - underdetermined, with many more columns than rows
6495*        and sufficient workspace for an efficient algorithm.
6496*
6497         LDWORK = M
6498         IF( LWORK.GE.MAX( 4*M+M*LDA+MAX( M, 2*M-4, NRHS, N-3*M ),
6499     $       M*LDA+M+M*NRHS ) )LDWORK = LDA
6500         ITAU = 1
6501         NWORK = M + 1
6502*
6503*        Compute A=L*Q.
6504*        (CWorkspace: need 2*M, prefer M+M*NB)
6505*
6506         CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
6507     $                LWORK-NWORK+1, INFO )
6508         IL = NWORK
6509*
6510*        Copy L to WORK(IL), zeroing out above its diagonal.
6511*
6512         CALL ZLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWORK )
6513         CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, WORK( IL+LDWORK ),
6514     $                LDWORK )
6515         ITAUQ = IL + LDWORK*M
6516         ITAUP = ITAUQ + M
6517         NWORK = ITAUP + M
6518         IE = 1
6519         NRWORK = IE + M
6520*
6521*        Bidiagonalize L in WORK(IL).
6522*        (RWorkspace: need M)
6523*        (CWorkspace: need M*M+4*M, prefer M*M+4*M+2*M*NB)
6524*
6525         CALL ZGEBRD( M, M, WORK( IL ), LDWORK, S, RWORK( IE ),
6526     $                WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
6527     $                LWORK-NWORK+1, INFO )
6528*
6529*        Multiply B by transpose of left bidiagonalizing vectors of L.
6530*        (CWorkspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB)
6531*
6532         CALL ZUNMBR( 'Q', 'L', 'C', M, NRHS, M, WORK( IL ), LDWORK,
6533     $                WORK( ITAUQ ), B, LDB, WORK( NWORK ),
6534     $                LWORK-NWORK+1, INFO )
6535*
6536*        Solve the bidiagonal least squares problem.
6537*
6538         CALL ZLALSD( 'U', SMLSIZ, M, NRHS, S, RWORK( IE ), B, LDB,
6539     $                RCOND, RANK, WORK( NWORK ), RWORK( NRWORK ),
6540     $                IWORK, INFO )
6541         IF( INFO.NE.0 ) THEN
6542            GO TO 10
6543         END IF
6544*
6545*        Multiply B by right bidiagonalizing vectors of L.
6546*
6547         CALL ZUNMBR( 'P', 'L', 'N', M, NRHS, M, WORK( IL ), LDWORK,
6548     $                WORK( ITAUP ), B, LDB, WORK( NWORK ),
6549     $                LWORK-NWORK+1, INFO )
6550*
6551*        Zero out below first M rows of B.
6552*
6553         CALL ZLASET( 'F', N-M, NRHS, CZERO, CZERO, B( M+1, 1 ), LDB )
6554         NWORK = ITAU + M
6555*
6556*        Multiply transpose(Q) by B.
6557*        (CWorkspace: need NRHS, prefer NRHS*NB)
6558*
6559         CALL ZUNMLQ( 'L', 'C', N, NRHS, M, A, LDA, WORK( ITAU ), B,
6560     $                LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
6561*
6562      ELSE
6563*
6564*        Path 2 - remaining underdetermined cases.
6565*
6566         ITAUQ = 1
6567         ITAUP = ITAUQ + M
6568         NWORK = ITAUP + M
6569         IE = 1
6570         NRWORK = IE + M
6571*
6572*        Bidiagonalize A.
6573*        (RWorkspace: need M)
6574*        (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB)
6575*
6576         CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
6577     $                WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
6578     $                INFO )
6579*
6580*        Multiply B by transpose of left bidiagonalizing vectors.
6581*        (CWorkspace: need 2*M+NRHS, prefer 2*M+NRHS*NB)
6582*
6583         CALL ZUNMBR( 'Q', 'L', 'C', M, NRHS, N, A, LDA, WORK( ITAUQ ),
6584     $                B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
6585*
6586*        Solve the bidiagonal least squares problem.
6587*
6588         CALL ZLALSD( 'L', SMLSIZ, M, NRHS, S, RWORK( IE ), B, LDB,
6589     $                RCOND, RANK, WORK( NWORK ), RWORK( NRWORK ),
6590     $                IWORK, INFO )
6591         IF( INFO.NE.0 ) THEN
6592            GO TO 10
6593         END IF
6594*
6595*        Multiply B by right bidiagonalizing vectors of A.
6596*
6597         CALL ZUNMBR( 'P', 'L', 'N', N, NRHS, M, A, LDA, WORK( ITAUP ),
6598     $                B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
6599*
6600      END IF
6601*
6602*     Undo scaling.
6603*
6604      IF( IASCL.EQ.1 ) THEN
6605         CALL ZLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
6606         CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
6607     $                INFO )
6608      ELSE IF( IASCL.EQ.2 ) THEN
6609         CALL ZLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
6610         CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
6611     $                INFO )
6612      END IF
6613      IF( IBSCL.EQ.1 ) THEN
6614         CALL ZLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
6615      ELSE IF( IBSCL.EQ.2 ) THEN
6616         CALL ZLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
6617      END IF
6618*
6619   10 CONTINUE
6620      WORK( 1 ) = MAXWRK
6621      IWORK( 1 ) = LIWORK
6622      RWORK( 1 ) = LRWORK
6623      RETURN
6624*
6625*     End of ZGELSD
6626*
6627      END
6628*> \brief \b ZGEQP3
6629*
6630*  =========== DOCUMENTATION ===========
6631*
6632* Online html documentation available at
6633*            http://www.netlib.org/lapack/explore-html/
6634*
6635*> \htmlonly
6636*> Download ZGEQP3 + dependencies
6637*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgeqp3.f">
6638*> [TGZ]</a>
6639*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgeqp3.f">
6640*> [ZIP]</a>
6641*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgeqp3.f">
6642*> [TXT]</a>
6643*> \endhtmlonly
6644*
6645*  Definition:
6646*  ===========
6647*
6648*       SUBROUTINE ZGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, RWORK,
6649*                          INFO )
6650*
6651*       .. Scalar Arguments ..
6652*       INTEGER            INFO, LDA, LWORK, M, N
6653*       ..
6654*       .. Array Arguments ..
6655*       INTEGER            JPVT( * )
6656*       DOUBLE PRECISION   RWORK( * )
6657*       COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
6658*       ..
6659*
6660*
6661*> \par Purpose:
6662*  =============
6663*>
6664*> \verbatim
6665*>
6666*> ZGEQP3 computes a QR factorization with column pivoting of a
6667*> matrix A:  A*P = Q*R  using Level 3 BLAS.
6668*> \endverbatim
6669*
6670*  Arguments:
6671*  ==========
6672*
6673*> \param[in] M
6674*> \verbatim
6675*>          M is INTEGER
6676*>          The number of rows of the matrix A. M >= 0.
6677*> \endverbatim
6678*>
6679*> \param[in] N
6680*> \verbatim
6681*>          N is INTEGER
6682*>          The number of columns of the matrix A.  N >= 0.
6683*> \endverbatim
6684*>
6685*> \param[in,out] A
6686*> \verbatim
6687*>          A is COMPLEX*16 array, dimension (LDA,N)
6688*>          On entry, the M-by-N matrix A.
6689*>          On exit, the upper triangle of the array contains the
6690*>          min(M,N)-by-N upper trapezoidal matrix R; the elements below
6691*>          the diagonal, together with the array TAU, represent the
6692*>          unitary matrix Q as a product of min(M,N) elementary
6693*>          reflectors.
6694*> \endverbatim
6695*>
6696*> \param[in] LDA
6697*> \verbatim
6698*>          LDA is INTEGER
6699*>          The leading dimension of the array A. LDA >= max(1,M).
6700*> \endverbatim
6701*>
6702*> \param[in,out] JPVT
6703*> \verbatim
6704*>          JPVT is INTEGER array, dimension (N)
6705*>          On entry, if JPVT(J).ne.0, the J-th column of A is permuted
6706*>          to the front of A*P (a leading column); if JPVT(J)=0,
6707*>          the J-th column of A is a free column.
6708*>          On exit, if JPVT(J)=K, then the J-th column of A*P was the
6709*>          the K-th column of A.
6710*> \endverbatim
6711*>
6712*> \param[out] TAU
6713*> \verbatim
6714*>          TAU is COMPLEX*16 array, dimension (min(M,N))
6715*>          The scalar factors of the elementary reflectors.
6716*> \endverbatim
6717*>
6718*> \param[out] WORK
6719*> \verbatim
6720*>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
6721*>          On exit, if INFO=0, WORK(1) returns the optimal LWORK.
6722*> \endverbatim
6723*>
6724*> \param[in] LWORK
6725*> \verbatim
6726*>          LWORK is INTEGER
6727*>          The dimension of the array WORK. LWORK >= N+1.
6728*>          For optimal performance LWORK >= ( N+1 )*NB, where NB
6729*>          is the optimal blocksize.
6730*>
6731*>          If LWORK = -1, then a workspace query is assumed; the routine
6732*>          only calculates the optimal size of the WORK array, returns
6733*>          this value as the first entry of the WORK array, and no error
6734*>          message related to LWORK is issued by XERBLA.
6735*> \endverbatim
6736*>
6737*> \param[out] RWORK
6738*> \verbatim
6739*>          RWORK is DOUBLE PRECISION array, dimension (2*N)
6740*> \endverbatim
6741*>
6742*> \param[out] INFO
6743*> \verbatim
6744*>          INFO is INTEGER
6745*>          = 0: successful exit.
6746*>          < 0: if INFO = -i, the i-th argument had an illegal value.
6747*> \endverbatim
6748*
6749*  Authors:
6750*  ========
6751*
6752*> \author Univ. of Tennessee
6753*> \author Univ. of California Berkeley
6754*> \author Univ. of Colorado Denver
6755*> \author NAG Ltd.
6756*
6757*> \date December 2016
6758*
6759*> \ingroup complex16GEcomputational
6760*
6761*> \par Further Details:
6762*  =====================
6763*>
6764*> \verbatim
6765*>
6766*>  The matrix Q is represented as a product of elementary reflectors
6767*>
6768*>     Q = H(1) H(2) . . . H(k), where k = min(m,n).
6769*>
6770*>  Each H(i) has the form
6771*>
6772*>     H(i) = I - tau * v * v**H
6773*>
6774*>  where tau is a complex scalar, and v is a real/complex vector
6775*>  with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in
6776*>  A(i+1:m,i), and tau in TAU(i).
6777*> \endverbatim
6778*
6779*> \par Contributors:
6780*  ==================
6781*>
6782*>    G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
6783*>    X. Sun, Computer Science Dept., Duke University, USA
6784*>
6785*  =====================================================================
6786      SUBROUTINE ZGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, RWORK,
6787     $                   INFO )
6788*
6789*  -- LAPACK computational routine (version 3.7.0) --
6790*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
6791*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
6792*     December 2016
6793*
6794*     .. Scalar Arguments ..
6795      INTEGER            INFO, LDA, LWORK, M, N
6796*     ..
6797*     .. Array Arguments ..
6798      INTEGER            JPVT( * )
6799      DOUBLE PRECISION   RWORK( * )
6800      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
6801*     ..
6802*
6803*  =====================================================================
6804*
6805*     .. Parameters ..
6806      INTEGER            INB, INBMIN, IXOVER
6807      PARAMETER          ( INB = 1, INBMIN = 2, IXOVER = 3 )
6808*     ..
6809*     .. Local Scalars ..
6810      LOGICAL            LQUERY
6811      INTEGER            FJB, IWS, J, JB, LWKOPT, MINMN, MINWS, NA, NB,
6812     $                   NBMIN, NFXD, NX, SM, SMINMN, SN, TOPBMN
6813*     ..
6814*     .. External Subroutines ..
6815      EXTERNAL           XERBLA, ZGEQRF, ZLAQP2, ZLAQPS, ZSWAP, ZUNMQR
6816*     ..
6817*     .. External Functions ..
6818      INTEGER            ILAENV
6819      DOUBLE PRECISION   DZNRM2
6820      EXTERNAL           ILAENV, DZNRM2
6821*     ..
6822*     .. Intrinsic Functions ..
6823      INTRINSIC          INT, MAX, MIN
6824*     ..
6825*     .. Executable Statements ..
6826*
6827*     Test input arguments
6828*  ====================
6829*
6830      INFO = 0
6831      LQUERY = ( LWORK.EQ.-1 )
6832      IF( M.LT.0 ) THEN
6833         INFO = -1
6834      ELSE IF( N.LT.0 ) THEN
6835         INFO = -2
6836      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
6837         INFO = -4
6838      END IF
6839*
6840      IF( INFO.EQ.0 ) THEN
6841         MINMN = MIN( M, N )
6842         IF( MINMN.EQ.0 ) THEN
6843            IWS = 1
6844            LWKOPT = 1
6845         ELSE
6846            IWS = N + 1
6847            NB = ILAENV( INB, 'ZGEQRF', ' ', M, N, -1, -1 )
6848            LWKOPT = ( N + 1 )*NB
6849         END IF
6850         WORK( 1 ) = DCMPLX( LWKOPT )
6851*
6852         IF( ( LWORK.LT.IWS ) .AND. .NOT.LQUERY ) THEN
6853            INFO = -8
6854         END IF
6855      END IF
6856*
6857      IF( INFO.NE.0 ) THEN
6858         CALL XERBLA( 'ZGEQP3', -INFO )
6859         RETURN
6860      ELSE IF( LQUERY ) THEN
6861         RETURN
6862      END IF
6863*
6864*     Move initial columns up front.
6865*
6866      NFXD = 1
6867      DO 10 J = 1, N
6868         IF( JPVT( J ).NE.0 ) THEN
6869            IF( J.NE.NFXD ) THEN
6870               CALL ZSWAP( M, A( 1, J ), 1, A( 1, NFXD ), 1 )
6871               JPVT( J ) = JPVT( NFXD )
6872               JPVT( NFXD ) = J
6873            ELSE
6874               JPVT( J ) = J
6875            END IF
6876            NFXD = NFXD + 1
6877         ELSE
6878            JPVT( J ) = J
6879         END IF
6880   10 CONTINUE
6881      NFXD = NFXD - 1
6882*
6883*     Factorize fixed columns
6884*  =======================
6885*
6886*     Compute the QR factorization of fixed columns and update
6887*     remaining columns.
6888*
6889      IF( NFXD.GT.0 ) THEN
6890         NA = MIN( M, NFXD )
6891*CC      CALL ZGEQR2( M, NA, A, LDA, TAU, WORK, INFO )
6892         CALL ZGEQRF( M, NA, A, LDA, TAU, WORK, LWORK, INFO )
6893         IWS = MAX( IWS, INT( WORK( 1 ) ) )
6894         IF( NA.LT.N ) THEN
6895*CC         CALL ZUNM2R( 'Left', 'Conjugate Transpose', M, N-NA,
6896*CC  $                   NA, A, LDA, TAU, A( 1, NA+1 ), LDA, WORK,
6897*CC  $                   INFO )
6898            CALL ZUNMQR( 'Left', 'Conjugate Transpose', M, N-NA, NA, A,
6899     $                   LDA, TAU, A( 1, NA+1 ), LDA, WORK, LWORK,
6900     $                   INFO )
6901            IWS = MAX( IWS, INT( WORK( 1 ) ) )
6902         END IF
6903      END IF
6904*
6905*     Factorize free columns
6906*  ======================
6907*
6908      IF( NFXD.LT.MINMN ) THEN
6909*
6910         SM = M - NFXD
6911         SN = N - NFXD
6912         SMINMN = MINMN - NFXD
6913*
6914*        Determine the block size.
6915*
6916         NB = ILAENV( INB, 'ZGEQRF', ' ', SM, SN, -1, -1 )
6917         NBMIN = 2
6918         NX = 0
6919*
6920         IF( ( NB.GT.1 ) .AND. ( NB.LT.SMINMN ) ) THEN
6921*
6922*           Determine when to cross over from blocked to unblocked code.
6923*
6924            NX = MAX( 0, ILAENV( IXOVER, 'ZGEQRF', ' ', SM, SN, -1,
6925     $           -1 ) )
6926*
6927*
6928            IF( NX.LT.SMINMN ) THEN
6929*
6930*              Determine if workspace is large enough for blocked code.
6931*
6932               MINWS = ( SN+1 )*NB
6933               IWS = MAX( IWS, MINWS )
6934               IF( LWORK.LT.MINWS ) THEN
6935*
6936*                 Not enough workspace to use optimal NB: Reduce NB and
6937*                 determine the minimum value of NB.
6938*
6939                  NB = LWORK / ( SN+1 )
6940                  NBMIN = MAX( 2, ILAENV( INBMIN, 'ZGEQRF', ' ', SM, SN,
6941     $                    -1, -1 ) )
6942*
6943*
6944               END IF
6945            END IF
6946         END IF
6947*
6948*        Initialize partial column norms. The first N elements of work
6949*        store the exact column norms.
6950*
6951         DO 20 J = NFXD + 1, N
6952            RWORK( J ) = DZNRM2( SM, A( NFXD+1, J ), 1 )
6953            RWORK( N+J ) = RWORK( J )
6954   20    CONTINUE
6955*
6956         IF( ( NB.GE.NBMIN ) .AND. ( NB.LT.SMINMN ) .AND.
6957     $       ( NX.LT.SMINMN ) ) THEN
6958*
6959*           Use blocked code initially.
6960*
6961            J = NFXD + 1
6962*
6963*           Compute factorization: while loop.
6964*
6965*
6966            TOPBMN = MINMN - NX
6967   30       CONTINUE
6968            IF( J.LE.TOPBMN ) THEN
6969               JB = MIN( NB, TOPBMN-J+1 )
6970*
6971*              Factorize JB columns among columns J:N.
6972*
6973               CALL ZLAQPS( M, N-J+1, J-1, JB, FJB, A( 1, J ), LDA,
6974     $                      JPVT( J ), TAU( J ), RWORK( J ),
6975     $                      RWORK( N+J ), WORK( 1 ), WORK( JB+1 ),
6976     $                      N-J+1 )
6977*
6978               J = J + FJB
6979               GO TO 30
6980            END IF
6981         ELSE
6982            J = NFXD + 1
6983         END IF
6984*
6985*        Use unblocked code to factor the last or only block.
6986*
6987*
6988         IF( J.LE.MINMN )
6989     $      CALL ZLAQP2( M, N-J+1, J-1, A( 1, J ), LDA, JPVT( J ),
6990     $                   TAU( J ), RWORK( J ), RWORK( N+J ), WORK( 1 ) )
6991*
6992      END IF
6993*
6994      WORK( 1 ) = DCMPLX( LWKOPT )
6995      RETURN
6996*
6997*     End of ZGEQP3
6998*
6999      END
7000*> \brief \b ZGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm.
7001*
7002*  =========== DOCUMENTATION ===========
7003*
7004* Online html documentation available at
7005*            http://www.netlib.org/lapack/explore-html/
7006*
7007*> \htmlonly
7008*> Download ZGEQR2 + dependencies
7009*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgeqr2.f">
7010*> [TGZ]</a>
7011*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgeqr2.f">
7012*> [ZIP]</a>
7013*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgeqr2.f">
7014*> [TXT]</a>
7015*> \endhtmlonly
7016*
7017*  Definition:
7018*  ===========
7019*
7020*       SUBROUTINE ZGEQR2( M, N, A, LDA, TAU, WORK, INFO )
7021*
7022*       .. Scalar Arguments ..
7023*       INTEGER            INFO, LDA, M, N
7024*       ..
7025*       .. Array Arguments ..
7026*       COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
7027*       ..
7028*
7029*
7030*> \par Purpose:
7031*  =============
7032*>
7033*> \verbatim
7034*>
7035*> ZGEQR2 computes a QR factorization of a complex m-by-n matrix A:
7036*>
7037*>    A = Q * ( R ),
7038*>            ( 0 )
7039*>
7040*> where:
7041*>
7042*>    Q is a m-by-m orthogonal matrix;
7043*>    R is an upper-triangular n-by-n matrix;
7044*>    0 is a (m-n)-by-n zero matrix, if m > n.
7045*>
7046*> \endverbatim
7047*
7048*  Arguments:
7049*  ==========
7050*
7051*> \param[in] M
7052*> \verbatim
7053*>          M is INTEGER
7054*>          The number of rows of the matrix A.  M >= 0.
7055*> \endverbatim
7056*>
7057*> \param[in] N
7058*> \verbatim
7059*>          N is INTEGER
7060*>          The number of columns of the matrix A.  N >= 0.
7061*> \endverbatim
7062*>
7063*> \param[in,out] A
7064*> \verbatim
7065*>          A is COMPLEX*16 array, dimension (LDA,N)
7066*>          On entry, the m by n matrix A.
7067*>          On exit, the elements on and above the diagonal of the array
7068*>          contain the min(m,n) by n upper trapezoidal matrix R (R is
7069*>          upper triangular if m >= n); the elements below the diagonal,
7070*>          with the array TAU, represent the unitary matrix Q as a
7071*>          product of elementary reflectors (see Further Details).
7072*> \endverbatim
7073*>
7074*> \param[in] LDA
7075*> \verbatim
7076*>          LDA is INTEGER
7077*>          The leading dimension of the array A.  LDA >= max(1,M).
7078*> \endverbatim
7079*>
7080*> \param[out] TAU
7081*> \verbatim
7082*>          TAU is COMPLEX*16 array, dimension (min(M,N))
7083*>          The scalar factors of the elementary reflectors (see Further
7084*>          Details).
7085*> \endverbatim
7086*>
7087*> \param[out] WORK
7088*> \verbatim
7089*>          WORK is COMPLEX*16 array, dimension (N)
7090*> \endverbatim
7091*>
7092*> \param[out] INFO
7093*> \verbatim
7094*>          INFO is INTEGER
7095*>          = 0: successful exit
7096*>          < 0: if INFO = -i, the i-th argument had an illegal value
7097*> \endverbatim
7098*
7099*  Authors:
7100*  ========
7101*
7102*> \author Univ. of Tennessee
7103*> \author Univ. of California Berkeley
7104*> \author Univ. of Colorado Denver
7105*> \author NAG Ltd.
7106*
7107*> \date November 2019
7108*
7109*> \ingroup complex16GEcomputational
7110*
7111*> \par Further Details:
7112*  =====================
7113*>
7114*> \verbatim
7115*>
7116*>  The matrix Q is represented as a product of elementary reflectors
7117*>
7118*>     Q = H(1) H(2) . . . H(k), where k = min(m,n).
7119*>
7120*>  Each H(i) has the form
7121*>
7122*>     H(i) = I - tau * v * v**H
7123*>
7124*>  where tau is a complex scalar, and v is a complex vector with
7125*>  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
7126*>  and tau in TAU(i).
7127*> \endverbatim
7128*>
7129*  =====================================================================
7130      SUBROUTINE ZGEQR2( M, N, A, LDA, TAU, WORK, INFO )
7131*
7132*  -- LAPACK computational routine (version 3.9.0) --
7133*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
7134*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
7135*     November 2019
7136*
7137*     .. Scalar Arguments ..
7138      INTEGER            INFO, LDA, M, N
7139*     ..
7140*     .. Array Arguments ..
7141      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
7142*     ..
7143*
7144*  =====================================================================
7145*
7146*     .. Parameters ..
7147      COMPLEX*16         ONE
7148      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
7149*     ..
7150*     .. Local Scalars ..
7151      INTEGER            I, K
7152      COMPLEX*16         ALPHA
7153*     ..
7154*     .. External Subroutines ..
7155      EXTERNAL           XERBLA, ZLARF, ZLARFG
7156*     ..
7157*     .. Intrinsic Functions ..
7158      INTRINSIC          DCONJG, MAX, MIN
7159*     ..
7160*     .. Executable Statements ..
7161*
7162*     Test the input arguments
7163*
7164      INFO = 0
7165      IF( M.LT.0 ) THEN
7166         INFO = -1
7167      ELSE IF( N.LT.0 ) THEN
7168         INFO = -2
7169      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
7170         INFO = -4
7171      END IF
7172      IF( INFO.NE.0 ) THEN
7173         CALL XERBLA( 'ZGEQR2', -INFO )
7174         RETURN
7175      END IF
7176*
7177      K = MIN( M, N )
7178*
7179      DO 10 I = 1, K
7180*
7181*        Generate elementary reflector H(i) to annihilate A(i+1:m,i)
7182*
7183         CALL ZLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1,
7184     $                TAU( I ) )
7185         IF( I.LT.N ) THEN
7186*
7187*           Apply H(i)**H to A(i:m,i+1:n) from the left
7188*
7189            ALPHA = A( I, I )
7190            A( I, I ) = ONE
7191            CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1,
7192     $                  DCONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK )
7193            A( I, I ) = ALPHA
7194         END IF
7195   10 CONTINUE
7196      RETURN
7197*
7198*     End of ZGEQR2
7199*
7200      END
7201*> \brief \b ZGEQRF
7202*
7203*  =========== DOCUMENTATION ===========
7204*
7205* Online html documentation available at
7206*            http://www.netlib.org/lapack/explore-html/
7207*
7208*> \htmlonly
7209*> Download ZGEQRF + dependencies
7210*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgeqrf.f">
7211*> [TGZ]</a>
7212*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgeqrf.f">
7213*> [ZIP]</a>
7214*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgeqrf.f">
7215*> [TXT]</a>
7216*> \endhtmlonly
7217*
7218*  Definition:
7219*  ===========
7220*
7221*       SUBROUTINE ZGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
7222*
7223*       .. Scalar Arguments ..
7224*       INTEGER            INFO, LDA, LWORK, M, N
7225*       ..
7226*       .. Array Arguments ..
7227*       COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
7228*       ..
7229*
7230*
7231*> \par Purpose:
7232*  =============
7233*>
7234*> \verbatim
7235*>
7236*> ZGEQRF computes a QR factorization of a complex M-by-N matrix A:
7237*>
7238*>    A = Q * ( R ),
7239*>            ( 0 )
7240*>
7241*> where:
7242*>
7243*>    Q is a M-by-M orthogonal matrix;
7244*>    R is an upper-triangular N-by-N matrix;
7245*>    0 is a (M-N)-by-N zero matrix, if M > N.
7246*>
7247*> \endverbatim
7248*
7249*  Arguments:
7250*  ==========
7251*
7252*> \param[in] M
7253*> \verbatim
7254*>          M is INTEGER
7255*>          The number of rows of the matrix A.  M >= 0.
7256*> \endverbatim
7257*>
7258*> \param[in] N
7259*> \verbatim
7260*>          N is INTEGER
7261*>          The number of columns of the matrix A.  N >= 0.
7262*> \endverbatim
7263*>
7264*> \param[in,out] A
7265*> \verbatim
7266*>          A is COMPLEX*16 array, dimension (LDA,N)
7267*>          On entry, the M-by-N matrix A.
7268*>          On exit, the elements on and above the diagonal of the array
7269*>          contain the min(M,N)-by-N upper trapezoidal matrix R (R is
7270*>          upper triangular if m >= n); the elements below the diagonal,
7271*>          with the array TAU, represent the unitary matrix Q as a
7272*>          product of min(m,n) elementary reflectors (see Further
7273*>          Details).
7274*> \endverbatim
7275*>
7276*> \param[in] LDA
7277*> \verbatim
7278*>          LDA is INTEGER
7279*>          The leading dimension of the array A.  LDA >= max(1,M).
7280*> \endverbatim
7281*>
7282*> \param[out] TAU
7283*> \verbatim
7284*>          TAU is COMPLEX*16 array, dimension (min(M,N))
7285*>          The scalar factors of the elementary reflectors (see Further
7286*>          Details).
7287*> \endverbatim
7288*>
7289*> \param[out] WORK
7290*> \verbatim
7291*>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
7292*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
7293*> \endverbatim
7294*>
7295*> \param[in] LWORK
7296*> \verbatim
7297*>          LWORK is INTEGER
7298*>          The dimension of the array WORK.  LWORK >= max(1,N).
7299*>          For optimum performance LWORK >= N*NB, where NB is
7300*>          the optimal blocksize.
7301*>
7302*>          If LWORK = -1, then a workspace query is assumed; the routine
7303*>          only calculates the optimal size of the WORK array, returns
7304*>          this value as the first entry of the WORK array, and no error
7305*>          message related to LWORK is issued by XERBLA.
7306*> \endverbatim
7307*>
7308*> \param[out] INFO
7309*> \verbatim
7310*>          INFO is INTEGER
7311*>          = 0:  successful exit
7312*>          < 0:  if INFO = -i, the i-th argument had an illegal value
7313*> \endverbatim
7314*
7315*  Authors:
7316*  ========
7317*
7318*> \author Univ. of Tennessee
7319*> \author Univ. of California Berkeley
7320*> \author Univ. of Colorado Denver
7321*> \author NAG Ltd.
7322*
7323*> \date November 2019
7324*
7325*> \ingroup complex16GEcomputational
7326*
7327*> \par Further Details:
7328*  =====================
7329*>
7330*> \verbatim
7331*>
7332*>  The matrix Q is represented as a product of elementary reflectors
7333*>
7334*>     Q = H(1) H(2) . . . H(k), where k = min(m,n).
7335*>
7336*>  Each H(i) has the form
7337*>
7338*>     H(i) = I - tau * v * v**H
7339*>
7340*>  where tau is a complex scalar, and v is a complex vector with
7341*>  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
7342*>  and tau in TAU(i).
7343*> \endverbatim
7344*>
7345*  =====================================================================
7346      SUBROUTINE ZGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
7347*
7348*  -- LAPACK computational routine (version 3.9.0) --
7349*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
7350*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
7351*     November 2019
7352*
7353*     .. Scalar Arguments ..
7354      INTEGER            INFO, LDA, LWORK, M, N
7355*     ..
7356*     .. Array Arguments ..
7357      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
7358*     ..
7359*
7360*  =====================================================================
7361*
7362*     .. Local Scalars ..
7363      LOGICAL            LQUERY
7364      INTEGER            I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,
7365     $                   NBMIN, NX
7366*     ..
7367*     .. External Subroutines ..
7368      EXTERNAL           XERBLA, ZGEQR2, ZLARFB, ZLARFT
7369*     ..
7370*     .. Intrinsic Functions ..
7371      INTRINSIC          MAX, MIN
7372*     ..
7373*     .. External Functions ..
7374      INTEGER            ILAENV
7375      EXTERNAL           ILAENV
7376*     ..
7377*     .. Executable Statements ..
7378*
7379*     Test the input arguments
7380*
7381      INFO = 0
7382      NB = ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 )
7383      LWKOPT = N*NB
7384      WORK( 1 ) = LWKOPT
7385      LQUERY = ( LWORK.EQ.-1 )
7386      IF( M.LT.0 ) THEN
7387         INFO = -1
7388      ELSE IF( N.LT.0 ) THEN
7389         INFO = -2
7390      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
7391         INFO = -4
7392      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
7393         INFO = -7
7394      END IF
7395      IF( INFO.NE.0 ) THEN
7396         CALL XERBLA( 'ZGEQRF', -INFO )
7397         RETURN
7398      ELSE IF( LQUERY ) THEN
7399         RETURN
7400      END IF
7401*
7402*     Quick return if possible
7403*
7404      K = MIN( M, N )
7405      IF( K.EQ.0 ) THEN
7406         WORK( 1 ) = 1
7407         RETURN
7408      END IF
7409*
7410      NBMIN = 2
7411      NX = 0
7412      IWS = N
7413      IF( NB.GT.1 .AND. NB.LT.K ) THEN
7414*
7415*        Determine when to cross over from blocked to unblocked code.
7416*
7417         NX = MAX( 0, ILAENV( 3, 'ZGEQRF', ' ', M, N, -1, -1 ) )
7418         IF( NX.LT.K ) THEN
7419*
7420*           Determine if workspace is large enough for blocked code.
7421*
7422            LDWORK = N
7423            IWS = LDWORK*NB
7424            IF( LWORK.LT.IWS ) THEN
7425*
7426*              Not enough workspace to use optimal NB:  reduce NB and
7427*              determine the minimum value of NB.
7428*
7429               NB = LWORK / LDWORK
7430               NBMIN = MAX( 2, ILAENV( 2, 'ZGEQRF', ' ', M, N, -1,
7431     $                 -1 ) )
7432            END IF
7433         END IF
7434      END IF
7435*
7436      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
7437*
7438*        Use blocked code initially
7439*
7440         DO 10 I = 1, K - NX, NB
7441            IB = MIN( K-I+1, NB )
7442*
7443*           Compute the QR factorization of the current block
7444*           A(i:m,i:i+ib-1)
7445*
7446            CALL ZGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), WORK,
7447     $                   IINFO )
7448            IF( I+IB.LE.N ) THEN
7449*
7450*              Form the triangular factor of the block reflector
7451*              H = H(i) H(i+1) . . . H(i+ib-1)
7452*
7453               CALL ZLARFT( 'Forward', 'Columnwise', M-I+1, IB,
7454     $                      A( I, I ), LDA, TAU( I ), WORK, LDWORK )
7455*
7456*              Apply H**H to A(i:m,i+ib:n) from the left
7457*
7458               CALL ZLARFB( 'Left', 'Conjugate transpose', 'Forward',
7459     $                      'Columnwise', M-I+1, N-I-IB+1, IB,
7460     $                      A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ),
7461     $                      LDA, WORK( IB+1 ), LDWORK )
7462            END IF
7463   10    CONTINUE
7464      ELSE
7465         I = 1
7466      END IF
7467*
7468*     Use unblocked code to factor the last or only block.
7469*
7470      IF( I.LE.K )
7471     $   CALL ZGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
7472     $                IINFO )
7473*
7474      WORK( 1 ) = IWS
7475      RETURN
7476*
7477*     End of ZGEQRF
7478*
7479      END
7480*> \brief \b ZGERFS
7481*
7482*  =========== DOCUMENTATION ===========
7483*
7484* Online html documentation available at
7485*            http://www.netlib.org/lapack/explore-html/
7486*
7487*> \htmlonly
7488*> Download ZGERFS + dependencies
7489*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgerfs.f">
7490*> [TGZ]</a>
7491*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgerfs.f">
7492*> [ZIP]</a>
7493*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgerfs.f">
7494*> [TXT]</a>
7495*> \endhtmlonly
7496*
7497*  Definition:
7498*  ===========
7499*
7500*       SUBROUTINE ZGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB,
7501*                          X, LDX, FERR, BERR, WORK, RWORK, INFO )
7502*
7503*       .. Scalar Arguments ..
7504*       CHARACTER          TRANS
7505*       INTEGER            INFO, LDA, LDAF, LDB, LDX, N, NRHS
7506*       ..
7507*       .. Array Arguments ..
7508*       INTEGER            IPIV( * )
7509*       DOUBLE PRECISION   BERR( * ), FERR( * ), RWORK( * )
7510*       COMPLEX*16         A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
7511*      $                   WORK( * ), X( LDX, * )
7512*       ..
7513*
7514*
7515*> \par Purpose:
7516*  =============
7517*>
7518*> \verbatim
7519*>
7520*> ZGERFS improves the computed solution to a system of linear
7521*> equations and provides error bounds and backward error estimates for
7522*> the solution.
7523*> \endverbatim
7524*
7525*  Arguments:
7526*  ==========
7527*
7528*> \param[in] TRANS
7529*> \verbatim
7530*>          TRANS is CHARACTER*1
7531*>          Specifies the form of the system of equations:
7532*>          = 'N':  A * X = B     (No transpose)
7533*>          = 'T':  A**T * X = B  (Transpose)
7534*>          = 'C':  A**H * X = B  (Conjugate transpose)
7535*> \endverbatim
7536*>
7537*> \param[in] N
7538*> \verbatim
7539*>          N is INTEGER
7540*>          The order of the matrix A.  N >= 0.
7541*> \endverbatim
7542*>
7543*> \param[in] NRHS
7544*> \verbatim
7545*>          NRHS is INTEGER
7546*>          The number of right hand sides, i.e., the number of columns
7547*>          of the matrices B and X.  NRHS >= 0.
7548*> \endverbatim
7549*>
7550*> \param[in] A
7551*> \verbatim
7552*>          A is COMPLEX*16 array, dimension (LDA,N)
7553*>          The original N-by-N matrix A.
7554*> \endverbatim
7555*>
7556*> \param[in] LDA
7557*> \verbatim
7558*>          LDA is INTEGER
7559*>          The leading dimension of the array A.  LDA >= max(1,N).
7560*> \endverbatim
7561*>
7562*> \param[in] AF
7563*> \verbatim
7564*>          AF is COMPLEX*16 array, dimension (LDAF,N)
7565*>          The factors L and U from the factorization A = P*L*U
7566*>          as computed by ZGETRF.
7567*> \endverbatim
7568*>
7569*> \param[in] LDAF
7570*> \verbatim
7571*>          LDAF is INTEGER
7572*>          The leading dimension of the array AF.  LDAF >= max(1,N).
7573*> \endverbatim
7574*>
7575*> \param[in] IPIV
7576*> \verbatim
7577*>          IPIV is INTEGER array, dimension (N)
7578*>          The pivot indices from ZGETRF; for 1<=i<=N, row i of the
7579*>          matrix was interchanged with row IPIV(i).
7580*> \endverbatim
7581*>
7582*> \param[in] B
7583*> \verbatim
7584*>          B is COMPLEX*16 array, dimension (LDB,NRHS)
7585*>          The right hand side matrix B.
7586*> \endverbatim
7587*>
7588*> \param[in] LDB
7589*> \verbatim
7590*>          LDB is INTEGER
7591*>          The leading dimension of the array B.  LDB >= max(1,N).
7592*> \endverbatim
7593*>
7594*> \param[in,out] X
7595*> \verbatim
7596*>          X is COMPLEX*16 array, dimension (LDX,NRHS)
7597*>          On entry, the solution matrix X, as computed by ZGETRS.
7598*>          On exit, the improved solution matrix X.
7599*> \endverbatim
7600*>
7601*> \param[in] LDX
7602*> \verbatim
7603*>          LDX is INTEGER
7604*>          The leading dimension of the array X.  LDX >= max(1,N).
7605*> \endverbatim
7606*>
7607*> \param[out] FERR
7608*> \verbatim
7609*>          FERR is DOUBLE PRECISION array, dimension (NRHS)
7610*>          The estimated forward error bound for each solution vector
7611*>          X(j) (the j-th column of the solution matrix X).
7612*>          If XTRUE is the true solution corresponding to X(j), FERR(j)
7613*>          is an estimated upper bound for the magnitude of the largest
7614*>          element in (X(j) - XTRUE) divided by the magnitude of the
7615*>          largest element in X(j).  The estimate is as reliable as
7616*>          the estimate for RCOND, and is almost always a slight
7617*>          overestimate of the true error.
7618*> \endverbatim
7619*>
7620*> \param[out] BERR
7621*> \verbatim
7622*>          BERR is DOUBLE PRECISION array, dimension (NRHS)
7623*>          The componentwise relative backward error of each solution
7624*>          vector X(j) (i.e., the smallest relative change in
7625*>          any element of A or B that makes X(j) an exact solution).
7626*> \endverbatim
7627*>
7628*> \param[out] WORK
7629*> \verbatim
7630*>          WORK is COMPLEX*16 array, dimension (2*N)
7631*> \endverbatim
7632*>
7633*> \param[out] RWORK
7634*> \verbatim
7635*>          RWORK is DOUBLE PRECISION array, dimension (N)
7636*> \endverbatim
7637*>
7638*> \param[out] INFO
7639*> \verbatim
7640*>          INFO is INTEGER
7641*>          = 0:  successful exit
7642*>          < 0:  if INFO = -i, the i-th argument had an illegal value
7643*> \endverbatim
7644*
7645*> \par Internal Parameters:
7646*  =========================
7647*>
7648*> \verbatim
7649*>  ITMAX is the maximum number of steps of iterative refinement.
7650*> \endverbatim
7651*
7652*  Authors:
7653*  ========
7654*
7655*> \author Univ. of Tennessee
7656*> \author Univ. of California Berkeley
7657*> \author Univ. of Colorado Denver
7658*> \author NAG Ltd.
7659*
7660*> \date December 2016
7661*
7662*> \ingroup complex16GEcomputational
7663*
7664*  =====================================================================
7665      SUBROUTINE ZGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB,
7666     $                   X, LDX, FERR, BERR, WORK, RWORK, INFO )
7667*
7668*  -- LAPACK computational routine (version 3.7.0) --
7669*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
7670*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
7671*     December 2016
7672*
7673*     .. Scalar Arguments ..
7674      CHARACTER          TRANS
7675      INTEGER            INFO, LDA, LDAF, LDB, LDX, N, NRHS
7676*     ..
7677*     .. Array Arguments ..
7678      INTEGER            IPIV( * )
7679      DOUBLE PRECISION   BERR( * ), FERR( * ), RWORK( * )
7680      COMPLEX*16         A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
7681     $                   WORK( * ), X( LDX, * )
7682*     ..
7683*
7684*  =====================================================================
7685*
7686*     .. Parameters ..
7687      INTEGER            ITMAX
7688      PARAMETER          ( ITMAX = 5 )
7689      DOUBLE PRECISION   ZERO
7690      PARAMETER          ( ZERO = 0.0D+0 )
7691      COMPLEX*16         ONE
7692      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
7693      DOUBLE PRECISION   TWO
7694      PARAMETER          ( TWO = 2.0D+0 )
7695      DOUBLE PRECISION   THREE
7696      PARAMETER          ( THREE = 3.0D+0 )
7697*     ..
7698*     .. Local Scalars ..
7699      LOGICAL            NOTRAN
7700      CHARACTER          TRANSN, TRANST
7701      INTEGER            COUNT, I, J, K, KASE, NZ
7702      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
7703      COMPLEX*16         ZDUM
7704*     ..
7705*     .. Local Arrays ..
7706      INTEGER            ISAVE( 3 )
7707*     ..
7708*     .. External Functions ..
7709      LOGICAL            LSAME
7710      DOUBLE PRECISION   DLAMCH
7711      EXTERNAL           LSAME, DLAMCH
7712*     ..
7713*     .. External Subroutines ..
7714      EXTERNAL           XERBLA, ZAXPY, ZCOPY, ZGEMV, ZGETRS, ZLACN2
7715*     ..
7716*     .. Intrinsic Functions ..
7717      INTRINSIC          ABS, DBLE, DIMAG, MAX
7718*     ..
7719*     .. Statement Functions ..
7720      DOUBLE PRECISION   CABS1
7721*     ..
7722*     .. Statement Function definitions ..
7723      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
7724*     ..
7725*     .. Executable Statements ..
7726*
7727*     Test the input parameters.
7728*
7729      INFO = 0
7730      NOTRAN = LSAME( TRANS, 'N' )
7731      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
7732     $    LSAME( TRANS, 'C' ) ) THEN
7733         INFO = -1
7734      ELSE IF( N.LT.0 ) THEN
7735         INFO = -2
7736      ELSE IF( NRHS.LT.0 ) THEN
7737         INFO = -3
7738      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
7739         INFO = -5
7740      ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
7741         INFO = -7
7742      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
7743         INFO = -10
7744      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
7745         INFO = -12
7746      END IF
7747      IF( INFO.NE.0 ) THEN
7748         CALL XERBLA( 'ZGERFS', -INFO )
7749         RETURN
7750      END IF
7751*
7752*     Quick return if possible
7753*
7754      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
7755         DO 10 J = 1, NRHS
7756            FERR( J ) = ZERO
7757            BERR( J ) = ZERO
7758   10    CONTINUE
7759         RETURN
7760      END IF
7761*
7762      IF( NOTRAN ) THEN
7763         TRANSN = 'N'
7764         TRANST = 'C'
7765      ELSE
7766         TRANSN = 'C'
7767         TRANST = 'N'
7768      END IF
7769*
7770*     NZ = maximum number of nonzero elements in each row of A, plus 1
7771*
7772      NZ = N + 1
7773      EPS = DLAMCH( 'Epsilon' )
7774      SAFMIN = DLAMCH( 'Safe minimum' )
7775      SAFE1 = NZ*SAFMIN
7776      SAFE2 = SAFE1 / EPS
7777*
7778*     Do for each right hand side
7779*
7780      DO 140 J = 1, NRHS
7781*
7782         COUNT = 1
7783         LSTRES = THREE
7784   20    CONTINUE
7785*
7786*        Loop until stopping criterion is satisfied.
7787*
7788*        Compute residual R = B - op(A) * X,
7789*        where op(A) = A, A**T, or A**H, depending on TRANS.
7790*
7791         CALL ZCOPY( N, B( 1, J ), 1, WORK, 1 )
7792         CALL ZGEMV( TRANS, N, N, -ONE, A, LDA, X( 1, J ), 1, ONE, WORK,
7793     $               1 )
7794*
7795*        Compute componentwise relative backward error from formula
7796*
7797*        max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
7798*
7799*        where abs(Z) is the componentwise absolute value of the matrix
7800*        or vector Z.  If the i-th component of the denominator is less
7801*        than SAFE2, then SAFE1 is added to the i-th components of the
7802*        numerator and denominator before dividing.
7803*
7804         DO 30 I = 1, N
7805            RWORK( I ) = CABS1( B( I, J ) )
7806   30    CONTINUE
7807*
7808*        Compute abs(op(A))*abs(X) + abs(B).
7809*
7810         IF( NOTRAN ) THEN
7811            DO 50 K = 1, N
7812               XK = CABS1( X( K, J ) )
7813               DO 40 I = 1, N
7814                  RWORK( I ) = RWORK( I ) + CABS1( A( I, K ) )*XK
7815   40          CONTINUE
7816   50       CONTINUE
7817         ELSE
7818            DO 70 K = 1, N
7819               S = ZERO
7820               DO 60 I = 1, N
7821                  S = S + CABS1( A( I, K ) )*CABS1( X( I, J ) )
7822   60          CONTINUE
7823               RWORK( K ) = RWORK( K ) + S
7824   70       CONTINUE
7825         END IF
7826         S = ZERO
7827         DO 80 I = 1, N
7828            IF( RWORK( I ).GT.SAFE2 ) THEN
7829               S = MAX( S, CABS1( WORK( I ) ) / RWORK( I ) )
7830            ELSE
7831               S = MAX( S, ( CABS1( WORK( I ) )+SAFE1 ) /
7832     $             ( RWORK( I )+SAFE1 ) )
7833            END IF
7834   80    CONTINUE
7835         BERR( J ) = S
7836*
7837*        Test stopping criterion. Continue iterating if
7838*           1) The residual BERR(J) is larger than machine epsilon, and
7839*           2) BERR(J) decreased by at least a factor of 2 during the
7840*              last iteration, and
7841*           3) At most ITMAX iterations tried.
7842*
7843         IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
7844     $       COUNT.LE.ITMAX ) THEN
7845*
7846*           Update solution and try again.
7847*
7848            CALL ZGETRS( TRANS, N, 1, AF, LDAF, IPIV, WORK, N, INFO )
7849            CALL ZAXPY( N, ONE, WORK, 1, X( 1, J ), 1 )
7850            LSTRES = BERR( J )
7851            COUNT = COUNT + 1
7852            GO TO 20
7853         END IF
7854*
7855*        Bound error from formula
7856*
7857*        norm(X - XTRUE) / norm(X) .le. FERR =
7858*        norm( abs(inv(op(A)))*
7859*           ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
7860*
7861*        where
7862*          norm(Z) is the magnitude of the largest component of Z
7863*          inv(op(A)) is the inverse of op(A)
7864*          abs(Z) is the componentwise absolute value of the matrix or
7865*             vector Z
7866*          NZ is the maximum number of nonzeros in any row of A, plus 1
7867*          EPS is machine epsilon
7868*
7869*        The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
7870*        is incremented by SAFE1 if the i-th component of
7871*        abs(op(A))*abs(X) + abs(B) is less than SAFE2.
7872*
7873*        Use ZLACN2 to estimate the infinity-norm of the matrix
7874*           inv(op(A)) * diag(W),
7875*        where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
7876*
7877         DO 90 I = 1, N
7878            IF( RWORK( I ).GT.SAFE2 ) THEN
7879               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I )
7880            ELSE
7881               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I ) +
7882     $                      SAFE1
7883            END IF
7884   90    CONTINUE
7885*
7886         KASE = 0
7887  100    CONTINUE
7888         CALL ZLACN2( N, WORK( N+1 ), WORK, FERR( J ), KASE, ISAVE )
7889         IF( KASE.NE.0 ) THEN
7890            IF( KASE.EQ.1 ) THEN
7891*
7892*              Multiply by diag(W)*inv(op(A)**H).
7893*
7894               CALL ZGETRS( TRANST, N, 1, AF, LDAF, IPIV, WORK, N,
7895     $                      INFO )
7896               DO 110 I = 1, N
7897                  WORK( I ) = RWORK( I )*WORK( I )
7898  110          CONTINUE
7899            ELSE
7900*
7901*              Multiply by inv(op(A))*diag(W).
7902*
7903               DO 120 I = 1, N
7904                  WORK( I ) = RWORK( I )*WORK( I )
7905  120          CONTINUE
7906               CALL ZGETRS( TRANSN, N, 1, AF, LDAF, IPIV, WORK, N,
7907     $                      INFO )
7908            END IF
7909            GO TO 100
7910         END IF
7911*
7912*        Normalize error.
7913*
7914         LSTRES = ZERO
7915         DO 130 I = 1, N
7916            LSTRES = MAX( LSTRES, CABS1( X( I, J ) ) )
7917  130    CONTINUE
7918         IF( LSTRES.NE.ZERO )
7919     $      FERR( J ) = FERR( J ) / LSTRES
7920*
7921  140 CONTINUE
7922*
7923      RETURN
7924*
7925*     End of ZGERFS
7926*
7927      END
7928*> \brief \b ZGESC2 solves a system of linear equations using the LU factorization with complete pivoting computed by sgetc2.
7929*
7930*  =========== DOCUMENTATION ===========
7931*
7932* Online html documentation available at
7933*            http://www.netlib.org/lapack/explore-html/
7934*
7935*> \htmlonly
7936*> Download ZGESC2 + dependencies
7937*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgesc2.f">
7938*> [TGZ]</a>
7939*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgesc2.f">
7940*> [ZIP]</a>
7941*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgesc2.f">
7942*> [TXT]</a>
7943*> \endhtmlonly
7944*
7945*  Definition:
7946*  ===========
7947*
7948*       SUBROUTINE ZGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE )
7949*
7950*       .. Scalar Arguments ..
7951*       INTEGER            LDA, N
7952*       DOUBLE PRECISION   SCALE
7953*       ..
7954*       .. Array Arguments ..
7955*       INTEGER            IPIV( * ), JPIV( * )
7956*       COMPLEX*16         A( LDA, * ), RHS( * )
7957*       ..
7958*
7959*
7960*> \par Purpose:
7961*  =============
7962*>
7963*> \verbatim
7964*>
7965*> ZGESC2 solves a system of linear equations
7966*>
7967*>           A * X = scale* RHS
7968*>
7969*> with a general N-by-N matrix A using the LU factorization with
7970*> complete pivoting computed by ZGETC2.
7971*>
7972*> \endverbatim
7973*
7974*  Arguments:
7975*  ==========
7976*
7977*> \param[in] N
7978*> \verbatim
7979*>          N is INTEGER
7980*>          The number of columns of the matrix A.
7981*> \endverbatim
7982*>
7983*> \param[in] A
7984*> \verbatim
7985*>          A is COMPLEX*16 array, dimension (LDA, N)
7986*>          On entry, the  LU part of the factorization of the n-by-n
7987*>          matrix A computed by ZGETC2:  A = P * L * U * Q
7988*> \endverbatim
7989*>
7990*> \param[in] LDA
7991*> \verbatim
7992*>          LDA is INTEGER
7993*>          The leading dimension of the array A.  LDA >= max(1, N).
7994*> \endverbatim
7995*>
7996*> \param[in,out] RHS
7997*> \verbatim
7998*>          RHS is COMPLEX*16 array, dimension N.
7999*>          On entry, the right hand side vector b.
8000*>          On exit, the solution vector X.
8001*> \endverbatim
8002*>
8003*> \param[in] IPIV
8004*> \verbatim
8005*>          IPIV is INTEGER array, dimension (N).
8006*>          The pivot indices; for 1 <= i <= N, row i of the
8007*>          matrix has been interchanged with row IPIV(i).
8008*> \endverbatim
8009*>
8010*> \param[in] JPIV
8011*> \verbatim
8012*>          JPIV is INTEGER array, dimension (N).
8013*>          The pivot indices; for 1 <= j <= N, column j of the
8014*>          matrix has been interchanged with column JPIV(j).
8015*> \endverbatim
8016*>
8017*> \param[out] SCALE
8018*> \verbatim
8019*>          SCALE is DOUBLE PRECISION
8020*>           On exit, SCALE contains the scale factor. SCALE is chosen
8021*>           0 <= SCALE <= 1 to prevent overflow in the solution.
8022*> \endverbatim
8023*
8024*  Authors:
8025*  ========
8026*
8027*> \author Univ. of Tennessee
8028*> \author Univ. of California Berkeley
8029*> \author Univ. of Colorado Denver
8030*> \author NAG Ltd.
8031*
8032*> \date November 2017
8033*
8034*> \ingroup complex16GEauxiliary
8035*
8036*> \par Contributors:
8037*  ==================
8038*>
8039*>     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
8040*>     Umea University, S-901 87 Umea, Sweden.
8041*
8042*  =====================================================================
8043      SUBROUTINE ZGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE )
8044*
8045*  -- LAPACK auxiliary routine (version 3.8.0) --
8046*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
8047*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
8048*     November 2017
8049*
8050*     .. Scalar Arguments ..
8051      INTEGER            LDA, N
8052      DOUBLE PRECISION   SCALE
8053*     ..
8054*     .. Array Arguments ..
8055      INTEGER            IPIV( * ), JPIV( * )
8056      COMPLEX*16         A( LDA, * ), RHS( * )
8057*     ..
8058*
8059*  =====================================================================
8060*
8061*     .. Parameters ..
8062      DOUBLE PRECISION   ZERO, ONE, TWO
8063      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
8064*     ..
8065*     .. Local Scalars ..
8066      INTEGER            I, J
8067      DOUBLE PRECISION   BIGNUM, EPS, SMLNUM
8068      COMPLEX*16         TEMP
8069*     ..
8070*     .. External Subroutines ..
8071      EXTERNAL           ZLASWP, ZSCAL, DLABAD
8072*     ..
8073*     .. External Functions ..
8074      INTEGER            IZAMAX
8075      DOUBLE PRECISION   DLAMCH
8076      EXTERNAL           IZAMAX, DLAMCH
8077*     ..
8078*     .. Intrinsic Functions ..
8079      INTRINSIC          ABS, DBLE, DCMPLX
8080*     ..
8081*     .. Executable Statements ..
8082*
8083*     Set constant to control overflow
8084*
8085      EPS = DLAMCH( 'P' )
8086      SMLNUM = DLAMCH( 'S' ) / EPS
8087      BIGNUM = ONE / SMLNUM
8088      CALL DLABAD( SMLNUM, BIGNUM )
8089*
8090*     Apply permutations IPIV to RHS
8091*
8092      CALL ZLASWP( 1, RHS, LDA, 1, N-1, IPIV, 1 )
8093*
8094*     Solve for L part
8095*
8096      DO 20 I = 1, N - 1
8097         DO 10 J = I + 1, N
8098            RHS( J ) = RHS( J ) - A( J, I )*RHS( I )
8099   10    CONTINUE
8100   20 CONTINUE
8101*
8102*     Solve for U part
8103*
8104      SCALE = ONE
8105*
8106*     Check for scaling
8107*
8108      I = IZAMAX( N, RHS, 1 )
8109      IF( TWO*SMLNUM*ABS( RHS( I ) ).GT.ABS( A( N, N ) ) ) THEN
8110         TEMP = DCMPLX( ONE / TWO, ZERO ) / ABS( RHS( I ) )
8111         CALL ZSCAL( N, TEMP, RHS( 1 ), 1 )
8112         SCALE = SCALE*DBLE( TEMP )
8113      END IF
8114      DO 40 I = N, 1, -1
8115         TEMP = DCMPLX( ONE, ZERO ) / A( I, I )
8116         RHS( I ) = RHS( I )*TEMP
8117         DO 30 J = I + 1, N
8118            RHS( I ) = RHS( I ) - RHS( J )*( A( I, J )*TEMP )
8119   30    CONTINUE
8120   40 CONTINUE
8121*
8122*     Apply permutations JPIV to the solution (RHS)
8123*
8124      CALL ZLASWP( 1, RHS, LDA, 1, N-1, JPIV, -1 )
8125      RETURN
8126*
8127*     End of ZGESC2
8128*
8129      END
8130*> \brief \b ZGESDD
8131*
8132*  =========== DOCUMENTATION ===========
8133*
8134* Online html documentation available at
8135*            http://www.netlib.org/lapack/explore-html/
8136*
8137*> \htmlonly
8138*> Download ZGESDD + dependencies
8139*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgesdd.f">
8140*> [TGZ]</a>
8141*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgesdd.f">
8142*> [ZIP]</a>
8143*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgesdd.f">
8144*> [TXT]</a>
8145*> \endhtmlonly
8146*
8147*  Definition:
8148*  ===========
8149*
8150*       SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT,
8151*                          WORK, LWORK, RWORK, IWORK, INFO )
8152*
8153*       .. Scalar Arguments ..
8154*       CHARACTER          JOBZ
8155*       INTEGER            INFO, LDA, LDU, LDVT, LWORK, M, N
8156*       ..
8157*       .. Array Arguments ..
8158*       INTEGER            IWORK( * )
8159*       DOUBLE PRECISION   RWORK( * ), S( * )
8160*       COMPLEX*16         A( LDA, * ), U( LDU, * ), VT( LDVT, * ),
8161*      $                   WORK( * )
8162*       ..
8163*
8164*
8165*> \par Purpose:
8166*  =============
8167*>
8168*> \verbatim
8169*>
8170*> ZGESDD computes the singular value decomposition (SVD) of a complex
8171*> M-by-N matrix A, optionally computing the left and/or right singular
8172*> vectors, by using divide-and-conquer method. The SVD is written
8173*>
8174*>      A = U * SIGMA * conjugate-transpose(V)
8175*>
8176*> where SIGMA is an M-by-N matrix which is zero except for its
8177*> min(m,n) diagonal elements, U is an M-by-M unitary matrix, and
8178*> V is an N-by-N unitary matrix.  The diagonal elements of SIGMA
8179*> are the singular values of A; they are real and non-negative, and
8180*> are returned in descending order.  The first min(m,n) columns of
8181*> U and V are the left and right singular vectors of A.
8182*>
8183*> Note that the routine returns VT = V**H, not V.
8184*>
8185*> The divide and conquer algorithm makes very mild assumptions about
8186*> floating point arithmetic. It will work on machines with a guard
8187*> digit in add/subtract, or on those binary machines without guard
8188*> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
8189*> Cray-2. It could conceivably fail on hexadecimal or decimal machines
8190*> without guard digits, but we know of none.
8191*> \endverbatim
8192*
8193*  Arguments:
8194*  ==========
8195*
8196*> \param[in] JOBZ
8197*> \verbatim
8198*>          JOBZ is CHARACTER*1
8199*>          Specifies options for computing all or part of the matrix U:
8200*>          = 'A':  all M columns of U and all N rows of V**H are
8201*>                  returned in the arrays U and VT;
8202*>          = 'S':  the first min(M,N) columns of U and the first
8203*>                  min(M,N) rows of V**H are returned in the arrays U
8204*>                  and VT;
8205*>          = 'O':  If M >= N, the first N columns of U are overwritten
8206*>                  in the array A and all rows of V**H are returned in
8207*>                  the array VT;
8208*>                  otherwise, all columns of U are returned in the
8209*>                  array U and the first M rows of V**H are overwritten
8210*>                  in the array A;
8211*>          = 'N':  no columns of U or rows of V**H are computed.
8212*> \endverbatim
8213*>
8214*> \param[in] M
8215*> \verbatim
8216*>          M is INTEGER
8217*>          The number of rows of the input matrix A.  M >= 0.
8218*> \endverbatim
8219*>
8220*> \param[in] N
8221*> \verbatim
8222*>          N is INTEGER
8223*>          The number of columns of the input matrix A.  N >= 0.
8224*> \endverbatim
8225*>
8226*> \param[in,out] A
8227*> \verbatim
8228*>          A is COMPLEX*16 array, dimension (LDA,N)
8229*>          On entry, the M-by-N matrix A.
8230*>          On exit,
8231*>          if JOBZ = 'O',  A is overwritten with the first N columns
8232*>                          of U (the left singular vectors, stored
8233*>                          columnwise) if M >= N;
8234*>                          A is overwritten with the first M rows
8235*>                          of V**H (the right singular vectors, stored
8236*>                          rowwise) otherwise.
8237*>          if JOBZ .ne. 'O', the contents of A are destroyed.
8238*> \endverbatim
8239*>
8240*> \param[in] LDA
8241*> \verbatim
8242*>          LDA is INTEGER
8243*>          The leading dimension of the array A.  LDA >= max(1,M).
8244*> \endverbatim
8245*>
8246*> \param[out] S
8247*> \verbatim
8248*>          S is DOUBLE PRECISION array, dimension (min(M,N))
8249*>          The singular values of A, sorted so that S(i) >= S(i+1).
8250*> \endverbatim
8251*>
8252*> \param[out] U
8253*> \verbatim
8254*>          U is COMPLEX*16 array, dimension (LDU,UCOL)
8255*>          UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N;
8256*>          UCOL = min(M,N) if JOBZ = 'S'.
8257*>          If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M
8258*>          unitary matrix U;
8259*>          if JOBZ = 'S', U contains the first min(M,N) columns of U
8260*>          (the left singular vectors, stored columnwise);
8261*>          if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced.
8262*> \endverbatim
8263*>
8264*> \param[in] LDU
8265*> \verbatim
8266*>          LDU is INTEGER
8267*>          The leading dimension of the array U.  LDU >= 1;
8268*>          if JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M.
8269*> \endverbatim
8270*>
8271*> \param[out] VT
8272*> \verbatim
8273*>          VT is COMPLEX*16 array, dimension (LDVT,N)
8274*>          If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the
8275*>          N-by-N unitary matrix V**H;
8276*>          if JOBZ = 'S', VT contains the first min(M,N) rows of
8277*>          V**H (the right singular vectors, stored rowwise);
8278*>          if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced.
8279*> \endverbatim
8280*>
8281*> \param[in] LDVT
8282*> \verbatim
8283*>          LDVT is INTEGER
8284*>          The leading dimension of the array VT.  LDVT >= 1;
8285*>          if JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N;
8286*>          if JOBZ = 'S', LDVT >= min(M,N).
8287*> \endverbatim
8288*>
8289*> \param[out] WORK
8290*> \verbatim
8291*>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
8292*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
8293*> \endverbatim
8294*>
8295*> \param[in] LWORK
8296*> \verbatim
8297*>          LWORK is INTEGER
8298*>          The dimension of the array WORK. LWORK >= 1.
8299*>          If LWORK = -1, a workspace query is assumed.  The optimal
8300*>          size for the WORK array is calculated and stored in WORK(1),
8301*>          and no other work except argument checking is performed.
8302*>
8303*>          Let mx = max(M,N) and mn = min(M,N).
8304*>          If JOBZ = 'N', LWORK >= 2*mn + mx.
8305*>          If JOBZ = 'O', LWORK >= 2*mn*mn + 2*mn + mx.
8306*>          If JOBZ = 'S', LWORK >=   mn*mn + 3*mn.
8307*>          If JOBZ = 'A', LWORK >=   mn*mn + 2*mn + mx.
8308*>          These are not tight minimums in all cases; see comments inside code.
8309*>          For good performance, LWORK should generally be larger;
8310*>          a query is recommended.
8311*> \endverbatim
8312*>
8313*> \param[out] RWORK
8314*> \verbatim
8315*>          RWORK is DOUBLE PRECISION array, dimension (MAX(1,LRWORK))
8316*>          Let mx = max(M,N) and mn = min(M,N).
8317*>          If JOBZ = 'N',    LRWORK >= 5*mn (LAPACK <= 3.6 needs 7*mn);
8318*>          else if mx >> mn, LRWORK >= 5*mn*mn + 5*mn;
8319*>          else              LRWORK >= max( 5*mn*mn + 5*mn,
8320*>                                           2*mx*mn + 2*mn*mn + mn ).
8321*> \endverbatim
8322*>
8323*> \param[out] IWORK
8324*> \verbatim
8325*>          IWORK is INTEGER array, dimension (8*min(M,N))
8326*> \endverbatim
8327*>
8328*> \param[out] INFO
8329*> \verbatim
8330*>          INFO is INTEGER
8331*>          = 0:  successful exit.
8332*>          < 0:  if INFO = -i, the i-th argument had an illegal value.
8333*>          > 0:  The updating process of DBDSDC did not converge.
8334*> \endverbatim
8335*
8336*  Authors:
8337*  ========
8338*
8339*> \author Univ. of Tennessee
8340*> \author Univ. of California Berkeley
8341*> \author Univ. of Colorado Denver
8342*> \author NAG Ltd.
8343*
8344*> \date June 2016
8345*
8346*> \ingroup complex16GEsing
8347*
8348*> \par Contributors:
8349*  ==================
8350*>
8351*>     Ming Gu and Huan Ren, Computer Science Division, University of
8352*>     California at Berkeley, USA
8353*>
8354*  =====================================================================
8355      SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT,
8356     $                   WORK, LWORK, RWORK, IWORK, INFO )
8357      implicit none
8358*
8359*  -- LAPACK driver routine (version 3.7.0) --
8360*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
8361*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
8362*     June 2016
8363*
8364*     .. Scalar Arguments ..
8365      CHARACTER          JOBZ
8366      INTEGER            INFO, LDA, LDU, LDVT, LWORK, M, N
8367*     ..
8368*     .. Array Arguments ..
8369      INTEGER            IWORK( * )
8370      DOUBLE PRECISION   RWORK( * ), S( * )
8371      COMPLEX*16         A( LDA, * ), U( LDU, * ), VT( LDVT, * ),
8372     $                   WORK( * )
8373*     ..
8374*
8375*  =====================================================================
8376*
8377*     .. Parameters ..
8378      COMPLEX*16         CZERO, CONE
8379      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ),
8380     $                   CONE = ( 1.0D+0, 0.0D+0 ) )
8381      DOUBLE PRECISION   ZERO, ONE
8382      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
8383*     ..
8384*     .. Local Scalars ..
8385      LOGICAL            LQUERY, WNTQA, WNTQAS, WNTQN, WNTQO, WNTQS
8386      INTEGER            BLK, CHUNK, I, IE, IERR, IL, IR, IRU, IRVT,
8387     $                   ISCL, ITAU, ITAUP, ITAUQ, IU, IVT, LDWKVT,
8388     $                   LDWRKL, LDWRKR, LDWRKU, MAXWRK, MINMN, MINWRK,
8389     $                   MNTHR1, MNTHR2, NRWORK, NWORK, WRKBL
8390      INTEGER            LWORK_ZGEBRD_MN, LWORK_ZGEBRD_MM,
8391     $                   LWORK_ZGEBRD_NN, LWORK_ZGELQF_MN,
8392     $                   LWORK_ZGEQRF_MN,
8393     $                   LWORK_ZUNGBR_P_MN, LWORK_ZUNGBR_P_NN,
8394     $                   LWORK_ZUNGBR_Q_MN, LWORK_ZUNGBR_Q_MM,
8395     $                   LWORK_ZUNGLQ_MN, LWORK_ZUNGLQ_NN,
8396     $                   LWORK_ZUNGQR_MM, LWORK_ZUNGQR_MN,
8397     $                   LWORK_ZUNMBR_PRC_MM, LWORK_ZUNMBR_QLN_MM,
8398     $                   LWORK_ZUNMBR_PRC_MN, LWORK_ZUNMBR_QLN_MN,
8399     $                   LWORK_ZUNMBR_PRC_NN, LWORK_ZUNMBR_QLN_NN
8400      DOUBLE PRECISION   ANRM, BIGNUM, EPS, SMLNUM
8401*     ..
8402*     .. Local Arrays ..
8403      INTEGER            IDUM( 1 )
8404      DOUBLE PRECISION   DUM( 1 )
8405      COMPLEX*16         CDUM( 1 )
8406*     ..
8407*     .. External Subroutines ..
8408      EXTERNAL           DBDSDC, DLASCL, XERBLA, ZGEBRD, ZGELQF, ZGEMM,
8409     $                   ZGEQRF, ZLACP2, ZLACPY, ZLACRM, ZLARCM, ZLASCL,
8410     $                   ZLASET, ZUNGBR, ZUNGLQ, ZUNGQR, ZUNMBR
8411*     ..
8412*     .. External Functions ..
8413      LOGICAL            LSAME
8414      DOUBLE PRECISION   DLAMCH, ZLANGE
8415      EXTERNAL           LSAME, DLAMCH, ZLANGE
8416*     ..
8417*     .. Intrinsic Functions ..
8418      INTRINSIC          INT, MAX, MIN, SQRT
8419*     ..
8420*     .. Executable Statements ..
8421*
8422*     Test the input arguments
8423*
8424      INFO   = 0
8425      MINMN  = MIN( M, N )
8426      MNTHR1 = INT( MINMN*17.0D0 / 9.0D0 )
8427      MNTHR2 = INT( MINMN*5.0D0 / 3.0D0 )
8428      WNTQA  = LSAME( JOBZ, 'A' )
8429      WNTQS  = LSAME( JOBZ, 'S' )
8430      WNTQAS = WNTQA .OR. WNTQS
8431      WNTQO  = LSAME( JOBZ, 'O' )
8432      WNTQN  = LSAME( JOBZ, 'N' )
8433      LQUERY = ( LWORK.EQ.-1 )
8434      MINWRK = 1
8435      MAXWRK = 1
8436*
8437      IF( .NOT.( WNTQA .OR. WNTQS .OR. WNTQO .OR. WNTQN ) ) THEN
8438         INFO = -1
8439      ELSE IF( M.LT.0 ) THEN
8440         INFO = -2
8441      ELSE IF( N.LT.0 ) THEN
8442         INFO = -3
8443      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
8444         INFO = -5
8445      ELSE IF( LDU.LT.1 .OR. ( WNTQAS .AND. LDU.LT.M ) .OR.
8446     $         ( WNTQO .AND. M.LT.N .AND. LDU.LT.M ) ) THEN
8447         INFO = -8
8448      ELSE IF( LDVT.LT.1 .OR. ( WNTQA .AND. LDVT.LT.N ) .OR.
8449     $         ( WNTQS .AND. LDVT.LT.MINMN ) .OR.
8450     $         ( WNTQO .AND. M.GE.N .AND. LDVT.LT.N ) ) THEN
8451         INFO = -10
8452      END IF
8453*
8454*     Compute workspace
8455*       Note: Comments in the code beginning "Workspace:" describe the
8456*       minimal amount of workspace allocated at that point in the code,
8457*       as well as the preferred amount for good performance.
8458*       CWorkspace refers to complex workspace, and RWorkspace to
8459*       real workspace. NB refers to the optimal block size for the
8460*       immediately following subroutine, as returned by ILAENV.)
8461*
8462      IF( INFO.EQ.0 ) THEN
8463         MINWRK = 1
8464         MAXWRK = 1
8465         IF( M.GE.N .AND. MINMN.GT.0 ) THEN
8466*
8467*           There is no complex work space needed for bidiagonal SVD
8468*           The real work space needed for bidiagonal SVD (dbdsdc) is
8469*           BDSPAC = 3*N*N + 4*N for singular values and vectors;
8470*           BDSPAC = 4*N         for singular values only;
8471*           not including e, RU, and RVT matrices.
8472*
8473*           Compute space preferred for each routine
8474            CALL ZGEBRD( M, N, CDUM(1), M, DUM(1), DUM(1), CDUM(1),
8475     $                   CDUM(1), CDUM(1), -1, IERR )
8476            LWORK_ZGEBRD_MN = INT( CDUM(1) )
8477*
8478            CALL ZGEBRD( N, N, CDUM(1), N, DUM(1), DUM(1), CDUM(1),
8479     $                   CDUM(1), CDUM(1), -1, IERR )
8480            LWORK_ZGEBRD_NN = INT( CDUM(1) )
8481*
8482            CALL ZGEQRF( M, N, CDUM(1), M, CDUM(1), CDUM(1), -1, IERR )
8483            LWORK_ZGEQRF_MN = INT( CDUM(1) )
8484*
8485            CALL ZUNGBR( 'P', N, N, N, CDUM(1), N, CDUM(1), CDUM(1),
8486     $                   -1, IERR )
8487            LWORK_ZUNGBR_P_NN = INT( CDUM(1) )
8488*
8489            CALL ZUNGBR( 'Q', M, M, N, CDUM(1), M, CDUM(1), CDUM(1),
8490     $                   -1, IERR )
8491            LWORK_ZUNGBR_Q_MM = INT( CDUM(1) )
8492*
8493            CALL ZUNGBR( 'Q', M, N, N, CDUM(1), M, CDUM(1), CDUM(1),
8494     $                   -1, IERR )
8495            LWORK_ZUNGBR_Q_MN = INT( CDUM(1) )
8496*
8497            CALL ZUNGQR( M, M, N, CDUM(1), M, CDUM(1), CDUM(1),
8498     $                   -1, IERR )
8499            LWORK_ZUNGQR_MM = INT( CDUM(1) )
8500*
8501            CALL ZUNGQR( M, N, N, CDUM(1), M, CDUM(1), CDUM(1),
8502     $                   -1, IERR )
8503            LWORK_ZUNGQR_MN = INT( CDUM(1) )
8504*
8505            CALL ZUNMBR( 'P', 'R', 'C', N, N, N, CDUM(1), N, CDUM(1),
8506     $                   CDUM(1), N, CDUM(1), -1, IERR )
8507            LWORK_ZUNMBR_PRC_NN = INT( CDUM(1) )
8508*
8509            CALL ZUNMBR( 'Q', 'L', 'N', M, M, N, CDUM(1), M, CDUM(1),
8510     $                   CDUM(1), M, CDUM(1), -1, IERR )
8511            LWORK_ZUNMBR_QLN_MM = INT( CDUM(1) )
8512*
8513            CALL ZUNMBR( 'Q', 'L', 'N', M, N, N, CDUM(1), M, CDUM(1),
8514     $                   CDUM(1), M, CDUM(1), -1, IERR )
8515            LWORK_ZUNMBR_QLN_MN = INT( CDUM(1) )
8516*
8517            CALL ZUNMBR( 'Q', 'L', 'N', N, N, N, CDUM(1), N, CDUM(1),
8518     $                   CDUM(1), N, CDUM(1), -1, IERR )
8519            LWORK_ZUNMBR_QLN_NN = INT( CDUM(1) )
8520*
8521            IF( M.GE.MNTHR1 ) THEN
8522               IF( WNTQN ) THEN
8523*
8524*                 Path 1 (M >> N, JOBZ='N')
8525*
8526                  MAXWRK = N + LWORK_ZGEQRF_MN
8527                  MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZGEBRD_NN )
8528                  MINWRK = 3*N
8529               ELSE IF( WNTQO ) THEN
8530*
8531*                 Path 2 (M >> N, JOBZ='O')
8532*
8533                  WRKBL = N + LWORK_ZGEQRF_MN
8534                  WRKBL = MAX( WRKBL,   N + LWORK_ZUNGQR_MN )
8535                  WRKBL = MAX( WRKBL, 2*N + LWORK_ZGEBRD_NN )
8536                  WRKBL = MAX( WRKBL, 2*N + LWORK_ZUNMBR_QLN_NN )
8537                  WRKBL = MAX( WRKBL, 2*N + LWORK_ZUNMBR_PRC_NN )
8538                  MAXWRK = M*N + N*N + WRKBL
8539                  MINWRK = 2*N*N + 3*N
8540               ELSE IF( WNTQS ) THEN
8541*
8542*                 Path 3 (M >> N, JOBZ='S')
8543*
8544                  WRKBL = N + LWORK_ZGEQRF_MN
8545                  WRKBL = MAX( WRKBL,   N + LWORK_ZUNGQR_MN )
8546                  WRKBL = MAX( WRKBL, 2*N + LWORK_ZGEBRD_NN )
8547                  WRKBL = MAX( WRKBL, 2*N + LWORK_ZUNMBR_QLN_NN )
8548                  WRKBL = MAX( WRKBL, 2*N + LWORK_ZUNMBR_PRC_NN )
8549                  MAXWRK = N*N + WRKBL
8550                  MINWRK = N*N + 3*N
8551               ELSE IF( WNTQA ) THEN
8552*
8553*                 Path 4 (M >> N, JOBZ='A')
8554*
8555                  WRKBL = N + LWORK_ZGEQRF_MN
8556                  WRKBL = MAX( WRKBL,   N + LWORK_ZUNGQR_MM )
8557                  WRKBL = MAX( WRKBL, 2*N + LWORK_ZGEBRD_NN )
8558                  WRKBL = MAX( WRKBL, 2*N + LWORK_ZUNMBR_QLN_NN )
8559                  WRKBL = MAX( WRKBL, 2*N + LWORK_ZUNMBR_PRC_NN )
8560                  MAXWRK = N*N + WRKBL
8561                  MINWRK = N*N + MAX( 3*N, N + M )
8562               END IF
8563            ELSE IF( M.GE.MNTHR2 ) THEN
8564*
8565*              Path 5 (M >> N, but not as much as MNTHR1)
8566*
8567               MAXWRK = 2*N + LWORK_ZGEBRD_MN
8568               MINWRK = 2*N + M
8569               IF( WNTQO ) THEN
8570*                 Path 5o (M >> N, JOBZ='O')
8571                  MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZUNGBR_P_NN )
8572                  MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZUNGBR_Q_MN )
8573                  MAXWRK = MAXWRK + M*N
8574                  MINWRK = MINWRK + N*N
8575               ELSE IF( WNTQS ) THEN
8576*                 Path 5s (M >> N, JOBZ='S')
8577                  MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZUNGBR_P_NN )
8578                  MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZUNGBR_Q_MN )
8579               ELSE IF( WNTQA ) THEN
8580*                 Path 5a (M >> N, JOBZ='A')
8581                  MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZUNGBR_P_NN )
8582                  MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZUNGBR_Q_MM )
8583               END IF
8584            ELSE
8585*
8586*              Path 6 (M >= N, but not much larger)
8587*
8588               MAXWRK = 2*N + LWORK_ZGEBRD_MN
8589               MINWRK = 2*N + M
8590               IF( WNTQO ) THEN
8591*                 Path 6o (M >= N, JOBZ='O')
8592                  MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZUNMBR_PRC_NN )
8593                  MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZUNMBR_QLN_MN )
8594                  MAXWRK = MAXWRK + M*N
8595                  MINWRK = MINWRK + N*N
8596               ELSE IF( WNTQS ) THEN
8597*                 Path 6s (M >= N, JOBZ='S')
8598                  MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZUNMBR_QLN_MN )
8599                  MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZUNMBR_PRC_NN )
8600               ELSE IF( WNTQA ) THEN
8601*                 Path 6a (M >= N, JOBZ='A')
8602                  MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZUNMBR_QLN_MM )
8603                  MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZUNMBR_PRC_NN )
8604               END IF
8605            END IF
8606         ELSE IF( MINMN.GT.0 ) THEN
8607*
8608*           There is no complex work space needed for bidiagonal SVD
8609*           The real work space needed for bidiagonal SVD (dbdsdc) is
8610*           BDSPAC = 3*M*M + 4*M for singular values and vectors;
8611*           BDSPAC = 4*M         for singular values only;
8612*           not including e, RU, and RVT matrices.
8613*
8614*           Compute space preferred for each routine
8615            CALL ZGEBRD( M, N, CDUM(1), M, DUM(1), DUM(1), CDUM(1),
8616     $                   CDUM(1), CDUM(1), -1, IERR )
8617            LWORK_ZGEBRD_MN = INT( CDUM(1) )
8618*
8619            CALL ZGEBRD( M, M, CDUM(1), M, DUM(1), DUM(1), CDUM(1),
8620     $                   CDUM(1), CDUM(1), -1, IERR )
8621            LWORK_ZGEBRD_MM = INT( CDUM(1) )
8622*
8623            CALL ZGELQF( M, N, CDUM(1), M, CDUM(1), CDUM(1), -1, IERR )
8624            LWORK_ZGELQF_MN = INT( CDUM(1) )
8625*
8626            CALL ZUNGBR( 'P', M, N, M, CDUM(1), M, CDUM(1), CDUM(1),
8627     $                   -1, IERR )
8628            LWORK_ZUNGBR_P_MN = INT( CDUM(1) )
8629*
8630            CALL ZUNGBR( 'P', N, N, M, CDUM(1), N, CDUM(1), CDUM(1),
8631     $                   -1, IERR )
8632            LWORK_ZUNGBR_P_NN = INT( CDUM(1) )
8633*
8634            CALL ZUNGBR( 'Q', M, M, N, CDUM(1), M, CDUM(1), CDUM(1),
8635     $                   -1, IERR )
8636            LWORK_ZUNGBR_Q_MM = INT( CDUM(1) )
8637*
8638            CALL ZUNGLQ( M, N, M, CDUM(1), M, CDUM(1), CDUM(1),
8639     $                   -1, IERR )
8640            LWORK_ZUNGLQ_MN = INT( CDUM(1) )
8641*
8642            CALL ZUNGLQ( N, N, M, CDUM(1), N, CDUM(1), CDUM(1),
8643     $                   -1, IERR )
8644            LWORK_ZUNGLQ_NN = INT( CDUM(1) )
8645*
8646            CALL ZUNMBR( 'P', 'R', 'C', M, M, M, CDUM(1), M, CDUM(1),
8647     $                   CDUM(1), M, CDUM(1), -1, IERR )
8648            LWORK_ZUNMBR_PRC_MM = INT( CDUM(1) )
8649*
8650            CALL ZUNMBR( 'P', 'R', 'C', M, N, M, CDUM(1), M, CDUM(1),
8651     $                   CDUM(1), M, CDUM(1), -1, IERR )
8652            LWORK_ZUNMBR_PRC_MN = INT( CDUM(1) )
8653*
8654            CALL ZUNMBR( 'P', 'R', 'C', N, N, M, CDUM(1), N, CDUM(1),
8655     $                   CDUM(1), N, CDUM(1), -1, IERR )
8656            LWORK_ZUNMBR_PRC_NN = INT( CDUM(1) )
8657*
8658            CALL ZUNMBR( 'Q', 'L', 'N', M, M, M, CDUM(1), M, CDUM(1),
8659     $                   CDUM(1), M, CDUM(1), -1, IERR )
8660            LWORK_ZUNMBR_QLN_MM = INT( CDUM(1) )
8661*
8662            IF( N.GE.MNTHR1 ) THEN
8663               IF( WNTQN ) THEN
8664*
8665*                 Path 1t (N >> M, JOBZ='N')
8666*
8667                  MAXWRK = M + LWORK_ZGELQF_MN
8668                  MAXWRK = MAX( MAXWRK, 2*M + LWORK_ZGEBRD_MM )
8669                  MINWRK = 3*M
8670               ELSE IF( WNTQO ) THEN
8671*
8672*                 Path 2t (N >> M, JOBZ='O')
8673*
8674                  WRKBL = M + LWORK_ZGELQF_MN
8675                  WRKBL = MAX( WRKBL,   M + LWORK_ZUNGLQ_MN )
8676                  WRKBL = MAX( WRKBL, 2*M + LWORK_ZGEBRD_MM )
8677                  WRKBL = MAX( WRKBL, 2*M + LWORK_ZUNMBR_QLN_MM )
8678                  WRKBL = MAX( WRKBL, 2*M + LWORK_ZUNMBR_PRC_MM )
8679                  MAXWRK = M*N + M*M + WRKBL
8680                  MINWRK = 2*M*M + 3*M
8681               ELSE IF( WNTQS ) THEN
8682*
8683*                 Path 3t (N >> M, JOBZ='S')
8684*
8685                  WRKBL = M + LWORK_ZGELQF_MN
8686                  WRKBL = MAX( WRKBL,   M + LWORK_ZUNGLQ_MN )
8687                  WRKBL = MAX( WRKBL, 2*M + LWORK_ZGEBRD_MM )
8688                  WRKBL = MAX( WRKBL, 2*M + LWORK_ZUNMBR_QLN_MM )
8689                  WRKBL = MAX( WRKBL, 2*M + LWORK_ZUNMBR_PRC_MM )
8690                  MAXWRK = M*M + WRKBL
8691                  MINWRK = M*M + 3*M
8692               ELSE IF( WNTQA ) THEN
8693*
8694*                 Path 4t (N >> M, JOBZ='A')
8695*
8696                  WRKBL = M + LWORK_ZGELQF_MN
8697                  WRKBL = MAX( WRKBL,   M + LWORK_ZUNGLQ_NN )
8698                  WRKBL = MAX( WRKBL, 2*M + LWORK_ZGEBRD_MM )
8699                  WRKBL = MAX( WRKBL, 2*M + LWORK_ZUNMBR_QLN_MM )
8700                  WRKBL = MAX( WRKBL, 2*M + LWORK_ZUNMBR_PRC_MM )
8701                  MAXWRK = M*M + WRKBL
8702                  MINWRK = M*M + MAX( 3*M, M + N )
8703               END IF
8704            ELSE IF( N.GE.MNTHR2 ) THEN
8705*
8706*              Path 5t (N >> M, but not as much as MNTHR1)
8707*
8708               MAXWRK = 2*M + LWORK_ZGEBRD_MN
8709               MINWRK = 2*M + N
8710               IF( WNTQO ) THEN
8711*                 Path 5to (N >> M, JOBZ='O')
8712                  MAXWRK = MAX( MAXWRK, 2*M + LWORK_ZUNGBR_Q_MM )
8713                  MAXWRK = MAX( MAXWRK, 2*M + LWORK_ZUNGBR_P_MN )
8714                  MAXWRK = MAXWRK + M*N
8715                  MINWRK = MINWRK + M*M
8716               ELSE IF( WNTQS ) THEN
8717*                 Path 5ts (N >> M, JOBZ='S')
8718                  MAXWRK = MAX( MAXWRK, 2*M + LWORK_ZUNGBR_Q_MM )
8719                  MAXWRK = MAX( MAXWRK, 2*M + LWORK_ZUNGBR_P_MN )
8720               ELSE IF( WNTQA ) THEN
8721*                 Path 5ta (N >> M, JOBZ='A')
8722                  MAXWRK = MAX( MAXWRK, 2*M + LWORK_ZUNGBR_Q_MM )
8723                  MAXWRK = MAX( MAXWRK, 2*M + LWORK_ZUNGBR_P_NN )
8724               END IF
8725            ELSE
8726*
8727*              Path 6t (N > M, but not much larger)
8728*
8729               MAXWRK = 2*M + LWORK_ZGEBRD_MN
8730               MINWRK = 2*M + N
8731               IF( WNTQO ) THEN
8732*                 Path 6to (N > M, JOBZ='O')
8733                  MAXWRK = MAX( MAXWRK, 2*M + LWORK_ZUNMBR_QLN_MM )
8734                  MAXWRK = MAX( MAXWRK, 2*M + LWORK_ZUNMBR_PRC_MN )
8735                  MAXWRK = MAXWRK + M*N
8736                  MINWRK = MINWRK + M*M
8737               ELSE IF( WNTQS ) THEN
8738*                 Path 6ts (N > M, JOBZ='S')
8739                  MAXWRK = MAX( MAXWRK, 2*M + LWORK_ZUNMBR_QLN_MM )
8740                  MAXWRK = MAX( MAXWRK, 2*M + LWORK_ZUNMBR_PRC_MN )
8741               ELSE IF( WNTQA ) THEN
8742*                 Path 6ta (N > M, JOBZ='A')
8743                  MAXWRK = MAX( MAXWRK, 2*M + LWORK_ZUNMBR_QLN_MM )
8744                  MAXWRK = MAX( MAXWRK, 2*M + LWORK_ZUNMBR_PRC_NN )
8745               END IF
8746            END IF
8747         END IF
8748         MAXWRK = MAX( MAXWRK, MINWRK )
8749      END IF
8750      IF( INFO.EQ.0 ) THEN
8751         WORK( 1 ) = MAXWRK
8752         IF( LWORK.LT.MINWRK .AND. .NOT. LQUERY ) THEN
8753            INFO = -12
8754         END IF
8755      END IF
8756*
8757      IF( INFO.NE.0 ) THEN
8758         CALL XERBLA( 'ZGESDD', -INFO )
8759         RETURN
8760      ELSE IF( LQUERY ) THEN
8761         RETURN
8762      END IF
8763*
8764*     Quick return if possible
8765*
8766      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
8767         RETURN
8768      END IF
8769*
8770*     Get machine constants
8771*
8772      EPS = DLAMCH( 'P' )
8773      SMLNUM = SQRT( DLAMCH( 'S' ) ) / EPS
8774      BIGNUM = ONE / SMLNUM
8775*
8776*     Scale A if max element outside range [SMLNUM,BIGNUM]
8777*
8778      ANRM = ZLANGE( 'M', M, N, A, LDA, DUM )
8779      ISCL = 0
8780      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
8781         ISCL = 1
8782         CALL ZLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, IERR )
8783      ELSE IF( ANRM.GT.BIGNUM ) THEN
8784         ISCL = 1
8785         CALL ZLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, IERR )
8786      END IF
8787*
8788      IF( M.GE.N ) THEN
8789*
8790*        A has at least as many rows as columns. If A has sufficiently
8791*        more rows than columns, first reduce using the QR
8792*        decomposition (if sufficient workspace available)
8793*
8794         IF( M.GE.MNTHR1 ) THEN
8795*
8796            IF( WNTQN ) THEN
8797*
8798*              Path 1 (M >> N, JOBZ='N')
8799*              No singular vectors to be computed
8800*
8801               ITAU = 1
8802               NWORK = ITAU + N
8803*
8804*              Compute A=Q*R
8805*              CWorkspace: need   N [tau] + N    [work]
8806*              CWorkspace: prefer N [tau] + N*NB [work]
8807*              RWorkspace: need   0
8808*
8809               CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
8810     $                      LWORK-NWORK+1, IERR )
8811*
8812*              Zero out below R
8813*
8814               CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, A( 2, 1 ),
8815     $                      LDA )
8816               IE = 1
8817               ITAUQ = 1
8818               ITAUP = ITAUQ + N
8819               NWORK = ITAUP + N
8820*
8821*              Bidiagonalize R in A
8822*              CWorkspace: need   2*N [tauq, taup] + N      [work]
8823*              CWorkspace: prefer 2*N [tauq, taup] + 2*N*NB [work]
8824*              RWorkspace: need   N [e]
8825*
8826               CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
8827     $                      WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
8828     $                      IERR )
8829               NRWORK = IE + N
8830*
8831*              Perform bidiagonal SVD, compute singular values only
8832*              CWorkspace: need   0
8833*              RWorkspace: need   N [e] + BDSPAC
8834*
8835               CALL DBDSDC( 'U', 'N', N, S, RWORK( IE ), DUM,1,DUM,1,
8836     $                      DUM, IDUM, RWORK( NRWORK ), IWORK, INFO )
8837*
8838            ELSE IF( WNTQO ) THEN
8839*
8840*              Path 2 (M >> N, JOBZ='O')
8841*              N left singular vectors to be overwritten on A and
8842*              N right singular vectors to be computed in VT
8843*
8844               IU = 1
8845*
8846*              WORK(IU) is N by N
8847*
8848               LDWRKU = N
8849               IR = IU + LDWRKU*N
8850               IF( LWORK .GE. M*N + N*N + 3*N ) THEN
8851*
8852*                 WORK(IR) is M by N
8853*
8854                  LDWRKR = M
8855               ELSE
8856                  LDWRKR = ( LWORK - N*N - 3*N ) / N
8857               END IF
8858               ITAU = IR + LDWRKR*N
8859               NWORK = ITAU + N
8860*
8861*              Compute A=Q*R
8862*              CWorkspace: need   N*N [U] + N*N [R] + N [tau] + N    [work]
8863*              CWorkspace: prefer N*N [U] + N*N [R] + N [tau] + N*NB [work]
8864*              RWorkspace: need   0
8865*
8866               CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
8867     $                      LWORK-NWORK+1, IERR )
8868*
8869*              Copy R to WORK( IR ), zeroing out below it
8870*
8871               CALL ZLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR )
8872               CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, WORK( IR+1 ),
8873     $                      LDWRKR )
8874*
8875*              Generate Q in A
8876*              CWorkspace: need   N*N [U] + N*N [R] + N [tau] + N    [work]
8877*              CWorkspace: prefer N*N [U] + N*N [R] + N [tau] + N*NB [work]
8878*              RWorkspace: need   0
8879*
8880               CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ),
8881     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
8882               IE = 1
8883               ITAUQ = ITAU
8884               ITAUP = ITAUQ + N
8885               NWORK = ITAUP + N
8886*
8887*              Bidiagonalize R in WORK(IR)
8888*              CWorkspace: need   N*N [U] + N*N [R] + 2*N [tauq, taup] + N      [work]
8889*              CWorkspace: prefer N*N [U] + N*N [R] + 2*N [tauq, taup] + 2*N*NB [work]
8890*              RWorkspace: need   N [e]
8891*
8892               CALL ZGEBRD( N, N, WORK( IR ), LDWRKR, S, RWORK( IE ),
8893     $                      WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
8894     $                      LWORK-NWORK+1, IERR )
8895*
8896*              Perform bidiagonal SVD, computing left singular vectors
8897*              of R in WORK(IRU) and computing right singular vectors
8898*              of R in WORK(IRVT)
8899*              CWorkspace: need   0
8900*              RWorkspace: need   N [e] + N*N [RU] + N*N [RVT] + BDSPAC
8901*
8902               IRU = IE + N
8903               IRVT = IRU + N*N
8904               NRWORK = IRVT + N*N
8905               CALL DBDSDC( 'U', 'I', N, S, RWORK( IE ), RWORK( IRU ),
8906     $                      N, RWORK( IRVT ), N, DUM, IDUM,
8907     $                      RWORK( NRWORK ), IWORK, INFO )
8908*
8909*              Copy real matrix RWORK(IRU) to complex matrix WORK(IU)
8910*              Overwrite WORK(IU) by the left singular vectors of R
8911*              CWorkspace: need   N*N [U] + N*N [R] + 2*N [tauq, taup] + N    [work]
8912*              CWorkspace: prefer N*N [U] + N*N [R] + 2*N [tauq, taup] + N*NB [work]
8913*              RWorkspace: need   0
8914*
8915               CALL ZLACP2( 'F', N, N, RWORK( IRU ), N, WORK( IU ),
8916     $                      LDWRKU )
8917               CALL ZUNMBR( 'Q', 'L', 'N', N, N, N, WORK( IR ), LDWRKR,
8918     $                      WORK( ITAUQ ), WORK( IU ), LDWRKU,
8919     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
8920*
8921*              Copy real matrix RWORK(IRVT) to complex matrix VT
8922*              Overwrite VT by the right singular vectors of R
8923*              CWorkspace: need   N*N [U] + N*N [R] + 2*N [tauq, taup] + N    [work]
8924*              CWorkspace: prefer N*N [U] + N*N [R] + 2*N [tauq, taup] + N*NB [work]
8925*              RWorkspace: need   0
8926*
8927               CALL ZLACP2( 'F', N, N, RWORK( IRVT ), N, VT, LDVT )
8928               CALL ZUNMBR( 'P', 'R', 'C', N, N, N, WORK( IR ), LDWRKR,
8929     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
8930     $                      LWORK-NWORK+1, IERR )
8931*
8932*              Multiply Q in A by left singular vectors of R in
8933*              WORK(IU), storing result in WORK(IR) and copying to A
8934*              CWorkspace: need   N*N [U] + N*N [R]
8935*              CWorkspace: prefer N*N [U] + M*N [R]
8936*              RWorkspace: need   0
8937*
8938               DO 10 I = 1, M, LDWRKR
8939                  CHUNK = MIN( M-I+1, LDWRKR )
8940                  CALL ZGEMM( 'N', 'N', CHUNK, N, N, CONE, A( I, 1 ),
8941     $                        LDA, WORK( IU ), LDWRKU, CZERO,
8942     $                        WORK( IR ), LDWRKR )
8943                  CALL ZLACPY( 'F', CHUNK, N, WORK( IR ), LDWRKR,
8944     $                         A( I, 1 ), LDA )
8945   10          CONTINUE
8946*
8947            ELSE IF( WNTQS ) THEN
8948*
8949*              Path 3 (M >> N, JOBZ='S')
8950*              N left singular vectors to be computed in U and
8951*              N right singular vectors to be computed in VT
8952*
8953               IR = 1
8954*
8955*              WORK(IR) is N by N
8956*
8957               LDWRKR = N
8958               ITAU = IR + LDWRKR*N
8959               NWORK = ITAU + N
8960*
8961*              Compute A=Q*R
8962*              CWorkspace: need   N*N [R] + N [tau] + N    [work]
8963*              CWorkspace: prefer N*N [R] + N [tau] + N*NB [work]
8964*              RWorkspace: need   0
8965*
8966               CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
8967     $                      LWORK-NWORK+1, IERR )
8968*
8969*              Copy R to WORK(IR), zeroing out below it
8970*
8971               CALL ZLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR )
8972               CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, WORK( IR+1 ),
8973     $                      LDWRKR )
8974*
8975*              Generate Q in A
8976*              CWorkspace: need   N*N [R] + N [tau] + N    [work]
8977*              CWorkspace: prefer N*N [R] + N [tau] + N*NB [work]
8978*              RWorkspace: need   0
8979*
8980               CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ),
8981     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
8982               IE = 1
8983               ITAUQ = ITAU
8984               ITAUP = ITAUQ + N
8985               NWORK = ITAUP + N
8986*
8987*              Bidiagonalize R in WORK(IR)
8988*              CWorkspace: need   N*N [R] + 2*N [tauq, taup] + N      [work]
8989*              CWorkspace: prefer N*N [R] + 2*N [tauq, taup] + 2*N*NB [work]
8990*              RWorkspace: need   N [e]
8991*
8992               CALL ZGEBRD( N, N, WORK( IR ), LDWRKR, S, RWORK( IE ),
8993     $                      WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
8994     $                      LWORK-NWORK+1, IERR )
8995*
8996*              Perform bidiagonal SVD, computing left singular vectors
8997*              of bidiagonal matrix in RWORK(IRU) and computing right
8998*              singular vectors of bidiagonal matrix in RWORK(IRVT)
8999*              CWorkspace: need   0
9000*              RWorkspace: need   N [e] + N*N [RU] + N*N [RVT] + BDSPAC
9001*
9002               IRU = IE + N
9003               IRVT = IRU + N*N
9004               NRWORK = IRVT + N*N
9005               CALL DBDSDC( 'U', 'I', N, S, RWORK( IE ), RWORK( IRU ),
9006     $                      N, RWORK( IRVT ), N, DUM, IDUM,
9007     $                      RWORK( NRWORK ), IWORK, INFO )
9008*
9009*              Copy real matrix RWORK(IRU) to complex matrix U
9010*              Overwrite U by left singular vectors of R
9011*              CWorkspace: need   N*N [R] + 2*N [tauq, taup] + N    [work]
9012*              CWorkspace: prefer N*N [R] + 2*N [tauq, taup] + N*NB [work]
9013*              RWorkspace: need   0
9014*
9015               CALL ZLACP2( 'F', N, N, RWORK( IRU ), N, U, LDU )
9016               CALL ZUNMBR( 'Q', 'L', 'N', N, N, N, WORK( IR ), LDWRKR,
9017     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
9018     $                      LWORK-NWORK+1, IERR )
9019*
9020*              Copy real matrix RWORK(IRVT) to complex matrix VT
9021*              Overwrite VT by right singular vectors of R
9022*              CWorkspace: need   N*N [R] + 2*N [tauq, taup] + N    [work]
9023*              CWorkspace: prefer N*N [R] + 2*N [tauq, taup] + N*NB [work]
9024*              RWorkspace: need   0
9025*
9026               CALL ZLACP2( 'F', N, N, RWORK( IRVT ), N, VT, LDVT )
9027               CALL ZUNMBR( 'P', 'R', 'C', N, N, N, WORK( IR ), LDWRKR,
9028     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
9029     $                      LWORK-NWORK+1, IERR )
9030*
9031*              Multiply Q in A by left singular vectors of R in
9032*              WORK(IR), storing result in U
9033*              CWorkspace: need   N*N [R]
9034*              RWorkspace: need   0
9035*
9036               CALL ZLACPY( 'F', N, N, U, LDU, WORK( IR ), LDWRKR )
9037               CALL ZGEMM( 'N', 'N', M, N, N, CONE, A, LDA, WORK( IR ),
9038     $                     LDWRKR, CZERO, U, LDU )
9039*
9040            ELSE IF( WNTQA ) THEN
9041*
9042*              Path 4 (M >> N, JOBZ='A')
9043*              M left singular vectors to be computed in U and
9044*              N right singular vectors to be computed in VT
9045*
9046               IU = 1
9047*
9048*              WORK(IU) is N by N
9049*
9050               LDWRKU = N
9051               ITAU = IU + LDWRKU*N
9052               NWORK = ITAU + N
9053*
9054*              Compute A=Q*R, copying result to U
9055*              CWorkspace: need   N*N [U] + N [tau] + N    [work]
9056*              CWorkspace: prefer N*N [U] + N [tau] + N*NB [work]
9057*              RWorkspace: need   0
9058*
9059               CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
9060     $                      LWORK-NWORK+1, IERR )
9061               CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
9062*
9063*              Generate Q in U
9064*              CWorkspace: need   N*N [U] + N [tau] + M    [work]
9065*              CWorkspace: prefer N*N [U] + N [tau] + M*NB [work]
9066*              RWorkspace: need   0
9067*
9068               CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ),
9069     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
9070*
9071*              Produce R in A, zeroing out below it
9072*
9073               CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, A( 2, 1 ),
9074     $                      LDA )
9075               IE = 1
9076               ITAUQ = ITAU
9077               ITAUP = ITAUQ + N
9078               NWORK = ITAUP + N
9079*
9080*              Bidiagonalize R in A
9081*              CWorkspace: need   N*N [U] + 2*N [tauq, taup] + N      [work]
9082*              CWorkspace: prefer N*N [U] + 2*N [tauq, taup] + 2*N*NB [work]
9083*              RWorkspace: need   N [e]
9084*
9085               CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
9086     $                      WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
9087     $                      IERR )
9088               IRU = IE + N
9089               IRVT = IRU + N*N
9090               NRWORK = IRVT + N*N
9091*
9092*              Perform bidiagonal SVD, computing left singular vectors
9093*              of bidiagonal matrix in RWORK(IRU) and computing right
9094*              singular vectors of bidiagonal matrix in RWORK(IRVT)
9095*              CWorkspace: need   0
9096*              RWorkspace: need   N [e] + N*N [RU] + N*N [RVT] + BDSPAC
9097*
9098               CALL DBDSDC( 'U', 'I', N, S, RWORK( IE ), RWORK( IRU ),
9099     $                      N, RWORK( IRVT ), N, DUM, IDUM,
9100     $                      RWORK( NRWORK ), IWORK, INFO )
9101*
9102*              Copy real matrix RWORK(IRU) to complex matrix WORK(IU)
9103*              Overwrite WORK(IU) by left singular vectors of R
9104*              CWorkspace: need   N*N [U] + 2*N [tauq, taup] + N    [work]
9105*              CWorkspace: prefer N*N [U] + 2*N [tauq, taup] + N*NB [work]
9106*              RWorkspace: need   0
9107*
9108               CALL ZLACP2( 'F', N, N, RWORK( IRU ), N, WORK( IU ),
9109     $                      LDWRKU )
9110               CALL ZUNMBR( 'Q', 'L', 'N', N, N, N, A, LDA,
9111     $                      WORK( ITAUQ ), WORK( IU ), LDWRKU,
9112     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
9113*
9114*              Copy real matrix RWORK(IRVT) to complex matrix VT
9115*              Overwrite VT by right singular vectors of R
9116*              CWorkspace: need   N*N [U] + 2*N [tauq, taup] + N    [work]
9117*              CWorkspace: prefer N*N [U] + 2*N [tauq, taup] + N*NB [work]
9118*              RWorkspace: need   0
9119*
9120               CALL ZLACP2( 'F', N, N, RWORK( IRVT ), N, VT, LDVT )
9121               CALL ZUNMBR( 'P', 'R', 'C', N, N, N, A, LDA,
9122     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
9123     $                      LWORK-NWORK+1, IERR )
9124*
9125*              Multiply Q in U by left singular vectors of R in
9126*              WORK(IU), storing result in A
9127*              CWorkspace: need   N*N [U]
9128*              RWorkspace: need   0
9129*
9130               CALL ZGEMM( 'N', 'N', M, N, N, CONE, U, LDU, WORK( IU ),
9131     $                     LDWRKU, CZERO, A, LDA )
9132*
9133*              Copy left singular vectors of A from A to U
9134*
9135               CALL ZLACPY( 'F', M, N, A, LDA, U, LDU )
9136*
9137            END IF
9138*
9139         ELSE IF( M.GE.MNTHR2 ) THEN
9140*
9141*           MNTHR2 <= M < MNTHR1
9142*
9143*           Path 5 (M >> N, but not as much as MNTHR1)
9144*           Reduce to bidiagonal form without QR decomposition, use
9145*           ZUNGBR and matrix multiplication to compute singular vectors
9146*
9147            IE = 1
9148            NRWORK = IE + N
9149            ITAUQ = 1
9150            ITAUP = ITAUQ + N
9151            NWORK = ITAUP + N
9152*
9153*           Bidiagonalize A
9154*           CWorkspace: need   2*N [tauq, taup] + M        [work]
9155*           CWorkspace: prefer 2*N [tauq, taup] + (M+N)*NB [work]
9156*           RWorkspace: need   N [e]
9157*
9158            CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
9159     $                   WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
9160     $                   IERR )
9161            IF( WNTQN ) THEN
9162*
9163*              Path 5n (M >> N, JOBZ='N')
9164*              Compute singular values only
9165*              CWorkspace: need   0
9166*              RWorkspace: need   N [e] + BDSPAC
9167*
9168               CALL DBDSDC( 'U', 'N', N, S, RWORK( IE ), DUM, 1,DUM,1,
9169     $                      DUM, IDUM, RWORK( NRWORK ), IWORK, INFO )
9170            ELSE IF( WNTQO ) THEN
9171               IU = NWORK
9172               IRU = NRWORK
9173               IRVT = IRU + N*N
9174               NRWORK = IRVT + N*N
9175*
9176*              Path 5o (M >> N, JOBZ='O')
9177*              Copy A to VT, generate P**H
9178*              CWorkspace: need   2*N [tauq, taup] + N    [work]
9179*              CWorkspace: prefer 2*N [tauq, taup] + N*NB [work]
9180*              RWorkspace: need   0
9181*
9182               CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT )
9183               CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
9184     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
9185*
9186*              Generate Q in A
9187*              CWorkspace: need   2*N [tauq, taup] + N    [work]
9188*              CWorkspace: prefer 2*N [tauq, taup] + N*NB [work]
9189*              RWorkspace: need   0
9190*
9191               CALL ZUNGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
9192     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
9193*
9194               IF( LWORK .GE. M*N + 3*N ) THEN
9195*
9196*                 WORK( IU ) is M by N
9197*
9198                  LDWRKU = M
9199               ELSE
9200*
9201*                 WORK(IU) is LDWRKU by N
9202*
9203                  LDWRKU = ( LWORK - 3*N ) / N
9204               END IF
9205               NWORK = IU + LDWRKU*N
9206*
9207*              Perform bidiagonal SVD, computing left singular vectors
9208*              of bidiagonal matrix in RWORK(IRU) and computing right
9209*              singular vectors of bidiagonal matrix in RWORK(IRVT)
9210*              CWorkspace: need   0
9211*              RWorkspace: need   N [e] + N*N [RU] + N*N [RVT] + BDSPAC
9212*
9213               CALL DBDSDC( 'U', 'I', N, S, RWORK( IE ), RWORK( IRU ),
9214     $                      N, RWORK( IRVT ), N, DUM, IDUM,
9215     $                      RWORK( NRWORK ), IWORK, INFO )
9216*
9217*              Multiply real matrix RWORK(IRVT) by P**H in VT,
9218*              storing the result in WORK(IU), copying to VT
9219*              CWorkspace: need   2*N [tauq, taup] + N*N [U]
9220*              RWorkspace: need   N [e] + N*N [RU] + N*N [RVT] + 2*N*N [rwork]
9221*
9222               CALL ZLARCM( N, N, RWORK( IRVT ), N, VT, LDVT,
9223     $                      WORK( IU ), LDWRKU, RWORK( NRWORK ) )
9224               CALL ZLACPY( 'F', N, N, WORK( IU ), LDWRKU, VT, LDVT )
9225*
9226*              Multiply Q in A by real matrix RWORK(IRU), storing the
9227*              result in WORK(IU), copying to A
9228*              CWorkspace: need   2*N [tauq, taup] + N*N [U]
9229*              CWorkspace: prefer 2*N [tauq, taup] + M*N [U]
9230*              RWorkspace: need   N [e] + N*N [RU] + 2*N*N [rwork]
9231*              RWorkspace: prefer N [e] + N*N [RU] + 2*M*N [rwork] < N + 5*N*N since M < 2*N here
9232*
9233               NRWORK = IRVT
9234               DO 20 I = 1, M, LDWRKU
9235                  CHUNK = MIN( M-I+1, LDWRKU )
9236                  CALL ZLACRM( CHUNK, N, A( I, 1 ), LDA, RWORK( IRU ),
9237     $                         N, WORK( IU ), LDWRKU, RWORK( NRWORK ) )
9238                  CALL ZLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU,
9239     $                         A( I, 1 ), LDA )
9240   20          CONTINUE
9241*
9242            ELSE IF( WNTQS ) THEN
9243*
9244*              Path 5s (M >> N, JOBZ='S')
9245*              Copy A to VT, generate P**H
9246*              CWorkspace: need   2*N [tauq, taup] + N    [work]
9247*              CWorkspace: prefer 2*N [tauq, taup] + N*NB [work]
9248*              RWorkspace: need   0
9249*
9250               CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT )
9251               CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
9252     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
9253*
9254*              Copy A to U, generate Q
9255*              CWorkspace: need   2*N [tauq, taup] + N    [work]
9256*              CWorkspace: prefer 2*N [tauq, taup] + N*NB [work]
9257*              RWorkspace: need   0
9258*
9259               CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
9260               CALL ZUNGBR( 'Q', M, N, N, U, LDU, WORK( ITAUQ ),
9261     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
9262*
9263*              Perform bidiagonal SVD, computing left singular vectors
9264*              of bidiagonal matrix in RWORK(IRU) and computing right
9265*              singular vectors of bidiagonal matrix in RWORK(IRVT)
9266*              CWorkspace: need   0
9267*              RWorkspace: need   N [e] + N*N [RU] + N*N [RVT] + BDSPAC
9268*
9269               IRU = NRWORK
9270               IRVT = IRU + N*N
9271               NRWORK = IRVT + N*N
9272               CALL DBDSDC( 'U', 'I', N, S, RWORK( IE ), RWORK( IRU ),
9273     $                      N, RWORK( IRVT ), N, DUM, IDUM,
9274     $                      RWORK( NRWORK ), IWORK, INFO )
9275*
9276*              Multiply real matrix RWORK(IRVT) by P**H in VT,
9277*              storing the result in A, copying to VT
9278*              CWorkspace: need   0
9279*              RWorkspace: need   N [e] + N*N [RU] + N*N [RVT] + 2*N*N [rwork]
9280*
9281               CALL ZLARCM( N, N, RWORK( IRVT ), N, VT, LDVT, A, LDA,
9282     $                      RWORK( NRWORK ) )
9283               CALL ZLACPY( 'F', N, N, A, LDA, VT, LDVT )
9284*
9285*              Multiply Q in U by real matrix RWORK(IRU), storing the
9286*              result in A, copying to U
9287*              CWorkspace: need   0
9288*              RWorkspace: need   N [e] + N*N [RU] + 2*M*N [rwork] < N + 5*N*N since M < 2*N here
9289*
9290               NRWORK = IRVT
9291               CALL ZLACRM( M, N, U, LDU, RWORK( IRU ), N, A, LDA,
9292     $                      RWORK( NRWORK ) )
9293               CALL ZLACPY( 'F', M, N, A, LDA, U, LDU )
9294            ELSE
9295*
9296*              Path 5a (M >> N, JOBZ='A')
9297*              Copy A to VT, generate P**H
9298*              CWorkspace: need   2*N [tauq, taup] + N    [work]
9299*              CWorkspace: prefer 2*N [tauq, taup] + N*NB [work]
9300*              RWorkspace: need   0
9301*
9302               CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT )
9303               CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
9304     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
9305*
9306*              Copy A to U, generate Q
9307*              CWorkspace: need   2*N [tauq, taup] + M    [work]
9308*              CWorkspace: prefer 2*N [tauq, taup] + M*NB [work]
9309*              RWorkspace: need   0
9310*
9311               CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
9312               CALL ZUNGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ),
9313     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
9314*
9315*              Perform bidiagonal SVD, computing left singular vectors
9316*              of bidiagonal matrix in RWORK(IRU) and computing right
9317*              singular vectors of bidiagonal matrix in RWORK(IRVT)
9318*              CWorkspace: need   0
9319*              RWorkspace: need   N [e] + N*N [RU] + N*N [RVT] + BDSPAC
9320*
9321               IRU = NRWORK
9322               IRVT = IRU + N*N
9323               NRWORK = IRVT + N*N
9324               CALL DBDSDC( 'U', 'I', N, S, RWORK( IE ), RWORK( IRU ),
9325     $                      N, RWORK( IRVT ), N, DUM, IDUM,
9326     $                      RWORK( NRWORK ), IWORK, INFO )
9327*
9328*              Multiply real matrix RWORK(IRVT) by P**H in VT,
9329*              storing the result in A, copying to VT
9330*              CWorkspace: need   0
9331*              RWorkspace: need   N [e] + N*N [RU] + N*N [RVT] + 2*N*N [rwork]
9332*
9333               CALL ZLARCM( N, N, RWORK( IRVT ), N, VT, LDVT, A, LDA,
9334     $                      RWORK( NRWORK ) )
9335               CALL ZLACPY( 'F', N, N, A, LDA, VT, LDVT )
9336*
9337*              Multiply Q in U by real matrix RWORK(IRU), storing the
9338*              result in A, copying to U
9339*              CWorkspace: need   0
9340*              RWorkspace: need   N [e] + N*N [RU] + 2*M*N [rwork] < N + 5*N*N since M < 2*N here
9341*
9342               NRWORK = IRVT
9343               CALL ZLACRM( M, N, U, LDU, RWORK( IRU ), N, A, LDA,
9344     $                      RWORK( NRWORK ) )
9345               CALL ZLACPY( 'F', M, N, A, LDA, U, LDU )
9346            END IF
9347*
9348         ELSE
9349*
9350*           M .LT. MNTHR2
9351*
9352*           Path 6 (M >= N, but not much larger)
9353*           Reduce to bidiagonal form without QR decomposition
9354*           Use ZUNMBR to compute singular vectors
9355*
9356            IE = 1
9357            NRWORK = IE + N
9358            ITAUQ = 1
9359            ITAUP = ITAUQ + N
9360            NWORK = ITAUP + N
9361*
9362*           Bidiagonalize A
9363*           CWorkspace: need   2*N [tauq, taup] + M        [work]
9364*           CWorkspace: prefer 2*N [tauq, taup] + (M+N)*NB [work]
9365*           RWorkspace: need   N [e]
9366*
9367            CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
9368     $                   WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
9369     $                   IERR )
9370            IF( WNTQN ) THEN
9371*
9372*              Path 6n (M >= N, JOBZ='N')
9373*              Compute singular values only
9374*              CWorkspace: need   0
9375*              RWorkspace: need   N [e] + BDSPAC
9376*
9377               CALL DBDSDC( 'U', 'N', N, S, RWORK( IE ), DUM,1,DUM,1,
9378     $                      DUM, IDUM, RWORK( NRWORK ), IWORK, INFO )
9379            ELSE IF( WNTQO ) THEN
9380               IU = NWORK
9381               IRU = NRWORK
9382               IRVT = IRU + N*N
9383               NRWORK = IRVT + N*N
9384               IF( LWORK .GE. M*N + 3*N ) THEN
9385*
9386*                 WORK( IU ) is M by N
9387*
9388                  LDWRKU = M
9389               ELSE
9390*
9391*                 WORK( IU ) is LDWRKU by N
9392*
9393                  LDWRKU = ( LWORK - 3*N ) / N
9394               END IF
9395               NWORK = IU + LDWRKU*N
9396*
9397*              Path 6o (M >= N, JOBZ='O')
9398*              Perform bidiagonal SVD, computing left singular vectors
9399*              of bidiagonal matrix in RWORK(IRU) and computing right
9400*              singular vectors of bidiagonal matrix in RWORK(IRVT)
9401*              CWorkspace: need   0
9402*              RWorkspace: need   N [e] + N*N [RU] + N*N [RVT] + BDSPAC
9403*
9404               CALL DBDSDC( 'U', 'I', N, S, RWORK( IE ), RWORK( IRU ),
9405     $                      N, RWORK( IRVT ), N, DUM, IDUM,
9406     $                      RWORK( NRWORK ), IWORK, INFO )
9407*
9408*              Copy real matrix RWORK(IRVT) to complex matrix VT
9409*              Overwrite VT by right singular vectors of A
9410*              CWorkspace: need   2*N [tauq, taup] + N*N [U] + N    [work]
9411*              CWorkspace: prefer 2*N [tauq, taup] + N*N [U] + N*NB [work]
9412*              RWorkspace: need   N [e] + N*N [RU] + N*N [RVT]
9413*
9414               CALL ZLACP2( 'F', N, N, RWORK( IRVT ), N, VT, LDVT )
9415               CALL ZUNMBR( 'P', 'R', 'C', N, N, N, A, LDA,
9416     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
9417     $                      LWORK-NWORK+1, IERR )
9418*
9419               IF( LWORK .GE. M*N + 3*N ) THEN
9420*
9421*                 Path 6o-fast
9422*                 Copy real matrix RWORK(IRU) to complex matrix WORK(IU)
9423*                 Overwrite WORK(IU) by left singular vectors of A, copying
9424*                 to A
9425*                 CWorkspace: need   2*N [tauq, taup] + M*N [U] + N    [work]
9426*                 CWorkspace: prefer 2*N [tauq, taup] + M*N [U] + N*NB [work]
9427*                 RWorkspace: need   N [e] + N*N [RU]
9428*
9429                  CALL ZLASET( 'F', M, N, CZERO, CZERO, WORK( IU ),
9430     $                         LDWRKU )
9431                  CALL ZLACP2( 'F', N, N, RWORK( IRU ), N, WORK( IU ),
9432     $                         LDWRKU )
9433                  CALL ZUNMBR( 'Q', 'L', 'N', M, N, N, A, LDA,
9434     $                         WORK( ITAUQ ), WORK( IU ), LDWRKU,
9435     $                         WORK( NWORK ), LWORK-NWORK+1, IERR )
9436                  CALL ZLACPY( 'F', M, N, WORK( IU ), LDWRKU, A, LDA )
9437               ELSE
9438*
9439*                 Path 6o-slow
9440*                 Generate Q in A
9441*                 CWorkspace: need   2*N [tauq, taup] + N*N [U] + N    [work]
9442*                 CWorkspace: prefer 2*N [tauq, taup] + N*N [U] + N*NB [work]
9443*                 RWorkspace: need   0
9444*
9445                  CALL ZUNGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
9446     $                         WORK( NWORK ), LWORK-NWORK+1, IERR )
9447*
9448*                 Multiply Q in A by real matrix RWORK(IRU), storing the
9449*                 result in WORK(IU), copying to A
9450*                 CWorkspace: need   2*N [tauq, taup] + N*N [U]
9451*                 CWorkspace: prefer 2*N [tauq, taup] + M*N [U]
9452*                 RWorkspace: need   N [e] + N*N [RU] + 2*N*N [rwork]
9453*                 RWorkspace: prefer N [e] + N*N [RU] + 2*M*N [rwork] < N + 5*N*N since M < 2*N here
9454*
9455                  NRWORK = IRVT
9456                  DO 30 I = 1, M, LDWRKU
9457                     CHUNK = MIN( M-I+1, LDWRKU )
9458                     CALL ZLACRM( CHUNK, N, A( I, 1 ), LDA,
9459     $                            RWORK( IRU ), N, WORK( IU ), LDWRKU,
9460     $                            RWORK( NRWORK ) )
9461                     CALL ZLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU,
9462     $                            A( I, 1 ), LDA )
9463   30             CONTINUE
9464               END IF
9465*
9466            ELSE IF( WNTQS ) THEN
9467*
9468*              Path 6s (M >= N, JOBZ='S')
9469*              Perform bidiagonal SVD, computing left singular vectors
9470*              of bidiagonal matrix in RWORK(IRU) and computing right
9471*              singular vectors of bidiagonal matrix in RWORK(IRVT)
9472*              CWorkspace: need   0
9473*              RWorkspace: need   N [e] + N*N [RU] + N*N [RVT] + BDSPAC
9474*
9475               IRU = NRWORK
9476               IRVT = IRU + N*N
9477               NRWORK = IRVT + N*N
9478               CALL DBDSDC( 'U', 'I', N, S, RWORK( IE ), RWORK( IRU ),
9479     $                      N, RWORK( IRVT ), N, DUM, IDUM,
9480     $                      RWORK( NRWORK ), IWORK, INFO )
9481*
9482*              Copy real matrix RWORK(IRU) to complex matrix U
9483*              Overwrite U by left singular vectors of A
9484*              CWorkspace: need   2*N [tauq, taup] + N    [work]
9485*              CWorkspace: prefer 2*N [tauq, taup] + N*NB [work]
9486*              RWorkspace: need   N [e] + N*N [RU] + N*N [RVT]
9487*
9488               CALL ZLASET( 'F', M, N, CZERO, CZERO, U, LDU )
9489               CALL ZLACP2( 'F', N, N, RWORK( IRU ), N, U, LDU )
9490               CALL ZUNMBR( 'Q', 'L', 'N', M, N, N, A, LDA,
9491     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
9492     $                      LWORK-NWORK+1, IERR )
9493*
9494*              Copy real matrix RWORK(IRVT) to complex matrix VT
9495*              Overwrite VT by right singular vectors of A
9496*              CWorkspace: need   2*N [tauq, taup] + N    [work]
9497*              CWorkspace: prefer 2*N [tauq, taup] + N*NB [work]
9498*              RWorkspace: need   N [e] + N*N [RU] + N*N [RVT]
9499*
9500               CALL ZLACP2( 'F', N, N, RWORK( IRVT ), N, VT, LDVT )
9501               CALL ZUNMBR( 'P', 'R', 'C', N, N, N, A, LDA,
9502     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
9503     $                      LWORK-NWORK+1, IERR )
9504            ELSE
9505*
9506*              Path 6a (M >= N, JOBZ='A')
9507*              Perform bidiagonal SVD, computing left singular vectors
9508*              of bidiagonal matrix in RWORK(IRU) and computing right
9509*              singular vectors of bidiagonal matrix in RWORK(IRVT)
9510*              CWorkspace: need   0
9511*              RWorkspace: need   N [e] + N*N [RU] + N*N [RVT] + BDSPAC
9512*
9513               IRU = NRWORK
9514               IRVT = IRU + N*N
9515               NRWORK = IRVT + N*N
9516               CALL DBDSDC( 'U', 'I', N, S, RWORK( IE ), RWORK( IRU ),
9517     $                      N, RWORK( IRVT ), N, DUM, IDUM,
9518     $                      RWORK( NRWORK ), IWORK, INFO )
9519*
9520*              Set the right corner of U to identity matrix
9521*
9522               CALL ZLASET( 'F', M, M, CZERO, CZERO, U, LDU )
9523               IF( M.GT.N ) THEN
9524                  CALL ZLASET( 'F', M-N, M-N, CZERO, CONE,
9525     $                         U( N+1, N+1 ), LDU )
9526               END IF
9527*
9528*              Copy real matrix RWORK(IRU) to complex matrix U
9529*              Overwrite U by left singular vectors of A
9530*              CWorkspace: need   2*N [tauq, taup] + M    [work]
9531*              CWorkspace: prefer 2*N [tauq, taup] + M*NB [work]
9532*              RWorkspace: need   N [e] + N*N [RU] + N*N [RVT]
9533*
9534               CALL ZLACP2( 'F', N, N, RWORK( IRU ), N, U, LDU )
9535               CALL ZUNMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
9536     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
9537     $                      LWORK-NWORK+1, IERR )
9538*
9539*              Copy real matrix RWORK(IRVT) to complex matrix VT
9540*              Overwrite VT by right singular vectors of A
9541*              CWorkspace: need   2*N [tauq, taup] + N    [work]
9542*              CWorkspace: prefer 2*N [tauq, taup] + N*NB [work]
9543*              RWorkspace: need   N [e] + N*N [RU] + N*N [RVT]
9544*
9545               CALL ZLACP2( 'F', N, N, RWORK( IRVT ), N, VT, LDVT )
9546               CALL ZUNMBR( 'P', 'R', 'C', N, N, N, A, LDA,
9547     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
9548     $                      LWORK-NWORK+1, IERR )
9549            END IF
9550*
9551         END IF
9552*
9553      ELSE
9554*
9555*        A has more columns than rows. If A has sufficiently more
9556*        columns than rows, first reduce using the LQ decomposition (if
9557*        sufficient workspace available)
9558*
9559         IF( N.GE.MNTHR1 ) THEN
9560*
9561            IF( WNTQN ) THEN
9562*
9563*              Path 1t (N >> M, JOBZ='N')
9564*              No singular vectors to be computed
9565*
9566               ITAU = 1
9567               NWORK = ITAU + M
9568*
9569*              Compute A=L*Q
9570*              CWorkspace: need   M [tau] + M    [work]
9571*              CWorkspace: prefer M [tau] + M*NB [work]
9572*              RWorkspace: need   0
9573*
9574               CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
9575     $                      LWORK-NWORK+1, IERR )
9576*
9577*              Zero out above L
9578*
9579               CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, A( 1, 2 ),
9580     $                      LDA )
9581               IE = 1
9582               ITAUQ = 1
9583               ITAUP = ITAUQ + M
9584               NWORK = ITAUP + M
9585*
9586*              Bidiagonalize L in A
9587*              CWorkspace: need   2*M [tauq, taup] + M      [work]
9588*              CWorkspace: prefer 2*M [tauq, taup] + 2*M*NB [work]
9589*              RWorkspace: need   M [e]
9590*
9591               CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
9592     $                      WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
9593     $                      IERR )
9594               NRWORK = IE + M
9595*
9596*              Perform bidiagonal SVD, compute singular values only
9597*              CWorkspace: need   0
9598*              RWorkspace: need   M [e] + BDSPAC
9599*
9600               CALL DBDSDC( 'U', 'N', M, S, RWORK( IE ), DUM,1,DUM,1,
9601     $                      DUM, IDUM, RWORK( NRWORK ), IWORK, INFO )
9602*
9603            ELSE IF( WNTQO ) THEN
9604*
9605*              Path 2t (N >> M, JOBZ='O')
9606*              M right singular vectors to be overwritten on A and
9607*              M left singular vectors to be computed in U
9608*
9609               IVT = 1
9610               LDWKVT = M
9611*
9612*              WORK(IVT) is M by M
9613*
9614               IL = IVT + LDWKVT*M
9615               IF( LWORK .GE. M*N + M*M + 3*M ) THEN
9616*
9617*                 WORK(IL) M by N
9618*
9619                  LDWRKL = M
9620                  CHUNK = N
9621               ELSE
9622*
9623*                 WORK(IL) is M by CHUNK
9624*
9625                  LDWRKL = M
9626                  CHUNK = ( LWORK - M*M - 3*M ) / M
9627               END IF
9628               ITAU = IL + LDWRKL*CHUNK
9629               NWORK = ITAU + M
9630*
9631*              Compute A=L*Q
9632*              CWorkspace: need   M*M [VT] + M*M [L] + M [tau] + M    [work]
9633*              CWorkspace: prefer M*M [VT] + M*M [L] + M [tau] + M*NB [work]
9634*              RWorkspace: need   0
9635*
9636               CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
9637     $                      LWORK-NWORK+1, IERR )
9638*
9639*              Copy L to WORK(IL), zeroing about above it
9640*
9641               CALL ZLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWRKL )
9642               CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
9643     $                      WORK( IL+LDWRKL ), LDWRKL )
9644*
9645*              Generate Q in A
9646*              CWorkspace: need   M*M [VT] + M*M [L] + M [tau] + M    [work]
9647*              CWorkspace: prefer M*M [VT] + M*M [L] + M [tau] + M*NB [work]
9648*              RWorkspace: need   0
9649*
9650               CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
9651     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
9652               IE = 1
9653               ITAUQ = ITAU
9654               ITAUP = ITAUQ + M
9655               NWORK = ITAUP + M
9656*
9657*              Bidiagonalize L in WORK(IL)
9658*              CWorkspace: need   M*M [VT] + M*M [L] + 2*M [tauq, taup] + M      [work]
9659*              CWorkspace: prefer M*M [VT] + M*M [L] + 2*M [tauq, taup] + 2*M*NB [work]
9660*              RWorkspace: need   M [e]
9661*
9662               CALL ZGEBRD( M, M, WORK( IL ), LDWRKL, S, RWORK( IE ),
9663     $                      WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
9664     $                      LWORK-NWORK+1, IERR )
9665*
9666*              Perform bidiagonal SVD, computing left singular vectors
9667*              of bidiagonal matrix in RWORK(IRU) and computing right
9668*              singular vectors of bidiagonal matrix in RWORK(IRVT)
9669*              CWorkspace: need   0
9670*              RWorkspace: need   M [e] + M*M [RU] + M*M [RVT] + BDSPAC
9671*
9672               IRU = IE + M
9673               IRVT = IRU + M*M
9674               NRWORK = IRVT + M*M
9675               CALL DBDSDC( 'U', 'I', M, S, RWORK( IE ), RWORK( IRU ),
9676     $                      M, RWORK( IRVT ), M, DUM, IDUM,
9677     $                      RWORK( NRWORK ), IWORK, INFO )
9678*
9679*              Copy real matrix RWORK(IRU) to complex matrix WORK(IU)
9680*              Overwrite WORK(IU) by the left singular vectors of L
9681*              CWorkspace: need   M*M [VT] + M*M [L] + 2*M [tauq, taup] + M    [work]
9682*              CWorkspace: prefer M*M [VT] + M*M [L] + 2*M [tauq, taup] + M*NB [work]
9683*              RWorkspace: need   0
9684*
9685               CALL ZLACP2( 'F', M, M, RWORK( IRU ), M, U, LDU )
9686               CALL ZUNMBR( 'Q', 'L', 'N', M, M, M, WORK( IL ), LDWRKL,
9687     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
9688     $                      LWORK-NWORK+1, IERR )
9689*
9690*              Copy real matrix RWORK(IRVT) to complex matrix WORK(IVT)
9691*              Overwrite WORK(IVT) by the right singular vectors of L
9692*              CWorkspace: need   M*M [VT] + M*M [L] + 2*M [tauq, taup] + M    [work]
9693*              CWorkspace: prefer M*M [VT] + M*M [L] + 2*M [tauq, taup] + M*NB [work]
9694*              RWorkspace: need   0
9695*
9696               CALL ZLACP2( 'F', M, M, RWORK( IRVT ), M, WORK( IVT ),
9697     $                      LDWKVT )
9698               CALL ZUNMBR( 'P', 'R', 'C', M, M, M, WORK( IL ), LDWRKL,
9699     $                      WORK( ITAUP ), WORK( IVT ), LDWKVT,
9700     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
9701*
9702*              Multiply right singular vectors of L in WORK(IL) by Q
9703*              in A, storing result in WORK(IL) and copying to A
9704*              CWorkspace: need   M*M [VT] + M*M [L]
9705*              CWorkspace: prefer M*M [VT] + M*N [L]
9706*              RWorkspace: need   0
9707*
9708               DO 40 I = 1, N, CHUNK
9709                  BLK = MIN( N-I+1, CHUNK )
9710                  CALL ZGEMM( 'N', 'N', M, BLK, M, CONE, WORK( IVT ), M,
9711     $                        A( 1, I ), LDA, CZERO, WORK( IL ),
9712     $                        LDWRKL )
9713                  CALL ZLACPY( 'F', M, BLK, WORK( IL ), LDWRKL,
9714     $                         A( 1, I ), LDA )
9715   40          CONTINUE
9716*
9717            ELSE IF( WNTQS ) THEN
9718*
9719*              Path 3t (N >> M, JOBZ='S')
9720*              M right singular vectors to be computed in VT and
9721*              M left singular vectors to be computed in U
9722*
9723               IL = 1
9724*
9725*              WORK(IL) is M by M
9726*
9727               LDWRKL = M
9728               ITAU = IL + LDWRKL*M
9729               NWORK = ITAU + M
9730*
9731*              Compute A=L*Q
9732*              CWorkspace: need   M*M [L] + M [tau] + M    [work]
9733*              CWorkspace: prefer M*M [L] + M [tau] + M*NB [work]
9734*              RWorkspace: need   0
9735*
9736               CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
9737     $                      LWORK-NWORK+1, IERR )
9738*
9739*              Copy L to WORK(IL), zeroing out above it
9740*
9741               CALL ZLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWRKL )
9742               CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
9743     $                      WORK( IL+LDWRKL ), LDWRKL )
9744*
9745*              Generate Q in A
9746*              CWorkspace: need   M*M [L] + M [tau] + M    [work]
9747*              CWorkspace: prefer M*M [L] + M [tau] + M*NB [work]
9748*              RWorkspace: need   0
9749*
9750               CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
9751     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
9752               IE = 1
9753               ITAUQ = ITAU
9754               ITAUP = ITAUQ + M
9755               NWORK = ITAUP + M
9756*
9757*              Bidiagonalize L in WORK(IL)
9758*              CWorkspace: need   M*M [L] + 2*M [tauq, taup] + M      [work]
9759*              CWorkspace: prefer M*M [L] + 2*M [tauq, taup] + 2*M*NB [work]
9760*              RWorkspace: need   M [e]
9761*
9762               CALL ZGEBRD( M, M, WORK( IL ), LDWRKL, S, RWORK( IE ),
9763     $                      WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
9764     $                      LWORK-NWORK+1, IERR )
9765*
9766*              Perform bidiagonal SVD, computing left singular vectors
9767*              of bidiagonal matrix in RWORK(IRU) and computing right
9768*              singular vectors of bidiagonal matrix in RWORK(IRVT)
9769*              CWorkspace: need   0
9770*              RWorkspace: need   M [e] + M*M [RU] + M*M [RVT] + BDSPAC
9771*
9772               IRU = IE + M
9773               IRVT = IRU + M*M
9774               NRWORK = IRVT + M*M
9775               CALL DBDSDC( 'U', 'I', M, S, RWORK( IE ), RWORK( IRU ),
9776     $                      M, RWORK( IRVT ), M, DUM, IDUM,
9777     $                      RWORK( NRWORK ), IWORK, INFO )
9778*
9779*              Copy real matrix RWORK(IRU) to complex matrix U
9780*              Overwrite U by left singular vectors of L
9781*              CWorkspace: need   M*M [L] + 2*M [tauq, taup] + M    [work]
9782*              CWorkspace: prefer M*M [L] + 2*M [tauq, taup] + M*NB [work]
9783*              RWorkspace: need   0
9784*
9785               CALL ZLACP2( 'F', M, M, RWORK( IRU ), M, U, LDU )
9786               CALL ZUNMBR( 'Q', 'L', 'N', M, M, M, WORK( IL ), LDWRKL,
9787     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
9788     $                      LWORK-NWORK+1, IERR )
9789*
9790*              Copy real matrix RWORK(IRVT) to complex matrix VT
9791*              Overwrite VT by left singular vectors of L
9792*              CWorkspace: need   M*M [L] + 2*M [tauq, taup] + M    [work]
9793*              CWorkspace: prefer M*M [L] + 2*M [tauq, taup] + M*NB [work]
9794*              RWorkspace: need   0
9795*
9796               CALL ZLACP2( 'F', M, M, RWORK( IRVT ), M, VT, LDVT )
9797               CALL ZUNMBR( 'P', 'R', 'C', M, M, M, WORK( IL ), LDWRKL,
9798     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
9799     $                      LWORK-NWORK+1, IERR )
9800*
9801*              Copy VT to WORK(IL), multiply right singular vectors of L
9802*              in WORK(IL) by Q in A, storing result in VT
9803*              CWorkspace: need   M*M [L]
9804*              RWorkspace: need   0
9805*
9806               CALL ZLACPY( 'F', M, M, VT, LDVT, WORK( IL ), LDWRKL )
9807               CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IL ), LDWRKL,
9808     $                     A, LDA, CZERO, VT, LDVT )
9809*
9810            ELSE IF( WNTQA ) THEN
9811*
9812*              Path 4t (N >> M, JOBZ='A')
9813*              N right singular vectors to be computed in VT and
9814*              M left singular vectors to be computed in U
9815*
9816               IVT = 1
9817*
9818*              WORK(IVT) is M by M
9819*
9820               LDWKVT = M
9821               ITAU = IVT + LDWKVT*M
9822               NWORK = ITAU + M
9823*
9824*              Compute A=L*Q, copying result to VT
9825*              CWorkspace: need   M*M [VT] + M [tau] + M    [work]
9826*              CWorkspace: prefer M*M [VT] + M [tau] + M*NB [work]
9827*              RWorkspace: need   0
9828*
9829               CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
9830     $                      LWORK-NWORK+1, IERR )
9831               CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
9832*
9833*              Generate Q in VT
9834*              CWorkspace: need   M*M [VT] + M [tau] + N    [work]
9835*              CWorkspace: prefer M*M [VT] + M [tau] + N*NB [work]
9836*              RWorkspace: need   0
9837*
9838               CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
9839     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
9840*
9841*              Produce L in A, zeroing out above it
9842*
9843               CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, A( 1, 2 ),
9844     $                      LDA )
9845               IE = 1
9846               ITAUQ = ITAU
9847               ITAUP = ITAUQ + M
9848               NWORK = ITAUP + M
9849*
9850*              Bidiagonalize L in A
9851*              CWorkspace: need   M*M [VT] + 2*M [tauq, taup] + M      [work]
9852*              CWorkspace: prefer M*M [VT] + 2*M [tauq, taup] + 2*M*NB [work]
9853*              RWorkspace: need   M [e]
9854*
9855               CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
9856     $                      WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
9857     $                      IERR )
9858*
9859*              Perform bidiagonal SVD, computing left singular vectors
9860*              of bidiagonal matrix in RWORK(IRU) and computing right
9861*              singular vectors of bidiagonal matrix in RWORK(IRVT)
9862*              CWorkspace: need   0
9863*              RWorkspace: need   M [e] + M*M [RU] + M*M [RVT] + BDSPAC
9864*
9865               IRU = IE + M
9866               IRVT = IRU + M*M
9867               NRWORK = IRVT + M*M
9868               CALL DBDSDC( 'U', 'I', M, S, RWORK( IE ), RWORK( IRU ),
9869     $                      M, RWORK( IRVT ), M, DUM, IDUM,
9870     $                      RWORK( NRWORK ), IWORK, INFO )
9871*
9872*              Copy real matrix RWORK(IRU) to complex matrix U
9873*              Overwrite U by left singular vectors of L
9874*              CWorkspace: need   M*M [VT] + 2*M [tauq, taup] + M    [work]
9875*              CWorkspace: prefer M*M [VT] + 2*M [tauq, taup] + M*NB [work]
9876*              RWorkspace: need   0
9877*
9878               CALL ZLACP2( 'F', M, M, RWORK( IRU ), M, U, LDU )
9879               CALL ZUNMBR( 'Q', 'L', 'N', M, M, M, A, LDA,
9880     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
9881     $                      LWORK-NWORK+1, IERR )
9882*
9883*              Copy real matrix RWORK(IRVT) to complex matrix WORK(IVT)
9884*              Overwrite WORK(IVT) by right singular vectors of L
9885*              CWorkspace: need   M*M [VT] + 2*M [tauq, taup] + M    [work]
9886*              CWorkspace: prefer M*M [VT] + 2*M [tauq, taup] + M*NB [work]
9887*              RWorkspace: need   0
9888*
9889               CALL ZLACP2( 'F', M, M, RWORK( IRVT ), M, WORK( IVT ),
9890     $                      LDWKVT )
9891               CALL ZUNMBR( 'P', 'R', 'C', M, M, M, A, LDA,
9892     $                      WORK( ITAUP ), WORK( IVT ), LDWKVT,
9893     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
9894*
9895*              Multiply right singular vectors of L in WORK(IVT) by
9896*              Q in VT, storing result in A
9897*              CWorkspace: need   M*M [VT]
9898*              RWorkspace: need   0
9899*
9900               CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IVT ), LDWKVT,
9901     $                     VT, LDVT, CZERO, A, LDA )
9902*
9903*              Copy right singular vectors of A from A to VT
9904*
9905               CALL ZLACPY( 'F', M, N, A, LDA, VT, LDVT )
9906*
9907            END IF
9908*
9909         ELSE IF( N.GE.MNTHR2 ) THEN
9910*
9911*           MNTHR2 <= N < MNTHR1
9912*
9913*           Path 5t (N >> M, but not as much as MNTHR1)
9914*           Reduce to bidiagonal form without QR decomposition, use
9915*           ZUNGBR and matrix multiplication to compute singular vectors
9916*
9917            IE = 1
9918            NRWORK = IE + M
9919            ITAUQ = 1
9920            ITAUP = ITAUQ + M
9921            NWORK = ITAUP + M
9922*
9923*           Bidiagonalize A
9924*           CWorkspace: need   2*M [tauq, taup] + N        [work]
9925*           CWorkspace: prefer 2*M [tauq, taup] + (M+N)*NB [work]
9926*           RWorkspace: need   M [e]
9927*
9928            CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
9929     $                   WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
9930     $                   IERR )
9931*
9932            IF( WNTQN ) THEN
9933*
9934*              Path 5tn (N >> M, JOBZ='N')
9935*              Compute singular values only
9936*              CWorkspace: need   0
9937*              RWorkspace: need   M [e] + BDSPAC
9938*
9939               CALL DBDSDC( 'L', 'N', M, S, RWORK( IE ), DUM,1,DUM,1,
9940     $                      DUM, IDUM, RWORK( NRWORK ), IWORK, INFO )
9941            ELSE IF( WNTQO ) THEN
9942               IRVT = NRWORK
9943               IRU = IRVT + M*M
9944               NRWORK = IRU + M*M
9945               IVT = NWORK
9946*
9947*              Path 5to (N >> M, JOBZ='O')
9948*              Copy A to U, generate Q
9949*              CWorkspace: need   2*M [tauq, taup] + M    [work]
9950*              CWorkspace: prefer 2*M [tauq, taup] + M*NB [work]
9951*              RWorkspace: need   0
9952*
9953               CALL ZLACPY( 'L', M, M, A, LDA, U, LDU )
9954               CALL ZUNGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ),
9955     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
9956*
9957*              Generate P**H in A
9958*              CWorkspace: need   2*M [tauq, taup] + M    [work]
9959*              CWorkspace: prefer 2*M [tauq, taup] + M*NB [work]
9960*              RWorkspace: need   0
9961*
9962               CALL ZUNGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
9963     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
9964*
9965               LDWKVT = M
9966               IF( LWORK .GE. M*N + 3*M ) THEN
9967*
9968*                 WORK( IVT ) is M by N
9969*
9970                  NWORK = IVT + LDWKVT*N
9971                  CHUNK = N
9972               ELSE
9973*
9974*                 WORK( IVT ) is M by CHUNK
9975*
9976                  CHUNK = ( LWORK - 3*M ) / M
9977                  NWORK = IVT + LDWKVT*CHUNK
9978               END IF
9979*
9980*              Perform bidiagonal SVD, computing left singular vectors
9981*              of bidiagonal matrix in RWORK(IRU) and computing right
9982*              singular vectors of bidiagonal matrix in RWORK(IRVT)
9983*              CWorkspace: need   0
9984*              RWorkspace: need   M [e] + M*M [RVT] + M*M [RU] + BDSPAC
9985*
9986               CALL DBDSDC( 'L', 'I', M, S, RWORK( IE ), RWORK( IRU ),
9987     $                      M, RWORK( IRVT ), M, DUM, IDUM,
9988     $                      RWORK( NRWORK ), IWORK, INFO )
9989*
9990*              Multiply Q in U by real matrix RWORK(IRVT)
9991*              storing the result in WORK(IVT), copying to U
9992*              CWorkspace: need   2*M [tauq, taup] + M*M [VT]
9993*              RWorkspace: need   M [e] + M*M [RVT] + M*M [RU] + 2*M*M [rwork]
9994*
9995               CALL ZLACRM( M, M, U, LDU, RWORK( IRU ), M, WORK( IVT ),
9996     $                      LDWKVT, RWORK( NRWORK ) )
9997               CALL ZLACPY( 'F', M, M, WORK( IVT ), LDWKVT, U, LDU )
9998*
9999*              Multiply RWORK(IRVT) by P**H in A, storing the
10000*              result in WORK(IVT), copying to A
10001*              CWorkspace: need   2*M [tauq, taup] + M*M [VT]
10002*              CWorkspace: prefer 2*M [tauq, taup] + M*N [VT]
10003*              RWorkspace: need   M [e] + M*M [RVT] + 2*M*M [rwork]
10004*              RWorkspace: prefer M [e] + M*M [RVT] + 2*M*N [rwork] < M + 5*M*M since N < 2*M here
10005*
10006               NRWORK = IRU
10007               DO 50 I = 1, N, CHUNK
10008                  BLK = MIN( N-I+1, CHUNK )
10009                  CALL ZLARCM( M, BLK, RWORK( IRVT ), M, A( 1, I ), LDA,
10010     $                         WORK( IVT ), LDWKVT, RWORK( NRWORK ) )
10011                  CALL ZLACPY( 'F', M, BLK, WORK( IVT ), LDWKVT,
10012     $                         A( 1, I ), LDA )
10013   50          CONTINUE
10014            ELSE IF( WNTQS ) THEN
10015*
10016*              Path 5ts (N >> M, JOBZ='S')
10017*              Copy A to U, generate Q
10018*              CWorkspace: need   2*M [tauq, taup] + M    [work]
10019*              CWorkspace: prefer 2*M [tauq, taup] + M*NB [work]
10020*              RWorkspace: need   0
10021*
10022               CALL ZLACPY( 'L', M, M, A, LDA, U, LDU )
10023               CALL ZUNGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ),
10024     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
10025*
10026*              Copy A to VT, generate P**H
10027*              CWorkspace: need   2*M [tauq, taup] + M    [work]
10028*              CWorkspace: prefer 2*M [tauq, taup] + M*NB [work]
10029*              RWorkspace: need   0
10030*
10031               CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
10032               CALL ZUNGBR( 'P', M, N, M, VT, LDVT, WORK( ITAUP ),
10033     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
10034*
10035*              Perform bidiagonal SVD, computing left singular vectors
10036*              of bidiagonal matrix in RWORK(IRU) and computing right
10037*              singular vectors of bidiagonal matrix in RWORK(IRVT)
10038*              CWorkspace: need   0
10039*              RWorkspace: need   M [e] + M*M [RVT] + M*M [RU] + BDSPAC
10040*
10041               IRVT = NRWORK
10042               IRU = IRVT + M*M
10043               NRWORK = IRU + M*M
10044               CALL DBDSDC( 'L', 'I', M, S, RWORK( IE ), RWORK( IRU ),
10045     $                      M, RWORK( IRVT ), M, DUM, IDUM,
10046     $                      RWORK( NRWORK ), IWORK, INFO )
10047*
10048*              Multiply Q in U by real matrix RWORK(IRU), storing the
10049*              result in A, copying to U
10050*              CWorkspace: need   0
10051*              RWorkspace: need   M [e] + M*M [RVT] + M*M [RU] + 2*M*M [rwork]
10052*
10053               CALL ZLACRM( M, M, U, LDU, RWORK( IRU ), M, A, LDA,
10054     $                      RWORK( NRWORK ) )
10055               CALL ZLACPY( 'F', M, M, A, LDA, U, LDU )
10056*
10057*              Multiply real matrix RWORK(IRVT) by P**H in VT,
10058*              storing the result in A, copying to VT
10059*              CWorkspace: need   0
10060*              RWorkspace: need   M [e] + M*M [RVT] + 2*M*N [rwork] < M + 5*M*M since N < 2*M here
10061*
10062               NRWORK = IRU
10063               CALL ZLARCM( M, N, RWORK( IRVT ), M, VT, LDVT, A, LDA,
10064     $                      RWORK( NRWORK ) )
10065               CALL ZLACPY( 'F', M, N, A, LDA, VT, LDVT )
10066            ELSE
10067*
10068*              Path 5ta (N >> M, JOBZ='A')
10069*              Copy A to U, generate Q
10070*              CWorkspace: need   2*M [tauq, taup] + M    [work]
10071*              CWorkspace: prefer 2*M [tauq, taup] + M*NB [work]
10072*              RWorkspace: need   0
10073*
10074               CALL ZLACPY( 'L', M, M, A, LDA, U, LDU )
10075               CALL ZUNGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ),
10076     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
10077*
10078*              Copy A to VT, generate P**H
10079*              CWorkspace: need   2*M [tauq, taup] + N    [work]
10080*              CWorkspace: prefer 2*M [tauq, taup] + N*NB [work]
10081*              RWorkspace: need   0
10082*
10083               CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
10084               CALL ZUNGBR( 'P', N, N, M, VT, LDVT, WORK( ITAUP ),
10085     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
10086*
10087*              Perform bidiagonal SVD, computing left singular vectors
10088*              of bidiagonal matrix in RWORK(IRU) and computing right
10089*              singular vectors of bidiagonal matrix in RWORK(IRVT)
10090*              CWorkspace: need   0
10091*              RWorkspace: need   M [e] + M*M [RVT] + M*M [RU] + BDSPAC
10092*
10093               IRVT = NRWORK
10094               IRU = IRVT + M*M
10095               NRWORK = IRU + M*M
10096               CALL DBDSDC( 'L', 'I', M, S, RWORK( IE ), RWORK( IRU ),
10097     $                      M, RWORK( IRVT ), M, DUM, IDUM,
10098     $                      RWORK( NRWORK ), IWORK, INFO )
10099*
10100*              Multiply Q in U by real matrix RWORK(IRU), storing the
10101*              result in A, copying to U
10102*              CWorkspace: need   0
10103*              RWorkspace: need   M [e] + M*M [RVT] + M*M [RU] + 2*M*M [rwork]
10104*
10105               CALL ZLACRM( M, M, U, LDU, RWORK( IRU ), M, A, LDA,
10106     $                      RWORK( NRWORK ) )
10107               CALL ZLACPY( 'F', M, M, A, LDA, U, LDU )
10108*
10109*              Multiply real matrix RWORK(IRVT) by P**H in VT,
10110*              storing the result in A, copying to VT
10111*              CWorkspace: need   0
10112*              RWorkspace: need   M [e] + M*M [RVT] + 2*M*N [rwork] < M + 5*M*M since N < 2*M here
10113*
10114               NRWORK = IRU
10115               CALL ZLARCM( M, N, RWORK( IRVT ), M, VT, LDVT, A, LDA,
10116     $                      RWORK( NRWORK ) )
10117               CALL ZLACPY( 'F', M, N, A, LDA, VT, LDVT )
10118            END IF
10119*
10120         ELSE
10121*
10122*           N .LT. MNTHR2
10123*
10124*           Path 6t (N > M, but not much larger)
10125*           Reduce to bidiagonal form without LQ decomposition
10126*           Use ZUNMBR to compute singular vectors
10127*
10128            IE = 1
10129            NRWORK = IE + M
10130            ITAUQ = 1
10131            ITAUP = ITAUQ + M
10132            NWORK = ITAUP + M
10133*
10134*           Bidiagonalize A
10135*           CWorkspace: need   2*M [tauq, taup] + N        [work]
10136*           CWorkspace: prefer 2*M [tauq, taup] + (M+N)*NB [work]
10137*           RWorkspace: need   M [e]
10138*
10139            CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
10140     $                   WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
10141     $                   IERR )
10142            IF( WNTQN ) THEN
10143*
10144*              Path 6tn (N > M, JOBZ='N')
10145*              Compute singular values only
10146*              CWorkspace: need   0
10147*              RWorkspace: need   M [e] + BDSPAC
10148*
10149               CALL DBDSDC( 'L', 'N', M, S, RWORK( IE ), DUM,1,DUM,1,
10150     $                      DUM, IDUM, RWORK( NRWORK ), IWORK, INFO )
10151            ELSE IF( WNTQO ) THEN
10152*              Path 6to (N > M, JOBZ='O')
10153               LDWKVT = M
10154               IVT = NWORK
10155               IF( LWORK .GE. M*N + 3*M ) THEN
10156*
10157*                 WORK( IVT ) is M by N
10158*
10159                  CALL ZLASET( 'F', M, N, CZERO, CZERO, WORK( IVT ),
10160     $                         LDWKVT )
10161                  NWORK = IVT + LDWKVT*N
10162               ELSE
10163*
10164*                 WORK( IVT ) is M by CHUNK
10165*
10166                  CHUNK = ( LWORK - 3*M ) / M
10167                  NWORK = IVT + LDWKVT*CHUNK
10168               END IF
10169*
10170*              Perform bidiagonal SVD, computing left singular vectors
10171*              of bidiagonal matrix in RWORK(IRU) and computing right
10172*              singular vectors of bidiagonal matrix in RWORK(IRVT)
10173*              CWorkspace: need   0
10174*              RWorkspace: need   M [e] + M*M [RVT] + M*M [RU] + BDSPAC
10175*
10176               IRVT = NRWORK
10177               IRU = IRVT + M*M
10178               NRWORK = IRU + M*M
10179               CALL DBDSDC( 'L', 'I', M, S, RWORK( IE ), RWORK( IRU ),
10180     $                      M, RWORK( IRVT ), M, DUM, IDUM,
10181     $                      RWORK( NRWORK ), IWORK, INFO )
10182*
10183*              Copy real matrix RWORK(IRU) to complex matrix U
10184*              Overwrite U by left singular vectors of A
10185*              CWorkspace: need   2*M [tauq, taup] + M*M [VT] + M    [work]
10186*              CWorkspace: prefer 2*M [tauq, taup] + M*M [VT] + M*NB [work]
10187*              RWorkspace: need   M [e] + M*M [RVT] + M*M [RU]
10188*
10189               CALL ZLACP2( 'F', M, M, RWORK( IRU ), M, U, LDU )
10190               CALL ZUNMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
10191     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
10192     $                      LWORK-NWORK+1, IERR )
10193*
10194               IF( LWORK .GE. M*N + 3*M ) THEN
10195*
10196*                 Path 6to-fast
10197*                 Copy real matrix RWORK(IRVT) to complex matrix WORK(IVT)
10198*                 Overwrite WORK(IVT) by right singular vectors of A,
10199*                 copying to A
10200*                 CWorkspace: need   2*M [tauq, taup] + M*N [VT] + M    [work]
10201*                 CWorkspace: prefer 2*M [tauq, taup] + M*N [VT] + M*NB [work]
10202*                 RWorkspace: need   M [e] + M*M [RVT]
10203*
10204                  CALL ZLACP2( 'F', M, M, RWORK( IRVT ), M, WORK( IVT ),
10205     $                         LDWKVT )
10206                  CALL ZUNMBR( 'P', 'R', 'C', M, N, M, A, LDA,
10207     $                         WORK( ITAUP ), WORK( IVT ), LDWKVT,
10208     $                         WORK( NWORK ), LWORK-NWORK+1, IERR )
10209                  CALL ZLACPY( 'F', M, N, WORK( IVT ), LDWKVT, A, LDA )
10210               ELSE
10211*
10212*                 Path 6to-slow
10213*                 Generate P**H in A
10214*                 CWorkspace: need   2*M [tauq, taup] + M*M [VT] + M    [work]
10215*                 CWorkspace: prefer 2*M [tauq, taup] + M*M [VT] + M*NB [work]
10216*                 RWorkspace: need   0
10217*
10218                  CALL ZUNGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
10219     $                         WORK( NWORK ), LWORK-NWORK+1, IERR )
10220*
10221*                 Multiply Q in A by real matrix RWORK(IRU), storing the
10222*                 result in WORK(IU), copying to A
10223*                 CWorkspace: need   2*M [tauq, taup] + M*M [VT]
10224*                 CWorkspace: prefer 2*M [tauq, taup] + M*N [VT]
10225*                 RWorkspace: need   M [e] + M*M [RVT] + 2*M*M [rwork]
10226*                 RWorkspace: prefer M [e] + M*M [RVT] + 2*M*N [rwork] < M + 5*M*M since N < 2*M here
10227*
10228                  NRWORK = IRU
10229                  DO 60 I = 1, N, CHUNK
10230                     BLK = MIN( N-I+1, CHUNK )
10231                     CALL ZLARCM( M, BLK, RWORK( IRVT ), M, A( 1, I ),
10232     $                            LDA, WORK( IVT ), LDWKVT,
10233     $                            RWORK( NRWORK ) )
10234                     CALL ZLACPY( 'F', M, BLK, WORK( IVT ), LDWKVT,
10235     $                            A( 1, I ), LDA )
10236   60             CONTINUE
10237               END IF
10238            ELSE IF( WNTQS ) THEN
10239*
10240*              Path 6ts (N > M, JOBZ='S')
10241*              Perform bidiagonal SVD, computing left singular vectors
10242*              of bidiagonal matrix in RWORK(IRU) and computing right
10243*              singular vectors of bidiagonal matrix in RWORK(IRVT)
10244*              CWorkspace: need   0
10245*              RWorkspace: need   M [e] + M*M [RVT] + M*M [RU] + BDSPAC
10246*
10247               IRVT = NRWORK
10248               IRU = IRVT + M*M
10249               NRWORK = IRU + M*M
10250               CALL DBDSDC( 'L', 'I', M, S, RWORK( IE ), RWORK( IRU ),
10251     $                      M, RWORK( IRVT ), M, DUM, IDUM,
10252     $                      RWORK( NRWORK ), IWORK, INFO )
10253*
10254*              Copy real matrix RWORK(IRU) to complex matrix U
10255*              Overwrite U by left singular vectors of A
10256*              CWorkspace: need   2*M [tauq, taup] + M    [work]
10257*              CWorkspace: prefer 2*M [tauq, taup] + M*NB [work]
10258*              RWorkspace: need   M [e] + M*M [RVT] + M*M [RU]
10259*
10260               CALL ZLACP2( 'F', M, M, RWORK( IRU ), M, U, LDU )
10261               CALL ZUNMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
10262     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
10263     $                      LWORK-NWORK+1, IERR )
10264*
10265*              Copy real matrix RWORK(IRVT) to complex matrix VT
10266*              Overwrite VT by right singular vectors of A
10267*              CWorkspace: need   2*M [tauq, taup] + M    [work]
10268*              CWorkspace: prefer 2*M [tauq, taup] + M*NB [work]
10269*              RWorkspace: need   M [e] + M*M [RVT]
10270*
10271               CALL ZLASET( 'F', M, N, CZERO, CZERO, VT, LDVT )
10272               CALL ZLACP2( 'F', M, M, RWORK( IRVT ), M, VT, LDVT )
10273               CALL ZUNMBR( 'P', 'R', 'C', M, N, M, A, LDA,
10274     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
10275     $                      LWORK-NWORK+1, IERR )
10276            ELSE
10277*
10278*              Path 6ta (N > M, JOBZ='A')
10279*              Perform bidiagonal SVD, computing left singular vectors
10280*              of bidiagonal matrix in RWORK(IRU) and computing right
10281*              singular vectors of bidiagonal matrix in RWORK(IRVT)
10282*              CWorkspace: need   0
10283*              RWorkspace: need   M [e] + M*M [RVT] + M*M [RU] + BDSPAC
10284*
10285               IRVT = NRWORK
10286               IRU = IRVT + M*M
10287               NRWORK = IRU + M*M
10288*
10289               CALL DBDSDC( 'L', 'I', M, S, RWORK( IE ), RWORK( IRU ),
10290     $                      M, RWORK( IRVT ), M, DUM, IDUM,
10291     $                      RWORK( NRWORK ), IWORK, INFO )
10292*
10293*              Copy real matrix RWORK(IRU) to complex matrix U
10294*              Overwrite U by left singular vectors of A
10295*              CWorkspace: need   2*M [tauq, taup] + M    [work]
10296*              CWorkspace: prefer 2*M [tauq, taup] + M*NB [work]
10297*              RWorkspace: need   M [e] + M*M [RVT] + M*M [RU]
10298*
10299               CALL ZLACP2( 'F', M, M, RWORK( IRU ), M, U, LDU )
10300               CALL ZUNMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
10301     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
10302     $                      LWORK-NWORK+1, IERR )
10303*
10304*              Set all of VT to identity matrix
10305*
10306               CALL ZLASET( 'F', N, N, CZERO, CONE, VT, LDVT )
10307*
10308*              Copy real matrix RWORK(IRVT) to complex matrix VT
10309*              Overwrite VT by right singular vectors of A
10310*              CWorkspace: need   2*M [tauq, taup] + N    [work]
10311*              CWorkspace: prefer 2*M [tauq, taup] + N*NB [work]
10312*              RWorkspace: need   M [e] + M*M [RVT]
10313*
10314               CALL ZLACP2( 'F', M, M, RWORK( IRVT ), M, VT, LDVT )
10315               CALL ZUNMBR( 'P', 'R', 'C', N, N, M, A, LDA,
10316     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
10317     $                      LWORK-NWORK+1, IERR )
10318            END IF
10319*
10320         END IF
10321*
10322      END IF
10323*
10324*     Undo scaling if necessary
10325*
10326      IF( ISCL.EQ.1 ) THEN
10327         IF( ANRM.GT.BIGNUM )
10328     $      CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
10329     $                   IERR )
10330         IF( INFO.NE.0 .AND. ANRM.GT.BIGNUM )
10331     $      CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN-1, 1,
10332     $                   RWORK( IE ), MINMN, IERR )
10333         IF( ANRM.LT.SMLNUM )
10334     $      CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
10335     $                   IERR )
10336         IF( INFO.NE.0 .AND. ANRM.LT.SMLNUM )
10337     $      CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN-1, 1,
10338     $                   RWORK( IE ), MINMN, IERR )
10339      END IF
10340*
10341*     Return optimal workspace in WORK(1)
10342*
10343      WORK( 1 ) = MAXWRK
10344*
10345      RETURN
10346*
10347*     End of ZGESDD
10348*
10349      END
10350*> \brief <b> ZGESV computes the solution to system of linear equations A * X = B for GE matrices (simple driver) </b>
10351*
10352*  =========== DOCUMENTATION ===========
10353*
10354* Online html documentation available at
10355*            http://www.netlib.org/lapack/explore-html/
10356*
10357*> \htmlonly
10358*> Download ZGESV + dependencies
10359*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgesv.f">
10360*> [TGZ]</a>
10361*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgesv.f">
10362*> [ZIP]</a>
10363*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgesv.f">
10364*> [TXT]</a>
10365*> \endhtmlonly
10366*
10367*  Definition:
10368*  ===========
10369*
10370*       SUBROUTINE ZGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
10371*
10372*       .. Scalar Arguments ..
10373*       INTEGER            INFO, LDA, LDB, N, NRHS
10374*       ..
10375*       .. Array Arguments ..
10376*       INTEGER            IPIV( * )
10377*       COMPLEX*16         A( LDA, * ), B( LDB, * )
10378*       ..
10379*
10380*
10381*> \par Purpose:
10382*  =============
10383*>
10384*> \verbatim
10385*>
10386*> ZGESV computes the solution to a complex system of linear equations
10387*>    A * X = B,
10388*> where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
10389*>
10390*> The LU decomposition with partial pivoting and row interchanges is
10391*> used to factor A as
10392*>    A = P * L * U,
10393*> where P is a permutation matrix, L is unit lower triangular, and U is
10394*> upper triangular.  The factored form of A is then used to solve the
10395*> system of equations A * X = B.
10396*> \endverbatim
10397*
10398*  Arguments:
10399*  ==========
10400*
10401*> \param[in] N
10402*> \verbatim
10403*>          N is INTEGER
10404*>          The number of linear equations, i.e., the order of the
10405*>          matrix A.  N >= 0.
10406*> \endverbatim
10407*>
10408*> \param[in] NRHS
10409*> \verbatim
10410*>          NRHS is INTEGER
10411*>          The number of right hand sides, i.e., the number of columns
10412*>          of the matrix B.  NRHS >= 0.
10413*> \endverbatim
10414*>
10415*> \param[in,out] A
10416*> \verbatim
10417*>          A is COMPLEX*16 array, dimension (LDA,N)
10418*>          On entry, the N-by-N coefficient matrix A.
10419*>          On exit, the factors L and U from the factorization
10420*>          A = P*L*U; the unit diagonal elements of L are not stored.
10421*> \endverbatim
10422*>
10423*> \param[in] LDA
10424*> \verbatim
10425*>          LDA is INTEGER
10426*>          The leading dimension of the array A.  LDA >= max(1,N).
10427*> \endverbatim
10428*>
10429*> \param[out] IPIV
10430*> \verbatim
10431*>          IPIV is INTEGER array, dimension (N)
10432*>          The pivot indices that define the permutation matrix P;
10433*>          row i of the matrix was interchanged with row IPIV(i).
10434*> \endverbatim
10435*>
10436*> \param[in,out] B
10437*> \verbatim
10438*>          B is COMPLEX*16 array, dimension (LDB,NRHS)
10439*>          On entry, the N-by-NRHS matrix of right hand side matrix B.
10440*>          On exit, if INFO = 0, the N-by-NRHS solution matrix X.
10441*> \endverbatim
10442*>
10443*> \param[in] LDB
10444*> \verbatim
10445*>          LDB is INTEGER
10446*>          The leading dimension of the array B.  LDB >= max(1,N).
10447*> \endverbatim
10448*>
10449*> \param[out] INFO
10450*> \verbatim
10451*>          INFO is INTEGER
10452*>          = 0:  successful exit
10453*>          < 0:  if INFO = -i, the i-th argument had an illegal value
10454*>          > 0:  if INFO = i, U(i,i) is exactly zero.  The factorization
10455*>                has been completed, but the factor U is exactly
10456*>                singular, so the solution could not be computed.
10457*> \endverbatim
10458*
10459*  Authors:
10460*  ========
10461*
10462*> \author Univ. of Tennessee
10463*> \author Univ. of California Berkeley
10464*> \author Univ. of Colorado Denver
10465*> \author NAG Ltd.
10466*
10467*> \date June 2017
10468*
10469*> \ingroup complex16GEsolve
10470*
10471*  =====================================================================
10472      SUBROUTINE ZGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
10473*
10474*  -- LAPACK driver routine (version 3.7.1) --
10475*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
10476*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
10477*     June 2017
10478*
10479*     .. Scalar Arguments ..
10480      INTEGER            INFO, LDA, LDB, N, NRHS
10481*     ..
10482*     .. Array Arguments ..
10483      INTEGER            IPIV( * )
10484      COMPLEX*16         A( LDA, * ), B( LDB, * )
10485*     ..
10486*
10487*  =====================================================================
10488*
10489*     .. External Subroutines ..
10490      EXTERNAL           XERBLA, ZGETRF, ZGETRS
10491*     ..
10492*     .. Intrinsic Functions ..
10493      INTRINSIC          MAX
10494*     ..
10495*     .. Executable Statements ..
10496*
10497*     Test the input parameters.
10498*
10499      INFO = 0
10500      IF( N.LT.0 ) THEN
10501         INFO = -1
10502      ELSE IF( NRHS.LT.0 ) THEN
10503         INFO = -2
10504      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
10505         INFO = -4
10506      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
10507         INFO = -7
10508      END IF
10509      IF( INFO.NE.0 ) THEN
10510         CALL XERBLA( 'ZGESV ', -INFO )
10511         RETURN
10512      END IF
10513*
10514*     Compute the LU factorization of A.
10515*
10516      CALL ZGETRF( N, N, A, LDA, IPIV, INFO )
10517      IF( INFO.EQ.0 ) THEN
10518*
10519*        Solve the system A*X = B, overwriting B with X.
10520*
10521         CALL ZGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB,
10522     $                INFO )
10523      END IF
10524      RETURN
10525*
10526*     End of ZGESV
10527*
10528      END
10529*> \brief <b> ZGESVD computes the singular value decomposition (SVD) for GE matrices</b>
10530*
10531*  =========== DOCUMENTATION ===========
10532*
10533* Online html documentation available at
10534*            http://www.netlib.org/lapack/explore-html/
10535*
10536*> \htmlonly
10537*> Download ZGESVD + dependencies
10538*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgesvd.f">
10539*> [TGZ]</a>
10540*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgesvd.f">
10541*> [ZIP]</a>
10542*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgesvd.f">
10543*> [TXT]</a>
10544*> \endhtmlonly
10545*
10546*  Definition:
10547*  ===========
10548*
10549*       SUBROUTINE ZGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT,
10550*                          WORK, LWORK, RWORK, INFO )
10551*
10552*       .. Scalar Arguments ..
10553*       CHARACTER          JOBU, JOBVT
10554*       INTEGER            INFO, LDA, LDU, LDVT, LWORK, M, N
10555*       ..
10556*       .. Array Arguments ..
10557*       DOUBLE PRECISION   RWORK( * ), S( * )
10558*       COMPLEX*16         A( LDA, * ), U( LDU, * ), VT( LDVT, * ),
10559*      $                   WORK( * )
10560*       ..
10561*
10562*
10563*> \par Purpose:
10564*  =============
10565*>
10566*> \verbatim
10567*>
10568*> ZGESVD computes the singular value decomposition (SVD) of a complex
10569*> M-by-N matrix A, optionally computing the left and/or right singular
10570*> vectors. The SVD is written
10571*>
10572*>      A = U * SIGMA * conjugate-transpose(V)
10573*>
10574*> where SIGMA is an M-by-N matrix which is zero except for its
10575*> min(m,n) diagonal elements, U is an M-by-M unitary matrix, and
10576*> V is an N-by-N unitary matrix.  The diagonal elements of SIGMA
10577*> are the singular values of A; they are real and non-negative, and
10578*> are returned in descending order.  The first min(m,n) columns of
10579*> U and V are the left and right singular vectors of A.
10580*>
10581*> Note that the routine returns V**H, not V.
10582*> \endverbatim
10583*
10584*  Arguments:
10585*  ==========
10586*
10587*> \param[in] JOBU
10588*> \verbatim
10589*>          JOBU is CHARACTER*1
10590*>          Specifies options for computing all or part of the matrix U:
10591*>          = 'A':  all M columns of U are returned in array U:
10592*>          = 'S':  the first min(m,n) columns of U (the left singular
10593*>                  vectors) are returned in the array U;
10594*>          = 'O':  the first min(m,n) columns of U (the left singular
10595*>                  vectors) are overwritten on the array A;
10596*>          = 'N':  no columns of U (no left singular vectors) are
10597*>                  computed.
10598*> \endverbatim
10599*>
10600*> \param[in] JOBVT
10601*> \verbatim
10602*>          JOBVT is CHARACTER*1
10603*>          Specifies options for computing all or part of the matrix
10604*>          V**H:
10605*>          = 'A':  all N rows of V**H are returned in the array VT;
10606*>          = 'S':  the first min(m,n) rows of V**H (the right singular
10607*>                  vectors) are returned in the array VT;
10608*>          = 'O':  the first min(m,n) rows of V**H (the right singular
10609*>                  vectors) are overwritten on the array A;
10610*>          = 'N':  no rows of V**H (no right singular vectors) are
10611*>                  computed.
10612*>
10613*>          JOBVT and JOBU cannot both be 'O'.
10614*> \endverbatim
10615*>
10616*> \param[in] M
10617*> \verbatim
10618*>          M is INTEGER
10619*>          The number of rows of the input matrix A.  M >= 0.
10620*> \endverbatim
10621*>
10622*> \param[in] N
10623*> \verbatim
10624*>          N is INTEGER
10625*>          The number of columns of the input matrix A.  N >= 0.
10626*> \endverbatim
10627*>
10628*> \param[in,out] A
10629*> \verbatim
10630*>          A is COMPLEX*16 array, dimension (LDA,N)
10631*>          On entry, the M-by-N matrix A.
10632*>          On exit,
10633*>          if JOBU = 'O',  A is overwritten with the first min(m,n)
10634*>                          columns of U (the left singular vectors,
10635*>                          stored columnwise);
10636*>          if JOBVT = 'O', A is overwritten with the first min(m,n)
10637*>                          rows of V**H (the right singular vectors,
10638*>                          stored rowwise);
10639*>          if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A
10640*>                          are destroyed.
10641*> \endverbatim
10642*>
10643*> \param[in] LDA
10644*> \verbatim
10645*>          LDA is INTEGER
10646*>          The leading dimension of the array A.  LDA >= max(1,M).
10647*> \endverbatim
10648*>
10649*> \param[out] S
10650*> \verbatim
10651*>          S is DOUBLE PRECISION array, dimension (min(M,N))
10652*>          The singular values of A, sorted so that S(i) >= S(i+1).
10653*> \endverbatim
10654*>
10655*> \param[out] U
10656*> \verbatim
10657*>          U is COMPLEX*16 array, dimension (LDU,UCOL)
10658*>          (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'.
10659*>          If JOBU = 'A', U contains the M-by-M unitary matrix U;
10660*>          if JOBU = 'S', U contains the first min(m,n) columns of U
10661*>          (the left singular vectors, stored columnwise);
10662*>          if JOBU = 'N' or 'O', U is not referenced.
10663*> \endverbatim
10664*>
10665*> \param[in] LDU
10666*> \verbatim
10667*>          LDU is INTEGER
10668*>          The leading dimension of the array U.  LDU >= 1; if
10669*>          JOBU = 'S' or 'A', LDU >= M.
10670*> \endverbatim
10671*>
10672*> \param[out] VT
10673*> \verbatim
10674*>          VT is COMPLEX*16 array, dimension (LDVT,N)
10675*>          If JOBVT = 'A', VT contains the N-by-N unitary matrix
10676*>          V**H;
10677*>          if JOBVT = 'S', VT contains the first min(m,n) rows of
10678*>          V**H (the right singular vectors, stored rowwise);
10679*>          if JOBVT = 'N' or 'O', VT is not referenced.
10680*> \endverbatim
10681*>
10682*> \param[in] LDVT
10683*> \verbatim
10684*>          LDVT is INTEGER
10685*>          The leading dimension of the array VT.  LDVT >= 1; if
10686*>          JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N).
10687*> \endverbatim
10688*>
10689*> \param[out] WORK
10690*> \verbatim
10691*>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
10692*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
10693*> \endverbatim
10694*>
10695*> \param[in] LWORK
10696*> \verbatim
10697*>          LWORK is INTEGER
10698*>          The dimension of the array WORK.
10699*>          LWORK >=  MAX(1,2*MIN(M,N)+MAX(M,N)).
10700*>          For good performance, LWORK should generally be larger.
10701*>
10702*>          If LWORK = -1, then a workspace query is assumed; the routine
10703*>          only calculates the optimal size of the WORK array, returns
10704*>          this value as the first entry of the WORK array, and no error
10705*>          message related to LWORK is issued by XERBLA.
10706*> \endverbatim
10707*>
10708*> \param[out] RWORK
10709*> \verbatim
10710*>          RWORK is DOUBLE PRECISION array, dimension (5*min(M,N))
10711*>          On exit, if INFO > 0, RWORK(1:MIN(M,N)-1) contains the
10712*>          unconverged superdiagonal elements of an upper bidiagonal
10713*>          matrix B whose diagonal is in S (not necessarily sorted).
10714*>          B satisfies A = U * B * VT, so it has the same singular
10715*>          values as A, and singular vectors related by U and VT.
10716*> \endverbatim
10717*>
10718*> \param[out] INFO
10719*> \verbatim
10720*>          INFO is INTEGER
10721*>          = 0:  successful exit.
10722*>          < 0:  if INFO = -i, the i-th argument had an illegal value.
10723*>          > 0:  if ZBDSQR did not converge, INFO specifies how many
10724*>                superdiagonals of an intermediate bidiagonal form B
10725*>                did not converge to zero. See the description of RWORK
10726*>                above for details.
10727*> \endverbatim
10728*
10729*  Authors:
10730*  ========
10731*
10732*> \author Univ. of Tennessee
10733*> \author Univ. of California Berkeley
10734*> \author Univ. of Colorado Denver
10735*> \author NAG Ltd.
10736*
10737*> \date April 2012
10738*
10739*> \ingroup complex16GEsing
10740*
10741*  =====================================================================
10742      SUBROUTINE ZGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU,
10743     $                   VT, LDVT, WORK, LWORK, RWORK, INFO )
10744*
10745*  -- LAPACK driver routine (version 3.7.0) --
10746*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
10747*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
10748*     April 2012
10749*
10750*     .. Scalar Arguments ..
10751      CHARACTER          JOBU, JOBVT
10752      INTEGER            INFO, LDA, LDU, LDVT, LWORK, M, N
10753*     ..
10754*     .. Array Arguments ..
10755      DOUBLE PRECISION   RWORK( * ), S( * )
10756      COMPLEX*16         A( LDA, * ), U( LDU, * ), VT( LDVT, * ),
10757     $                   WORK( * )
10758*     ..
10759*
10760*  =====================================================================
10761*
10762*     .. Parameters ..
10763      COMPLEX*16         CZERO, CONE
10764      PARAMETER          ( CZERO = ( 0.0D0, 0.0D0 ),
10765     $                   CONE = ( 1.0D0, 0.0D0 ) )
10766      DOUBLE PRECISION   ZERO, ONE
10767      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
10768*     ..
10769*     .. Local Scalars ..
10770      LOGICAL            LQUERY, WNTUA, WNTUAS, WNTUN, WNTUO, WNTUS,
10771     $                   WNTVA, WNTVAS, WNTVN, WNTVO, WNTVS
10772      INTEGER            BLK, CHUNK, I, IE, IERR, IR, IRWORK, ISCL,
10773     $                   ITAU, ITAUP, ITAUQ, IU, IWORK, LDWRKR, LDWRKU,
10774     $                   MAXWRK, MINMN, MINWRK, MNTHR, NCU, NCVT, NRU,
10775     $                   NRVT, WRKBL
10776      INTEGER            LWORK_ZGEQRF, LWORK_ZUNGQR_N, LWORK_ZUNGQR_M,
10777     $                   LWORK_ZGEBRD, LWORK_ZUNGBR_P, LWORK_ZUNGBR_Q,
10778     $                   LWORK_ZGELQF, LWORK_ZUNGLQ_N, LWORK_ZUNGLQ_M
10779      DOUBLE PRECISION   ANRM, BIGNUM, EPS, SMLNUM
10780*     ..
10781*     .. Local Arrays ..
10782      DOUBLE PRECISION   DUM( 1 )
10783      COMPLEX*16         CDUM( 1 )
10784*     ..
10785*     .. External Subroutines ..
10786      EXTERNAL           DLASCL, XERBLA, ZBDSQR, ZGEBRD, ZGELQF, ZGEMM,
10787     $                   ZGEQRF, ZLACPY, ZLASCL, ZLASET, ZUNGBR, ZUNGLQ,
10788     $                   ZUNGQR, ZUNMBR
10789*     ..
10790*     .. External Functions ..
10791      LOGICAL            LSAME
10792      INTEGER            ILAENV
10793      DOUBLE PRECISION   DLAMCH, ZLANGE
10794      EXTERNAL           LSAME, ILAENV, DLAMCH, ZLANGE
10795*     ..
10796*     .. Intrinsic Functions ..
10797      INTRINSIC          MAX, MIN, SQRT
10798*     ..
10799*     .. Executable Statements ..
10800*
10801*     Test the input arguments
10802*
10803      INFO = 0
10804      MINMN = MIN( M, N )
10805      WNTUA = LSAME( JOBU, 'A' )
10806      WNTUS = LSAME( JOBU, 'S' )
10807      WNTUAS = WNTUA .OR. WNTUS
10808      WNTUO = LSAME( JOBU, 'O' )
10809      WNTUN = LSAME( JOBU, 'N' )
10810      WNTVA = LSAME( JOBVT, 'A' )
10811      WNTVS = LSAME( JOBVT, 'S' )
10812      WNTVAS = WNTVA .OR. WNTVS
10813      WNTVO = LSAME( JOBVT, 'O' )
10814      WNTVN = LSAME( JOBVT, 'N' )
10815      LQUERY = ( LWORK.EQ.-1 )
10816*
10817      IF( .NOT.( WNTUA .OR. WNTUS .OR. WNTUO .OR. WNTUN ) ) THEN
10818         INFO = -1
10819      ELSE IF( .NOT.( WNTVA .OR. WNTVS .OR. WNTVO .OR. WNTVN ) .OR.
10820     $         ( WNTVO .AND. WNTUO ) ) THEN
10821         INFO = -2
10822      ELSE IF( M.LT.0 ) THEN
10823         INFO = -3
10824      ELSE IF( N.LT.0 ) THEN
10825         INFO = -4
10826      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
10827         INFO = -6
10828      ELSE IF( LDU.LT.1 .OR. ( WNTUAS .AND. LDU.LT.M ) ) THEN
10829         INFO = -9
10830      ELSE IF( LDVT.LT.1 .OR. ( WNTVA .AND. LDVT.LT.N ) .OR.
10831     $         ( WNTVS .AND. LDVT.LT.MINMN ) ) THEN
10832         INFO = -11
10833      END IF
10834*
10835*     Compute workspace
10836*      (Note: Comments in the code beginning "Workspace:" describe the
10837*       minimal amount of workspace needed at that point in the code,
10838*       as well as the preferred amount for good performance.
10839*       CWorkspace refers to complex workspace, and RWorkspace to
10840*       real workspace. NB refers to the optimal block size for the
10841*       immediately following subroutine, as returned by ILAENV.)
10842*
10843      IF( INFO.EQ.0 ) THEN
10844         MINWRK = 1
10845         MAXWRK = 1
10846         IF( M.GE.N .AND. MINMN.GT.0 ) THEN
10847*
10848*           Space needed for ZBDSQR is BDSPAC = 5*N
10849*
10850            MNTHR = ILAENV( 6, 'ZGESVD', JOBU // JOBVT, M, N, 0, 0 )
10851*           Compute space needed for ZGEQRF
10852            CALL ZGEQRF( M, N, A, LDA, CDUM(1), CDUM(1), -1, IERR )
10853            LWORK_ZGEQRF = INT( CDUM(1) )
10854*           Compute space needed for ZUNGQR
10855            CALL ZUNGQR( M, N, N, A, LDA, CDUM(1), CDUM(1), -1, IERR )
10856            LWORK_ZUNGQR_N = INT( CDUM(1) )
10857            CALL ZUNGQR( M, M, N, A, LDA, CDUM(1), CDUM(1), -1, IERR )
10858            LWORK_ZUNGQR_M = INT( CDUM(1) )
10859*           Compute space needed for ZGEBRD
10860            CALL ZGEBRD( N, N, A, LDA, S, DUM(1), CDUM(1),
10861     $                   CDUM(1), CDUM(1), -1, IERR )
10862            LWORK_ZGEBRD = INT( CDUM(1) )
10863*           Compute space needed for ZUNGBR
10864            CALL ZUNGBR( 'P', N, N, N, A, LDA, CDUM(1),
10865     $                   CDUM(1), -1, IERR )
10866            LWORK_ZUNGBR_P = INT( CDUM(1) )
10867            CALL ZUNGBR( 'Q', N, N, N, A, LDA, CDUM(1),
10868     $                   CDUM(1), -1, IERR )
10869            LWORK_ZUNGBR_Q = INT( CDUM(1) )
10870*
10871            IF( M.GE.MNTHR ) THEN
10872               IF( WNTUN ) THEN
10873*
10874*                 Path 1 (M much larger than N, JOBU='N')
10875*
10876                  MAXWRK = N + LWORK_ZGEQRF
10877                  MAXWRK = MAX( MAXWRK, 2*N+LWORK_ZGEBRD )
10878                  IF( WNTVO .OR. WNTVAS )
10879     $               MAXWRK = MAX( MAXWRK, 2*N+LWORK_ZUNGBR_P )
10880                  MINWRK = 3*N
10881               ELSE IF( WNTUO .AND. WNTVN ) THEN
10882*
10883*                 Path 2 (M much larger than N, JOBU='O', JOBVT='N')
10884*
10885                  WRKBL = N + LWORK_ZGEQRF
10886                  WRKBL = MAX( WRKBL, N+LWORK_ZUNGQR_N )
10887                  WRKBL = MAX( WRKBL, 2*N+LWORK_ZGEBRD )
10888                  WRKBL = MAX( WRKBL, 2*N+LWORK_ZUNGBR_Q )
10889                  MAXWRK = MAX( N*N+WRKBL, N*N+M*N )
10890                  MINWRK = 2*N + M
10891               ELSE IF( WNTUO .AND. WNTVAS ) THEN
10892*
10893*                 Path 3 (M much larger than N, JOBU='O', JOBVT='S' or
10894*                 'A')
10895*
10896                  WRKBL = N + LWORK_ZGEQRF
10897                  WRKBL = MAX( WRKBL, N+LWORK_ZUNGQR_N )
10898                  WRKBL = MAX( WRKBL, 2*N+LWORK_ZGEBRD )
10899                  WRKBL = MAX( WRKBL, 2*N+LWORK_ZUNGBR_Q )
10900                  WRKBL = MAX( WRKBL, 2*N+LWORK_ZUNGBR_P )
10901                  MAXWRK = MAX( N*N+WRKBL, N*N+M*N )
10902                  MINWRK = 2*N + M
10903               ELSE IF( WNTUS .AND. WNTVN ) THEN
10904*
10905*                 Path 4 (M much larger than N, JOBU='S', JOBVT='N')
10906*
10907                  WRKBL = N + LWORK_ZGEQRF
10908                  WRKBL = MAX( WRKBL, N+LWORK_ZUNGQR_N )
10909                  WRKBL = MAX( WRKBL, 2*N+LWORK_ZGEBRD )
10910                  WRKBL = MAX( WRKBL, 2*N+LWORK_ZUNGBR_Q )
10911                  MAXWRK = N*N + WRKBL
10912                  MINWRK = 2*N + M
10913               ELSE IF( WNTUS .AND. WNTVO ) THEN
10914*
10915*                 Path 5 (M much larger than N, JOBU='S', JOBVT='O')
10916*
10917                  WRKBL = N + LWORK_ZGEQRF
10918                  WRKBL = MAX( WRKBL, N+LWORK_ZUNGQR_N )
10919                  WRKBL = MAX( WRKBL, 2*N+LWORK_ZGEBRD )
10920                  WRKBL = MAX( WRKBL, 2*N+LWORK_ZUNGBR_Q )
10921                  WRKBL = MAX( WRKBL, 2*N+LWORK_ZUNGBR_P )
10922                  MAXWRK = 2*N*N + WRKBL
10923                  MINWRK = 2*N + M
10924               ELSE IF( WNTUS .AND. WNTVAS ) THEN
10925*
10926*                 Path 6 (M much larger than N, JOBU='S', JOBVT='S' or
10927*                 'A')
10928*
10929                  WRKBL = N + LWORK_ZGEQRF
10930                  WRKBL = MAX( WRKBL, N+LWORK_ZUNGQR_N )
10931                  WRKBL = MAX( WRKBL, 2*N+LWORK_ZGEBRD )
10932                  WRKBL = MAX( WRKBL, 2*N+LWORK_ZUNGBR_Q )
10933                  WRKBL = MAX( WRKBL, 2*N+LWORK_ZUNGBR_P )
10934                  MAXWRK = N*N + WRKBL
10935                  MINWRK = 2*N + M
10936               ELSE IF( WNTUA .AND. WNTVN ) THEN
10937*
10938*                 Path 7 (M much larger than N, JOBU='A', JOBVT='N')
10939*
10940                  WRKBL = N + LWORK_ZGEQRF
10941                  WRKBL = MAX( WRKBL, N+LWORK_ZUNGQR_M )
10942                  WRKBL = MAX( WRKBL, 2*N+LWORK_ZGEBRD )
10943                  WRKBL = MAX( WRKBL, 2*N+LWORK_ZUNGBR_Q )
10944                  MAXWRK = N*N + WRKBL
10945                  MINWRK = 2*N + M
10946               ELSE IF( WNTUA .AND. WNTVO ) THEN
10947*
10948*                 Path 8 (M much larger than N, JOBU='A', JOBVT='O')
10949*
10950                  WRKBL = N + LWORK_ZGEQRF
10951                  WRKBL = MAX( WRKBL, N+LWORK_ZUNGQR_M )
10952                  WRKBL = MAX( WRKBL, 2*N+LWORK_ZGEBRD )
10953                  WRKBL = MAX( WRKBL, 2*N+LWORK_ZUNGBR_Q )
10954                  WRKBL = MAX( WRKBL, 2*N+LWORK_ZUNGBR_P )
10955                  MAXWRK = 2*N*N + WRKBL
10956                  MINWRK = 2*N + M
10957               ELSE IF( WNTUA .AND. WNTVAS ) THEN
10958*
10959*                 Path 9 (M much larger than N, JOBU='A', JOBVT='S' or
10960*                 'A')
10961*
10962                  WRKBL = N + LWORK_ZGEQRF
10963                  WRKBL = MAX( WRKBL, N+LWORK_ZUNGQR_M )
10964                  WRKBL = MAX( WRKBL, 2*N+LWORK_ZGEBRD )
10965                  WRKBL = MAX( WRKBL, 2*N+LWORK_ZUNGBR_Q )
10966                  WRKBL = MAX( WRKBL, 2*N+LWORK_ZUNGBR_P )
10967                  MAXWRK = N*N + WRKBL
10968                  MINWRK = 2*N + M
10969               END IF
10970            ELSE
10971*
10972*              Path 10 (M at least N, but not much larger)
10973*
10974               CALL ZGEBRD( M, N, A, LDA, S, DUM(1), CDUM(1),
10975     $                   CDUM(1), CDUM(1), -1, IERR )
10976               LWORK_ZGEBRD = INT( CDUM(1) )
10977               MAXWRK = 2*N + LWORK_ZGEBRD
10978               IF( WNTUS .OR. WNTUO ) THEN
10979                  CALL ZUNGBR( 'Q', M, N, N, A, LDA, CDUM(1),
10980     $                   CDUM(1), -1, IERR )
10981                  LWORK_ZUNGBR_Q = INT( CDUM(1) )
10982                  MAXWRK = MAX( MAXWRK, 2*N+LWORK_ZUNGBR_Q )
10983               END IF
10984               IF( WNTUA ) THEN
10985                  CALL ZUNGBR( 'Q', M, M, N, A, LDA, CDUM(1),
10986     $                   CDUM(1), -1, IERR )
10987                  LWORK_ZUNGBR_Q = INT( CDUM(1) )
10988                  MAXWRK = MAX( MAXWRK, 2*N+LWORK_ZUNGBR_Q )
10989               END IF
10990               IF( .NOT.WNTVN ) THEN
10991                  MAXWRK = MAX( MAXWRK, 2*N+LWORK_ZUNGBR_P )
10992               END IF
10993               MINWRK = 2*N + M
10994            END IF
10995         ELSE IF( MINMN.GT.0 ) THEN
10996*
10997*           Space needed for ZBDSQR is BDSPAC = 5*M
10998*
10999            MNTHR = ILAENV( 6, 'ZGESVD', JOBU // JOBVT, M, N, 0, 0 )
11000*           Compute space needed for ZGELQF
11001            CALL ZGELQF( M, N, A, LDA, CDUM(1), CDUM(1), -1, IERR )
11002            LWORK_ZGELQF = INT( CDUM(1) )
11003*           Compute space needed for ZUNGLQ
11004            CALL ZUNGLQ( N, N, M, CDUM(1), N, CDUM(1), CDUM(1), -1,
11005     $                   IERR )
11006            LWORK_ZUNGLQ_N = INT( CDUM(1) )
11007            CALL ZUNGLQ( M, N, M, A, LDA, CDUM(1), CDUM(1), -1, IERR )
11008            LWORK_ZUNGLQ_M = INT( CDUM(1) )
11009*           Compute space needed for ZGEBRD
11010            CALL ZGEBRD( M, M, A, LDA, S, DUM(1), CDUM(1),
11011     $                   CDUM(1), CDUM(1), -1, IERR )
11012            LWORK_ZGEBRD = INT( CDUM(1) )
11013*            Compute space needed for ZUNGBR P
11014            CALL ZUNGBR( 'P', M, M, M, A, N, CDUM(1),
11015     $                   CDUM(1), -1, IERR )
11016            LWORK_ZUNGBR_P = INT( CDUM(1) )
11017*           Compute space needed for ZUNGBR Q
11018            CALL ZUNGBR( 'Q', M, M, M, A, N, CDUM(1),
11019     $                   CDUM(1), -1, IERR )
11020            LWORK_ZUNGBR_Q = INT( CDUM(1) )
11021            IF( N.GE.MNTHR ) THEN
11022               IF( WNTVN ) THEN
11023*
11024*                 Path 1t(N much larger than M, JOBVT='N')
11025*
11026                  MAXWRK = M + LWORK_ZGELQF
11027                  MAXWRK = MAX( MAXWRK, 2*M+LWORK_ZGEBRD )
11028                  IF( WNTUO .OR. WNTUAS )
11029     $               MAXWRK = MAX( MAXWRK, 2*M+LWORK_ZUNGBR_Q )
11030                  MINWRK = 3*M
11031               ELSE IF( WNTVO .AND. WNTUN ) THEN
11032*
11033*                 Path 2t(N much larger than M, JOBU='N', JOBVT='O')
11034*
11035                  WRKBL = M + LWORK_ZGELQF
11036                  WRKBL = MAX( WRKBL, M+LWORK_ZUNGLQ_M )
11037                  WRKBL = MAX( WRKBL, 2*M+LWORK_ZGEBRD )
11038                  WRKBL = MAX( WRKBL, 2*M+LWORK_ZUNGBR_P )
11039                  MAXWRK = MAX( M*M+WRKBL, M*M+M*N )
11040                  MINWRK = 2*M + N
11041               ELSE IF( WNTVO .AND. WNTUAS ) THEN
11042*
11043*                 Path 3t(N much larger than M, JOBU='S' or 'A',
11044*                 JOBVT='O')
11045*
11046                  WRKBL = M + LWORK_ZGELQF
11047                  WRKBL = MAX( WRKBL, M+LWORK_ZUNGLQ_M )
11048                  WRKBL = MAX( WRKBL, 2*M+LWORK_ZGEBRD )
11049                  WRKBL = MAX( WRKBL, 2*M+LWORK_ZUNGBR_P )
11050                  WRKBL = MAX( WRKBL, 2*M+LWORK_ZUNGBR_Q )
11051                  MAXWRK = MAX( M*M+WRKBL, M*M+M*N )
11052                  MINWRK = 2*M + N
11053               ELSE IF( WNTVS .AND. WNTUN ) THEN
11054*
11055*                 Path 4t(N much larger than M, JOBU='N', JOBVT='S')
11056*
11057                  WRKBL = M + LWORK_ZGELQF
11058                  WRKBL = MAX( WRKBL, M+LWORK_ZUNGLQ_M )
11059                  WRKBL = MAX( WRKBL, 2*M+LWORK_ZGEBRD )
11060                  WRKBL = MAX( WRKBL, 2*M+LWORK_ZUNGBR_P )
11061                  MAXWRK = M*M + WRKBL
11062                  MINWRK = 2*M + N
11063               ELSE IF( WNTVS .AND. WNTUO ) THEN
11064*
11065*                 Path 5t(N much larger than M, JOBU='O', JOBVT='S')
11066*
11067                  WRKBL = M + LWORK_ZGELQF
11068                  WRKBL = MAX( WRKBL, M+LWORK_ZUNGLQ_M )
11069                  WRKBL = MAX( WRKBL, 2*M+LWORK_ZGEBRD )
11070                  WRKBL = MAX( WRKBL, 2*M+LWORK_ZUNGBR_P )
11071                  WRKBL = MAX( WRKBL, 2*M+LWORK_ZUNGBR_Q )
11072                  MAXWRK = 2*M*M + WRKBL
11073                  MINWRK = 2*M + N
11074               ELSE IF( WNTVS .AND. WNTUAS ) THEN
11075*
11076*                 Path 6t(N much larger than M, JOBU='S' or 'A',
11077*                 JOBVT='S')
11078*
11079                  WRKBL = M + LWORK_ZGELQF
11080                  WRKBL = MAX( WRKBL, M+LWORK_ZUNGLQ_M )
11081                  WRKBL = MAX( WRKBL, 2*M+LWORK_ZGEBRD )
11082                  WRKBL = MAX( WRKBL, 2*M+LWORK_ZUNGBR_P )
11083                  WRKBL = MAX( WRKBL, 2*M+LWORK_ZUNGBR_Q )
11084                  MAXWRK = M*M + WRKBL
11085                  MINWRK = 2*M + N
11086               ELSE IF( WNTVA .AND. WNTUN ) THEN
11087*
11088*                 Path 7t(N much larger than M, JOBU='N', JOBVT='A')
11089*
11090                  WRKBL = M + LWORK_ZGELQF
11091                  WRKBL = MAX( WRKBL, M+LWORK_ZUNGLQ_N )
11092                  WRKBL = MAX( WRKBL, 2*M+LWORK_ZGEBRD )
11093                  WRKBL = MAX( WRKBL, 2*M+LWORK_ZUNGBR_P )
11094                  MAXWRK = M*M + WRKBL
11095                  MINWRK = 2*M + N
11096               ELSE IF( WNTVA .AND. WNTUO ) THEN
11097*
11098*                 Path 8t(N much larger than M, JOBU='O', JOBVT='A')
11099*
11100                  WRKBL = M + LWORK_ZGELQF
11101                  WRKBL = MAX( WRKBL, M+LWORK_ZUNGLQ_N )
11102                  WRKBL = MAX( WRKBL, 2*M+LWORK_ZGEBRD )
11103                  WRKBL = MAX( WRKBL, 2*M+LWORK_ZUNGBR_P )
11104                  WRKBL = MAX( WRKBL, 2*M+LWORK_ZUNGBR_Q )
11105                  MAXWRK = 2*M*M + WRKBL
11106                  MINWRK = 2*M + N
11107               ELSE IF( WNTVA .AND. WNTUAS ) THEN
11108*
11109*                 Path 9t(N much larger than M, JOBU='S' or 'A',
11110*                 JOBVT='A')
11111*
11112                  WRKBL = M + LWORK_ZGELQF
11113                  WRKBL = MAX( WRKBL, M+LWORK_ZUNGLQ_N )
11114                  WRKBL = MAX( WRKBL, 2*M+LWORK_ZGEBRD )
11115                  WRKBL = MAX( WRKBL, 2*M+LWORK_ZUNGBR_P )
11116                  WRKBL = MAX( WRKBL, 2*M+LWORK_ZUNGBR_Q )
11117                  MAXWRK = M*M + WRKBL
11118                  MINWRK = 2*M + N
11119               END IF
11120            ELSE
11121*
11122*              Path 10t(N greater than M, but not much larger)
11123*
11124               CALL ZGEBRD( M, N, A, LDA, S, DUM(1), CDUM(1),
11125     $                   CDUM(1), CDUM(1), -1, IERR )
11126               LWORK_ZGEBRD = INT( CDUM(1) )
11127               MAXWRK = 2*M + LWORK_ZGEBRD
11128               IF( WNTVS .OR. WNTVO ) THEN
11129*                Compute space needed for ZUNGBR P
11130                 CALL ZUNGBR( 'P', M, N, M, A, N, CDUM(1),
11131     $                   CDUM(1), -1, IERR )
11132                 LWORK_ZUNGBR_P = INT( CDUM(1) )
11133                 MAXWRK = MAX( MAXWRK, 2*M+LWORK_ZUNGBR_P )
11134               END IF
11135               IF( WNTVA ) THEN
11136                 CALL ZUNGBR( 'P', N,  N, M, A, N, CDUM(1),
11137     $                   CDUM(1), -1, IERR )
11138                 LWORK_ZUNGBR_P = INT( CDUM(1) )
11139                 MAXWRK = MAX( MAXWRK, 2*M+LWORK_ZUNGBR_P )
11140               END IF
11141               IF( .NOT.WNTUN ) THEN
11142                  MAXWRK = MAX( MAXWRK, 2*M+LWORK_ZUNGBR_Q )
11143               END IF
11144               MINWRK = 2*M + N
11145            END IF
11146         END IF
11147         MAXWRK = MAX( MAXWRK, MINWRK )
11148         WORK( 1 ) = MAXWRK
11149*
11150         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
11151            INFO = -13
11152         END IF
11153      END IF
11154*
11155      IF( INFO.NE.0 ) THEN
11156         CALL XERBLA( 'ZGESVD', -INFO )
11157         RETURN
11158      ELSE IF( LQUERY ) THEN
11159         RETURN
11160      END IF
11161*
11162*     Quick return if possible
11163*
11164      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
11165         RETURN
11166      END IF
11167*
11168*     Get machine constants
11169*
11170      EPS = DLAMCH( 'P' )
11171      SMLNUM = SQRT( DLAMCH( 'S' ) ) / EPS
11172      BIGNUM = ONE / SMLNUM
11173*
11174*     Scale A if max element outside range [SMLNUM,BIGNUM]
11175*
11176      ANRM = ZLANGE( 'M', M, N, A, LDA, DUM )
11177      ISCL = 0
11178      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
11179         ISCL = 1
11180         CALL ZLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, IERR )
11181      ELSE IF( ANRM.GT.BIGNUM ) THEN
11182         ISCL = 1
11183         CALL ZLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, IERR )
11184      END IF
11185*
11186      IF( M.GE.N ) THEN
11187*
11188*        A has at least as many rows as columns. If A has sufficiently
11189*        more rows than columns, first reduce using the QR
11190*        decomposition (if sufficient workspace available)
11191*
11192         IF( M.GE.MNTHR ) THEN
11193*
11194            IF( WNTUN ) THEN
11195*
11196*              Path 1 (M much larger than N, JOBU='N')
11197*              No left singular vectors to be computed
11198*
11199               ITAU = 1
11200               IWORK = ITAU + N
11201*
11202*              Compute A=Q*R
11203*              (CWorkspace: need 2*N, prefer N+N*NB)
11204*              (RWorkspace: need 0)
11205*
11206               CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
11207     $                      LWORK-IWORK+1, IERR )
11208*
11209*              Zero out below R
11210*
11211               IF( N .GT. 1 ) THEN
11212                  CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, A( 2, 1 ),
11213     $                         LDA )
11214               END IF
11215               IE = 1
11216               ITAUQ = 1
11217               ITAUP = ITAUQ + N
11218               IWORK = ITAUP + N
11219*
11220*              Bidiagonalize R in A
11221*              (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
11222*              (RWorkspace: need N)
11223*
11224               CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
11225     $                      WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
11226     $                      IERR )
11227               NCVT = 0
11228               IF( WNTVO .OR. WNTVAS ) THEN
11229*
11230*                 If right singular vectors desired, generate P'.
11231*                 (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
11232*                 (RWorkspace: 0)
11233*
11234                  CALL ZUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
11235     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
11236                  NCVT = N
11237               END IF
11238               IRWORK = IE + N
11239*
11240*              Perform bidiagonal QR iteration, computing right
11241*              singular vectors of A in A if desired
11242*              (CWorkspace: 0)
11243*              (RWorkspace: need BDSPAC)
11244*
11245               CALL ZBDSQR( 'U', N, NCVT, 0, 0, S, RWORK( IE ), A, LDA,
11246     $                      CDUM, 1, CDUM, 1, RWORK( IRWORK ), INFO )
11247*
11248*              If right singular vectors desired in VT, copy them there
11249*
11250               IF( WNTVAS )
11251     $            CALL ZLACPY( 'F', N, N, A, LDA, VT, LDVT )
11252*
11253            ELSE IF( WNTUO .AND. WNTVN ) THEN
11254*
11255*              Path 2 (M much larger than N, JOBU='O', JOBVT='N')
11256*              N left singular vectors to be overwritten on A and
11257*              no right singular vectors to be computed
11258*
11259               IF( LWORK.GE.N*N+3*N ) THEN
11260*
11261*                 Sufficient workspace for a fast algorithm
11262*
11263                  IR = 1
11264                  IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*N ) THEN
11265*
11266*                    WORK(IU) is LDA by N, WORK(IR) is LDA by N
11267*
11268                     LDWRKU = LDA
11269                     LDWRKR = LDA
11270                  ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+N*N ) THEN
11271*
11272*                    WORK(IU) is LDA by N, WORK(IR) is N by N
11273*
11274                     LDWRKU = LDA
11275                     LDWRKR = N
11276                  ELSE
11277*
11278*                    WORK(IU) is LDWRKU by N, WORK(IR) is N by N
11279*
11280                     LDWRKU = ( LWORK-N*N ) / N
11281                     LDWRKR = N
11282                  END IF
11283                  ITAU = IR + LDWRKR*N
11284                  IWORK = ITAU + N
11285*
11286*                 Compute A=Q*R
11287*                 (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
11288*                 (RWorkspace: 0)
11289*
11290                  CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
11291     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
11292*
11293*                 Copy R to WORK(IR) and zero out below it
11294*
11295                  CALL ZLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR )
11296                  CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
11297     $                         WORK( IR+1 ), LDWRKR )
11298*
11299*                 Generate Q in A
11300*                 (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
11301*                 (RWorkspace: 0)
11302*
11303                  CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ),
11304     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
11305                  IE = 1
11306                  ITAUQ = ITAU
11307                  ITAUP = ITAUQ + N
11308                  IWORK = ITAUP + N
11309*
11310*                 Bidiagonalize R in WORK(IR)
11311*                 (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB)
11312*                 (RWorkspace: need N)
11313*
11314                  CALL ZGEBRD( N, N, WORK( IR ), LDWRKR, S, RWORK( IE ),
11315     $                         WORK( ITAUQ ), WORK( ITAUP ),
11316     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
11317*
11318*                 Generate left vectors bidiagonalizing R
11319*                 (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
11320*                 (RWorkspace: need 0)
11321*
11322                  CALL ZUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
11323     $                         WORK( ITAUQ ), WORK( IWORK ),
11324     $                         LWORK-IWORK+1, IERR )
11325                  IRWORK = IE + N
11326*
11327*                 Perform bidiagonal QR iteration, computing left
11328*                 singular vectors of R in WORK(IR)
11329*                 (CWorkspace: need N*N)
11330*                 (RWorkspace: need BDSPAC)
11331*
11332                  CALL ZBDSQR( 'U', N, 0, N, 0, S, RWORK( IE ), CDUM, 1,
11333     $                         WORK( IR ), LDWRKR, CDUM, 1,
11334     $                         RWORK( IRWORK ), INFO )
11335                  IU = ITAUQ
11336*
11337*                 Multiply Q in A by left singular vectors of R in
11338*                 WORK(IR), storing result in WORK(IU) and copying to A
11339*                 (CWorkspace: need N*N+N, prefer N*N+M*N)
11340*                 (RWorkspace: 0)
11341*
11342                  DO 10 I = 1, M, LDWRKU
11343                     CHUNK = MIN( M-I+1, LDWRKU )
11344                     CALL ZGEMM( 'N', 'N', CHUNK, N, N, CONE, A( I, 1 ),
11345     $                           LDA, WORK( IR ), LDWRKR, CZERO,
11346     $                           WORK( IU ), LDWRKU )
11347                     CALL ZLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU,
11348     $                            A( I, 1 ), LDA )
11349   10             CONTINUE
11350*
11351               ELSE
11352*
11353*                 Insufficient workspace for a fast algorithm
11354*
11355                  IE = 1
11356                  ITAUQ = 1
11357                  ITAUP = ITAUQ + N
11358                  IWORK = ITAUP + N
11359*
11360*                 Bidiagonalize A
11361*                 (CWorkspace: need 2*N+M, prefer 2*N+(M+N)*NB)
11362*                 (RWorkspace: N)
11363*
11364                  CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ),
11365     $                         WORK( ITAUQ ), WORK( ITAUP ),
11366     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
11367*
11368*                 Generate left vectors bidiagonalizing A
11369*                 (CWorkspace: need 3*N, prefer 2*N+N*NB)
11370*                 (RWorkspace: 0)
11371*
11372                  CALL ZUNGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
11373     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
11374                  IRWORK = IE + N
11375*
11376*                 Perform bidiagonal QR iteration, computing left
11377*                 singular vectors of A in A
11378*                 (CWorkspace: need 0)
11379*                 (RWorkspace: need BDSPAC)
11380*
11381                  CALL ZBDSQR( 'U', N, 0, M, 0, S, RWORK( IE ), CDUM, 1,
11382     $                         A, LDA, CDUM, 1, RWORK( IRWORK ), INFO )
11383*
11384               END IF
11385*
11386            ELSE IF( WNTUO .AND. WNTVAS ) THEN
11387*
11388*              Path 3 (M much larger than N, JOBU='O', JOBVT='S' or 'A')
11389*              N left singular vectors to be overwritten on A and
11390*              N right singular vectors to be computed in VT
11391*
11392               IF( LWORK.GE.N*N+3*N ) THEN
11393*
11394*                 Sufficient workspace for a fast algorithm
11395*
11396                  IR = 1
11397                  IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*N ) THEN
11398*
11399*                    WORK(IU) is LDA by N and WORK(IR) is LDA by N
11400*
11401                     LDWRKU = LDA
11402                     LDWRKR = LDA
11403                  ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+N*N ) THEN
11404*
11405*                    WORK(IU) is LDA by N and WORK(IR) is N by N
11406*
11407                     LDWRKU = LDA
11408                     LDWRKR = N
11409                  ELSE
11410*
11411*                    WORK(IU) is LDWRKU by N and WORK(IR) is N by N
11412*
11413                     LDWRKU = ( LWORK-N*N ) / N
11414                     LDWRKR = N
11415                  END IF
11416                  ITAU = IR + LDWRKR*N
11417                  IWORK = ITAU + N
11418*
11419*                 Compute A=Q*R
11420*                 (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
11421*                 (RWorkspace: 0)
11422*
11423                  CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
11424     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
11425*
11426*                 Copy R to VT, zeroing out below it
11427*
11428                  CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT )
11429                  IF( N.GT.1 )
11430     $               CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
11431     $                            VT( 2, 1 ), LDVT )
11432*
11433*                 Generate Q in A
11434*                 (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
11435*                 (RWorkspace: 0)
11436*
11437                  CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ),
11438     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
11439                  IE = 1
11440                  ITAUQ = ITAU
11441                  ITAUP = ITAUQ + N
11442                  IWORK = ITAUP + N
11443*
11444*                 Bidiagonalize R in VT, copying result to WORK(IR)
11445*                 (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB)
11446*                 (RWorkspace: need N)
11447*
11448                  CALL ZGEBRD( N, N, VT, LDVT, S, RWORK( IE ),
11449     $                         WORK( ITAUQ ), WORK( ITAUP ),
11450     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
11451                  CALL ZLACPY( 'L', N, N, VT, LDVT, WORK( IR ), LDWRKR )
11452*
11453*                 Generate left vectors bidiagonalizing R in WORK(IR)
11454*                 (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
11455*                 (RWorkspace: 0)
11456*
11457                  CALL ZUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
11458     $                         WORK( ITAUQ ), WORK( IWORK ),
11459     $                         LWORK-IWORK+1, IERR )
11460*
11461*                 Generate right vectors bidiagonalizing R in VT
11462*                 (CWorkspace: need N*N+3*N-1, prefer N*N+2*N+(N-1)*NB)
11463*                 (RWorkspace: 0)
11464*
11465                  CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
11466     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
11467                  IRWORK = IE + N
11468*
11469*                 Perform bidiagonal QR iteration, computing left
11470*                 singular vectors of R in WORK(IR) and computing right
11471*                 singular vectors of R in VT
11472*                 (CWorkspace: need N*N)
11473*                 (RWorkspace: need BDSPAC)
11474*
11475                  CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ), VT,
11476     $                         LDVT, WORK( IR ), LDWRKR, CDUM, 1,
11477     $                         RWORK( IRWORK ), INFO )
11478                  IU = ITAUQ
11479*
11480*                 Multiply Q in A by left singular vectors of R in
11481*                 WORK(IR), storing result in WORK(IU) and copying to A
11482*                 (CWorkspace: need N*N+N, prefer N*N+M*N)
11483*                 (RWorkspace: 0)
11484*
11485                  DO 20 I = 1, M, LDWRKU
11486                     CHUNK = MIN( M-I+1, LDWRKU )
11487                     CALL ZGEMM( 'N', 'N', CHUNK, N, N, CONE, A( I, 1 ),
11488     $                           LDA, WORK( IR ), LDWRKR, CZERO,
11489     $                           WORK( IU ), LDWRKU )
11490                     CALL ZLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU,
11491     $                            A( I, 1 ), LDA )
11492   20             CONTINUE
11493*
11494               ELSE
11495*
11496*                 Insufficient workspace for a fast algorithm
11497*
11498                  ITAU = 1
11499                  IWORK = ITAU + N
11500*
11501*                 Compute A=Q*R
11502*                 (CWorkspace: need 2*N, prefer N+N*NB)
11503*                 (RWorkspace: 0)
11504*
11505                  CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
11506     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
11507*
11508*                 Copy R to VT, zeroing out below it
11509*
11510                  CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT )
11511                  IF( N.GT.1 )
11512     $               CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
11513     $                            VT( 2, 1 ), LDVT )
11514*
11515*                 Generate Q in A
11516*                 (CWorkspace: need 2*N, prefer N+N*NB)
11517*                 (RWorkspace: 0)
11518*
11519                  CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ),
11520     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
11521                  IE = 1
11522                  ITAUQ = ITAU
11523                  ITAUP = ITAUQ + N
11524                  IWORK = ITAUP + N
11525*
11526*                 Bidiagonalize R in VT
11527*                 (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
11528*                 (RWorkspace: N)
11529*
11530                  CALL ZGEBRD( N, N, VT, LDVT, S, RWORK( IE ),
11531     $                         WORK( ITAUQ ), WORK( ITAUP ),
11532     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
11533*
11534*                 Multiply Q in A by left vectors bidiagonalizing R
11535*                 (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
11536*                 (RWorkspace: 0)
11537*
11538                  CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
11539     $                         WORK( ITAUQ ), A, LDA, WORK( IWORK ),
11540     $                         LWORK-IWORK+1, IERR )
11541*
11542*                 Generate right vectors bidiagonalizing R in VT
11543*                 (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
11544*                 (RWorkspace: 0)
11545*
11546                  CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
11547     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
11548                  IRWORK = IE + N
11549*
11550*                 Perform bidiagonal QR iteration, computing left
11551*                 singular vectors of A in A and computing right
11552*                 singular vectors of A in VT
11553*                 (CWorkspace: 0)
11554*                 (RWorkspace: need BDSPAC)
11555*
11556                  CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), VT,
11557     $                         LDVT, A, LDA, CDUM, 1, RWORK( IRWORK ),
11558     $                         INFO )
11559*
11560               END IF
11561*
11562            ELSE IF( WNTUS ) THEN
11563*
11564               IF( WNTVN ) THEN
11565*
11566*                 Path 4 (M much larger than N, JOBU='S', JOBVT='N')
11567*                 N left singular vectors to be computed in U and
11568*                 no right singular vectors to be computed
11569*
11570                  IF( LWORK.GE.N*N+3*N ) THEN
11571*
11572*                    Sufficient workspace for a fast algorithm
11573*
11574                     IR = 1
11575                     IF( LWORK.GE.WRKBL+LDA*N ) THEN
11576*
11577*                       WORK(IR) is LDA by N
11578*
11579                        LDWRKR = LDA
11580                     ELSE
11581*
11582*                       WORK(IR) is N by N
11583*
11584                        LDWRKR = N
11585                     END IF
11586                     ITAU = IR + LDWRKR*N
11587                     IWORK = ITAU + N
11588*
11589*                    Compute A=Q*R
11590*                    (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
11591*                    (RWorkspace: 0)
11592*
11593                     CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
11594     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
11595*
11596*                    Copy R to WORK(IR), zeroing out below it
11597*
11598                     CALL ZLACPY( 'U', N, N, A, LDA, WORK( IR ),
11599     $                            LDWRKR )
11600                     CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
11601     $                            WORK( IR+1 ), LDWRKR )
11602*
11603*                    Generate Q in A
11604*                    (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
11605*                    (RWorkspace: 0)
11606*
11607                     CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ),
11608     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
11609                     IE = 1
11610                     ITAUQ = ITAU
11611                     ITAUP = ITAUQ + N
11612                     IWORK = ITAUP + N
11613*
11614*                    Bidiagonalize R in WORK(IR)
11615*                    (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB)
11616*                    (RWorkspace: need N)
11617*
11618                     CALL ZGEBRD( N, N, WORK( IR ), LDWRKR, S,
11619     $                            RWORK( IE ), WORK( ITAUQ ),
11620     $                            WORK( ITAUP ), WORK( IWORK ),
11621     $                            LWORK-IWORK+1, IERR )
11622*
11623*                    Generate left vectors bidiagonalizing R in WORK(IR)
11624*                    (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
11625*                    (RWorkspace: 0)
11626*
11627                     CALL ZUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
11628     $                            WORK( ITAUQ ), WORK( IWORK ),
11629     $                            LWORK-IWORK+1, IERR )
11630                     IRWORK = IE + N
11631*
11632*                    Perform bidiagonal QR iteration, computing left
11633*                    singular vectors of R in WORK(IR)
11634*                    (CWorkspace: need N*N)
11635*                    (RWorkspace: need BDSPAC)
11636*
11637                     CALL ZBDSQR( 'U', N, 0, N, 0, S, RWORK( IE ), CDUM,
11638     $                            1, WORK( IR ), LDWRKR, CDUM, 1,
11639     $                            RWORK( IRWORK ), INFO )
11640*
11641*                    Multiply Q in A by left singular vectors of R in
11642*                    WORK(IR), storing result in U
11643*                    (CWorkspace: need N*N)
11644*                    (RWorkspace: 0)
11645*
11646                     CALL ZGEMM( 'N', 'N', M, N, N, CONE, A, LDA,
11647     $                           WORK( IR ), LDWRKR, CZERO, U, LDU )
11648*
11649                  ELSE
11650*
11651*                    Insufficient workspace for a fast algorithm
11652*
11653                     ITAU = 1
11654                     IWORK = ITAU + N
11655*
11656*                    Compute A=Q*R, copying result to U
11657*                    (CWorkspace: need 2*N, prefer N+N*NB)
11658*                    (RWorkspace: 0)
11659*
11660                     CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
11661     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
11662                     CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
11663*
11664*                    Generate Q in U
11665*                    (CWorkspace: need 2*N, prefer N+N*NB)
11666*                    (RWorkspace: 0)
11667*
11668                     CALL ZUNGQR( M, N, N, U, LDU, WORK( ITAU ),
11669     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
11670                     IE = 1
11671                     ITAUQ = ITAU
11672                     ITAUP = ITAUQ + N
11673                     IWORK = ITAUP + N
11674*
11675*                    Zero out below R in A
11676*
11677                     IF( N .GT. 1 ) THEN
11678                        CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
11679     $                               A( 2, 1 ), LDA )
11680                     END IF
11681*
11682*                    Bidiagonalize R in A
11683*                    (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
11684*                    (RWorkspace: need N)
11685*
11686                     CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ),
11687     $                            WORK( ITAUQ ), WORK( ITAUP ),
11688     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
11689*
11690*                    Multiply Q in U by left vectors bidiagonalizing R
11691*                    (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
11692*                    (RWorkspace: 0)
11693*
11694                     CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
11695     $                            WORK( ITAUQ ), U, LDU, WORK( IWORK ),
11696     $                            LWORK-IWORK+1, IERR )
11697                     IRWORK = IE + N
11698*
11699*                    Perform bidiagonal QR iteration, computing left
11700*                    singular vectors of A in U
11701*                    (CWorkspace: 0)
11702*                    (RWorkspace: need BDSPAC)
11703*
11704                     CALL ZBDSQR( 'U', N, 0, M, 0, S, RWORK( IE ), CDUM,
11705     $                            1, U, LDU, CDUM, 1, RWORK( IRWORK ),
11706     $                            INFO )
11707*
11708                  END IF
11709*
11710               ELSE IF( WNTVO ) THEN
11711*
11712*                 Path 5 (M much larger than N, JOBU='S', JOBVT='O')
11713*                 N left singular vectors to be computed in U and
11714*                 N right singular vectors to be overwritten on A
11715*
11716                  IF( LWORK.GE.2*N*N+3*N ) THEN
11717*
11718*                    Sufficient workspace for a fast algorithm
11719*
11720                     IU = 1
11721                     IF( LWORK.GE.WRKBL+2*LDA*N ) THEN
11722*
11723*                       WORK(IU) is LDA by N and WORK(IR) is LDA by N
11724*
11725                        LDWRKU = LDA
11726                        IR = IU + LDWRKU*N
11727                        LDWRKR = LDA
11728                     ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN
11729*
11730*                       WORK(IU) is LDA by N and WORK(IR) is N by N
11731*
11732                        LDWRKU = LDA
11733                        IR = IU + LDWRKU*N
11734                        LDWRKR = N
11735                     ELSE
11736*
11737*                       WORK(IU) is N by N and WORK(IR) is N by N
11738*
11739                        LDWRKU = N
11740                        IR = IU + LDWRKU*N
11741                        LDWRKR = N
11742                     END IF
11743                     ITAU = IR + LDWRKR*N
11744                     IWORK = ITAU + N
11745*
11746*                    Compute A=Q*R
11747*                    (CWorkspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
11748*                    (RWorkspace: 0)
11749*
11750                     CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
11751     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
11752*
11753*                    Copy R to WORK(IU), zeroing out below it
11754*
11755                     CALL ZLACPY( 'U', N, N, A, LDA, WORK( IU ),
11756     $                            LDWRKU )
11757                     CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
11758     $                            WORK( IU+1 ), LDWRKU )
11759*
11760*                    Generate Q in A
11761*                    (CWorkspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
11762*                    (RWorkspace: 0)
11763*
11764                     CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ),
11765     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
11766                     IE = 1
11767                     ITAUQ = ITAU
11768                     ITAUP = ITAUQ + N
11769                     IWORK = ITAUP + N
11770*
11771*                    Bidiagonalize R in WORK(IU), copying result to
11772*                    WORK(IR)
11773*                    (CWorkspace: need   2*N*N+3*N,
11774*                                 prefer 2*N*N+2*N+2*N*NB)
11775*                    (RWorkspace: need   N)
11776*
11777                     CALL ZGEBRD( N, N, WORK( IU ), LDWRKU, S,
11778     $                            RWORK( IE ), WORK( ITAUQ ),
11779     $                            WORK( ITAUP ), WORK( IWORK ),
11780     $                            LWORK-IWORK+1, IERR )
11781                     CALL ZLACPY( 'U', N, N, WORK( IU ), LDWRKU,
11782     $                            WORK( IR ), LDWRKR )
11783*
11784*                    Generate left bidiagonalizing vectors in WORK(IU)
11785*                    (CWorkspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB)
11786*                    (RWorkspace: 0)
11787*
11788                     CALL ZUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
11789     $                            WORK( ITAUQ ), WORK( IWORK ),
11790     $                            LWORK-IWORK+1, IERR )
11791*
11792*                    Generate right bidiagonalizing vectors in WORK(IR)
11793*                    (CWorkspace: need   2*N*N+3*N-1,
11794*                                 prefer 2*N*N+2*N+(N-1)*NB)
11795*                    (RWorkspace: 0)
11796*
11797                     CALL ZUNGBR( 'P', N, N, N, WORK( IR ), LDWRKR,
11798     $                            WORK( ITAUP ), WORK( IWORK ),
11799     $                            LWORK-IWORK+1, IERR )
11800                     IRWORK = IE + N
11801*
11802*                    Perform bidiagonal QR iteration, computing left
11803*                    singular vectors of R in WORK(IU) and computing
11804*                    right singular vectors of R in WORK(IR)
11805*                    (CWorkspace: need 2*N*N)
11806*                    (RWorkspace: need BDSPAC)
11807*
11808                     CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ),
11809     $                            WORK( IR ), LDWRKR, WORK( IU ),
11810     $                            LDWRKU, CDUM, 1, RWORK( IRWORK ),
11811     $                            INFO )
11812*
11813*                    Multiply Q in A by left singular vectors of R in
11814*                    WORK(IU), storing result in U
11815*                    (CWorkspace: need N*N)
11816*                    (RWorkspace: 0)
11817*
11818                     CALL ZGEMM( 'N', 'N', M, N, N, CONE, A, LDA,
11819     $                           WORK( IU ), LDWRKU, CZERO, U, LDU )
11820*
11821*                    Copy right singular vectors of R to A
11822*                    (CWorkspace: need N*N)
11823*                    (RWorkspace: 0)
11824*
11825                     CALL ZLACPY( 'F', N, N, WORK( IR ), LDWRKR, A,
11826     $                            LDA )
11827*
11828                  ELSE
11829*
11830*                    Insufficient workspace for a fast algorithm
11831*
11832                     ITAU = 1
11833                     IWORK = ITAU + N
11834*
11835*                    Compute A=Q*R, copying result to U
11836*                    (CWorkspace: need 2*N, prefer N+N*NB)
11837*                    (RWorkspace: 0)
11838*
11839                     CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
11840     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
11841                     CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
11842*
11843*                    Generate Q in U
11844*                    (CWorkspace: need 2*N, prefer N+N*NB)
11845*                    (RWorkspace: 0)
11846*
11847                     CALL ZUNGQR( M, N, N, U, LDU, WORK( ITAU ),
11848     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
11849                     IE = 1
11850                     ITAUQ = ITAU
11851                     ITAUP = ITAUQ + N
11852                     IWORK = ITAUP + N
11853*
11854*                    Zero out below R in A
11855*
11856                     IF( N .GT. 1 ) THEN
11857                        CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
11858     $                               A( 2, 1 ), LDA )
11859                     END IF
11860*
11861*                    Bidiagonalize R in A
11862*                    (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
11863*                    (RWorkspace: need N)
11864*
11865                     CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ),
11866     $                            WORK( ITAUQ ), WORK( ITAUP ),
11867     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
11868*
11869*                    Multiply Q in U by left vectors bidiagonalizing R
11870*                    (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
11871*                    (RWorkspace: 0)
11872*
11873                     CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
11874     $                            WORK( ITAUQ ), U, LDU, WORK( IWORK ),
11875     $                            LWORK-IWORK+1, IERR )
11876*
11877*                    Generate right vectors bidiagonalizing R in A
11878*                    (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
11879*                    (RWorkspace: 0)
11880*
11881                     CALL ZUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
11882     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
11883                     IRWORK = IE + N
11884*
11885*                    Perform bidiagonal QR iteration, computing left
11886*                    singular vectors of A in U and computing right
11887*                    singular vectors of A in A
11888*                    (CWorkspace: 0)
11889*                    (RWorkspace: need BDSPAC)
11890*
11891                     CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), A,
11892     $                            LDA, U, LDU, CDUM, 1, RWORK( IRWORK ),
11893     $                            INFO )
11894*
11895                  END IF
11896*
11897               ELSE IF( WNTVAS ) THEN
11898*
11899*                 Path 6 (M much larger than N, JOBU='S', JOBVT='S'
11900*                         or 'A')
11901*                 N left singular vectors to be computed in U and
11902*                 N right singular vectors to be computed in VT
11903*
11904                  IF( LWORK.GE.N*N+3*N ) THEN
11905*
11906*                    Sufficient workspace for a fast algorithm
11907*
11908                     IU = 1
11909                     IF( LWORK.GE.WRKBL+LDA*N ) THEN
11910*
11911*                       WORK(IU) is LDA by N
11912*
11913                        LDWRKU = LDA
11914                     ELSE
11915*
11916*                       WORK(IU) is N by N
11917*
11918                        LDWRKU = N
11919                     END IF
11920                     ITAU = IU + LDWRKU*N
11921                     IWORK = ITAU + N
11922*
11923*                    Compute A=Q*R
11924*                    (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
11925*                    (RWorkspace: 0)
11926*
11927                     CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
11928     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
11929*
11930*                    Copy R to WORK(IU), zeroing out below it
11931*
11932                     CALL ZLACPY( 'U', N, N, A, LDA, WORK( IU ),
11933     $                            LDWRKU )
11934                     CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
11935     $                            WORK( IU+1 ), LDWRKU )
11936*
11937*                    Generate Q in A
11938*                    (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
11939*                    (RWorkspace: 0)
11940*
11941                     CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ),
11942     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
11943                     IE = 1
11944                     ITAUQ = ITAU
11945                     ITAUP = ITAUQ + N
11946                     IWORK = ITAUP + N
11947*
11948*                    Bidiagonalize R in WORK(IU), copying result to VT
11949*                    (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB)
11950*                    (RWorkspace: need N)
11951*
11952                     CALL ZGEBRD( N, N, WORK( IU ), LDWRKU, S,
11953     $                            RWORK( IE ), WORK( ITAUQ ),
11954     $                            WORK( ITAUP ), WORK( IWORK ),
11955     $                            LWORK-IWORK+1, IERR )
11956                     CALL ZLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT,
11957     $                            LDVT )
11958*
11959*                    Generate left bidiagonalizing vectors in WORK(IU)
11960*                    (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
11961*                    (RWorkspace: 0)
11962*
11963                     CALL ZUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
11964     $                            WORK( ITAUQ ), WORK( IWORK ),
11965     $                            LWORK-IWORK+1, IERR )
11966*
11967*                    Generate right bidiagonalizing vectors in VT
11968*                    (CWorkspace: need   N*N+3*N-1,
11969*                                 prefer N*N+2*N+(N-1)*NB)
11970*                    (RWorkspace: 0)
11971*
11972                     CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
11973     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
11974                     IRWORK = IE + N
11975*
11976*                    Perform bidiagonal QR iteration, computing left
11977*                    singular vectors of R in WORK(IU) and computing
11978*                    right singular vectors of R in VT
11979*                    (CWorkspace: need N*N)
11980*                    (RWorkspace: need BDSPAC)
11981*
11982                     CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ), VT,
11983     $                            LDVT, WORK( IU ), LDWRKU, CDUM, 1,
11984     $                            RWORK( IRWORK ), INFO )
11985*
11986*                    Multiply Q in A by left singular vectors of R in
11987*                    WORK(IU), storing result in U
11988*                    (CWorkspace: need N*N)
11989*                    (RWorkspace: 0)
11990*
11991                     CALL ZGEMM( 'N', 'N', M, N, N, CONE, A, LDA,
11992     $                           WORK( IU ), LDWRKU, CZERO, U, LDU )
11993*
11994                  ELSE
11995*
11996*                    Insufficient workspace for a fast algorithm
11997*
11998                     ITAU = 1
11999                     IWORK = ITAU + N
12000*
12001*                    Compute A=Q*R, copying result to U
12002*                    (CWorkspace: need 2*N, prefer N+N*NB)
12003*                    (RWorkspace: 0)
12004*
12005                     CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
12006     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
12007                     CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
12008*
12009*                    Generate Q in U
12010*                    (CWorkspace: need 2*N, prefer N+N*NB)
12011*                    (RWorkspace: 0)
12012*
12013                     CALL ZUNGQR( M, N, N, U, LDU, WORK( ITAU ),
12014     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
12015*
12016*                    Copy R to VT, zeroing out below it
12017*
12018                     CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT )
12019                     IF( N.GT.1 )
12020     $                  CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
12021     $                               VT( 2, 1 ), LDVT )
12022                     IE = 1
12023                     ITAUQ = ITAU
12024                     ITAUP = ITAUQ + N
12025                     IWORK = ITAUP + N
12026*
12027*                    Bidiagonalize R in VT
12028*                    (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
12029*                    (RWorkspace: need N)
12030*
12031                     CALL ZGEBRD( N, N, VT, LDVT, S, RWORK( IE ),
12032     $                            WORK( ITAUQ ), WORK( ITAUP ),
12033     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
12034*
12035*                    Multiply Q in U by left bidiagonalizing vectors
12036*                    in VT
12037*                    (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
12038*                    (RWorkspace: 0)
12039*
12040                     CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
12041     $                            WORK( ITAUQ ), U, LDU, WORK( IWORK ),
12042     $                            LWORK-IWORK+1, IERR )
12043*
12044*                    Generate right bidiagonalizing vectors in VT
12045*                    (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
12046*                    (RWorkspace: 0)
12047*
12048                     CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
12049     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
12050                     IRWORK = IE + N
12051*
12052*                    Perform bidiagonal QR iteration, computing left
12053*                    singular vectors of A in U and computing right
12054*                    singular vectors of A in VT
12055*                    (CWorkspace: 0)
12056*                    (RWorkspace: need BDSPAC)
12057*
12058                     CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), VT,
12059     $                            LDVT, U, LDU, CDUM, 1,
12060     $                            RWORK( IRWORK ), INFO )
12061*
12062                  END IF
12063*
12064               END IF
12065*
12066            ELSE IF( WNTUA ) THEN
12067*
12068               IF( WNTVN ) THEN
12069*
12070*                 Path 7 (M much larger than N, JOBU='A', JOBVT='N')
12071*                 M left singular vectors to be computed in U and
12072*                 no right singular vectors to be computed
12073*
12074                  IF( LWORK.GE.N*N+MAX( N+M, 3*N ) ) THEN
12075*
12076*                    Sufficient workspace for a fast algorithm
12077*
12078                     IR = 1
12079                     IF( LWORK.GE.WRKBL+LDA*N ) THEN
12080*
12081*                       WORK(IR) is LDA by N
12082*
12083                        LDWRKR = LDA
12084                     ELSE
12085*
12086*                       WORK(IR) is N by N
12087*
12088                        LDWRKR = N
12089                     END IF
12090                     ITAU = IR + LDWRKR*N
12091                     IWORK = ITAU + N
12092*
12093*                    Compute A=Q*R, copying result to U
12094*                    (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
12095*                    (RWorkspace: 0)
12096*
12097                     CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
12098     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
12099                     CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
12100*
12101*                    Copy R to WORK(IR), zeroing out below it
12102*
12103                     CALL ZLACPY( 'U', N, N, A, LDA, WORK( IR ),
12104     $                            LDWRKR )
12105                     CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
12106     $                            WORK( IR+1 ), LDWRKR )
12107*
12108*                    Generate Q in U
12109*                    (CWorkspace: need N*N+N+M, prefer N*N+N+M*NB)
12110*                    (RWorkspace: 0)
12111*
12112                     CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ),
12113     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
12114                     IE = 1
12115                     ITAUQ = ITAU
12116                     ITAUP = ITAUQ + N
12117                     IWORK = ITAUP + N
12118*
12119*                    Bidiagonalize R in WORK(IR)
12120*                    (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB)
12121*                    (RWorkspace: need N)
12122*
12123                     CALL ZGEBRD( N, N, WORK( IR ), LDWRKR, S,
12124     $                            RWORK( IE ), WORK( ITAUQ ),
12125     $                            WORK( ITAUP ), WORK( IWORK ),
12126     $                            LWORK-IWORK+1, IERR )
12127*
12128*                    Generate left bidiagonalizing vectors in WORK(IR)
12129*                    (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
12130*                    (RWorkspace: 0)
12131*
12132                     CALL ZUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
12133     $                            WORK( ITAUQ ), WORK( IWORK ),
12134     $                            LWORK-IWORK+1, IERR )
12135                     IRWORK = IE + N
12136*
12137*                    Perform bidiagonal QR iteration, computing left
12138*                    singular vectors of R in WORK(IR)
12139*                    (CWorkspace: need N*N)
12140*                    (RWorkspace: need BDSPAC)
12141*
12142                     CALL ZBDSQR( 'U', N, 0, N, 0, S, RWORK( IE ), CDUM,
12143     $                            1, WORK( IR ), LDWRKR, CDUM, 1,
12144     $                            RWORK( IRWORK ), INFO )
12145*
12146*                    Multiply Q in U by left singular vectors of R in
12147*                    WORK(IR), storing result in A
12148*                    (CWorkspace: need N*N)
12149*                    (RWorkspace: 0)
12150*
12151                     CALL ZGEMM( 'N', 'N', M, N, N, CONE, U, LDU,
12152     $                           WORK( IR ), LDWRKR, CZERO, A, LDA )
12153*
12154*                    Copy left singular vectors of A from A to U
12155*
12156                     CALL ZLACPY( 'F', M, N, A, LDA, U, LDU )
12157*
12158                  ELSE
12159*
12160*                    Insufficient workspace for a fast algorithm
12161*
12162                     ITAU = 1
12163                     IWORK = ITAU + N
12164*
12165*                    Compute A=Q*R, copying result to U
12166*                    (CWorkspace: need 2*N, prefer N+N*NB)
12167*                    (RWorkspace: 0)
12168*
12169                     CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
12170     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
12171                     CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
12172*
12173*                    Generate Q in U
12174*                    (CWorkspace: need N+M, prefer N+M*NB)
12175*                    (RWorkspace: 0)
12176*
12177                     CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ),
12178     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
12179                     IE = 1
12180                     ITAUQ = ITAU
12181                     ITAUP = ITAUQ + N
12182                     IWORK = ITAUP + N
12183*
12184*                    Zero out below R in A
12185*
12186                     IF( N .GT. 1 ) THEN
12187                        CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
12188     $                               A( 2, 1 ), LDA )
12189                     END IF
12190*
12191*                    Bidiagonalize R in A
12192*                    (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
12193*                    (RWorkspace: need N)
12194*
12195                     CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ),
12196     $                            WORK( ITAUQ ), WORK( ITAUP ),
12197     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
12198*
12199*                    Multiply Q in U by left bidiagonalizing vectors
12200*                    in A
12201*                    (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
12202*                    (RWorkspace: 0)
12203*
12204                     CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
12205     $                            WORK( ITAUQ ), U, LDU, WORK( IWORK ),
12206     $                            LWORK-IWORK+1, IERR )
12207                     IRWORK = IE + N
12208*
12209*                    Perform bidiagonal QR iteration, computing left
12210*                    singular vectors of A in U
12211*                    (CWorkspace: 0)
12212*                    (RWorkspace: need BDSPAC)
12213*
12214                     CALL ZBDSQR( 'U', N, 0, M, 0, S, RWORK( IE ), CDUM,
12215     $                            1, U, LDU, CDUM, 1, RWORK( IRWORK ),
12216     $                            INFO )
12217*
12218                  END IF
12219*
12220               ELSE IF( WNTVO ) THEN
12221*
12222*                 Path 8 (M much larger than N, JOBU='A', JOBVT='O')
12223*                 M left singular vectors to be computed in U and
12224*                 N right singular vectors to be overwritten on A
12225*
12226                  IF( LWORK.GE.2*N*N+MAX( N+M, 3*N ) ) THEN
12227*
12228*                    Sufficient workspace for a fast algorithm
12229*
12230                     IU = 1
12231                     IF( LWORK.GE.WRKBL+2*LDA*N ) THEN
12232*
12233*                       WORK(IU) is LDA by N and WORK(IR) is LDA by N
12234*
12235                        LDWRKU = LDA
12236                        IR = IU + LDWRKU*N
12237                        LDWRKR = LDA
12238                     ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN
12239*
12240*                       WORK(IU) is LDA by N and WORK(IR) is N by N
12241*
12242                        LDWRKU = LDA
12243                        IR = IU + LDWRKU*N
12244                        LDWRKR = N
12245                     ELSE
12246*
12247*                       WORK(IU) is N by N and WORK(IR) is N by N
12248*
12249                        LDWRKU = N
12250                        IR = IU + LDWRKU*N
12251                        LDWRKR = N
12252                     END IF
12253                     ITAU = IR + LDWRKR*N
12254                     IWORK = ITAU + N
12255*
12256*                    Compute A=Q*R, copying result to U
12257*                    (CWorkspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
12258*                    (RWorkspace: 0)
12259*
12260                     CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
12261     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
12262                     CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
12263*
12264*                    Generate Q in U
12265*                    (CWorkspace: need 2*N*N+N+M, prefer 2*N*N+N+M*NB)
12266*                    (RWorkspace: 0)
12267*
12268                     CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ),
12269     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
12270*
12271*                    Copy R to WORK(IU), zeroing out below it
12272*
12273                     CALL ZLACPY( 'U', N, N, A, LDA, WORK( IU ),
12274     $                            LDWRKU )
12275                     CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
12276     $                            WORK( IU+1 ), LDWRKU )
12277                     IE = 1
12278                     ITAUQ = ITAU
12279                     ITAUP = ITAUQ + N
12280                     IWORK = ITAUP + N
12281*
12282*                    Bidiagonalize R in WORK(IU), copying result to
12283*                    WORK(IR)
12284*                    (CWorkspace: need   2*N*N+3*N,
12285*                                 prefer 2*N*N+2*N+2*N*NB)
12286*                    (RWorkspace: need   N)
12287*
12288                     CALL ZGEBRD( N, N, WORK( IU ), LDWRKU, S,
12289     $                            RWORK( IE ), WORK( ITAUQ ),
12290     $                            WORK( ITAUP ), WORK( IWORK ),
12291     $                            LWORK-IWORK+1, IERR )
12292                     CALL ZLACPY( 'U', N, N, WORK( IU ), LDWRKU,
12293     $                            WORK( IR ), LDWRKR )
12294*
12295*                    Generate left bidiagonalizing vectors in WORK(IU)
12296*                    (CWorkspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB)
12297*                    (RWorkspace: 0)
12298*
12299                     CALL ZUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
12300     $                            WORK( ITAUQ ), WORK( IWORK ),
12301     $                            LWORK-IWORK+1, IERR )
12302*
12303*                    Generate right bidiagonalizing vectors in WORK(IR)
12304*                    (CWorkspace: need   2*N*N+3*N-1,
12305*                                 prefer 2*N*N+2*N+(N-1)*NB)
12306*                    (RWorkspace: 0)
12307*
12308                     CALL ZUNGBR( 'P', N, N, N, WORK( IR ), LDWRKR,
12309     $                            WORK( ITAUP ), WORK( IWORK ),
12310     $                            LWORK-IWORK+1, IERR )
12311                     IRWORK = IE + N
12312*
12313*                    Perform bidiagonal QR iteration, computing left
12314*                    singular vectors of R in WORK(IU) and computing
12315*                    right singular vectors of R in WORK(IR)
12316*                    (CWorkspace: need 2*N*N)
12317*                    (RWorkspace: need BDSPAC)
12318*
12319                     CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ),
12320     $                            WORK( IR ), LDWRKR, WORK( IU ),
12321     $                            LDWRKU, CDUM, 1, RWORK( IRWORK ),
12322     $                            INFO )
12323*
12324*                    Multiply Q in U by left singular vectors of R in
12325*                    WORK(IU), storing result in A
12326*                    (CWorkspace: need N*N)
12327*                    (RWorkspace: 0)
12328*
12329                     CALL ZGEMM( 'N', 'N', M, N, N, CONE, U, LDU,
12330     $                           WORK( IU ), LDWRKU, CZERO, A, LDA )
12331*
12332*                    Copy left singular vectors of A from A to U
12333*
12334                     CALL ZLACPY( 'F', M, N, A, LDA, U, LDU )
12335*
12336*                    Copy right singular vectors of R from WORK(IR) to A
12337*
12338                     CALL ZLACPY( 'F', N, N, WORK( IR ), LDWRKR, A,
12339     $                            LDA )
12340*
12341                  ELSE
12342*
12343*                    Insufficient workspace for a fast algorithm
12344*
12345                     ITAU = 1
12346                     IWORK = ITAU + N
12347*
12348*                    Compute A=Q*R, copying result to U
12349*                    (CWorkspace: need 2*N, prefer N+N*NB)
12350*                    (RWorkspace: 0)
12351*
12352                     CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
12353     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
12354                     CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
12355*
12356*                    Generate Q in U
12357*                    (CWorkspace: need N+M, prefer N+M*NB)
12358*                    (RWorkspace: 0)
12359*
12360                     CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ),
12361     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
12362                     IE = 1
12363                     ITAUQ = ITAU
12364                     ITAUP = ITAUQ + N
12365                     IWORK = ITAUP + N
12366*
12367*                    Zero out below R in A
12368*
12369                     IF( N .GT. 1 ) THEN
12370                        CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
12371     $                               A( 2, 1 ), LDA )
12372                     END IF
12373*
12374*                    Bidiagonalize R in A
12375*                    (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
12376*                    (RWorkspace: need N)
12377*
12378                     CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ),
12379     $                            WORK( ITAUQ ), WORK( ITAUP ),
12380     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
12381*
12382*                    Multiply Q in U by left bidiagonalizing vectors
12383*                    in A
12384*                    (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
12385*                    (RWorkspace: 0)
12386*
12387                     CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
12388     $                            WORK( ITAUQ ), U, LDU, WORK( IWORK ),
12389     $                            LWORK-IWORK+1, IERR )
12390*
12391*                    Generate right bidiagonalizing vectors in A
12392*                    (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
12393*                    (RWorkspace: 0)
12394*
12395                     CALL ZUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
12396     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
12397                     IRWORK = IE + N
12398*
12399*                    Perform bidiagonal QR iteration, computing left
12400*                    singular vectors of A in U and computing right
12401*                    singular vectors of A in A
12402*                    (CWorkspace: 0)
12403*                    (RWorkspace: need BDSPAC)
12404*
12405                     CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), A,
12406     $                            LDA, U, LDU, CDUM, 1, RWORK( IRWORK ),
12407     $                            INFO )
12408*
12409                  END IF
12410*
12411               ELSE IF( WNTVAS ) THEN
12412*
12413*                 Path 9 (M much larger than N, JOBU='A', JOBVT='S'
12414*                         or 'A')
12415*                 M left singular vectors to be computed in U and
12416*                 N right singular vectors to be computed in VT
12417*
12418                  IF( LWORK.GE.N*N+MAX( N+M, 3*N ) ) THEN
12419*
12420*                    Sufficient workspace for a fast algorithm
12421*
12422                     IU = 1
12423                     IF( LWORK.GE.WRKBL+LDA*N ) THEN
12424*
12425*                       WORK(IU) is LDA by N
12426*
12427                        LDWRKU = LDA
12428                     ELSE
12429*
12430*                       WORK(IU) is N by N
12431*
12432                        LDWRKU = N
12433                     END IF
12434                     ITAU = IU + LDWRKU*N
12435                     IWORK = ITAU + N
12436*
12437*                    Compute A=Q*R, copying result to U
12438*                    (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
12439*                    (RWorkspace: 0)
12440*
12441                     CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
12442     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
12443                     CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
12444*
12445*                    Generate Q in U
12446*                    (CWorkspace: need N*N+N+M, prefer N*N+N+M*NB)
12447*                    (RWorkspace: 0)
12448*
12449                     CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ),
12450     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
12451*
12452*                    Copy R to WORK(IU), zeroing out below it
12453*
12454                     CALL ZLACPY( 'U', N, N, A, LDA, WORK( IU ),
12455     $                            LDWRKU )
12456                     CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
12457     $                            WORK( IU+1 ), LDWRKU )
12458                     IE = 1
12459                     ITAUQ = ITAU
12460                     ITAUP = ITAUQ + N
12461                     IWORK = ITAUP + N
12462*
12463*                    Bidiagonalize R in WORK(IU), copying result to VT
12464*                    (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB)
12465*                    (RWorkspace: need N)
12466*
12467                     CALL ZGEBRD( N, N, WORK( IU ), LDWRKU, S,
12468     $                            RWORK( IE ), WORK( ITAUQ ),
12469     $                            WORK( ITAUP ), WORK( IWORK ),
12470     $                            LWORK-IWORK+1, IERR )
12471                     CALL ZLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT,
12472     $                            LDVT )
12473*
12474*                    Generate left bidiagonalizing vectors in WORK(IU)
12475*                    (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
12476*                    (RWorkspace: 0)
12477*
12478                     CALL ZUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
12479     $                            WORK( ITAUQ ), WORK( IWORK ),
12480     $                            LWORK-IWORK+1, IERR )
12481*
12482*                    Generate right bidiagonalizing vectors in VT
12483*                    (CWorkspace: need   N*N+3*N-1,
12484*                                 prefer N*N+2*N+(N-1)*NB)
12485*                    (RWorkspace: need   0)
12486*
12487                     CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
12488     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
12489                     IRWORK = IE + N
12490*
12491*                    Perform bidiagonal QR iteration, computing left
12492*                    singular vectors of R in WORK(IU) and computing
12493*                    right singular vectors of R in VT
12494*                    (CWorkspace: need N*N)
12495*                    (RWorkspace: need BDSPAC)
12496*
12497                     CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ), VT,
12498     $                            LDVT, WORK( IU ), LDWRKU, CDUM, 1,
12499     $                            RWORK( IRWORK ), INFO )
12500*
12501*                    Multiply Q in U by left singular vectors of R in
12502*                    WORK(IU), storing result in A
12503*                    (CWorkspace: need N*N)
12504*                    (RWorkspace: 0)
12505*
12506                     CALL ZGEMM( 'N', 'N', M, N, N, CONE, U, LDU,
12507     $                           WORK( IU ), LDWRKU, CZERO, A, LDA )
12508*
12509*                    Copy left singular vectors of A from A to U
12510*
12511                     CALL ZLACPY( 'F', M, N, A, LDA, U, LDU )
12512*
12513                  ELSE
12514*
12515*                    Insufficient workspace for a fast algorithm
12516*
12517                     ITAU = 1
12518                     IWORK = ITAU + N
12519*
12520*                    Compute A=Q*R, copying result to U
12521*                    (CWorkspace: need 2*N, prefer N+N*NB)
12522*                    (RWorkspace: 0)
12523*
12524                     CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
12525     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
12526                     CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
12527*
12528*                    Generate Q in U
12529*                    (CWorkspace: need N+M, prefer N+M*NB)
12530*                    (RWorkspace: 0)
12531*
12532                     CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ),
12533     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
12534*
12535*                    Copy R from A to VT, zeroing out below it
12536*
12537                     CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT )
12538                     IF( N.GT.1 )
12539     $                  CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
12540     $                               VT( 2, 1 ), LDVT )
12541                     IE = 1
12542                     ITAUQ = ITAU
12543                     ITAUP = ITAUQ + N
12544                     IWORK = ITAUP + N
12545*
12546*                    Bidiagonalize R in VT
12547*                    (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
12548*                    (RWorkspace: need N)
12549*
12550                     CALL ZGEBRD( N, N, VT, LDVT, S, RWORK( IE ),
12551     $                            WORK( ITAUQ ), WORK( ITAUP ),
12552     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
12553*
12554*                    Multiply Q in U by left bidiagonalizing vectors
12555*                    in VT
12556*                    (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
12557*                    (RWorkspace: 0)
12558*
12559                     CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
12560     $                            WORK( ITAUQ ), U, LDU, WORK( IWORK ),
12561     $                            LWORK-IWORK+1, IERR )
12562*
12563*                    Generate right bidiagonalizing vectors in VT
12564*                    (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
12565*                    (RWorkspace: 0)
12566*
12567                     CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
12568     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
12569                     IRWORK = IE + N
12570*
12571*                    Perform bidiagonal QR iteration, computing left
12572*                    singular vectors of A in U and computing right
12573*                    singular vectors of A in VT
12574*                    (CWorkspace: 0)
12575*                    (RWorkspace: need BDSPAC)
12576*
12577                     CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), VT,
12578     $                            LDVT, U, LDU, CDUM, 1,
12579     $                            RWORK( IRWORK ), INFO )
12580*
12581                  END IF
12582*
12583               END IF
12584*
12585            END IF
12586*
12587         ELSE
12588*
12589*           M .LT. MNTHR
12590*
12591*           Path 10 (M at least N, but not much larger)
12592*           Reduce to bidiagonal form without QR decomposition
12593*
12594            IE = 1
12595            ITAUQ = 1
12596            ITAUP = ITAUQ + N
12597            IWORK = ITAUP + N
12598*
12599*           Bidiagonalize A
12600*           (CWorkspace: need 2*N+M, prefer 2*N+(M+N)*NB)
12601*           (RWorkspace: need N)
12602*
12603            CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
12604     $                   WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
12605     $                   IERR )
12606            IF( WNTUAS ) THEN
12607*
12608*              If left singular vectors desired in U, copy result to U
12609*              and generate left bidiagonalizing vectors in U
12610*              (CWorkspace: need 2*N+NCU, prefer 2*N+NCU*NB)
12611*              (RWorkspace: 0)
12612*
12613               CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
12614               IF( WNTUS )
12615     $            NCU = N
12616               IF( WNTUA )
12617     $            NCU = M
12618               CALL ZUNGBR( 'Q', M, NCU, N, U, LDU, WORK( ITAUQ ),
12619     $                      WORK( IWORK ), LWORK-IWORK+1, IERR )
12620            END IF
12621            IF( WNTVAS ) THEN
12622*
12623*              If right singular vectors desired in VT, copy result to
12624*              VT and generate right bidiagonalizing vectors in VT
12625*              (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
12626*              (RWorkspace: 0)
12627*
12628               CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT )
12629               CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
12630     $                      WORK( IWORK ), LWORK-IWORK+1, IERR )
12631            END IF
12632            IF( WNTUO ) THEN
12633*
12634*              If left singular vectors desired in A, generate left
12635*              bidiagonalizing vectors in A
12636*              (CWorkspace: need 3*N, prefer 2*N+N*NB)
12637*              (RWorkspace: 0)
12638*
12639               CALL ZUNGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
12640     $                      WORK( IWORK ), LWORK-IWORK+1, IERR )
12641            END IF
12642            IF( WNTVO ) THEN
12643*
12644*              If right singular vectors desired in A, generate right
12645*              bidiagonalizing vectors in A
12646*              (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
12647*              (RWorkspace: 0)
12648*
12649               CALL ZUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
12650     $                      WORK( IWORK ), LWORK-IWORK+1, IERR )
12651            END IF
12652            IRWORK = IE + N
12653            IF( WNTUAS .OR. WNTUO )
12654     $         NRU = M
12655            IF( WNTUN )
12656     $         NRU = 0
12657            IF( WNTVAS .OR. WNTVO )
12658     $         NCVT = N
12659            IF( WNTVN )
12660     $         NCVT = 0
12661            IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN
12662*
12663*              Perform bidiagonal QR iteration, if desired, computing
12664*              left singular vectors in U and computing right singular
12665*              vectors in VT
12666*              (CWorkspace: 0)
12667*              (RWorkspace: need BDSPAC)
12668*
12669               CALL ZBDSQR( 'U', N, NCVT, NRU, 0, S, RWORK( IE ), VT,
12670     $                      LDVT, U, LDU, CDUM, 1, RWORK( IRWORK ),
12671     $                      INFO )
12672            ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN
12673*
12674*              Perform bidiagonal QR iteration, if desired, computing
12675*              left singular vectors in U and computing right singular
12676*              vectors in A
12677*              (CWorkspace: 0)
12678*              (RWorkspace: need BDSPAC)
12679*
12680               CALL ZBDSQR( 'U', N, NCVT, NRU, 0, S, RWORK( IE ), A,
12681     $                      LDA, U, LDU, CDUM, 1, RWORK( IRWORK ),
12682     $                      INFO )
12683            ELSE
12684*
12685*              Perform bidiagonal QR iteration, if desired, computing
12686*              left singular vectors in A and computing right singular
12687*              vectors in VT
12688*              (CWorkspace: 0)
12689*              (RWorkspace: need BDSPAC)
12690*
12691               CALL ZBDSQR( 'U', N, NCVT, NRU, 0, S, RWORK( IE ), VT,
12692     $                      LDVT, A, LDA, CDUM, 1, RWORK( IRWORK ),
12693     $                      INFO )
12694            END IF
12695*
12696         END IF
12697*
12698      ELSE
12699*
12700*        A has more columns than rows. If A has sufficiently more
12701*        columns than rows, first reduce using the LQ decomposition (if
12702*        sufficient workspace available)
12703*
12704         IF( N.GE.MNTHR ) THEN
12705*
12706            IF( WNTVN ) THEN
12707*
12708*              Path 1t(N much larger than M, JOBVT='N')
12709*              No right singular vectors to be computed
12710*
12711               ITAU = 1
12712               IWORK = ITAU + M
12713*
12714*              Compute A=L*Q
12715*              (CWorkspace: need 2*M, prefer M+M*NB)
12716*              (RWorkspace: 0)
12717*
12718               CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
12719     $                      LWORK-IWORK+1, IERR )
12720*
12721*              Zero out above L
12722*
12723               CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, A( 1, 2 ),
12724     $                      LDA )
12725               IE = 1
12726               ITAUQ = 1
12727               ITAUP = ITAUQ + M
12728               IWORK = ITAUP + M
12729*
12730*              Bidiagonalize L in A
12731*              (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
12732*              (RWorkspace: need M)
12733*
12734               CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
12735     $                      WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
12736     $                      IERR )
12737               IF( WNTUO .OR. WNTUAS ) THEN
12738*
12739*                 If left singular vectors desired, generate Q
12740*                 (CWorkspace: need 3*M, prefer 2*M+M*NB)
12741*                 (RWorkspace: 0)
12742*
12743                  CALL ZUNGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
12744     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
12745               END IF
12746               IRWORK = IE + M
12747               NRU = 0
12748               IF( WNTUO .OR. WNTUAS )
12749     $            NRU = M
12750*
12751*              Perform bidiagonal QR iteration, computing left singular
12752*              vectors of A in A if desired
12753*              (CWorkspace: 0)
12754*              (RWorkspace: need BDSPAC)
12755*
12756               CALL ZBDSQR( 'U', M, 0, NRU, 0, S, RWORK( IE ), CDUM, 1,
12757     $                      A, LDA, CDUM, 1, RWORK( IRWORK ), INFO )
12758*
12759*              If left singular vectors desired in U, copy them there
12760*
12761               IF( WNTUAS )
12762     $            CALL ZLACPY( 'F', M, M, A, LDA, U, LDU )
12763*
12764            ELSE IF( WNTVO .AND. WNTUN ) THEN
12765*
12766*              Path 2t(N much larger than M, JOBU='N', JOBVT='O')
12767*              M right singular vectors to be overwritten on A and
12768*              no left singular vectors to be computed
12769*
12770               IF( LWORK.GE.M*M+3*M ) THEN
12771*
12772*                 Sufficient workspace for a fast algorithm
12773*
12774                  IR = 1
12775                  IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*M ) THEN
12776*
12777*                    WORK(IU) is LDA by N and WORK(IR) is LDA by M
12778*
12779                     LDWRKU = LDA
12780                     CHUNK = N
12781                     LDWRKR = LDA
12782                  ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+M*M ) THEN
12783*
12784*                    WORK(IU) is LDA by N and WORK(IR) is M by M
12785*
12786                     LDWRKU = LDA
12787                     CHUNK = N
12788                     LDWRKR = M
12789                  ELSE
12790*
12791*                    WORK(IU) is M by CHUNK and WORK(IR) is M by M
12792*
12793                     LDWRKU = M
12794                     CHUNK = ( LWORK-M*M ) / M
12795                     LDWRKR = M
12796                  END IF
12797                  ITAU = IR + LDWRKR*M
12798                  IWORK = ITAU + M
12799*
12800*                 Compute A=L*Q
12801*                 (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
12802*                 (RWorkspace: 0)
12803*
12804                  CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
12805     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
12806*
12807*                 Copy L to WORK(IR) and zero out above it
12808*
12809                  CALL ZLACPY( 'L', M, M, A, LDA, WORK( IR ), LDWRKR )
12810                  CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
12811     $                         WORK( IR+LDWRKR ), LDWRKR )
12812*
12813*                 Generate Q in A
12814*                 (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
12815*                 (RWorkspace: 0)
12816*
12817                  CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
12818     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
12819                  IE = 1
12820                  ITAUQ = ITAU
12821                  ITAUP = ITAUQ + M
12822                  IWORK = ITAUP + M
12823*
12824*                 Bidiagonalize L in WORK(IR)
12825*                 (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
12826*                 (RWorkspace: need M)
12827*
12828                  CALL ZGEBRD( M, M, WORK( IR ), LDWRKR, S, RWORK( IE ),
12829     $                         WORK( ITAUQ ), WORK( ITAUP ),
12830     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
12831*
12832*                 Generate right vectors bidiagonalizing L
12833*                 (CWorkspace: need M*M+3*M-1, prefer M*M+2*M+(M-1)*NB)
12834*                 (RWorkspace: 0)
12835*
12836                  CALL ZUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
12837     $                         WORK( ITAUP ), WORK( IWORK ),
12838     $                         LWORK-IWORK+1, IERR )
12839                  IRWORK = IE + M
12840*
12841*                 Perform bidiagonal QR iteration, computing right
12842*                 singular vectors of L in WORK(IR)
12843*                 (CWorkspace: need M*M)
12844*                 (RWorkspace: need BDSPAC)
12845*
12846                  CALL ZBDSQR( 'U', M, M, 0, 0, S, RWORK( IE ),
12847     $                         WORK( IR ), LDWRKR, CDUM, 1, CDUM, 1,
12848     $                         RWORK( IRWORK ), INFO )
12849                  IU = ITAUQ
12850*
12851*                 Multiply right singular vectors of L in WORK(IR) by Q
12852*                 in A, storing result in WORK(IU) and copying to A
12853*                 (CWorkspace: need M*M+M, prefer M*M+M*N)
12854*                 (RWorkspace: 0)
12855*
12856                  DO 30 I = 1, N, CHUNK
12857                     BLK = MIN( N-I+1, CHUNK )
12858                     CALL ZGEMM( 'N', 'N', M, BLK, M, CONE, WORK( IR ),
12859     $                           LDWRKR, A( 1, I ), LDA, CZERO,
12860     $                           WORK( IU ), LDWRKU )
12861                     CALL ZLACPY( 'F', M, BLK, WORK( IU ), LDWRKU,
12862     $                            A( 1, I ), LDA )
12863   30             CONTINUE
12864*
12865               ELSE
12866*
12867*                 Insufficient workspace for a fast algorithm
12868*
12869                  IE = 1
12870                  ITAUQ = 1
12871                  ITAUP = ITAUQ + M
12872                  IWORK = ITAUP + M
12873*
12874*                 Bidiagonalize A
12875*                 (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB)
12876*                 (RWorkspace: need M)
12877*
12878                  CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ),
12879     $                         WORK( ITAUQ ), WORK( ITAUP ),
12880     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
12881*
12882*                 Generate right vectors bidiagonalizing A
12883*                 (CWorkspace: need 3*M, prefer 2*M+M*NB)
12884*                 (RWorkspace: 0)
12885*
12886                  CALL ZUNGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
12887     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
12888                  IRWORK = IE + M
12889*
12890*                 Perform bidiagonal QR iteration, computing right
12891*                 singular vectors of A in A
12892*                 (CWorkspace: 0)
12893*                 (RWorkspace: need BDSPAC)
12894*
12895                  CALL ZBDSQR( 'L', M, N, 0, 0, S, RWORK( IE ), A, LDA,
12896     $                         CDUM, 1, CDUM, 1, RWORK( IRWORK ), INFO )
12897*
12898               END IF
12899*
12900            ELSE IF( WNTVO .AND. WNTUAS ) THEN
12901*
12902*              Path 3t(N much larger than M, JOBU='S' or 'A', JOBVT='O')
12903*              M right singular vectors to be overwritten on A and
12904*              M left singular vectors to be computed in U
12905*
12906               IF( LWORK.GE.M*M+3*M ) THEN
12907*
12908*                 Sufficient workspace for a fast algorithm
12909*
12910                  IR = 1
12911                  IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*M ) THEN
12912*
12913*                    WORK(IU) is LDA by N and WORK(IR) is LDA by M
12914*
12915                     LDWRKU = LDA
12916                     CHUNK = N
12917                     LDWRKR = LDA
12918                  ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+M*M ) THEN
12919*
12920*                    WORK(IU) is LDA by N and WORK(IR) is M by M
12921*
12922                     LDWRKU = LDA
12923                     CHUNK = N
12924                     LDWRKR = M
12925                  ELSE
12926*
12927*                    WORK(IU) is M by CHUNK and WORK(IR) is M by M
12928*
12929                     LDWRKU = M
12930                     CHUNK = ( LWORK-M*M ) / M
12931                     LDWRKR = M
12932                  END IF
12933                  ITAU = IR + LDWRKR*M
12934                  IWORK = ITAU + M
12935*
12936*                 Compute A=L*Q
12937*                 (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
12938*                 (RWorkspace: 0)
12939*
12940                  CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
12941     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
12942*
12943*                 Copy L to U, zeroing about above it
12944*
12945                  CALL ZLACPY( 'L', M, M, A, LDA, U, LDU )
12946                  CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, U( 1, 2 ),
12947     $                         LDU )
12948*
12949*                 Generate Q in A
12950*                 (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
12951*                 (RWorkspace: 0)
12952*
12953                  CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
12954     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
12955                  IE = 1
12956                  ITAUQ = ITAU
12957                  ITAUP = ITAUQ + M
12958                  IWORK = ITAUP + M
12959*
12960*                 Bidiagonalize L in U, copying result to WORK(IR)
12961*                 (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
12962*                 (RWorkspace: need M)
12963*
12964                  CALL ZGEBRD( M, M, U, LDU, S, RWORK( IE ),
12965     $                         WORK( ITAUQ ), WORK( ITAUP ),
12966     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
12967                  CALL ZLACPY( 'U', M, M, U, LDU, WORK( IR ), LDWRKR )
12968*
12969*                 Generate right vectors bidiagonalizing L in WORK(IR)
12970*                 (CWorkspace: need M*M+3*M-1, prefer M*M+2*M+(M-1)*NB)
12971*                 (RWorkspace: 0)
12972*
12973                  CALL ZUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
12974     $                         WORK( ITAUP ), WORK( IWORK ),
12975     $                         LWORK-IWORK+1, IERR )
12976*
12977*                 Generate left vectors bidiagonalizing L in U
12978*                 (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB)
12979*                 (RWorkspace: 0)
12980*
12981                  CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
12982     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
12983                  IRWORK = IE + M
12984*
12985*                 Perform bidiagonal QR iteration, computing left
12986*                 singular vectors of L in U, and computing right
12987*                 singular vectors of L in WORK(IR)
12988*                 (CWorkspace: need M*M)
12989*                 (RWorkspace: need BDSPAC)
12990*
12991                  CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ),
12992     $                         WORK( IR ), LDWRKR, U, LDU, CDUM, 1,
12993     $                         RWORK( IRWORK ), INFO )
12994                  IU = ITAUQ
12995*
12996*                 Multiply right singular vectors of L in WORK(IR) by Q
12997*                 in A, storing result in WORK(IU) and copying to A
12998*                 (CWorkspace: need M*M+M, prefer M*M+M*N))
12999*                 (RWorkspace: 0)
13000*
13001                  DO 40 I = 1, N, CHUNK
13002                     BLK = MIN( N-I+1, CHUNK )
13003                     CALL ZGEMM( 'N', 'N', M, BLK, M, CONE, WORK( IR ),
13004     $                           LDWRKR, A( 1, I ), LDA, CZERO,
13005     $                           WORK( IU ), LDWRKU )
13006                     CALL ZLACPY( 'F', M, BLK, WORK( IU ), LDWRKU,
13007     $                            A( 1, I ), LDA )
13008   40             CONTINUE
13009*
13010               ELSE
13011*
13012*                 Insufficient workspace for a fast algorithm
13013*
13014                  ITAU = 1
13015                  IWORK = ITAU + M
13016*
13017*                 Compute A=L*Q
13018*                 (CWorkspace: need 2*M, prefer M+M*NB)
13019*                 (RWorkspace: 0)
13020*
13021                  CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
13022     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
13023*
13024*                 Copy L to U, zeroing out above it
13025*
13026                  CALL ZLACPY( 'L', M, M, A, LDA, U, LDU )
13027                  CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, U( 1, 2 ),
13028     $                         LDU )
13029*
13030*                 Generate Q in A
13031*                 (CWorkspace: need 2*M, prefer M+M*NB)
13032*                 (RWorkspace: 0)
13033*
13034                  CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
13035     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
13036                  IE = 1
13037                  ITAUQ = ITAU
13038                  ITAUP = ITAUQ + M
13039                  IWORK = ITAUP + M
13040*
13041*                 Bidiagonalize L in U
13042*                 (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
13043*                 (RWorkspace: need M)
13044*
13045                  CALL ZGEBRD( M, M, U, LDU, S, RWORK( IE ),
13046     $                         WORK( ITAUQ ), WORK( ITAUP ),
13047     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
13048*
13049*                 Multiply right vectors bidiagonalizing L by Q in A
13050*                 (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
13051*                 (RWorkspace: 0)
13052*
13053                  CALL ZUNMBR( 'P', 'L', 'C', M, N, M, U, LDU,
13054     $                         WORK( ITAUP ), A, LDA, WORK( IWORK ),
13055     $                         LWORK-IWORK+1, IERR )
13056*
13057*                 Generate left vectors bidiagonalizing L in U
13058*                 (CWorkspace: need 3*M, prefer 2*M+M*NB)
13059*                 (RWorkspace: 0)
13060*
13061                  CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
13062     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
13063                  IRWORK = IE + M
13064*
13065*                 Perform bidiagonal QR iteration, computing left
13066*                 singular vectors of A in U and computing right
13067*                 singular vectors of A in A
13068*                 (CWorkspace: 0)
13069*                 (RWorkspace: need BDSPAC)
13070*
13071                  CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), A, LDA,
13072     $                         U, LDU, CDUM, 1, RWORK( IRWORK ), INFO )
13073*
13074               END IF
13075*
13076            ELSE IF( WNTVS ) THEN
13077*
13078               IF( WNTUN ) THEN
13079*
13080*                 Path 4t(N much larger than M, JOBU='N', JOBVT='S')
13081*                 M right singular vectors to be computed in VT and
13082*                 no left singular vectors to be computed
13083*
13084                  IF( LWORK.GE.M*M+3*M ) THEN
13085*
13086*                    Sufficient workspace for a fast algorithm
13087*
13088                     IR = 1
13089                     IF( LWORK.GE.WRKBL+LDA*M ) THEN
13090*
13091*                       WORK(IR) is LDA by M
13092*
13093                        LDWRKR = LDA
13094                     ELSE
13095*
13096*                       WORK(IR) is M by M
13097*
13098                        LDWRKR = M
13099                     END IF
13100                     ITAU = IR + LDWRKR*M
13101                     IWORK = ITAU + M
13102*
13103*                    Compute A=L*Q
13104*                    (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
13105*                    (RWorkspace: 0)
13106*
13107                     CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
13108     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
13109*
13110*                    Copy L to WORK(IR), zeroing out above it
13111*
13112                     CALL ZLACPY( 'L', M, M, A, LDA, WORK( IR ),
13113     $                            LDWRKR )
13114                     CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
13115     $                            WORK( IR+LDWRKR ), LDWRKR )
13116*
13117*                    Generate Q in A
13118*                    (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
13119*                    (RWorkspace: 0)
13120*
13121                     CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
13122     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
13123                     IE = 1
13124                     ITAUQ = ITAU
13125                     ITAUP = ITAUQ + M
13126                     IWORK = ITAUP + M
13127*
13128*                    Bidiagonalize L in WORK(IR)
13129*                    (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
13130*                    (RWorkspace: need M)
13131*
13132                     CALL ZGEBRD( M, M, WORK( IR ), LDWRKR, S,
13133     $                            RWORK( IE ), WORK( ITAUQ ),
13134     $                            WORK( ITAUP ), WORK( IWORK ),
13135     $                            LWORK-IWORK+1, IERR )
13136*
13137*                    Generate right vectors bidiagonalizing L in
13138*                    WORK(IR)
13139*                    (CWorkspace: need M*M+3*M, prefer M*M+2*M+(M-1)*NB)
13140*                    (RWorkspace: 0)
13141*
13142                     CALL ZUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
13143     $                            WORK( ITAUP ), WORK( IWORK ),
13144     $                            LWORK-IWORK+1, IERR )
13145                     IRWORK = IE + M
13146*
13147*                    Perform bidiagonal QR iteration, computing right
13148*                    singular vectors of L in WORK(IR)
13149*                    (CWorkspace: need M*M)
13150*                    (RWorkspace: need BDSPAC)
13151*
13152                     CALL ZBDSQR( 'U', M, M, 0, 0, S, RWORK( IE ),
13153     $                            WORK( IR ), LDWRKR, CDUM, 1, CDUM, 1,
13154     $                            RWORK( IRWORK ), INFO )
13155*
13156*                    Multiply right singular vectors of L in WORK(IR) by
13157*                    Q in A, storing result in VT
13158*                    (CWorkspace: need M*M)
13159*                    (RWorkspace: 0)
13160*
13161                     CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IR ),
13162     $                           LDWRKR, A, LDA, CZERO, VT, LDVT )
13163*
13164                  ELSE
13165*
13166*                    Insufficient workspace for a fast algorithm
13167*
13168                     ITAU = 1
13169                     IWORK = ITAU + M
13170*
13171*                    Compute A=L*Q
13172*                    (CWorkspace: need 2*M, prefer M+M*NB)
13173*                    (RWorkspace: 0)
13174*
13175                     CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
13176     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
13177*
13178*                    Copy result to VT
13179*
13180                     CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
13181*
13182*                    Generate Q in VT
13183*                    (CWorkspace: need 2*M, prefer M+M*NB)
13184*                    (RWorkspace: 0)
13185*
13186                     CALL ZUNGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
13187     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
13188                     IE = 1
13189                     ITAUQ = ITAU
13190                     ITAUP = ITAUQ + M
13191                     IWORK = ITAUP + M
13192*
13193*                    Zero out above L in A
13194*
13195                     CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
13196     $                            A( 1, 2 ), LDA )
13197*
13198*                    Bidiagonalize L in A
13199*                    (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
13200*                    (RWorkspace: need M)
13201*
13202                     CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ),
13203     $                            WORK( ITAUQ ), WORK( ITAUP ),
13204     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
13205*
13206*                    Multiply right vectors bidiagonalizing L by Q in VT
13207*                    (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
13208*                    (RWorkspace: 0)
13209*
13210                     CALL ZUNMBR( 'P', 'L', 'C', M, N, M, A, LDA,
13211     $                            WORK( ITAUP ), VT, LDVT,
13212     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
13213                     IRWORK = IE + M
13214*
13215*                    Perform bidiagonal QR iteration, computing right
13216*                    singular vectors of A in VT
13217*                    (CWorkspace: 0)
13218*                    (RWorkspace: need BDSPAC)
13219*
13220                     CALL ZBDSQR( 'U', M, N, 0, 0, S, RWORK( IE ), VT,
13221     $                            LDVT, CDUM, 1, CDUM, 1,
13222     $                            RWORK( IRWORK ), INFO )
13223*
13224                  END IF
13225*
13226               ELSE IF( WNTUO ) THEN
13227*
13228*                 Path 5t(N much larger than M, JOBU='O', JOBVT='S')
13229*                 M right singular vectors to be computed in VT and
13230*                 M left singular vectors to be overwritten on A
13231*
13232                  IF( LWORK.GE.2*M*M+3*M ) THEN
13233*
13234*                    Sufficient workspace for a fast algorithm
13235*
13236                     IU = 1
13237                     IF( LWORK.GE.WRKBL+2*LDA*M ) THEN
13238*
13239*                       WORK(IU) is LDA by M and WORK(IR) is LDA by M
13240*
13241                        LDWRKU = LDA
13242                        IR = IU + LDWRKU*M
13243                        LDWRKR = LDA
13244                     ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN
13245*
13246*                       WORK(IU) is LDA by M and WORK(IR) is M by M
13247*
13248                        LDWRKU = LDA
13249                        IR = IU + LDWRKU*M
13250                        LDWRKR = M
13251                     ELSE
13252*
13253*                       WORK(IU) is M by M and WORK(IR) is M by M
13254*
13255                        LDWRKU = M
13256                        IR = IU + LDWRKU*M
13257                        LDWRKR = M
13258                     END IF
13259                     ITAU = IR + LDWRKR*M
13260                     IWORK = ITAU + M
13261*
13262*                    Compute A=L*Q
13263*                    (CWorkspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
13264*                    (RWorkspace: 0)
13265*
13266                     CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
13267     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
13268*
13269*                    Copy L to WORK(IU), zeroing out below it
13270*
13271                     CALL ZLACPY( 'L', M, M, A, LDA, WORK( IU ),
13272     $                            LDWRKU )
13273                     CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
13274     $                            WORK( IU+LDWRKU ), LDWRKU )
13275*
13276*                    Generate Q in A
13277*                    (CWorkspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
13278*                    (RWorkspace: 0)
13279*
13280                     CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
13281     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
13282                     IE = 1
13283                     ITAUQ = ITAU
13284                     ITAUP = ITAUQ + M
13285                     IWORK = ITAUP + M
13286*
13287*                    Bidiagonalize L in WORK(IU), copying result to
13288*                    WORK(IR)
13289*                    (CWorkspace: need   2*M*M+3*M,
13290*                                 prefer 2*M*M+2*M+2*M*NB)
13291*                    (RWorkspace: need   M)
13292*
13293                     CALL ZGEBRD( M, M, WORK( IU ), LDWRKU, S,
13294     $                            RWORK( IE ), WORK( ITAUQ ),
13295     $                            WORK( ITAUP ), WORK( IWORK ),
13296     $                            LWORK-IWORK+1, IERR )
13297                     CALL ZLACPY( 'L', M, M, WORK( IU ), LDWRKU,
13298     $                            WORK( IR ), LDWRKR )
13299*
13300*                    Generate right bidiagonalizing vectors in WORK(IU)
13301*                    (CWorkspace: need   2*M*M+3*M-1,
13302*                                 prefer 2*M*M+2*M+(M-1)*NB)
13303*                    (RWorkspace: 0)
13304*
13305                     CALL ZUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
13306     $                            WORK( ITAUP ), WORK( IWORK ),
13307     $                            LWORK-IWORK+1, IERR )
13308*
13309*                    Generate left bidiagonalizing vectors in WORK(IR)
13310*                    (CWorkspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB)
13311*                    (RWorkspace: 0)
13312*
13313                     CALL ZUNGBR( 'Q', M, M, M, WORK( IR ), LDWRKR,
13314     $                            WORK( ITAUQ ), WORK( IWORK ),
13315     $                            LWORK-IWORK+1, IERR )
13316                     IRWORK = IE + M
13317*
13318*                    Perform bidiagonal QR iteration, computing left
13319*                    singular vectors of L in WORK(IR) and computing
13320*                    right singular vectors of L in WORK(IU)
13321*                    (CWorkspace: need 2*M*M)
13322*                    (RWorkspace: need BDSPAC)
13323*
13324                     CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ),
13325     $                            WORK( IU ), LDWRKU, WORK( IR ),
13326     $                            LDWRKR, CDUM, 1, RWORK( IRWORK ),
13327     $                            INFO )
13328*
13329*                    Multiply right singular vectors of L in WORK(IU) by
13330*                    Q in A, storing result in VT
13331*                    (CWorkspace: need M*M)
13332*                    (RWorkspace: 0)
13333*
13334                     CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ),
13335     $                           LDWRKU, A, LDA, CZERO, VT, LDVT )
13336*
13337*                    Copy left singular vectors of L to A
13338*                    (CWorkspace: need M*M)
13339*                    (RWorkspace: 0)
13340*
13341                     CALL ZLACPY( 'F', M, M, WORK( IR ), LDWRKR, A,
13342     $                            LDA )
13343*
13344                  ELSE
13345*
13346*                    Insufficient workspace for a fast algorithm
13347*
13348                     ITAU = 1
13349                     IWORK = ITAU + M
13350*
13351*                    Compute A=L*Q, copying result to VT
13352*                    (CWorkspace: need 2*M, prefer M+M*NB)
13353*                    (RWorkspace: 0)
13354*
13355                     CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
13356     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
13357                     CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
13358*
13359*                    Generate Q in VT
13360*                    (CWorkspace: need 2*M, prefer M+M*NB)
13361*                    (RWorkspace: 0)
13362*
13363                     CALL ZUNGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
13364     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
13365                     IE = 1
13366                     ITAUQ = ITAU
13367                     ITAUP = ITAUQ + M
13368                     IWORK = ITAUP + M
13369*
13370*                    Zero out above L in A
13371*
13372                     CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
13373     $                            A( 1, 2 ), LDA )
13374*
13375*                    Bidiagonalize L in A
13376*                    (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
13377*                    (RWorkspace: need M)
13378*
13379                     CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ),
13380     $                            WORK( ITAUQ ), WORK( ITAUP ),
13381     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
13382*
13383*                    Multiply right vectors bidiagonalizing L by Q in VT
13384*                    (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
13385*                    (RWorkspace: 0)
13386*
13387                     CALL ZUNMBR( 'P', 'L', 'C', M, N, M, A, LDA,
13388     $                            WORK( ITAUP ), VT, LDVT,
13389     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
13390*
13391*                    Generate left bidiagonalizing vectors of L in A
13392*                    (CWorkspace: need 3*M, prefer 2*M+M*NB)
13393*                    (RWorkspace: 0)
13394*
13395                     CALL ZUNGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
13396     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
13397                     IRWORK = IE + M
13398*
13399*                    Perform bidiagonal QR iteration, computing left
13400*                    singular vectors of A in A and computing right
13401*                    singular vectors of A in VT
13402*                    (CWorkspace: 0)
13403*                    (RWorkspace: need BDSPAC)
13404*
13405                     CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT,
13406     $                            LDVT, A, LDA, CDUM, 1,
13407     $                            RWORK( IRWORK ), INFO )
13408*
13409                  END IF
13410*
13411               ELSE IF( WNTUAS ) THEN
13412*
13413*                 Path 6t(N much larger than M, JOBU='S' or 'A',
13414*                         JOBVT='S')
13415*                 M right singular vectors to be computed in VT and
13416*                 M left singular vectors to be computed in U
13417*
13418                  IF( LWORK.GE.M*M+3*M ) THEN
13419*
13420*                    Sufficient workspace for a fast algorithm
13421*
13422                     IU = 1
13423                     IF( LWORK.GE.WRKBL+LDA*M ) THEN
13424*
13425*                       WORK(IU) is LDA by N
13426*
13427                        LDWRKU = LDA
13428                     ELSE
13429*
13430*                       WORK(IU) is LDA by M
13431*
13432                        LDWRKU = M
13433                     END IF
13434                     ITAU = IU + LDWRKU*M
13435                     IWORK = ITAU + M
13436*
13437*                    Compute A=L*Q
13438*                    (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
13439*                    (RWorkspace: 0)
13440*
13441                     CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
13442     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
13443*
13444*                    Copy L to WORK(IU), zeroing out above it
13445*
13446                     CALL ZLACPY( 'L', M, M, A, LDA, WORK( IU ),
13447     $                            LDWRKU )
13448                     CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
13449     $                            WORK( IU+LDWRKU ), LDWRKU )
13450*
13451*                    Generate Q in A
13452*                    (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
13453*                    (RWorkspace: 0)
13454*
13455                     CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
13456     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
13457                     IE = 1
13458                     ITAUQ = ITAU
13459                     ITAUP = ITAUQ + M
13460                     IWORK = ITAUP + M
13461*
13462*                    Bidiagonalize L in WORK(IU), copying result to U
13463*                    (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
13464*                    (RWorkspace: need M)
13465*
13466                     CALL ZGEBRD( M, M, WORK( IU ), LDWRKU, S,
13467     $                            RWORK( IE ), WORK( ITAUQ ),
13468     $                            WORK( ITAUP ), WORK( IWORK ),
13469     $                            LWORK-IWORK+1, IERR )
13470                     CALL ZLACPY( 'L', M, M, WORK( IU ), LDWRKU, U,
13471     $                            LDU )
13472*
13473*                    Generate right bidiagonalizing vectors in WORK(IU)
13474*                    (CWorkspace: need   M*M+3*M-1,
13475*                                 prefer M*M+2*M+(M-1)*NB)
13476*                    (RWorkspace: 0)
13477*
13478                     CALL ZUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
13479     $                            WORK( ITAUP ), WORK( IWORK ),
13480     $                            LWORK-IWORK+1, IERR )
13481*
13482*                    Generate left bidiagonalizing vectors in U
13483*                    (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB)
13484*                    (RWorkspace: 0)
13485*
13486                     CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
13487     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
13488                     IRWORK = IE + M
13489*
13490*                    Perform bidiagonal QR iteration, computing left
13491*                    singular vectors of L in U and computing right
13492*                    singular vectors of L in WORK(IU)
13493*                    (CWorkspace: need M*M)
13494*                    (RWorkspace: need BDSPAC)
13495*
13496                     CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ),
13497     $                            WORK( IU ), LDWRKU, U, LDU, CDUM, 1,
13498     $                            RWORK( IRWORK ), INFO )
13499*
13500*                    Multiply right singular vectors of L in WORK(IU) by
13501*                    Q in A, storing result in VT
13502*                    (CWorkspace: need M*M)
13503*                    (RWorkspace: 0)
13504*
13505                     CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ),
13506     $                           LDWRKU, A, LDA, CZERO, VT, LDVT )
13507*
13508                  ELSE
13509*
13510*                    Insufficient workspace for a fast algorithm
13511*
13512                     ITAU = 1
13513                     IWORK = ITAU + M
13514*
13515*                    Compute A=L*Q, copying result to VT
13516*                    (CWorkspace: need 2*M, prefer M+M*NB)
13517*                    (RWorkspace: 0)
13518*
13519                     CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
13520     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
13521                     CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
13522*
13523*                    Generate Q in VT
13524*                    (CWorkspace: need 2*M, prefer M+M*NB)
13525*                    (RWorkspace: 0)
13526*
13527                     CALL ZUNGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
13528     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
13529*
13530*                    Copy L to U, zeroing out above it
13531*
13532                     CALL ZLACPY( 'L', M, M, A, LDA, U, LDU )
13533                     CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
13534     $                            U( 1, 2 ), LDU )
13535                     IE = 1
13536                     ITAUQ = ITAU
13537                     ITAUP = ITAUQ + M
13538                     IWORK = ITAUP + M
13539*
13540*                    Bidiagonalize L in U
13541*                    (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
13542*                    (RWorkspace: need M)
13543*
13544                     CALL ZGEBRD( M, M, U, LDU, S, RWORK( IE ),
13545     $                            WORK( ITAUQ ), WORK( ITAUP ),
13546     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
13547*
13548*                    Multiply right bidiagonalizing vectors in U by Q
13549*                    in VT
13550*                    (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
13551*                    (RWorkspace: 0)
13552*
13553                     CALL ZUNMBR( 'P', 'L', 'C', M, N, M, U, LDU,
13554     $                            WORK( ITAUP ), VT, LDVT,
13555     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
13556*
13557*                    Generate left bidiagonalizing vectors in U
13558*                    (CWorkspace: need 3*M, prefer 2*M+M*NB)
13559*                    (RWorkspace: 0)
13560*
13561                     CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
13562     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
13563                     IRWORK = IE + M
13564*
13565*                    Perform bidiagonal QR iteration, computing left
13566*                    singular vectors of A in U and computing right
13567*                    singular vectors of A in VT
13568*                    (CWorkspace: 0)
13569*                    (RWorkspace: need BDSPAC)
13570*
13571                     CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT,
13572     $                            LDVT, U, LDU, CDUM, 1,
13573     $                            RWORK( IRWORK ), INFO )
13574*
13575                  END IF
13576*
13577               END IF
13578*
13579            ELSE IF( WNTVA ) THEN
13580*
13581               IF( WNTUN ) THEN
13582*
13583*                 Path 7t(N much larger than M, JOBU='N', JOBVT='A')
13584*                 N right singular vectors to be computed in VT and
13585*                 no left singular vectors to be computed
13586*
13587                  IF( LWORK.GE.M*M+MAX( N+M, 3*M ) ) THEN
13588*
13589*                    Sufficient workspace for a fast algorithm
13590*
13591                     IR = 1
13592                     IF( LWORK.GE.WRKBL+LDA*M ) THEN
13593*
13594*                       WORK(IR) is LDA by M
13595*
13596                        LDWRKR = LDA
13597                     ELSE
13598*
13599*                       WORK(IR) is M by M
13600*
13601                        LDWRKR = M
13602                     END IF
13603                     ITAU = IR + LDWRKR*M
13604                     IWORK = ITAU + M
13605*
13606*                    Compute A=L*Q, copying result to VT
13607*                    (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
13608*                    (RWorkspace: 0)
13609*
13610                     CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
13611     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
13612                     CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
13613*
13614*                    Copy L to WORK(IR), zeroing out above it
13615*
13616                     CALL ZLACPY( 'L', M, M, A, LDA, WORK( IR ),
13617     $                            LDWRKR )
13618                     CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
13619     $                            WORK( IR+LDWRKR ), LDWRKR )
13620*
13621*                    Generate Q in VT
13622*                    (CWorkspace: need M*M+M+N, prefer M*M+M+N*NB)
13623*                    (RWorkspace: 0)
13624*
13625                     CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
13626     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
13627                     IE = 1
13628                     ITAUQ = ITAU
13629                     ITAUP = ITAUQ + M
13630                     IWORK = ITAUP + M
13631*
13632*                    Bidiagonalize L in WORK(IR)
13633*                    (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
13634*                    (RWorkspace: need M)
13635*
13636                     CALL ZGEBRD( M, M, WORK( IR ), LDWRKR, S,
13637     $                            RWORK( IE ), WORK( ITAUQ ),
13638     $                            WORK( ITAUP ), WORK( IWORK ),
13639     $                            LWORK-IWORK+1, IERR )
13640*
13641*                    Generate right bidiagonalizing vectors in WORK(IR)
13642*                    (CWorkspace: need   M*M+3*M-1,
13643*                                 prefer M*M+2*M+(M-1)*NB)
13644*                    (RWorkspace: 0)
13645*
13646                     CALL ZUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
13647     $                            WORK( ITAUP ), WORK( IWORK ),
13648     $                            LWORK-IWORK+1, IERR )
13649                     IRWORK = IE + M
13650*
13651*                    Perform bidiagonal QR iteration, computing right
13652*                    singular vectors of L in WORK(IR)
13653*                    (CWorkspace: need M*M)
13654*                    (RWorkspace: need BDSPAC)
13655*
13656                     CALL ZBDSQR( 'U', M, M, 0, 0, S, RWORK( IE ),
13657     $                            WORK( IR ), LDWRKR, CDUM, 1, CDUM, 1,
13658     $                            RWORK( IRWORK ), INFO )
13659*
13660*                    Multiply right singular vectors of L in WORK(IR) by
13661*                    Q in VT, storing result in A
13662*                    (CWorkspace: need M*M)
13663*                    (RWorkspace: 0)
13664*
13665                     CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IR ),
13666     $                           LDWRKR, VT, LDVT, CZERO, A, LDA )
13667*
13668*                    Copy right singular vectors of A from A to VT
13669*
13670                     CALL ZLACPY( 'F', M, N, A, LDA, VT, LDVT )
13671*
13672                  ELSE
13673*
13674*                    Insufficient workspace for a fast algorithm
13675*
13676                     ITAU = 1
13677                     IWORK = ITAU + M
13678*
13679*                    Compute A=L*Q, copying result to VT
13680*                    (CWorkspace: need 2*M, prefer M+M*NB)
13681*                    (RWorkspace: 0)
13682*
13683                     CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
13684     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
13685                     CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
13686*
13687*                    Generate Q in VT
13688*                    (CWorkspace: need M+N, prefer M+N*NB)
13689*                    (RWorkspace: 0)
13690*
13691                     CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
13692     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
13693                     IE = 1
13694                     ITAUQ = ITAU
13695                     ITAUP = ITAUQ + M
13696                     IWORK = ITAUP + M
13697*
13698*                    Zero out above L in A
13699*
13700                     CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
13701     $                            A( 1, 2 ), LDA )
13702*
13703*                    Bidiagonalize L in A
13704*                    (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
13705*                    (RWorkspace: need M)
13706*
13707                     CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ),
13708     $                            WORK( ITAUQ ), WORK( ITAUP ),
13709     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
13710*
13711*                    Multiply right bidiagonalizing vectors in A by Q
13712*                    in VT
13713*                    (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
13714*                    (RWorkspace: 0)
13715*
13716                     CALL ZUNMBR( 'P', 'L', 'C', M, N, M, A, LDA,
13717     $                            WORK( ITAUP ), VT, LDVT,
13718     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
13719                     IRWORK = IE + M
13720*
13721*                    Perform bidiagonal QR iteration, computing right
13722*                    singular vectors of A in VT
13723*                    (CWorkspace: 0)
13724*                    (RWorkspace: need BDSPAC)
13725*
13726                     CALL ZBDSQR( 'U', M, N, 0, 0, S, RWORK( IE ), VT,
13727     $                            LDVT, CDUM, 1, CDUM, 1,
13728     $                            RWORK( IRWORK ), INFO )
13729*
13730                  END IF
13731*
13732               ELSE IF( WNTUO ) THEN
13733*
13734*                 Path 8t(N much larger than M, JOBU='O', JOBVT='A')
13735*                 N right singular vectors to be computed in VT and
13736*                 M left singular vectors to be overwritten on A
13737*
13738                  IF( LWORK.GE.2*M*M+MAX( N+M, 3*M ) ) THEN
13739*
13740*                    Sufficient workspace for a fast algorithm
13741*
13742                     IU = 1
13743                     IF( LWORK.GE.WRKBL+2*LDA*M ) THEN
13744*
13745*                       WORK(IU) is LDA by M and WORK(IR) is LDA by M
13746*
13747                        LDWRKU = LDA
13748                        IR = IU + LDWRKU*M
13749                        LDWRKR = LDA
13750                     ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN
13751*
13752*                       WORK(IU) is LDA by M and WORK(IR) is M by M
13753*
13754                        LDWRKU = LDA
13755                        IR = IU + LDWRKU*M
13756                        LDWRKR = M
13757                     ELSE
13758*
13759*                       WORK(IU) is M by M and WORK(IR) is M by M
13760*
13761                        LDWRKU = M
13762                        IR = IU + LDWRKU*M
13763                        LDWRKR = M
13764                     END IF
13765                     ITAU = IR + LDWRKR*M
13766                     IWORK = ITAU + M
13767*
13768*                    Compute A=L*Q, copying result to VT
13769*                    (CWorkspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
13770*                    (RWorkspace: 0)
13771*
13772                     CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
13773     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
13774                     CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
13775*
13776*                    Generate Q in VT
13777*                    (CWorkspace: need 2*M*M+M+N, prefer 2*M*M+M+N*NB)
13778*                    (RWorkspace: 0)
13779*
13780                     CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
13781     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
13782*
13783*                    Copy L to WORK(IU), zeroing out above it
13784*
13785                     CALL ZLACPY( 'L', M, M, A, LDA, WORK( IU ),
13786     $                            LDWRKU )
13787                     CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
13788     $                            WORK( IU+LDWRKU ), LDWRKU )
13789                     IE = 1
13790                     ITAUQ = ITAU
13791                     ITAUP = ITAUQ + M
13792                     IWORK = ITAUP + M
13793*
13794*                    Bidiagonalize L in WORK(IU), copying result to
13795*                    WORK(IR)
13796*                    (CWorkspace: need   2*M*M+3*M,
13797*                                 prefer 2*M*M+2*M+2*M*NB)
13798*                    (RWorkspace: need   M)
13799*
13800                     CALL ZGEBRD( M, M, WORK( IU ), LDWRKU, S,
13801     $                            RWORK( IE ), WORK( ITAUQ ),
13802     $                            WORK( ITAUP ), WORK( IWORK ),
13803     $                            LWORK-IWORK+1, IERR )
13804                     CALL ZLACPY( 'L', M, M, WORK( IU ), LDWRKU,
13805     $                            WORK( IR ), LDWRKR )
13806*
13807*                    Generate right bidiagonalizing vectors in WORK(IU)
13808*                    (CWorkspace: need   2*M*M+3*M-1,
13809*                                 prefer 2*M*M+2*M+(M-1)*NB)
13810*                    (RWorkspace: 0)
13811*
13812                     CALL ZUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
13813     $                            WORK( ITAUP ), WORK( IWORK ),
13814     $                            LWORK-IWORK+1, IERR )
13815*
13816*                    Generate left bidiagonalizing vectors in WORK(IR)
13817*                    (CWorkspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB)
13818*                    (RWorkspace: 0)
13819*
13820                     CALL ZUNGBR( 'Q', M, M, M, WORK( IR ), LDWRKR,
13821     $                            WORK( ITAUQ ), WORK( IWORK ),
13822     $                            LWORK-IWORK+1, IERR )
13823                     IRWORK = IE + M
13824*
13825*                    Perform bidiagonal QR iteration, computing left
13826*                    singular vectors of L in WORK(IR) and computing
13827*                    right singular vectors of L in WORK(IU)
13828*                    (CWorkspace: need 2*M*M)
13829*                    (RWorkspace: need BDSPAC)
13830*
13831                     CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ),
13832     $                            WORK( IU ), LDWRKU, WORK( IR ),
13833     $                            LDWRKR, CDUM, 1, RWORK( IRWORK ),
13834     $                            INFO )
13835*
13836*                    Multiply right singular vectors of L in WORK(IU) by
13837*                    Q in VT, storing result in A
13838*                    (CWorkspace: need M*M)
13839*                    (RWorkspace: 0)
13840*
13841                     CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ),
13842     $                           LDWRKU, VT, LDVT, CZERO, A, LDA )
13843*
13844*                    Copy right singular vectors of A from A to VT
13845*
13846                     CALL ZLACPY( 'F', M, N, A, LDA, VT, LDVT )
13847*
13848*                    Copy left singular vectors of A from WORK(IR) to A
13849*
13850                     CALL ZLACPY( 'F', M, M, WORK( IR ), LDWRKR, A,
13851     $                            LDA )
13852*
13853                  ELSE
13854*
13855*                    Insufficient workspace for a fast algorithm
13856*
13857                     ITAU = 1
13858                     IWORK = ITAU + M
13859*
13860*                    Compute A=L*Q, copying result to VT
13861*                    (CWorkspace: need 2*M, prefer M+M*NB)
13862*                    (RWorkspace: 0)
13863*
13864                     CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
13865     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
13866                     CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
13867*
13868*                    Generate Q in VT
13869*                    (CWorkspace: need M+N, prefer M+N*NB)
13870*                    (RWorkspace: 0)
13871*
13872                     CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
13873     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
13874                     IE = 1
13875                     ITAUQ = ITAU
13876                     ITAUP = ITAUQ + M
13877                     IWORK = ITAUP + M
13878*
13879*                    Zero out above L in A
13880*
13881                     CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
13882     $                            A( 1, 2 ), LDA )
13883*
13884*                    Bidiagonalize L in A
13885*                    (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
13886*                    (RWorkspace: need M)
13887*
13888                     CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ),
13889     $                            WORK( ITAUQ ), WORK( ITAUP ),
13890     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
13891*
13892*                    Multiply right bidiagonalizing vectors in A by Q
13893*                    in VT
13894*                    (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
13895*                    (RWorkspace: 0)
13896*
13897                     CALL ZUNMBR( 'P', 'L', 'C', M, N, M, A, LDA,
13898     $                            WORK( ITAUP ), VT, LDVT,
13899     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
13900*
13901*                    Generate left bidiagonalizing vectors in A
13902*                    (CWorkspace: need 3*M, prefer 2*M+M*NB)
13903*                    (RWorkspace: 0)
13904*
13905                     CALL ZUNGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
13906     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
13907                     IRWORK = IE + M
13908*
13909*                    Perform bidiagonal QR iteration, computing left
13910*                    singular vectors of A in A and computing right
13911*                    singular vectors of A in VT
13912*                    (CWorkspace: 0)
13913*                    (RWorkspace: need BDSPAC)
13914*
13915                     CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT,
13916     $                            LDVT, A, LDA, CDUM, 1,
13917     $                            RWORK( IRWORK ), INFO )
13918*
13919                  END IF
13920*
13921               ELSE IF( WNTUAS ) THEN
13922*
13923*                 Path 9t(N much larger than M, JOBU='S' or 'A',
13924*                         JOBVT='A')
13925*                 N right singular vectors to be computed in VT and
13926*                 M left singular vectors to be computed in U
13927*
13928                  IF( LWORK.GE.M*M+MAX( N+M, 3*M ) ) THEN
13929*
13930*                    Sufficient workspace for a fast algorithm
13931*
13932                     IU = 1
13933                     IF( LWORK.GE.WRKBL+LDA*M ) THEN
13934*
13935*                       WORK(IU) is LDA by M
13936*
13937                        LDWRKU = LDA
13938                     ELSE
13939*
13940*                       WORK(IU) is M by M
13941*
13942                        LDWRKU = M
13943                     END IF
13944                     ITAU = IU + LDWRKU*M
13945                     IWORK = ITAU + M
13946*
13947*                    Compute A=L*Q, copying result to VT
13948*                    (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
13949*                    (RWorkspace: 0)
13950*
13951                     CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
13952     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
13953                     CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
13954*
13955*                    Generate Q in VT
13956*                    (CWorkspace: need M*M+M+N, prefer M*M+M+N*NB)
13957*                    (RWorkspace: 0)
13958*
13959                     CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
13960     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
13961*
13962*                    Copy L to WORK(IU), zeroing out above it
13963*
13964                     CALL ZLACPY( 'L', M, M, A, LDA, WORK( IU ),
13965     $                            LDWRKU )
13966                     CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
13967     $                            WORK( IU+LDWRKU ), LDWRKU )
13968                     IE = 1
13969                     ITAUQ = ITAU
13970                     ITAUP = ITAUQ + M
13971                     IWORK = ITAUP + M
13972*
13973*                    Bidiagonalize L in WORK(IU), copying result to U
13974*                    (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
13975*                    (RWorkspace: need M)
13976*
13977                     CALL ZGEBRD( M, M, WORK( IU ), LDWRKU, S,
13978     $                            RWORK( IE ), WORK( ITAUQ ),
13979     $                            WORK( ITAUP ), WORK( IWORK ),
13980     $                            LWORK-IWORK+1, IERR )
13981                     CALL ZLACPY( 'L', M, M, WORK( IU ), LDWRKU, U,
13982     $                            LDU )
13983*
13984*                    Generate right bidiagonalizing vectors in WORK(IU)
13985*                    (CWorkspace: need M*M+3*M, prefer M*M+2*M+(M-1)*NB)
13986*                    (RWorkspace: 0)
13987*
13988                     CALL ZUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
13989     $                            WORK( ITAUP ), WORK( IWORK ),
13990     $                            LWORK-IWORK+1, IERR )
13991*
13992*                    Generate left bidiagonalizing vectors in U
13993*                    (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB)
13994*                    (RWorkspace: 0)
13995*
13996                     CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
13997     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
13998                     IRWORK = IE + M
13999*
14000*                    Perform bidiagonal QR iteration, computing left
14001*                    singular vectors of L in U and computing right
14002*                    singular vectors of L in WORK(IU)
14003*                    (CWorkspace: need M*M)
14004*                    (RWorkspace: need BDSPAC)
14005*
14006                     CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ),
14007     $                            WORK( IU ), LDWRKU, U, LDU, CDUM, 1,
14008     $                            RWORK( IRWORK ), INFO )
14009*
14010*                    Multiply right singular vectors of L in WORK(IU) by
14011*                    Q in VT, storing result in A
14012*                    (CWorkspace: need M*M)
14013*                    (RWorkspace: 0)
14014*
14015                     CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ),
14016     $                           LDWRKU, VT, LDVT, CZERO, A, LDA )
14017*
14018*                    Copy right singular vectors of A from A to VT
14019*
14020                     CALL ZLACPY( 'F', M, N, A, LDA, VT, LDVT )
14021*
14022                  ELSE
14023*
14024*                    Insufficient workspace for a fast algorithm
14025*
14026                     ITAU = 1
14027                     IWORK = ITAU + M
14028*
14029*                    Compute A=L*Q, copying result to VT
14030*                    (CWorkspace: need 2*M, prefer M+M*NB)
14031*                    (RWorkspace: 0)
14032*
14033                     CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
14034     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
14035                     CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
14036*
14037*                    Generate Q in VT
14038*                    (CWorkspace: need M+N, prefer M+N*NB)
14039*                    (RWorkspace: 0)
14040*
14041                     CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
14042     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
14043*
14044*                    Copy L to U, zeroing out above it
14045*
14046                     CALL ZLACPY( 'L', M, M, A, LDA, U, LDU )
14047                     CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
14048     $                            U( 1, 2 ), LDU )
14049                     IE = 1
14050                     ITAUQ = ITAU
14051                     ITAUP = ITAUQ + M
14052                     IWORK = ITAUP + M
14053*
14054*                    Bidiagonalize L in U
14055*                    (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
14056*                    (RWorkspace: need M)
14057*
14058                     CALL ZGEBRD( M, M, U, LDU, S, RWORK( IE ),
14059     $                            WORK( ITAUQ ), WORK( ITAUP ),
14060     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
14061*
14062*                    Multiply right bidiagonalizing vectors in U by Q
14063*                    in VT
14064*                    (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
14065*                    (RWorkspace: 0)
14066*
14067                     CALL ZUNMBR( 'P', 'L', 'C', M, N, M, U, LDU,
14068     $                            WORK( ITAUP ), VT, LDVT,
14069     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
14070*
14071*                    Generate left bidiagonalizing vectors in U
14072*                    (CWorkspace: need 3*M, prefer 2*M+M*NB)
14073*                    (RWorkspace: 0)
14074*
14075                     CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
14076     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
14077                     IRWORK = IE + M
14078*
14079*                    Perform bidiagonal QR iteration, computing left
14080*                    singular vectors of A in U and computing right
14081*                    singular vectors of A in VT
14082*                    (CWorkspace: 0)
14083*                    (RWorkspace: need BDSPAC)
14084*
14085                     CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT,
14086     $                            LDVT, U, LDU, CDUM, 1,
14087     $                            RWORK( IRWORK ), INFO )
14088*
14089                  END IF
14090*
14091               END IF
14092*
14093            END IF
14094*
14095         ELSE
14096*
14097*           N .LT. MNTHR
14098*
14099*           Path 10t(N greater than M, but not much larger)
14100*           Reduce to bidiagonal form without LQ decomposition
14101*
14102            IE = 1
14103            ITAUQ = 1
14104            ITAUP = ITAUQ + M
14105            IWORK = ITAUP + M
14106*
14107*           Bidiagonalize A
14108*           (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB)
14109*           (RWorkspace: M)
14110*
14111            CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
14112     $                   WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
14113     $                   IERR )
14114            IF( WNTUAS ) THEN
14115*
14116*              If left singular vectors desired in U, copy result to U
14117*              and generate left bidiagonalizing vectors in U
14118*              (CWorkspace: need 3*M-1, prefer 2*M+(M-1)*NB)
14119*              (RWorkspace: 0)
14120*
14121               CALL ZLACPY( 'L', M, M, A, LDA, U, LDU )
14122               CALL ZUNGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ),
14123     $                      WORK( IWORK ), LWORK-IWORK+1, IERR )
14124            END IF
14125            IF( WNTVAS ) THEN
14126*
14127*              If right singular vectors desired in VT, copy result to
14128*              VT and generate right bidiagonalizing vectors in VT
14129*              (CWorkspace: need 2*M+NRVT, prefer 2*M+NRVT*NB)
14130*              (RWorkspace: 0)
14131*
14132               CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
14133               IF( WNTVA )
14134     $            NRVT = N
14135               IF( WNTVS )
14136     $            NRVT = M
14137               CALL ZUNGBR( 'P', NRVT, N, M, VT, LDVT, WORK( ITAUP ),
14138     $                      WORK( IWORK ), LWORK-IWORK+1, IERR )
14139            END IF
14140            IF( WNTUO ) THEN
14141*
14142*              If left singular vectors desired in A, generate left
14143*              bidiagonalizing vectors in A
14144*              (CWorkspace: need 3*M-1, prefer 2*M+(M-1)*NB)
14145*              (RWorkspace: 0)
14146*
14147               CALL ZUNGBR( 'Q', M, M, N, A, LDA, WORK( ITAUQ ),
14148     $                      WORK( IWORK ), LWORK-IWORK+1, IERR )
14149            END IF
14150            IF( WNTVO ) THEN
14151*
14152*              If right singular vectors desired in A, generate right
14153*              bidiagonalizing vectors in A
14154*              (CWorkspace: need 3*M, prefer 2*M+M*NB)
14155*              (RWorkspace: 0)
14156*
14157               CALL ZUNGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
14158     $                      WORK( IWORK ), LWORK-IWORK+1, IERR )
14159            END IF
14160            IRWORK = IE + M
14161            IF( WNTUAS .OR. WNTUO )
14162     $         NRU = M
14163            IF( WNTUN )
14164     $         NRU = 0
14165            IF( WNTVAS .OR. WNTVO )
14166     $         NCVT = N
14167            IF( WNTVN )
14168     $         NCVT = 0
14169            IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN
14170*
14171*              Perform bidiagonal QR iteration, if desired, computing
14172*              left singular vectors in U and computing right singular
14173*              vectors in VT
14174*              (CWorkspace: 0)
14175*              (RWorkspace: need BDSPAC)
14176*
14177               CALL ZBDSQR( 'L', M, NCVT, NRU, 0, S, RWORK( IE ), VT,
14178     $                      LDVT, U, LDU, CDUM, 1, RWORK( IRWORK ),
14179     $                      INFO )
14180            ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN
14181*
14182*              Perform bidiagonal QR iteration, if desired, computing
14183*              left singular vectors in U and computing right singular
14184*              vectors in A
14185*              (CWorkspace: 0)
14186*              (RWorkspace: need BDSPAC)
14187*
14188               CALL ZBDSQR( 'L', M, NCVT, NRU, 0, S, RWORK( IE ), A,
14189     $                      LDA, U, LDU, CDUM, 1, RWORK( IRWORK ),
14190     $                      INFO )
14191            ELSE
14192*
14193*              Perform bidiagonal QR iteration, if desired, computing
14194*              left singular vectors in A and computing right singular
14195*              vectors in VT
14196*              (CWorkspace: 0)
14197*              (RWorkspace: need BDSPAC)
14198*
14199               CALL ZBDSQR( 'L', M, NCVT, NRU, 0, S, RWORK( IE ), VT,
14200     $                      LDVT, A, LDA, CDUM, 1, RWORK( IRWORK ),
14201     $                      INFO )
14202            END IF
14203*
14204         END IF
14205*
14206      END IF
14207*
14208*     Undo scaling if necessary
14209*
14210      IF( ISCL.EQ.1 ) THEN
14211         IF( ANRM.GT.BIGNUM )
14212     $      CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
14213     $                   IERR )
14214         IF( INFO.NE.0 .AND. ANRM.GT.BIGNUM )
14215     $      CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN-1, 1,
14216     $                   RWORK( IE ), MINMN, IERR )
14217         IF( ANRM.LT.SMLNUM )
14218     $      CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
14219     $                   IERR )
14220         IF( INFO.NE.0 .AND. ANRM.LT.SMLNUM )
14221     $      CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN-1, 1,
14222     $                   RWORK( IE ), MINMN, IERR )
14223      END IF
14224*
14225*     Return optimal workspace in WORK(1)
14226*
14227      WORK( 1 ) = MAXWRK
14228*
14229      RETURN
14230*
14231*     End of ZGESVD
14232*
14233      END
14234*> \brief <b> ZGESVX computes the solution to system of linear equations A * X = B for GE matrices</b>
14235*
14236*  =========== DOCUMENTATION ===========
14237*
14238* Online html documentation available at
14239*            http://www.netlib.org/lapack/explore-html/
14240*
14241*> \htmlonly
14242*> Download ZGESVX + dependencies
14243*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgesvx.f">
14244*> [TGZ]</a>
14245*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgesvx.f">
14246*> [ZIP]</a>
14247*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgesvx.f">
14248*> [TXT]</a>
14249*> \endhtmlonly
14250*
14251*  Definition:
14252*  ===========
14253*
14254*       SUBROUTINE ZGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV,
14255*                          EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR,
14256*                          WORK, RWORK, INFO )
14257*
14258*       .. Scalar Arguments ..
14259*       CHARACTER          EQUED, FACT, TRANS
14260*       INTEGER            INFO, LDA, LDAF, LDB, LDX, N, NRHS
14261*       DOUBLE PRECISION   RCOND
14262*       ..
14263*       .. Array Arguments ..
14264*       INTEGER            IPIV( * )
14265*       DOUBLE PRECISION   BERR( * ), C( * ), FERR( * ), R( * ),
14266*      $                   RWORK( * )
14267*       COMPLEX*16         A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
14268*      $                   WORK( * ), X( LDX, * )
14269*       ..
14270*
14271*
14272*> \par Purpose:
14273*  =============
14274*>
14275*> \verbatim
14276*>
14277*> ZGESVX uses the LU factorization to compute the solution to a complex
14278*> system of linear equations
14279*>    A * X = B,
14280*> where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
14281*>
14282*> Error bounds on the solution and a condition estimate are also
14283*> provided.
14284*> \endverbatim
14285*
14286*> \par Description:
14287*  =================
14288*>
14289*> \verbatim
14290*>
14291*> The following steps are performed:
14292*>
14293*> 1. If FACT = 'E', real scaling factors are computed to equilibrate
14294*>    the system:
14295*>       TRANS = 'N':  diag(R)*A*diag(C)     *inv(diag(C))*X = diag(R)*B
14296*>       TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
14297*>       TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
14298*>    Whether or not the system will be equilibrated depends on the
14299*>    scaling of the matrix A, but if equilibration is used, A is
14300*>    overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')
14301*>    or diag(C)*B (if TRANS = 'T' or 'C').
14302*>
14303*> 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the
14304*>    matrix A (after equilibration if FACT = 'E') as
14305*>       A = P * L * U,
14306*>    where P is a permutation matrix, L is a unit lower triangular
14307*>    matrix, and U is upper triangular.
14308*>
14309*> 3. If some U(i,i)=0, so that U is exactly singular, then the routine
14310*>    returns with INFO = i. Otherwise, the factored form of A is used
14311*>    to estimate the condition number of the matrix A.  If the
14312*>    reciprocal of the condition number is less than machine precision,
14313*>    INFO = N+1 is returned as a warning, but the routine still goes on
14314*>    to solve for X and compute error bounds as described below.
14315*>
14316*> 4. The system of equations is solved for X using the factored form
14317*>    of A.
14318*>
14319*> 5. Iterative refinement is applied to improve the computed solution
14320*>    matrix and calculate error bounds and backward error estimates
14321*>    for it.
14322*>
14323*> 6. If equilibration was used, the matrix X is premultiplied by
14324*>    diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
14325*>    that it solves the original system before equilibration.
14326*> \endverbatim
14327*
14328*  Arguments:
14329*  ==========
14330*
14331*> \param[in] FACT
14332*> \verbatim
14333*>          FACT is CHARACTER*1
14334*>          Specifies whether or not the factored form of the matrix A is
14335*>          supplied on entry, and if not, whether the matrix A should be
14336*>          equilibrated before it is factored.
14337*>          = 'F':  On entry, AF and IPIV contain the factored form of A.
14338*>                  If EQUED is not 'N', the matrix A has been
14339*>                  equilibrated with scaling factors given by R and C.
14340*>                  A, AF, and IPIV are not modified.
14341*>          = 'N':  The matrix A will be copied to AF and factored.
14342*>          = 'E':  The matrix A will be equilibrated if necessary, then
14343*>                  copied to AF and factored.
14344*> \endverbatim
14345*>
14346*> \param[in] TRANS
14347*> \verbatim
14348*>          TRANS is CHARACTER*1
14349*>          Specifies the form of the system of equations:
14350*>          = 'N':  A * X = B     (No transpose)
14351*>          = 'T':  A**T * X = B  (Transpose)
14352*>          = 'C':  A**H * X = B  (Conjugate transpose)
14353*> \endverbatim
14354*>
14355*> \param[in] N
14356*> \verbatim
14357*>          N is INTEGER
14358*>          The number of linear equations, i.e., the order of the
14359*>          matrix A.  N >= 0.
14360*> \endverbatim
14361*>
14362*> \param[in] NRHS
14363*> \verbatim
14364*>          NRHS is INTEGER
14365*>          The number of right hand sides, i.e., the number of columns
14366*>          of the matrices B and X.  NRHS >= 0.
14367*> \endverbatim
14368*>
14369*> \param[in,out] A
14370*> \verbatim
14371*>          A is COMPLEX*16 array, dimension (LDA,N)
14372*>          On entry, the N-by-N matrix A.  If FACT = 'F' and EQUED is
14373*>          not 'N', then A must have been equilibrated by the scaling
14374*>          factors in R and/or C.  A is not modified if FACT = 'F' or
14375*>          'N', or if FACT = 'E' and EQUED = 'N' on exit.
14376*>
14377*>          On exit, if EQUED .ne. 'N', A is scaled as follows:
14378*>          EQUED = 'R':  A := diag(R) * A
14379*>          EQUED = 'C':  A := A * diag(C)
14380*>          EQUED = 'B':  A := diag(R) * A * diag(C).
14381*> \endverbatim
14382*>
14383*> \param[in] LDA
14384*> \verbatim
14385*>          LDA is INTEGER
14386*>          The leading dimension of the array A.  LDA >= max(1,N).
14387*> \endverbatim
14388*>
14389*> \param[in,out] AF
14390*> \verbatim
14391*>          AF is COMPLEX*16 array, dimension (LDAF,N)
14392*>          If FACT = 'F', then AF is an input argument and on entry
14393*>          contains the factors L and U from the factorization
14394*>          A = P*L*U as computed by ZGETRF.  If EQUED .ne. 'N', then
14395*>          AF is the factored form of the equilibrated matrix A.
14396*>
14397*>          If FACT = 'N', then AF is an output argument and on exit
14398*>          returns the factors L and U from the factorization A = P*L*U
14399*>          of the original matrix A.
14400*>
14401*>          If FACT = 'E', then AF is an output argument and on exit
14402*>          returns the factors L and U from the factorization A = P*L*U
14403*>          of the equilibrated matrix A (see the description of A for
14404*>          the form of the equilibrated matrix).
14405*> \endverbatim
14406*>
14407*> \param[in] LDAF
14408*> \verbatim
14409*>          LDAF is INTEGER
14410*>          The leading dimension of the array AF.  LDAF >= max(1,N).
14411*> \endverbatim
14412*>
14413*> \param[in,out] IPIV
14414*> \verbatim
14415*>          IPIV is INTEGER array, dimension (N)
14416*>          If FACT = 'F', then IPIV is an input argument and on entry
14417*>          contains the pivot indices from the factorization A = P*L*U
14418*>          as computed by ZGETRF; row i of the matrix was interchanged
14419*>          with row IPIV(i).
14420*>
14421*>          If FACT = 'N', then IPIV is an output argument and on exit
14422*>          contains the pivot indices from the factorization A = P*L*U
14423*>          of the original matrix A.
14424*>
14425*>          If FACT = 'E', then IPIV is an output argument and on exit
14426*>          contains the pivot indices from the factorization A = P*L*U
14427*>          of the equilibrated matrix A.
14428*> \endverbatim
14429*>
14430*> \param[in,out] EQUED
14431*> \verbatim
14432*>          EQUED is CHARACTER*1
14433*>          Specifies the form of equilibration that was done.
14434*>          = 'N':  No equilibration (always true if FACT = 'N').
14435*>          = 'R':  Row equilibration, i.e., A has been premultiplied by
14436*>                  diag(R).
14437*>          = 'C':  Column equilibration, i.e., A has been postmultiplied
14438*>                  by diag(C).
14439*>          = 'B':  Both row and column equilibration, i.e., A has been
14440*>                  replaced by diag(R) * A * diag(C).
14441*>          EQUED is an input argument if FACT = 'F'; otherwise, it is an
14442*>          output argument.
14443*> \endverbatim
14444*>
14445*> \param[in,out] R
14446*> \verbatim
14447*>          R is DOUBLE PRECISION array, dimension (N)
14448*>          The row scale factors for A.  If EQUED = 'R' or 'B', A is
14449*>          multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
14450*>          is not accessed.  R is an input argument if FACT = 'F';
14451*>          otherwise, R is an output argument.  If FACT = 'F' and
14452*>          EQUED = 'R' or 'B', each element of R must be positive.
14453*> \endverbatim
14454*>
14455*> \param[in,out] C
14456*> \verbatim
14457*>          C is DOUBLE PRECISION array, dimension (N)
14458*>          The column scale factors for A.  If EQUED = 'C' or 'B', A is
14459*>          multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
14460*>          is not accessed.  C is an input argument if FACT = 'F';
14461*>          otherwise, C is an output argument.  If FACT = 'F' and
14462*>          EQUED = 'C' or 'B', each element of C must be positive.
14463*> \endverbatim
14464*>
14465*> \param[in,out] B
14466*> \verbatim
14467*>          B is COMPLEX*16 array, dimension (LDB,NRHS)
14468*>          On entry, the N-by-NRHS right hand side matrix B.
14469*>          On exit,
14470*>          if EQUED = 'N', B is not modified;
14471*>          if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by
14472*>          diag(R)*B;
14473*>          if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is
14474*>          overwritten by diag(C)*B.
14475*> \endverbatim
14476*>
14477*> \param[in] LDB
14478*> \verbatim
14479*>          LDB is INTEGER
14480*>          The leading dimension of the array B.  LDB >= max(1,N).
14481*> \endverbatim
14482*>
14483*> \param[out] X
14484*> \verbatim
14485*>          X is COMPLEX*16 array, dimension (LDX,NRHS)
14486*>          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X
14487*>          to the original system of equations.  Note that A and B are
14488*>          modified on exit if EQUED .ne. 'N', and the solution to the
14489*>          equilibrated system is inv(diag(C))*X if TRANS = 'N' and
14490*>          EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'
14491*>          and EQUED = 'R' or 'B'.
14492*> \endverbatim
14493*>
14494*> \param[in] LDX
14495*> \verbatim
14496*>          LDX is INTEGER
14497*>          The leading dimension of the array X.  LDX >= max(1,N).
14498*> \endverbatim
14499*>
14500*> \param[out] RCOND
14501*> \verbatim
14502*>          RCOND is DOUBLE PRECISION
14503*>          The estimate of the reciprocal condition number of the matrix
14504*>          A after equilibration (if done).  If RCOND is less than the
14505*>          machine precision (in particular, if RCOND = 0), the matrix
14506*>          is singular to working precision.  This condition is
14507*>          indicated by a return code of INFO > 0.
14508*> \endverbatim
14509*>
14510*> \param[out] FERR
14511*> \verbatim
14512*>          FERR is DOUBLE PRECISION array, dimension (NRHS)
14513*>          The estimated forward error bound for each solution vector
14514*>          X(j) (the j-th column of the solution matrix X).
14515*>          If XTRUE is the true solution corresponding to X(j), FERR(j)
14516*>          is an estimated upper bound for the magnitude of the largest
14517*>          element in (X(j) - XTRUE) divided by the magnitude of the
14518*>          largest element in X(j).  The estimate is as reliable as
14519*>          the estimate for RCOND, and is almost always a slight
14520*>          overestimate of the true error.
14521*> \endverbatim
14522*>
14523*> \param[out] BERR
14524*> \verbatim
14525*>          BERR is DOUBLE PRECISION array, dimension (NRHS)
14526*>          The componentwise relative backward error of each solution
14527*>          vector X(j) (i.e., the smallest relative change in
14528*>          any element of A or B that makes X(j) an exact solution).
14529*> \endverbatim
14530*>
14531*> \param[out] WORK
14532*> \verbatim
14533*>          WORK is COMPLEX*16 array, dimension (2*N)
14534*> \endverbatim
14535*>
14536*> \param[out] RWORK
14537*> \verbatim
14538*>          RWORK is DOUBLE PRECISION array, dimension (2*N)
14539*>          On exit, RWORK(1) contains the reciprocal pivot growth
14540*>          factor norm(A)/norm(U). The "max absolute element" norm is
14541*>          used. If RWORK(1) is much less than 1, then the stability
14542*>          of the LU factorization of the (equilibrated) matrix A
14543*>          could be poor. This also means that the solution X, condition
14544*>          estimator RCOND, and forward error bound FERR could be
14545*>          unreliable. If factorization fails with 0<INFO<=N, then
14546*>          RWORK(1) contains the reciprocal pivot growth factor for the
14547*>          leading INFO columns of A.
14548*> \endverbatim
14549*>
14550*> \param[out] INFO
14551*> \verbatim
14552*>          INFO is INTEGER
14553*>          = 0:  successful exit
14554*>          < 0:  if INFO = -i, the i-th argument had an illegal value
14555*>          > 0:  if INFO = i, and i is
14556*>                <= N:  U(i,i) is exactly zero.  The factorization has
14557*>                       been completed, but the factor U is exactly
14558*>                       singular, so the solution and error bounds
14559*>                       could not be computed. RCOND = 0 is returned.
14560*>                = N+1: U is nonsingular, but RCOND is less than machine
14561*>                       precision, meaning that the matrix is singular
14562*>                       to working precision.  Nevertheless, the
14563*>                       solution and error bounds are computed because
14564*>                       there are a number of situations where the
14565*>                       computed solution can be more accurate than the
14566*>                       value of RCOND would suggest.
14567*> \endverbatim
14568*
14569*  Authors:
14570*  ========
14571*
14572*> \author Univ. of Tennessee
14573*> \author Univ. of California Berkeley
14574*> \author Univ. of Colorado Denver
14575*> \author NAG Ltd.
14576*
14577*> \date April 2012
14578*
14579*> \ingroup complex16GEsolve
14580*
14581*  =====================================================================
14582      SUBROUTINE ZGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV,
14583     $                   EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR,
14584     $                   WORK, RWORK, INFO )
14585*
14586*  -- LAPACK driver routine (version 3.7.0) --
14587*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
14588*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
14589*     April 2012
14590*
14591*     .. Scalar Arguments ..
14592      CHARACTER          EQUED, FACT, TRANS
14593      INTEGER            INFO, LDA, LDAF, LDB, LDX, N, NRHS
14594      DOUBLE PRECISION   RCOND
14595*     ..
14596*     .. Array Arguments ..
14597      INTEGER            IPIV( * )
14598      DOUBLE PRECISION   BERR( * ), C( * ), FERR( * ), R( * ),
14599     $                   RWORK( * )
14600      COMPLEX*16         A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
14601     $                   WORK( * ), X( LDX, * )
14602*     ..
14603*
14604*  =====================================================================
14605*
14606*     .. Parameters ..
14607      DOUBLE PRECISION   ZERO, ONE
14608      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
14609*     ..
14610*     .. Local Scalars ..
14611      LOGICAL            COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU
14612      CHARACTER          NORM
14613      INTEGER            I, INFEQU, J
14614      DOUBLE PRECISION   AMAX, ANORM, BIGNUM, COLCND, RCMAX, RCMIN,
14615     $                   ROWCND, RPVGRW, SMLNUM
14616*     ..
14617*     .. External Functions ..
14618      LOGICAL            LSAME
14619      DOUBLE PRECISION   DLAMCH, ZLANGE, ZLANTR
14620      EXTERNAL           LSAME, DLAMCH, ZLANGE, ZLANTR
14621*     ..
14622*     .. External Subroutines ..
14623      EXTERNAL           XERBLA, ZGECON, ZGEEQU, ZGERFS, ZGETRF, ZGETRS,
14624     $                   ZLACPY, ZLAQGE
14625*     ..
14626*     .. Intrinsic Functions ..
14627      INTRINSIC          MAX, MIN
14628*     ..
14629*     .. Executable Statements ..
14630*
14631      INFO = 0
14632      NOFACT = LSAME( FACT, 'N' )
14633      EQUIL = LSAME( FACT, 'E' )
14634      NOTRAN = LSAME( TRANS, 'N' )
14635      IF( NOFACT .OR. EQUIL ) THEN
14636         EQUED = 'N'
14637         ROWEQU = .FALSE.
14638         COLEQU = .FALSE.
14639      ELSE
14640         ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
14641         COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
14642         SMLNUM = DLAMCH( 'Safe minimum' )
14643         BIGNUM = ONE / SMLNUM
14644      END IF
14645*
14646*     Test the input parameters.
14647*
14648      IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
14649     $     THEN
14650         INFO = -1
14651      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
14652     $         LSAME( TRANS, 'C' ) ) THEN
14653         INFO = -2
14654      ELSE IF( N.LT.0 ) THEN
14655         INFO = -3
14656      ELSE IF( NRHS.LT.0 ) THEN
14657         INFO = -4
14658      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
14659         INFO = -6
14660      ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
14661         INFO = -8
14662      ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
14663     $         ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
14664         INFO = -10
14665      ELSE
14666         IF( ROWEQU ) THEN
14667            RCMIN = BIGNUM
14668            RCMAX = ZERO
14669            DO 10 J = 1, N
14670               RCMIN = MIN( RCMIN, R( J ) )
14671               RCMAX = MAX( RCMAX, R( J ) )
14672   10       CONTINUE
14673            IF( RCMIN.LE.ZERO ) THEN
14674               INFO = -11
14675            ELSE IF( N.GT.0 ) THEN
14676               ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
14677            ELSE
14678               ROWCND = ONE
14679            END IF
14680         END IF
14681         IF( COLEQU .AND. INFO.EQ.0 ) THEN
14682            RCMIN = BIGNUM
14683            RCMAX = ZERO
14684            DO 20 J = 1, N
14685               RCMIN = MIN( RCMIN, C( J ) )
14686               RCMAX = MAX( RCMAX, C( J ) )
14687   20       CONTINUE
14688            IF( RCMIN.LE.ZERO ) THEN
14689               INFO = -12
14690            ELSE IF( N.GT.0 ) THEN
14691               COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
14692            ELSE
14693               COLCND = ONE
14694            END IF
14695         END IF
14696         IF( INFO.EQ.0 ) THEN
14697            IF( LDB.LT.MAX( 1, N ) ) THEN
14698               INFO = -14
14699            ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
14700               INFO = -16
14701            END IF
14702         END IF
14703      END IF
14704*
14705      IF( INFO.NE.0 ) THEN
14706         CALL XERBLA( 'ZGESVX', -INFO )
14707         RETURN
14708      END IF
14709*
14710      IF( EQUIL ) THEN
14711*
14712*        Compute row and column scalings to equilibrate the matrix A.
14713*
14714         CALL ZGEEQU( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFEQU )
14715         IF( INFEQU.EQ.0 ) THEN
14716*
14717*           Equilibrate the matrix.
14718*
14719            CALL ZLAQGE( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX,
14720     $                   EQUED )
14721            ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
14722            COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
14723         END IF
14724      END IF
14725*
14726*     Scale the right hand side.
14727*
14728      IF( NOTRAN ) THEN
14729         IF( ROWEQU ) THEN
14730            DO 40 J = 1, NRHS
14731               DO 30 I = 1, N
14732                  B( I, J ) = R( I )*B( I, J )
14733   30          CONTINUE
14734   40       CONTINUE
14735         END IF
14736      ELSE IF( COLEQU ) THEN
14737         DO 60 J = 1, NRHS
14738            DO 50 I = 1, N
14739               B( I, J ) = C( I )*B( I, J )
14740   50       CONTINUE
14741   60    CONTINUE
14742      END IF
14743*
14744      IF( NOFACT .OR. EQUIL ) THEN
14745*
14746*        Compute the LU factorization of A.
14747*
14748         CALL ZLACPY( 'Full', N, N, A, LDA, AF, LDAF )
14749         CALL ZGETRF( N, N, AF, LDAF, IPIV, INFO )
14750*
14751*        Return if INFO is non-zero.
14752*
14753         IF( INFO.GT.0 ) THEN
14754*
14755*           Compute the reciprocal pivot growth factor of the
14756*           leading rank-deficient INFO columns of A.
14757*
14758            RPVGRW = ZLANTR( 'M', 'U', 'N', INFO, INFO, AF, LDAF,
14759     $               RWORK )
14760            IF( RPVGRW.EQ.ZERO ) THEN
14761               RPVGRW = ONE
14762            ELSE
14763               RPVGRW = ZLANGE( 'M', N, INFO, A, LDA, RWORK ) /
14764     $                  RPVGRW
14765            END IF
14766            RWORK( 1 ) = RPVGRW
14767            RCOND = ZERO
14768            RETURN
14769         END IF
14770      END IF
14771*
14772*     Compute the norm of the matrix A and the
14773*     reciprocal pivot growth factor RPVGRW.
14774*
14775      IF( NOTRAN ) THEN
14776         NORM = '1'
14777      ELSE
14778         NORM = 'I'
14779      END IF
14780      ANORM = ZLANGE( NORM, N, N, A, LDA, RWORK )
14781      RPVGRW = ZLANTR( 'M', 'U', 'N', N, N, AF, LDAF, RWORK )
14782      IF( RPVGRW.EQ.ZERO ) THEN
14783         RPVGRW = ONE
14784      ELSE
14785         RPVGRW = ZLANGE( 'M', N, N, A, LDA, RWORK ) / RPVGRW
14786      END IF
14787*
14788*     Compute the reciprocal of the condition number of A.
14789*
14790      CALL ZGECON( NORM, N, AF, LDAF, ANORM, RCOND, WORK, RWORK, INFO )
14791*
14792*     Compute the solution matrix X.
14793*
14794      CALL ZLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
14795      CALL ZGETRS( TRANS, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO )
14796*
14797*     Use iterative refinement to improve the computed solution and
14798*     compute error bounds and backward error estimates for it.
14799*
14800      CALL ZGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X,
14801     $             LDX, FERR, BERR, WORK, RWORK, INFO )
14802*
14803*     Transform the solution matrix X to a solution of the original
14804*     system.
14805*
14806      IF( NOTRAN ) THEN
14807         IF( COLEQU ) THEN
14808            DO 80 J = 1, NRHS
14809               DO 70 I = 1, N
14810                  X( I, J ) = C( I )*X( I, J )
14811   70          CONTINUE
14812   80       CONTINUE
14813            DO 90 J = 1, NRHS
14814               FERR( J ) = FERR( J ) / COLCND
14815   90       CONTINUE
14816         END IF
14817      ELSE IF( ROWEQU ) THEN
14818         DO 110 J = 1, NRHS
14819            DO 100 I = 1, N
14820               X( I, J ) = R( I )*X( I, J )
14821  100       CONTINUE
14822  110    CONTINUE
14823         DO 120 J = 1, NRHS
14824            FERR( J ) = FERR( J ) / ROWCND
14825  120    CONTINUE
14826      END IF
14827*
14828*     Set INFO = N+1 if the matrix is singular to working precision.
14829*
14830      IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
14831     $   INFO = N + 1
14832*
14833      RWORK( 1 ) = RPVGRW
14834      RETURN
14835*
14836*     End of ZGESVX
14837*
14838      END
14839*> \brief \b ZGETC2 computes the LU factorization with complete pivoting of the general n-by-n matrix.
14840*
14841*  =========== DOCUMENTATION ===========
14842*
14843* Online html documentation available at
14844*            http://www.netlib.org/lapack/explore-html/
14845*
14846*> \htmlonly
14847*> Download ZGETC2 + dependencies
14848*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgetc2.f">
14849*> [TGZ]</a>
14850*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgetc2.f">
14851*> [ZIP]</a>
14852*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgetc2.f">
14853*> [TXT]</a>
14854*> \endhtmlonly
14855*
14856*  Definition:
14857*  ===========
14858*
14859*       SUBROUTINE ZGETC2( N, A, LDA, IPIV, JPIV, INFO )
14860*
14861*       .. Scalar Arguments ..
14862*       INTEGER            INFO, LDA, N
14863*       ..
14864*       .. Array Arguments ..
14865*       INTEGER            IPIV( * ), JPIV( * )
14866*       COMPLEX*16         A( LDA, * )
14867*       ..
14868*
14869*
14870*> \par Purpose:
14871*  =============
14872*>
14873*> \verbatim
14874*>
14875*> ZGETC2 computes an LU factorization, using complete pivoting, of the
14876*> n-by-n matrix A. The factorization has the form A = P * L * U * Q,
14877*> where P and Q are permutation matrices, L is lower triangular with
14878*> unit diagonal elements and U is upper triangular.
14879*>
14880*> This is a level 1 BLAS version of the algorithm.
14881*> \endverbatim
14882*
14883*  Arguments:
14884*  ==========
14885*
14886*> \param[in] N
14887*> \verbatim
14888*>          N is INTEGER
14889*>          The order of the matrix A. N >= 0.
14890*> \endverbatim
14891*>
14892*> \param[in,out] A
14893*> \verbatim
14894*>          A is COMPLEX*16 array, dimension (LDA, N)
14895*>          On entry, the n-by-n matrix to be factored.
14896*>          On exit, the factors L and U from the factorization
14897*>          A = P*L*U*Q; the unit diagonal elements of L are not stored.
14898*>          If U(k, k) appears to be less than SMIN, U(k, k) is given the
14899*>          value of SMIN, giving a nonsingular perturbed system.
14900*> \endverbatim
14901*>
14902*> \param[in] LDA
14903*> \verbatim
14904*>          LDA is INTEGER
14905*>          The leading dimension of the array A.  LDA >= max(1, N).
14906*> \endverbatim
14907*>
14908*> \param[out] IPIV
14909*> \verbatim
14910*>          IPIV is INTEGER array, dimension (N).
14911*>          The pivot indices; for 1 <= i <= N, row i of the
14912*>          matrix has been interchanged with row IPIV(i).
14913*> \endverbatim
14914*>
14915*> \param[out] JPIV
14916*> \verbatim
14917*>          JPIV is INTEGER array, dimension (N).
14918*>          The pivot indices; for 1 <= j <= N, column j of the
14919*>          matrix has been interchanged with column JPIV(j).
14920*> \endverbatim
14921*>
14922*> \param[out] INFO
14923*> \verbatim
14924*>          INFO is INTEGER
14925*>           = 0: successful exit
14926*>           > 0: if INFO = k, U(k, k) is likely to produce overflow if
14927*>                one tries to solve for x in Ax = b. So U is perturbed
14928*>                to avoid the overflow.
14929*> \endverbatim
14930*
14931*  Authors:
14932*  ========
14933*
14934*> \author Univ. of Tennessee
14935*> \author Univ. of California Berkeley
14936*> \author Univ. of Colorado Denver
14937*> \author NAG Ltd.
14938*
14939*> \date June 2016
14940*
14941*> \ingroup complex16GEauxiliary
14942*
14943*> \par Contributors:
14944*  ==================
14945*>
14946*>     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
14947*>     Umea University, S-901 87 Umea, Sweden.
14948*
14949*  =====================================================================
14950      SUBROUTINE ZGETC2( N, A, LDA, IPIV, JPIV, INFO )
14951*
14952*  -- LAPACK auxiliary routine (version 3.8.0) --
14953*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
14954*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
14955*     June 2016
14956*
14957*     .. Scalar Arguments ..
14958      INTEGER            INFO, LDA, N
14959*     ..
14960*     .. Array Arguments ..
14961      INTEGER            IPIV( * ), JPIV( * )
14962      COMPLEX*16         A( LDA, * )
14963*     ..
14964*
14965*  =====================================================================
14966*
14967*     .. Parameters ..
14968      DOUBLE PRECISION   ZERO, ONE
14969      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
14970*     ..
14971*     .. Local Scalars ..
14972      INTEGER            I, IP, IPV, J, JP, JPV
14973      DOUBLE PRECISION   BIGNUM, EPS, SMIN, SMLNUM, XMAX
14974*     ..
14975*     .. External Subroutines ..
14976      EXTERNAL           ZGERU, ZSWAP, DLABAD
14977*     ..
14978*     .. External Functions ..
14979      DOUBLE PRECISION   DLAMCH
14980      EXTERNAL           DLAMCH
14981*     ..
14982*     .. Intrinsic Functions ..
14983      INTRINSIC          ABS, DCMPLX, MAX
14984*     ..
14985*     .. Executable Statements ..
14986*
14987      INFO = 0
14988*
14989*     Quick return if possible
14990*
14991      IF( N.EQ.0 )
14992     $   RETURN
14993*
14994*     Set constants to control overflow
14995*
14996      EPS = DLAMCH( 'P' )
14997      SMLNUM = DLAMCH( 'S' ) / EPS
14998      BIGNUM = ONE / SMLNUM
14999      CALL DLABAD( SMLNUM, BIGNUM )
15000*
15001*     Handle the case N=1 by itself
15002*
15003      IF( N.EQ.1 ) THEN
15004         IPIV( 1 ) = 1
15005         JPIV( 1 ) = 1
15006         IF( ABS( A( 1, 1 ) ).LT.SMLNUM ) THEN
15007            INFO = 1
15008            A( 1, 1 ) = DCMPLX( SMLNUM, ZERO )
15009         END IF
15010         RETURN
15011      END IF
15012*
15013*     Factorize A using complete pivoting.
15014*     Set pivots less than SMIN to SMIN
15015*
15016      DO 40 I = 1, N - 1
15017*
15018*        Find max element in matrix A
15019*
15020         XMAX = ZERO
15021         DO 20 IP = I, N
15022            DO 10 JP = I, N
15023               IF( ABS( A( IP, JP ) ).GE.XMAX ) THEN
15024                  XMAX = ABS( A( IP, JP ) )
15025                  IPV = IP
15026                  JPV = JP
15027               END IF
15028   10       CONTINUE
15029   20    CONTINUE
15030         IF( I.EQ.1 )
15031     $      SMIN = MAX( EPS*XMAX, SMLNUM )
15032*
15033*        Swap rows
15034*
15035         IF( IPV.NE.I )
15036     $      CALL ZSWAP( N, A( IPV, 1 ), LDA, A( I, 1 ), LDA )
15037         IPIV( I ) = IPV
15038*
15039*        Swap columns
15040*
15041         IF( JPV.NE.I )
15042     $      CALL ZSWAP( N, A( 1, JPV ), 1, A( 1, I ), 1 )
15043         JPIV( I ) = JPV
15044*
15045*        Check for singularity
15046*
15047         IF( ABS( A( I, I ) ).LT.SMIN ) THEN
15048            INFO = I
15049            A( I, I ) = DCMPLX( SMIN, ZERO )
15050         END IF
15051         DO 30 J = I + 1, N
15052            A( J, I ) = A( J, I ) / A( I, I )
15053   30    CONTINUE
15054         CALL ZGERU( N-I, N-I, -DCMPLX( ONE ), A( I+1, I ), 1,
15055     $               A( I, I+1 ), LDA, A( I+1, I+1 ), LDA )
15056   40 CONTINUE
15057*
15058      IF( ABS( A( N, N ) ).LT.SMIN ) THEN
15059         INFO = N
15060         A( N, N ) = DCMPLX( SMIN, ZERO )
15061      END IF
15062*
15063*     Set last pivots to N
15064*
15065      IPIV( N ) = N
15066      JPIV( N ) = N
15067*
15068      RETURN
15069*
15070*     End of ZGETC2
15071*
15072      END
15073*> \brief \b ZGETF2 computes the LU factorization of a general m-by-n matrix using partial pivoting with row interchanges (unblocked algorithm).
15074*
15075*  =========== DOCUMENTATION ===========
15076*
15077* Online html documentation available at
15078*            http://www.netlib.org/lapack/explore-html/
15079*
15080*> \htmlonly
15081*> Download ZGETF2 + dependencies
15082*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgetf2.f">
15083*> [TGZ]</a>
15084*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgetf2.f">
15085*> [ZIP]</a>
15086*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgetf2.f">
15087*> [TXT]</a>
15088*> \endhtmlonly
15089*
15090*  Definition:
15091*  ===========
15092*
15093*       SUBROUTINE ZGETF2( M, N, A, LDA, IPIV, INFO )
15094*
15095*       .. Scalar Arguments ..
15096*       INTEGER            INFO, LDA, M, N
15097*       ..
15098*       .. Array Arguments ..
15099*       INTEGER            IPIV( * )
15100*       COMPLEX*16         A( LDA, * )
15101*       ..
15102*
15103*
15104*> \par Purpose:
15105*  =============
15106*>
15107*> \verbatim
15108*>
15109*> ZGETF2 computes an LU factorization of a general m-by-n matrix A
15110*> using partial pivoting with row interchanges.
15111*>
15112*> The factorization has the form
15113*>    A = P * L * U
15114*> where P is a permutation matrix, L is lower triangular with unit
15115*> diagonal elements (lower trapezoidal if m > n), and U is upper
15116*> triangular (upper trapezoidal if m < n).
15117*>
15118*> This is the right-looking Level 2 BLAS version of the algorithm.
15119*> \endverbatim
15120*
15121*  Arguments:
15122*  ==========
15123*
15124*> \param[in] M
15125*> \verbatim
15126*>          M is INTEGER
15127*>          The number of rows of the matrix A.  M >= 0.
15128*> \endverbatim
15129*>
15130*> \param[in] N
15131*> \verbatim
15132*>          N is INTEGER
15133*>          The number of columns of the matrix A.  N >= 0.
15134*> \endverbatim
15135*>
15136*> \param[in,out] A
15137*> \verbatim
15138*>          A is COMPLEX*16 array, dimension (LDA,N)
15139*>          On entry, the m by n matrix to be factored.
15140*>          On exit, the factors L and U from the factorization
15141*>          A = P*L*U; the unit diagonal elements of L are not stored.
15142*> \endverbatim
15143*>
15144*> \param[in] LDA
15145*> \verbatim
15146*>          LDA is INTEGER
15147*>          The leading dimension of the array A.  LDA >= max(1,M).
15148*> \endverbatim
15149*>
15150*> \param[out] IPIV
15151*> \verbatim
15152*>          IPIV is INTEGER array, dimension (min(M,N))
15153*>          The pivot indices; for 1 <= i <= min(M,N), row i of the
15154*>          matrix was interchanged with row IPIV(i).
15155*> \endverbatim
15156*>
15157*> \param[out] INFO
15158*> \verbatim
15159*>          INFO is INTEGER
15160*>          = 0: successful exit
15161*>          < 0: if INFO = -k, the k-th argument had an illegal value
15162*>          > 0: if INFO = k, U(k,k) is exactly zero. The factorization
15163*>               has been completed, but the factor U is exactly
15164*>               singular, and division by zero will occur if it is used
15165*>               to solve a system of equations.
15166*> \endverbatim
15167*
15168*  Authors:
15169*  ========
15170*
15171*> \author Univ. of Tennessee
15172*> \author Univ. of California Berkeley
15173*> \author Univ. of Colorado Denver
15174*> \author NAG Ltd.
15175*
15176*> \date December 2016
15177*
15178*> \ingroup complex16GEcomputational
15179*
15180*  =====================================================================
15181      SUBROUTINE ZGETF2( M, N, A, LDA, IPIV, INFO )
15182*
15183*  -- LAPACK computational routine (version 3.7.0) --
15184*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
15185*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
15186*     December 2016
15187*
15188*     .. Scalar Arguments ..
15189      INTEGER            INFO, LDA, M, N
15190*     ..
15191*     .. Array Arguments ..
15192      INTEGER            IPIV( * )
15193      COMPLEX*16         A( LDA, * )
15194*     ..
15195*
15196*  =====================================================================
15197*
15198*     .. Parameters ..
15199      COMPLEX*16         ONE, ZERO
15200      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),
15201     $                   ZERO = ( 0.0D+0, 0.0D+0 ) )
15202*     ..
15203*     .. Local Scalars ..
15204      DOUBLE PRECISION   SFMIN
15205      INTEGER            I, J, JP
15206*     ..
15207*     .. External Functions ..
15208      DOUBLE PRECISION   DLAMCH
15209      INTEGER            IZAMAX
15210      EXTERNAL           DLAMCH, IZAMAX
15211*     ..
15212*     .. External Subroutines ..
15213      EXTERNAL           XERBLA, ZGERU, ZSCAL, ZSWAP
15214*     ..
15215*     .. Intrinsic Functions ..
15216      INTRINSIC          MAX, MIN
15217*     ..
15218*     .. Executable Statements ..
15219*
15220*     Test the input parameters.
15221*
15222      INFO = 0
15223      IF( M.LT.0 ) THEN
15224         INFO = -1
15225      ELSE IF( N.LT.0 ) THEN
15226         INFO = -2
15227      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
15228         INFO = -4
15229      END IF
15230      IF( INFO.NE.0 ) THEN
15231         CALL XERBLA( 'ZGETF2', -INFO )
15232         RETURN
15233      END IF
15234*
15235*     Quick return if possible
15236*
15237      IF( M.EQ.0 .OR. N.EQ.0 )
15238     $   RETURN
15239*
15240*     Compute machine safe minimum
15241*
15242      SFMIN = DLAMCH('S')
15243*
15244      DO 10 J = 1, MIN( M, N )
15245*
15246*        Find pivot and test for singularity.
15247*
15248         JP = J - 1 + IZAMAX( M-J+1, A( J, J ), 1 )
15249         IPIV( J ) = JP
15250         IF( A( JP, J ).NE.ZERO ) THEN
15251*
15252*           Apply the interchange to columns 1:N.
15253*
15254            IF( JP.NE.J )
15255     $         CALL ZSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA )
15256*
15257*           Compute elements J+1:M of J-th column.
15258*
15259            IF( J.LT.M ) THEN
15260               IF( ABS(A( J, J )) .GE. SFMIN ) THEN
15261                  CALL ZSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 )
15262               ELSE
15263                  DO 20 I = 1, M-J
15264                     A( J+I, J ) = A( J+I, J ) / A( J, J )
15265   20             CONTINUE
15266               END IF
15267            END IF
15268*
15269         ELSE IF( INFO.EQ.0 ) THEN
15270*
15271            INFO = J
15272         END IF
15273*
15274         IF( J.LT.MIN( M, N ) ) THEN
15275*
15276*           Update trailing submatrix.
15277*
15278            CALL ZGERU( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ),
15279     $                  LDA, A( J+1, J+1 ), LDA )
15280         END IF
15281   10 CONTINUE
15282      RETURN
15283*
15284*     End of ZGETF2
15285*
15286      END
15287*> \brief \b ZGETRF
15288*
15289*  =========== DOCUMENTATION ===========
15290*
15291* Online html documentation available at
15292*            http://www.netlib.org/lapack/explore-html/
15293*
15294*> \htmlonly
15295*> Download ZGETRF + dependencies
15296*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgetrf.f">
15297*> [TGZ]</a>
15298*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgetrf.f">
15299*> [ZIP]</a>
15300*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgetrf.f">
15301*> [TXT]</a>
15302*> \endhtmlonly
15303*
15304*  Definition:
15305*  ===========
15306*
15307*       SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO )
15308*
15309*       .. Scalar Arguments ..
15310*       INTEGER            INFO, LDA, M, N
15311*       ..
15312*       .. Array Arguments ..
15313*       INTEGER            IPIV( * )
15314*       COMPLEX*16         A( LDA, * )
15315*       ..
15316*
15317*
15318*> \par Purpose:
15319*  =============
15320*>
15321*> \verbatim
15322*>
15323*> ZGETRF computes an LU factorization of a general M-by-N matrix A
15324*> using partial pivoting with row interchanges.
15325*>
15326*> The factorization has the form
15327*>    A = P * L * U
15328*> where P is a permutation matrix, L is lower triangular with unit
15329*> diagonal elements (lower trapezoidal if m > n), and U is upper
15330*> triangular (upper trapezoidal if m < n).
15331*>
15332*> This is the right-looking Level 3 BLAS version of the algorithm.
15333*> \endverbatim
15334*
15335*  Arguments:
15336*  ==========
15337*
15338*> \param[in] M
15339*> \verbatim
15340*>          M is INTEGER
15341*>          The number of rows of the matrix A.  M >= 0.
15342*> \endverbatim
15343*>
15344*> \param[in] N
15345*> \verbatim
15346*>          N is INTEGER
15347*>          The number of columns of the matrix A.  N >= 0.
15348*> \endverbatim
15349*>
15350*> \param[in,out] A
15351*> \verbatim
15352*>          A is COMPLEX*16 array, dimension (LDA,N)
15353*>          On entry, the M-by-N matrix to be factored.
15354*>          On exit, the factors L and U from the factorization
15355*>          A = P*L*U; the unit diagonal elements of L are not stored.
15356*> \endverbatim
15357*>
15358*> \param[in] LDA
15359*> \verbatim
15360*>          LDA is INTEGER
15361*>          The leading dimension of the array A.  LDA >= max(1,M).
15362*> \endverbatim
15363*>
15364*> \param[out] IPIV
15365*> \verbatim
15366*>          IPIV is INTEGER array, dimension (min(M,N))
15367*>          The pivot indices; for 1 <= i <= min(M,N), row i of the
15368*>          matrix was interchanged with row IPIV(i).
15369*> \endverbatim
15370*>
15371*> \param[out] INFO
15372*> \verbatim
15373*>          INFO is INTEGER
15374*>          = 0:  successful exit
15375*>          < 0:  if INFO = -i, the i-th argument had an illegal value
15376*>          > 0:  if INFO = i, U(i,i) is exactly zero. The factorization
15377*>                has been completed, but the factor U is exactly
15378*>                singular, and division by zero will occur if it is used
15379*>                to solve a system of equations.
15380*> \endverbatim
15381*
15382*  Authors:
15383*  ========
15384*
15385*> \author Univ. of Tennessee
15386*> \author Univ. of California Berkeley
15387*> \author Univ. of Colorado Denver
15388*> \author NAG Ltd.
15389*
15390*> \date December 2016
15391*
15392*> \ingroup complex16GEcomputational
15393*
15394*  =====================================================================
15395      SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO )
15396*
15397*  -- LAPACK computational routine (version 3.7.0) --
15398*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
15399*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
15400*     December 2016
15401*
15402*     .. Scalar Arguments ..
15403      INTEGER            INFO, LDA, M, N
15404*     ..
15405*     .. Array Arguments ..
15406      INTEGER            IPIV( * )
15407      COMPLEX*16         A( LDA, * )
15408*     ..
15409*
15410*  =====================================================================
15411*
15412*     .. Parameters ..
15413      COMPLEX*16         ONE
15414      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
15415*     ..
15416*     .. Local Scalars ..
15417      INTEGER            I, IINFO, J, JB, NB
15418*     ..
15419*     .. External Subroutines ..
15420      EXTERNAL           XERBLA, ZGEMM, ZGETRF2, ZLASWP, ZTRSM
15421*     ..
15422*     .. External Functions ..
15423      INTEGER            ILAENV
15424      EXTERNAL           ILAENV
15425*     ..
15426*     .. Intrinsic Functions ..
15427      INTRINSIC          MAX, MIN
15428*     ..
15429*     .. Executable Statements ..
15430*
15431*     Test the input parameters.
15432*
15433      INFO = 0
15434      IF( M.LT.0 ) THEN
15435         INFO = -1
15436      ELSE IF( N.LT.0 ) THEN
15437         INFO = -2
15438      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
15439         INFO = -4
15440      END IF
15441      IF( INFO.NE.0 ) THEN
15442         CALL XERBLA( 'ZGETRF', -INFO )
15443         RETURN
15444      END IF
15445*
15446*     Quick return if possible
15447*
15448      IF( M.EQ.0 .OR. N.EQ.0 )
15449     $   RETURN
15450*
15451*     Determine the block size for this environment.
15452*
15453      NB = ILAENV( 1, 'ZGETRF', ' ', M, N, -1, -1 )
15454      IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN
15455*
15456*        Use unblocked code.
15457*
15458         CALL ZGETRF2( M, N, A, LDA, IPIV, INFO )
15459      ELSE
15460*
15461*        Use blocked code.
15462*
15463         DO 20 J = 1, MIN( M, N ), NB
15464            JB = MIN( MIN( M, N )-J+1, NB )
15465*
15466*           Factor diagonal and subdiagonal blocks and test for exact
15467*           singularity.
15468*
15469            CALL ZGETRF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO )
15470*
15471*           Adjust INFO and the pivot indices.
15472*
15473            IF( INFO.EQ.0 .AND. IINFO.GT.0 )
15474     $         INFO = IINFO + J - 1
15475            DO 10 I = J, MIN( M, J+JB-1 )
15476               IPIV( I ) = J - 1 + IPIV( I )
15477   10       CONTINUE
15478*
15479*           Apply interchanges to columns 1:J-1.
15480*
15481            CALL ZLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 )
15482*
15483            IF( J+JB.LE.N ) THEN
15484*
15485*              Apply interchanges to columns J+JB:N.
15486*
15487               CALL ZLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1,
15488     $                      IPIV, 1 )
15489*
15490*              Compute block row of U.
15491*
15492               CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB,
15493     $                     N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ),
15494     $                     LDA )
15495               IF( J+JB.LE.M ) THEN
15496*
15497*                 Update trailing submatrix.
15498*
15499                  CALL ZGEMM( 'No transpose', 'No transpose', M-J-JB+1,
15500     $                        N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA,
15501     $                        A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ),
15502     $                        LDA )
15503               END IF
15504            END IF
15505   20    CONTINUE
15506      END IF
15507      RETURN
15508*
15509*     End of ZGETRF
15510*
15511      END
15512*> \brief \b ZGETRF2
15513*
15514*  =========== DOCUMENTATION ===========
15515*
15516* Online html documentation available at
15517*            http://www.netlib.org/lapack/explore-html/
15518*
15519*  Definition:
15520*  ===========
15521*
15522*       RECURSIVE SUBROUTINE ZGETRF2( M, N, A, LDA, IPIV, INFO )
15523*
15524*       .. Scalar Arguments ..
15525*       INTEGER            INFO, LDA, M, N
15526*       ..
15527*       .. Array Arguments ..
15528*       INTEGER            IPIV( * )
15529*       COMPLEX*16         A( LDA, * )
15530*       ..
15531*
15532*
15533*> \par Purpose:
15534*  =============
15535*>
15536*> \verbatim
15537*>
15538*> ZGETRF2 computes an LU factorization of a general M-by-N matrix A
15539*> using partial pivoting with row interchanges.
15540*>
15541*> The factorization has the form
15542*>    A = P * L * U
15543*> where P is a permutation matrix, L is lower triangular with unit
15544*> diagonal elements (lower trapezoidal if m > n), and U is upper
15545*> triangular (upper trapezoidal if m < n).
15546*>
15547*> This is the recursive version of the algorithm. It divides
15548*> the matrix into four submatrices:
15549*>
15550*>        [  A11 | A12  ]  where A11 is n1 by n1 and A22 is n2 by n2
15551*>    A = [ -----|----- ]  with n1 = min(m,n)/2
15552*>        [  A21 | A22  ]       n2 = n-n1
15553*>
15554*>                                       [ A11 ]
15555*> The subroutine calls itself to factor [ --- ],
15556*>                                       [ A12 ]
15557*>                 [ A12 ]
15558*> do the swaps on [ --- ], solve A12, update A22,
15559*>                 [ A22 ]
15560*>
15561*> then calls itself to factor A22 and do the swaps on A21.
15562*>
15563*> \endverbatim
15564*
15565*  Arguments:
15566*  ==========
15567*
15568*> \param[in] M
15569*> \verbatim
15570*>          M is INTEGER
15571*>          The number of rows of the matrix A.  M >= 0.
15572*> \endverbatim
15573*>
15574*> \param[in] N
15575*> \verbatim
15576*>          N is INTEGER
15577*>          The number of columns of the matrix A.  N >= 0.
15578*> \endverbatim
15579*>
15580*> \param[in,out] A
15581*> \verbatim
15582*>          A is COMPLEX*16 array, dimension (LDA,N)
15583*>          On entry, the M-by-N matrix to be factored.
15584*>          On exit, the factors L and U from the factorization
15585*>          A = P*L*U; the unit diagonal elements of L are not stored.
15586*> \endverbatim
15587*>
15588*> \param[in] LDA
15589*> \verbatim
15590*>          LDA is INTEGER
15591*>          The leading dimension of the array A.  LDA >= max(1,M).
15592*> \endverbatim
15593*>
15594*> \param[out] IPIV
15595*> \verbatim
15596*>          IPIV is INTEGER array, dimension (min(M,N))
15597*>          The pivot indices; for 1 <= i <= min(M,N), row i of the
15598*>          matrix was interchanged with row IPIV(i).
15599*> \endverbatim
15600*>
15601*> \param[out] INFO
15602*> \verbatim
15603*>          INFO is INTEGER
15604*>          = 0:  successful exit
15605*>          < 0:  if INFO = -i, the i-th argument had an illegal value
15606*>          > 0:  if INFO = i, U(i,i) is exactly zero. The factorization
15607*>                has been completed, but the factor U is exactly
15608*>                singular, and division by zero will occur if it is used
15609*>                to solve a system of equations.
15610*> \endverbatim
15611*
15612*  Authors:
15613*  ========
15614*
15615*> \author Univ. of Tennessee
15616*> \author Univ. of California Berkeley
15617*> \author Univ. of Colorado Denver
15618*> \author NAG Ltd.
15619*
15620*> \date June 2016
15621*
15622*> \ingroup complex16GEcomputational
15623*
15624*  =====================================================================
15625      RECURSIVE SUBROUTINE ZGETRF2( M, N, A, LDA, IPIV, INFO )
15626*
15627*  -- LAPACK computational routine (version 3.7.0) --
15628*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
15629*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
15630*     June 2016
15631*
15632*     .. Scalar Arguments ..
15633      INTEGER            INFO, LDA, M, N
15634*     ..
15635*     .. Array Arguments ..
15636      INTEGER            IPIV( * )
15637      COMPLEX*16         A( LDA, * )
15638*     ..
15639*
15640*  =====================================================================
15641*
15642*     .. Parameters ..
15643      COMPLEX*16         ONE, ZERO
15644      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),
15645     $                     ZERO = ( 0.0D+0, 0.0D+0 ) )
15646*     ..
15647*     .. Local Scalars ..
15648      DOUBLE PRECISION   SFMIN
15649      COMPLEX*16         TEMP
15650      INTEGER            I, IINFO, N1, N2
15651*     ..
15652*     .. External Functions ..
15653      DOUBLE PRECISION   DLAMCH
15654      INTEGER            IZAMAX
15655      EXTERNAL           DLAMCH, IZAMAX
15656*     ..
15657*     .. External Subroutines ..
15658      EXTERNAL           ZGEMM, ZSCAL, ZLASWP, ZTRSM, XERBLA
15659*     ..
15660*     .. Intrinsic Functions ..
15661      INTRINSIC          MAX, MIN
15662*     ..
15663*     .. Executable Statements ..
15664*
15665*     Test the input parameters
15666*
15667      INFO = 0
15668      IF( M.LT.0 ) THEN
15669         INFO = -1
15670      ELSE IF( N.LT.0 ) THEN
15671         INFO = -2
15672      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
15673         INFO = -4
15674      END IF
15675      IF( INFO.NE.0 ) THEN
15676         CALL XERBLA( 'ZGETRF2', -INFO )
15677         RETURN
15678      END IF
15679*
15680*     Quick return if possible
15681*
15682      IF( M.EQ.0 .OR. N.EQ.0 )
15683     $   RETURN
15684
15685      IF ( M.EQ.1 ) THEN
15686*
15687*        Use unblocked code for one row case
15688*        Just need to handle IPIV and INFO
15689*
15690         IPIV( 1 ) = 1
15691         IF ( A(1,1).EQ.ZERO )
15692     $      INFO = 1
15693*
15694      ELSE IF( N.EQ.1 ) THEN
15695*
15696*        Use unblocked code for one column case
15697*
15698*
15699*        Compute machine safe minimum
15700*
15701         SFMIN = DLAMCH('S')
15702*
15703*        Find pivot and test for singularity
15704*
15705         I = IZAMAX( M, A( 1, 1 ), 1 )
15706         IPIV( 1 ) = I
15707         IF( A( I, 1 ).NE.ZERO ) THEN
15708*
15709*           Apply the interchange
15710*
15711            IF( I.NE.1 ) THEN
15712               TEMP = A( 1, 1 )
15713               A( 1, 1 ) = A( I, 1 )
15714               A( I, 1 ) = TEMP
15715            END IF
15716*
15717*           Compute elements 2:M of the column
15718*
15719            IF( ABS(A( 1, 1 )) .GE. SFMIN ) THEN
15720               CALL ZSCAL( M-1, ONE / A( 1, 1 ), A( 2, 1 ), 1 )
15721            ELSE
15722               DO 10 I = 1, M-1
15723                  A( 1+I, 1 ) = A( 1+I, 1 ) / A( 1, 1 )
15724   10          CONTINUE
15725            END IF
15726*
15727         ELSE
15728            INFO = 1
15729         END IF
15730
15731      ELSE
15732*
15733*        Use recursive code
15734*
15735         N1 = MIN( M, N ) / 2
15736         N2 = N-N1
15737*
15738*               [ A11 ]
15739*        Factor [ --- ]
15740*               [ A21 ]
15741*
15742         CALL ZGETRF2( M, N1, A, LDA, IPIV, IINFO )
15743
15744         IF ( INFO.EQ.0 .AND. IINFO.GT.0 )
15745     $      INFO = IINFO
15746*
15747*                              [ A12 ]
15748*        Apply interchanges to [ --- ]
15749*                              [ A22 ]
15750*
15751         CALL ZLASWP( N2, A( 1, N1+1 ), LDA, 1, N1, IPIV, 1 )
15752*
15753*        Solve A12
15754*
15755         CALL ZTRSM( 'L', 'L', 'N', 'U', N1, N2, ONE, A, LDA,
15756     $               A( 1, N1+1 ), LDA )
15757*
15758*        Update A22
15759*
15760         CALL ZGEMM( 'N', 'N', M-N1, N2, N1, -ONE, A( N1+1, 1 ), LDA,
15761     $               A( 1, N1+1 ), LDA, ONE, A( N1+1, N1+1 ), LDA )
15762*
15763*        Factor A22
15764*
15765         CALL ZGETRF2( M-N1, N2, A( N1+1, N1+1 ), LDA, IPIV( N1+1 ),
15766     $                 IINFO )
15767*
15768*        Adjust INFO and the pivot indices
15769*
15770         IF ( INFO.EQ.0 .AND. IINFO.GT.0 )
15771     $      INFO = IINFO + N1
15772         DO 20 I = N1+1, MIN( M, N )
15773            IPIV( I ) = IPIV( I ) + N1
15774   20    CONTINUE
15775*
15776*        Apply interchanges to A21
15777*
15778         CALL ZLASWP( N1, A( 1, 1 ), LDA, N1+1, MIN( M, N), IPIV, 1 )
15779*
15780      END IF
15781      RETURN
15782*
15783*     End of ZGETRF2
15784*
15785      END
15786*> \brief \b ZGETRI
15787*
15788*  =========== DOCUMENTATION ===========
15789*
15790* Online html documentation available at
15791*            http://www.netlib.org/lapack/explore-html/
15792*
15793*> \htmlonly
15794*> Download ZGETRI + dependencies
15795*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgetri.f">
15796*> [TGZ]</a>
15797*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgetri.f">
15798*> [ZIP]</a>
15799*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgetri.f">
15800*> [TXT]</a>
15801*> \endhtmlonly
15802*
15803*  Definition:
15804*  ===========
15805*
15806*       SUBROUTINE ZGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )
15807*
15808*       .. Scalar Arguments ..
15809*       INTEGER            INFO, LDA, LWORK, N
15810*       ..
15811*       .. Array Arguments ..
15812*       INTEGER            IPIV( * )
15813*       COMPLEX*16         A( LDA, * ), WORK( * )
15814*       ..
15815*
15816*
15817*> \par Purpose:
15818*  =============
15819*>
15820*> \verbatim
15821*>
15822*> ZGETRI computes the inverse of a matrix using the LU factorization
15823*> computed by ZGETRF.
15824*>
15825*> This method inverts U and then computes inv(A) by solving the system
15826*> inv(A)*L = inv(U) for inv(A).
15827*> \endverbatim
15828*
15829*  Arguments:
15830*  ==========
15831*
15832*> \param[in] N
15833*> \verbatim
15834*>          N is INTEGER
15835*>          The order of the matrix A.  N >= 0.
15836*> \endverbatim
15837*>
15838*> \param[in,out] A
15839*> \verbatim
15840*>          A is COMPLEX*16 array, dimension (LDA,N)
15841*>          On entry, the factors L and U from the factorization
15842*>          A = P*L*U as computed by ZGETRF.
15843*>          On exit, if INFO = 0, the inverse of the original matrix A.
15844*> \endverbatim
15845*>
15846*> \param[in] LDA
15847*> \verbatim
15848*>          LDA is INTEGER
15849*>          The leading dimension of the array A.  LDA >= max(1,N).
15850*> \endverbatim
15851*>
15852*> \param[in] IPIV
15853*> \verbatim
15854*>          IPIV is INTEGER array, dimension (N)
15855*>          The pivot indices from ZGETRF; for 1<=i<=N, row i of the
15856*>          matrix was interchanged with row IPIV(i).
15857*> \endverbatim
15858*>
15859*> \param[out] WORK
15860*> \verbatim
15861*>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
15862*>          On exit, if INFO=0, then WORK(1) returns the optimal LWORK.
15863*> \endverbatim
15864*>
15865*> \param[in] LWORK
15866*> \verbatim
15867*>          LWORK is INTEGER
15868*>          The dimension of the array WORK.  LWORK >= max(1,N).
15869*>          For optimal performance LWORK >= N*NB, where NB is
15870*>          the optimal blocksize returned by ILAENV.
15871*>
15872*>          If LWORK = -1, then a workspace query is assumed; the routine
15873*>          only calculates the optimal size of the WORK array, returns
15874*>          this value as the first entry of the WORK array, and no error
15875*>          message related to LWORK is issued by XERBLA.
15876*> \endverbatim
15877*>
15878*> \param[out] INFO
15879*> \verbatim
15880*>          INFO is INTEGER
15881*>          = 0:  successful exit
15882*>          < 0:  if INFO = -i, the i-th argument had an illegal value
15883*>          > 0:  if INFO = i, U(i,i) is exactly zero; the matrix is
15884*>                singular and its inverse could not be computed.
15885*> \endverbatim
15886*
15887*  Authors:
15888*  ========
15889*
15890*> \author Univ. of Tennessee
15891*> \author Univ. of California Berkeley
15892*> \author Univ. of Colorado Denver
15893*> \author NAG Ltd.
15894*
15895*> \date December 2016
15896*
15897*> \ingroup complex16GEcomputational
15898*
15899*  =====================================================================
15900      SUBROUTINE ZGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )
15901*
15902*  -- LAPACK computational routine (version 3.7.0) --
15903*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
15904*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
15905*     December 2016
15906*
15907*     .. Scalar Arguments ..
15908      INTEGER            INFO, LDA, LWORK, N
15909*     ..
15910*     .. Array Arguments ..
15911      INTEGER            IPIV( * )
15912      COMPLEX*16         A( LDA, * ), WORK( * )
15913*     ..
15914*
15915*  =====================================================================
15916*
15917*     .. Parameters ..
15918      COMPLEX*16         ZERO, ONE
15919      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ),
15920     $                   ONE = ( 1.0D+0, 0.0D+0 ) )
15921*     ..
15922*     .. Local Scalars ..
15923      LOGICAL            LQUERY
15924      INTEGER            I, IWS, J, JB, JJ, JP, LDWORK, LWKOPT, NB,
15925     $                   NBMIN, NN
15926*     ..
15927*     .. External Functions ..
15928      INTEGER            ILAENV
15929      EXTERNAL           ILAENV
15930*     ..
15931*     .. External Subroutines ..
15932      EXTERNAL           XERBLA, ZGEMM, ZGEMV, ZSWAP, ZTRSM, ZTRTRI
15933*     ..
15934*     .. Intrinsic Functions ..
15935      INTRINSIC          MAX, MIN
15936*     ..
15937*     .. Executable Statements ..
15938*
15939*     Test the input parameters.
15940*
15941      INFO = 0
15942      NB = ILAENV( 1, 'ZGETRI', ' ', N, -1, -1, -1 )
15943      LWKOPT = N*NB
15944      WORK( 1 ) = LWKOPT
15945      LQUERY = ( LWORK.EQ.-1 )
15946      IF( N.LT.0 ) THEN
15947         INFO = -1
15948      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
15949         INFO = -3
15950      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
15951         INFO = -6
15952      END IF
15953      IF( INFO.NE.0 ) THEN
15954         CALL XERBLA( 'ZGETRI', -INFO )
15955         RETURN
15956      ELSE IF( LQUERY ) THEN
15957         RETURN
15958      END IF
15959*
15960*     Quick return if possible
15961*
15962      IF( N.EQ.0 )
15963     $   RETURN
15964*
15965*     Form inv(U).  If INFO > 0 from ZTRTRI, then U is singular,
15966*     and the inverse is not computed.
15967*
15968      CALL ZTRTRI( 'Upper', 'Non-unit', N, A, LDA, INFO )
15969      IF( INFO.GT.0 )
15970     $   RETURN
15971*
15972      NBMIN = 2
15973      LDWORK = N
15974      IF( NB.GT.1 .AND. NB.LT.N ) THEN
15975         IWS = MAX( LDWORK*NB, 1 )
15976         IF( LWORK.LT.IWS ) THEN
15977            NB = LWORK / LDWORK
15978            NBMIN = MAX( 2, ILAENV( 2, 'ZGETRI', ' ', N, -1, -1, -1 ) )
15979         END IF
15980      ELSE
15981         IWS = N
15982      END IF
15983*
15984*     Solve the equation inv(A)*L = inv(U) for inv(A).
15985*
15986      IF( NB.LT.NBMIN .OR. NB.GE.N ) THEN
15987*
15988*        Use unblocked code.
15989*
15990         DO 20 J = N, 1, -1
15991*
15992*           Copy current column of L to WORK and replace with zeros.
15993*
15994            DO 10 I = J + 1, N
15995               WORK( I ) = A( I, J )
15996               A( I, J ) = ZERO
15997   10       CONTINUE
15998*
15999*           Compute current column of inv(A).
16000*
16001            IF( J.LT.N )
16002     $         CALL ZGEMV( 'No transpose', N, N-J, -ONE, A( 1, J+1 ),
16003     $                     LDA, WORK( J+1 ), 1, ONE, A( 1, J ), 1 )
16004   20    CONTINUE
16005      ELSE
16006*
16007*        Use blocked code.
16008*
16009         NN = ( ( N-1 ) / NB )*NB + 1
16010         DO 50 J = NN, 1, -NB
16011            JB = MIN( NB, N-J+1 )
16012*
16013*           Copy current block column of L to WORK and replace with
16014*           zeros.
16015*
16016            DO 40 JJ = J, J + JB - 1
16017               DO 30 I = JJ + 1, N
16018                  WORK( I+( JJ-J )*LDWORK ) = A( I, JJ )
16019                  A( I, JJ ) = ZERO
16020   30          CONTINUE
16021   40       CONTINUE
16022*
16023*           Compute current block column of inv(A).
16024*
16025            IF( J+JB.LE.N )
16026     $         CALL ZGEMM( 'No transpose', 'No transpose', N, JB,
16027     $                     N-J-JB+1, -ONE, A( 1, J+JB ), LDA,
16028     $                     WORK( J+JB ), LDWORK, ONE, A( 1, J ), LDA )
16029            CALL ZTRSM( 'Right', 'Lower', 'No transpose', 'Unit', N, JB,
16030     $                  ONE, WORK( J ), LDWORK, A( 1, J ), LDA )
16031   50    CONTINUE
16032      END IF
16033*
16034*     Apply column interchanges.
16035*
16036      DO 60 J = N - 1, 1, -1
16037         JP = IPIV( J )
16038         IF( JP.NE.J )
16039     $      CALL ZSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 )
16040   60 CONTINUE
16041*
16042      WORK( 1 ) = IWS
16043      RETURN
16044*
16045*     End of ZGETRI
16046*
16047      END
16048*> \brief \b ZGETRS
16049*
16050*  =========== DOCUMENTATION ===========
16051*
16052* Online html documentation available at
16053*            http://www.netlib.org/lapack/explore-html/
16054*
16055*> \htmlonly
16056*> Download ZGETRS + dependencies
16057*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgetrs.f">
16058*> [TGZ]</a>
16059*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgetrs.f">
16060*> [ZIP]</a>
16061*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgetrs.f">
16062*> [TXT]</a>
16063*> \endhtmlonly
16064*
16065*  Definition:
16066*  ===========
16067*
16068*       SUBROUTINE ZGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
16069*
16070*       .. Scalar Arguments ..
16071*       CHARACTER          TRANS
16072*       INTEGER            INFO, LDA, LDB, N, NRHS
16073*       ..
16074*       .. Array Arguments ..
16075*       INTEGER            IPIV( * )
16076*       COMPLEX*16         A( LDA, * ), B( LDB, * )
16077*       ..
16078*
16079*
16080*> \par Purpose:
16081*  =============
16082*>
16083*> \verbatim
16084*>
16085*> ZGETRS solves a system of linear equations
16086*>    A * X = B,  A**T * X = B,  or  A**H * X = B
16087*> with a general N-by-N matrix A using the LU factorization computed
16088*> by ZGETRF.
16089*> \endverbatim
16090*
16091*  Arguments:
16092*  ==========
16093*
16094*> \param[in] TRANS
16095*> \verbatim
16096*>          TRANS is CHARACTER*1
16097*>          Specifies the form of the system of equations:
16098*>          = 'N':  A * X = B     (No transpose)
16099*>          = 'T':  A**T * X = B  (Transpose)
16100*>          = 'C':  A**H * X = B  (Conjugate transpose)
16101*> \endverbatim
16102*>
16103*> \param[in] N
16104*> \verbatim
16105*>          N is INTEGER
16106*>          The order of the matrix A.  N >= 0.
16107*> \endverbatim
16108*>
16109*> \param[in] NRHS
16110*> \verbatim
16111*>          NRHS is INTEGER
16112*>          The number of right hand sides, i.e., the number of columns
16113*>          of the matrix B.  NRHS >= 0.
16114*> \endverbatim
16115*>
16116*> \param[in] A
16117*> \verbatim
16118*>          A is COMPLEX*16 array, dimension (LDA,N)
16119*>          The factors L and U from the factorization A = P*L*U
16120*>          as computed by ZGETRF.
16121*> \endverbatim
16122*>
16123*> \param[in] LDA
16124*> \verbatim
16125*>          LDA is INTEGER
16126*>          The leading dimension of the array A.  LDA >= max(1,N).
16127*> \endverbatim
16128*>
16129*> \param[in] IPIV
16130*> \verbatim
16131*>          IPIV is INTEGER array, dimension (N)
16132*>          The pivot indices from ZGETRF; for 1<=i<=N, row i of the
16133*>          matrix was interchanged with row IPIV(i).
16134*> \endverbatim
16135*>
16136*> \param[in,out] B
16137*> \verbatim
16138*>          B is COMPLEX*16 array, dimension (LDB,NRHS)
16139*>          On entry, the right hand side matrix B.
16140*>          On exit, the solution matrix X.
16141*> \endverbatim
16142*>
16143*> \param[in] LDB
16144*> \verbatim
16145*>          LDB is INTEGER
16146*>          The leading dimension of the array B.  LDB >= max(1,N).
16147*> \endverbatim
16148*>
16149*> \param[out] INFO
16150*> \verbatim
16151*>          INFO is INTEGER
16152*>          = 0:  successful exit
16153*>          < 0:  if INFO = -i, the i-th argument had an illegal value
16154*> \endverbatim
16155*
16156*  Authors:
16157*  ========
16158*
16159*> \author Univ. of Tennessee
16160*> \author Univ. of California Berkeley
16161*> \author Univ. of Colorado Denver
16162*> \author NAG Ltd.
16163*
16164*> \date December 2016
16165*
16166*> \ingroup complex16GEcomputational
16167*
16168*  =====================================================================
16169      SUBROUTINE ZGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
16170*
16171*  -- LAPACK computational routine (version 3.7.0) --
16172*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
16173*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
16174*     December 2016
16175*
16176*     .. Scalar Arguments ..
16177      CHARACTER          TRANS
16178      INTEGER            INFO, LDA, LDB, N, NRHS
16179*     ..
16180*     .. Array Arguments ..
16181      INTEGER            IPIV( * )
16182      COMPLEX*16         A( LDA, * ), B( LDB, * )
16183*     ..
16184*
16185*  =====================================================================
16186*
16187*     .. Parameters ..
16188      COMPLEX*16         ONE
16189      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
16190*     ..
16191*     .. Local Scalars ..
16192      LOGICAL            NOTRAN
16193*     ..
16194*     .. External Functions ..
16195      LOGICAL            LSAME
16196      EXTERNAL           LSAME
16197*     ..
16198*     .. External Subroutines ..
16199      EXTERNAL           XERBLA, ZLASWP, ZTRSM
16200*     ..
16201*     .. Intrinsic Functions ..
16202      INTRINSIC          MAX
16203*     ..
16204*     .. Executable Statements ..
16205*
16206*     Test the input parameters.
16207*
16208      INFO = 0
16209      NOTRAN = LSAME( TRANS, 'N' )
16210      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
16211     $    LSAME( TRANS, 'C' ) ) THEN
16212         INFO = -1
16213      ELSE IF( N.LT.0 ) THEN
16214         INFO = -2
16215      ELSE IF( NRHS.LT.0 ) THEN
16216         INFO = -3
16217      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
16218         INFO = -5
16219      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
16220         INFO = -8
16221      END IF
16222      IF( INFO.NE.0 ) THEN
16223         CALL XERBLA( 'ZGETRS', -INFO )
16224         RETURN
16225      END IF
16226*
16227*     Quick return if possible
16228*
16229      IF( N.EQ.0 .OR. NRHS.EQ.0 )
16230     $   RETURN
16231*
16232      IF( NOTRAN ) THEN
16233*
16234*        Solve A * X = B.
16235*
16236*        Apply row interchanges to the right hand sides.
16237*
16238         CALL ZLASWP( NRHS, B, LDB, 1, N, IPIV, 1 )
16239*
16240*        Solve L*X = B, overwriting B with X.
16241*
16242         CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS,
16243     $               ONE, A, LDA, B, LDB )
16244*
16245*        Solve U*X = B, overwriting B with X.
16246*
16247         CALL ZTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N,
16248     $               NRHS, ONE, A, LDA, B, LDB )
16249      ELSE
16250*
16251*        Solve A**T * X = B  or A**H * X = B.
16252*
16253*        Solve U**T *X = B or U**H *X = B, overwriting B with X.
16254*
16255         CALL ZTRSM( 'Left', 'Upper', TRANS, 'Non-unit', N, NRHS, ONE,
16256     $               A, LDA, B, LDB )
16257*
16258*        Solve L**T *X = B, or L**H *X = B overwriting B with X.
16259*
16260         CALL ZTRSM( 'Left', 'Lower', TRANS, 'Unit', N, NRHS, ONE, A,
16261     $               LDA, B, LDB )
16262*
16263*        Apply row interchanges to the solution vectors.
16264*
16265         CALL ZLASWP( NRHS, B, LDB, 1, N, IPIV, -1 )
16266      END IF
16267*
16268      RETURN
16269*
16270*     End of ZGETRS
16271*
16272      END
16273*> \brief \b ZGGBAK
16274*
16275*  =========== DOCUMENTATION ===========
16276*
16277* Online html documentation available at
16278*            http://www.netlib.org/lapack/explore-html/
16279*
16280*> \htmlonly
16281*> Download ZGGBAK + dependencies
16282*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zggbak.f">
16283*> [TGZ]</a>
16284*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zggbak.f">
16285*> [ZIP]</a>
16286*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zggbak.f">
16287*> [TXT]</a>
16288*> \endhtmlonly
16289*
16290*  Definition:
16291*  ===========
16292*
16293*       SUBROUTINE ZGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V,
16294*                          LDV, INFO )
16295*
16296*       .. Scalar Arguments ..
16297*       CHARACTER          JOB, SIDE
16298*       INTEGER            IHI, ILO, INFO, LDV, M, N
16299*       ..
16300*       .. Array Arguments ..
16301*       DOUBLE PRECISION   LSCALE( * ), RSCALE( * )
16302*       COMPLEX*16         V( LDV, * )
16303*       ..
16304*
16305*
16306*> \par Purpose:
16307*  =============
16308*>
16309*> \verbatim
16310*>
16311*> ZGGBAK forms the right or left eigenvectors of a complex generalized
16312*> eigenvalue problem A*x = lambda*B*x, by backward transformation on
16313*> the computed eigenvectors of the balanced pair of matrices output by
16314*> ZGGBAL.
16315*> \endverbatim
16316*
16317*  Arguments:
16318*  ==========
16319*
16320*> \param[in] JOB
16321*> \verbatim
16322*>          JOB is CHARACTER*1
16323*>          Specifies the type of backward transformation required:
16324*>          = 'N':  do nothing, return immediately;
16325*>          = 'P':  do backward transformation for permutation only;
16326*>          = 'S':  do backward transformation for scaling only;
16327*>          = 'B':  do backward transformations for both permutation and
16328*>                  scaling.
16329*>          JOB must be the same as the argument JOB supplied to ZGGBAL.
16330*> \endverbatim
16331*>
16332*> \param[in] SIDE
16333*> \verbatim
16334*>          SIDE is CHARACTER*1
16335*>          = 'R':  V contains right eigenvectors;
16336*>          = 'L':  V contains left eigenvectors.
16337*> \endverbatim
16338*>
16339*> \param[in] N
16340*> \verbatim
16341*>          N is INTEGER
16342*>          The number of rows of the matrix V.  N >= 0.
16343*> \endverbatim
16344*>
16345*> \param[in] ILO
16346*> \verbatim
16347*>          ILO is INTEGER
16348*> \endverbatim
16349*>
16350*> \param[in] IHI
16351*> \verbatim
16352*>          IHI is INTEGER
16353*>          The integers ILO and IHI determined by ZGGBAL.
16354*>          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
16355*> \endverbatim
16356*>
16357*> \param[in] LSCALE
16358*> \verbatim
16359*>          LSCALE is DOUBLE PRECISION array, dimension (N)
16360*>          Details of the permutations and/or scaling factors applied
16361*>          to the left side of A and B, as returned by ZGGBAL.
16362*> \endverbatim
16363*>
16364*> \param[in] RSCALE
16365*> \verbatim
16366*>          RSCALE is DOUBLE PRECISION array, dimension (N)
16367*>          Details of the permutations and/or scaling factors applied
16368*>          to the right side of A and B, as returned by ZGGBAL.
16369*> \endverbatim
16370*>
16371*> \param[in] M
16372*> \verbatim
16373*>          M is INTEGER
16374*>          The number of columns of the matrix V.  M >= 0.
16375*> \endverbatim
16376*>
16377*> \param[in,out] V
16378*> \verbatim
16379*>          V is COMPLEX*16 array, dimension (LDV,M)
16380*>          On entry, the matrix of right or left eigenvectors to be
16381*>          transformed, as returned by ZTGEVC.
16382*>          On exit, V is overwritten by the transformed eigenvectors.
16383*> \endverbatim
16384*>
16385*> \param[in] LDV
16386*> \verbatim
16387*>          LDV is INTEGER
16388*>          The leading dimension of the matrix V. LDV >= max(1,N).
16389*> \endverbatim
16390*>
16391*> \param[out] INFO
16392*> \verbatim
16393*>          INFO is INTEGER
16394*>          = 0:  successful exit.
16395*>          < 0:  if INFO = -i, the i-th argument had an illegal value.
16396*> \endverbatim
16397*
16398*  Authors:
16399*  ========
16400*
16401*> \author Univ. of Tennessee
16402*> \author Univ. of California Berkeley
16403*> \author Univ. of Colorado Denver
16404*> \author NAG Ltd.
16405*
16406*> \date December 2016
16407*
16408*> \ingroup complex16GBcomputational
16409*
16410*> \par Further Details:
16411*  =====================
16412*>
16413*> \verbatim
16414*>
16415*>  See R.C. Ward, Balancing the generalized eigenvalue problem,
16416*>                 SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
16417*> \endverbatim
16418*>
16419*  =====================================================================
16420      SUBROUTINE ZGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V,
16421     $                   LDV, INFO )
16422*
16423*  -- LAPACK computational routine (version 3.7.0) --
16424*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
16425*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
16426*     December 2016
16427*
16428*     .. Scalar Arguments ..
16429      CHARACTER          JOB, SIDE
16430      INTEGER            IHI, ILO, INFO, LDV, M, N
16431*     ..
16432*     .. Array Arguments ..
16433      DOUBLE PRECISION   LSCALE( * ), RSCALE( * )
16434      COMPLEX*16         V( LDV, * )
16435*     ..
16436*
16437*  =====================================================================
16438*
16439*     .. Local Scalars ..
16440      LOGICAL            LEFTV, RIGHTV
16441      INTEGER            I, K
16442*     ..
16443*     .. External Functions ..
16444      LOGICAL            LSAME
16445      EXTERNAL           LSAME
16446*     ..
16447*     .. External Subroutines ..
16448      EXTERNAL           XERBLA, ZDSCAL, ZSWAP
16449*     ..
16450*     .. Intrinsic Functions ..
16451      INTRINSIC          MAX, INT
16452*     ..
16453*     .. Executable Statements ..
16454*
16455*     Test the input parameters
16456*
16457      RIGHTV = LSAME( SIDE, 'R' )
16458      LEFTV = LSAME( SIDE, 'L' )
16459*
16460      INFO = 0
16461      IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND.
16462     $    .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
16463         INFO = -1
16464      ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
16465         INFO = -2
16466      ELSE IF( N.LT.0 ) THEN
16467         INFO = -3
16468      ELSE IF( ILO.LT.1 ) THEN
16469         INFO = -4
16470      ELSE IF( N.EQ.0 .AND. IHI.EQ.0 .AND. ILO.NE.1 ) THEN
16471         INFO = -4
16472      ELSE IF( N.GT.0 .AND. ( IHI.LT.ILO .OR. IHI.GT.MAX( 1, N ) ) )
16473     $   THEN
16474         INFO = -5
16475      ELSE IF( N.EQ.0 .AND. ILO.EQ.1 .AND. IHI.NE.0 ) THEN
16476         INFO = -5
16477      ELSE IF( M.LT.0 ) THEN
16478         INFO = -8
16479      ELSE IF( LDV.LT.MAX( 1, N ) ) THEN
16480         INFO = -10
16481      END IF
16482      IF( INFO.NE.0 ) THEN
16483         CALL XERBLA( 'ZGGBAK', -INFO )
16484         RETURN
16485      END IF
16486*
16487*     Quick return if possible
16488*
16489      IF( N.EQ.0 )
16490     $   RETURN
16491      IF( M.EQ.0 )
16492     $   RETURN
16493      IF( LSAME( JOB, 'N' ) )
16494     $   RETURN
16495*
16496      IF( ILO.EQ.IHI )
16497     $   GO TO 30
16498*
16499*     Backward balance
16500*
16501      IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN
16502*
16503*        Backward transformation on right eigenvectors
16504*
16505         IF( RIGHTV ) THEN
16506            DO 10 I = ILO, IHI
16507               CALL ZDSCAL( M, RSCALE( I ), V( I, 1 ), LDV )
16508   10       CONTINUE
16509         END IF
16510*
16511*        Backward transformation on left eigenvectors
16512*
16513         IF( LEFTV ) THEN
16514            DO 20 I = ILO, IHI
16515               CALL ZDSCAL( M, LSCALE( I ), V( I, 1 ), LDV )
16516   20       CONTINUE
16517         END IF
16518      END IF
16519*
16520*     Backward permutation
16521*
16522   30 CONTINUE
16523      IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN
16524*
16525*        Backward permutation on right eigenvectors
16526*
16527         IF( RIGHTV ) THEN
16528            IF( ILO.EQ.1 )
16529     $         GO TO 50
16530            DO 40 I = ILO - 1, 1, -1
16531               K = INT(RSCALE( I ))
16532               IF( K.EQ.I )
16533     $            GO TO 40
16534               CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
16535   40       CONTINUE
16536*
16537   50       CONTINUE
16538            IF( IHI.EQ.N )
16539     $         GO TO 70
16540            DO 60 I = IHI + 1, N
16541               K = INT(RSCALE( I ))
16542               IF( K.EQ.I )
16543     $            GO TO 60
16544               CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
16545   60       CONTINUE
16546         END IF
16547*
16548*        Backward permutation on left eigenvectors
16549*
16550   70    CONTINUE
16551         IF( LEFTV ) THEN
16552            IF( ILO.EQ.1 )
16553     $         GO TO 90
16554            DO 80 I = ILO - 1, 1, -1
16555               K = INT(LSCALE( I ))
16556               IF( K.EQ.I )
16557     $            GO TO 80
16558               CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
16559   80       CONTINUE
16560*
16561   90       CONTINUE
16562            IF( IHI.EQ.N )
16563     $         GO TO 110
16564            DO 100 I = IHI + 1, N
16565               K = INT(LSCALE( I ))
16566               IF( K.EQ.I )
16567     $            GO TO 100
16568               CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
16569  100       CONTINUE
16570         END IF
16571      END IF
16572*
16573  110 CONTINUE
16574*
16575      RETURN
16576*
16577*     End of ZGGBAK
16578*
16579      END
16580*> \brief \b ZGGBAL
16581*
16582*  =========== DOCUMENTATION ===========
16583*
16584* Online html documentation available at
16585*            http://www.netlib.org/lapack/explore-html/
16586*
16587*> \htmlonly
16588*> Download ZGGBAL + dependencies
16589*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zggbal.f">
16590*> [TGZ]</a>
16591*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zggbal.f">
16592*> [ZIP]</a>
16593*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zggbal.f">
16594*> [TXT]</a>
16595*> \endhtmlonly
16596*
16597*  Definition:
16598*  ===========
16599*
16600*       SUBROUTINE ZGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE,
16601*                          RSCALE, WORK, INFO )
16602*
16603*       .. Scalar Arguments ..
16604*       CHARACTER          JOB
16605*       INTEGER            IHI, ILO, INFO, LDA, LDB, N
16606*       ..
16607*       .. Array Arguments ..
16608*       DOUBLE PRECISION   LSCALE( * ), RSCALE( * ), WORK( * )
16609*       COMPLEX*16         A( LDA, * ), B( LDB, * )
16610*       ..
16611*
16612*
16613*> \par Purpose:
16614*  =============
16615*>
16616*> \verbatim
16617*>
16618*> ZGGBAL balances a pair of general complex matrices (A,B).  This
16619*> involves, first, permuting A and B by similarity transformations to
16620*> isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N
16621*> elements on the diagonal; and second, applying a diagonal similarity
16622*> transformation to rows and columns ILO to IHI to make the rows
16623*> and columns as close in norm as possible. Both steps are optional.
16624*>
16625*> Balancing may reduce the 1-norm of the matrices, and improve the
16626*> accuracy of the computed eigenvalues and/or eigenvectors in the
16627*> generalized eigenvalue problem A*x = lambda*B*x.
16628*> \endverbatim
16629*
16630*  Arguments:
16631*  ==========
16632*
16633*> \param[in] JOB
16634*> \verbatim
16635*>          JOB is CHARACTER*1
16636*>          Specifies the operations to be performed on A and B:
16637*>          = 'N':  none:  simply set ILO = 1, IHI = N, LSCALE(I) = 1.0
16638*>                  and RSCALE(I) = 1.0 for i=1,...,N;
16639*>          = 'P':  permute only;
16640*>          = 'S':  scale only;
16641*>          = 'B':  both permute and scale.
16642*> \endverbatim
16643*>
16644*> \param[in] N
16645*> \verbatim
16646*>          N is INTEGER
16647*>          The order of the matrices A and B.  N >= 0.
16648*> \endverbatim
16649*>
16650*> \param[in,out] A
16651*> \verbatim
16652*>          A is COMPLEX*16 array, dimension (LDA,N)
16653*>          On entry, the input matrix A.
16654*>          On exit, A is overwritten by the balanced matrix.
16655*>          If JOB = 'N', A is not referenced.
16656*> \endverbatim
16657*>
16658*> \param[in] LDA
16659*> \verbatim
16660*>          LDA is INTEGER
16661*>          The leading dimension of the array A. LDA >= max(1,N).
16662*> \endverbatim
16663*>
16664*> \param[in,out] B
16665*> \verbatim
16666*>          B is COMPLEX*16 array, dimension (LDB,N)
16667*>          On entry, the input matrix B.
16668*>          On exit, B is overwritten by the balanced matrix.
16669*>          If JOB = 'N', B is not referenced.
16670*> \endverbatim
16671*>
16672*> \param[in] LDB
16673*> \verbatim
16674*>          LDB is INTEGER
16675*>          The leading dimension of the array B. LDB >= max(1,N).
16676*> \endverbatim
16677*>
16678*> \param[out] ILO
16679*> \verbatim
16680*>          ILO is INTEGER
16681*> \endverbatim
16682*>
16683*> \param[out] IHI
16684*> \verbatim
16685*>          IHI is INTEGER
16686*>          ILO and IHI are set to integers such that on exit
16687*>          A(i,j) = 0 and B(i,j) = 0 if i > j and
16688*>          j = 1,...,ILO-1 or i = IHI+1,...,N.
16689*>          If JOB = 'N' or 'S', ILO = 1 and IHI = N.
16690*> \endverbatim
16691*>
16692*> \param[out] LSCALE
16693*> \verbatim
16694*>          LSCALE is DOUBLE PRECISION array, dimension (N)
16695*>          Details of the permutations and scaling factors applied
16696*>          to the left side of A and B.  If P(j) is the index of the
16697*>          row interchanged with row j, and D(j) is the scaling factor
16698*>          applied to row j, then
16699*>            LSCALE(j) = P(j)    for J = 1,...,ILO-1
16700*>                      = D(j)    for J = ILO,...,IHI
16701*>                      = P(j)    for J = IHI+1,...,N.
16702*>          The order in which the interchanges are made is N to IHI+1,
16703*>          then 1 to ILO-1.
16704*> \endverbatim
16705*>
16706*> \param[out] RSCALE
16707*> \verbatim
16708*>          RSCALE is DOUBLE PRECISION array, dimension (N)
16709*>          Details of the permutations and scaling factors applied
16710*>          to the right side of A and B.  If P(j) is the index of the
16711*>          column interchanged with column j, and D(j) is the scaling
16712*>          factor applied to column j, then
16713*>            RSCALE(j) = P(j)    for J = 1,...,ILO-1
16714*>                      = D(j)    for J = ILO,...,IHI
16715*>                      = P(j)    for J = IHI+1,...,N.
16716*>          The order in which the interchanges are made is N to IHI+1,
16717*>          then 1 to ILO-1.
16718*> \endverbatim
16719*>
16720*> \param[out] WORK
16721*> \verbatim
16722*>          WORK is DOUBLE PRECISION array, dimension (lwork)
16723*>          lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and
16724*>          at least 1 when JOB = 'N' or 'P'.
16725*> \endverbatim
16726*>
16727*> \param[out] INFO
16728*> \verbatim
16729*>          INFO is INTEGER
16730*>          = 0:  successful exit
16731*>          < 0:  if INFO = -i, the i-th argument had an illegal value.
16732*> \endverbatim
16733*
16734*  Authors:
16735*  ========
16736*
16737*> \author Univ. of Tennessee
16738*> \author Univ. of California Berkeley
16739*> \author Univ. of Colorado Denver
16740*> \author NAG Ltd.
16741*
16742*> \date June 2016
16743*
16744*> \ingroup complex16GBcomputational
16745*
16746*> \par Further Details:
16747*  =====================
16748*>
16749*> \verbatim
16750*>
16751*>  See R.C. WARD, Balancing the generalized eigenvalue problem,
16752*>                 SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
16753*> \endverbatim
16754*>
16755*  =====================================================================
16756      SUBROUTINE ZGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE,
16757     $                   RSCALE, WORK, INFO )
16758*
16759*  -- LAPACK computational routine (version 3.7.0) --
16760*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
16761*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
16762*     June 2016
16763*
16764*     .. Scalar Arguments ..
16765      CHARACTER          JOB
16766      INTEGER            IHI, ILO, INFO, LDA, LDB, N
16767*     ..
16768*     .. Array Arguments ..
16769      DOUBLE PRECISION   LSCALE( * ), RSCALE( * ), WORK( * )
16770      COMPLEX*16         A( LDA, * ), B( LDB, * )
16771*     ..
16772*
16773*  =====================================================================
16774*
16775*     .. Parameters ..
16776      DOUBLE PRECISION   ZERO, HALF, ONE
16777      PARAMETER          ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 )
16778      DOUBLE PRECISION   THREE, SCLFAC
16779      PARAMETER          ( THREE = 3.0D+0, SCLFAC = 1.0D+1 )
16780      COMPLEX*16         CZERO
16781      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ) )
16782*     ..
16783*     .. Local Scalars ..
16784      INTEGER            I, ICAB, IFLOW, IP1, IR, IRAB, IT, J, JC, JP1,
16785     $                   K, KOUNT, L, LCAB, LM1, LRAB, LSFMAX, LSFMIN,
16786     $                   M, NR, NRP2
16787      DOUBLE PRECISION   ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2,
16788     $                   COEF5, COR, EW, EWC, GAMMA, PGAMMA, RAB, SFMAX,
16789     $                   SFMIN, SUM, T, TA, TB, TC
16790      COMPLEX*16         CDUM
16791*     ..
16792*     .. External Functions ..
16793      LOGICAL            LSAME
16794      INTEGER            IZAMAX
16795      DOUBLE PRECISION   DDOT, DLAMCH
16796      EXTERNAL           LSAME, IZAMAX, DDOT, DLAMCH
16797*     ..
16798*     .. External Subroutines ..
16799      EXTERNAL           DAXPY, DSCAL, XERBLA, ZDSCAL, ZSWAP
16800*     ..
16801*     .. Intrinsic Functions ..
16802      INTRINSIC          ABS, DBLE, DIMAG, INT, LOG10, MAX, MIN, SIGN
16803*     ..
16804*     .. Statement Functions ..
16805      DOUBLE PRECISION   CABS1
16806*     ..
16807*     .. Statement Function definitions ..
16808      CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
16809*     ..
16810*     .. Executable Statements ..
16811*
16812*     Test the input parameters
16813*
16814      INFO = 0
16815      IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND.
16816     $    .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
16817         INFO = -1
16818      ELSE IF( N.LT.0 ) THEN
16819         INFO = -2
16820      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
16821         INFO = -4
16822      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
16823         INFO = -6
16824      END IF
16825      IF( INFO.NE.0 ) THEN
16826         CALL XERBLA( 'ZGGBAL', -INFO )
16827         RETURN
16828      END IF
16829*
16830*     Quick return if possible
16831*
16832      IF( N.EQ.0 ) THEN
16833         ILO = 1
16834         IHI = N
16835         RETURN
16836      END IF
16837*
16838      IF( N.EQ.1 ) THEN
16839         ILO = 1
16840         IHI = N
16841         LSCALE( 1 ) = ONE
16842         RSCALE( 1 ) = ONE
16843         RETURN
16844      END IF
16845*
16846      IF( LSAME( JOB, 'N' ) ) THEN
16847         ILO = 1
16848         IHI = N
16849         DO 10 I = 1, N
16850            LSCALE( I ) = ONE
16851            RSCALE( I ) = ONE
16852   10    CONTINUE
16853         RETURN
16854      END IF
16855*
16856      K = 1
16857      L = N
16858      IF( LSAME( JOB, 'S' ) )
16859     $   GO TO 190
16860*
16861      GO TO 30
16862*
16863*     Permute the matrices A and B to isolate the eigenvalues.
16864*
16865*     Find row with one nonzero in columns 1 through L
16866*
16867   20 CONTINUE
16868      L = LM1
16869      IF( L.NE.1 )
16870     $   GO TO 30
16871*
16872      RSCALE( 1 ) = 1
16873      LSCALE( 1 ) = 1
16874      GO TO 190
16875*
16876   30 CONTINUE
16877      LM1 = L - 1
16878      DO 80 I = L, 1, -1
16879         DO 40 J = 1, LM1
16880            JP1 = J + 1
16881            IF( A( I, J ).NE.CZERO .OR. B( I, J ).NE.CZERO )
16882     $         GO TO 50
16883   40    CONTINUE
16884         J = L
16885         GO TO 70
16886*
16887   50    CONTINUE
16888         DO 60 J = JP1, L
16889            IF( A( I, J ).NE.CZERO .OR. B( I, J ).NE.CZERO )
16890     $         GO TO 80
16891   60    CONTINUE
16892         J = JP1 - 1
16893*
16894   70    CONTINUE
16895         M = L
16896         IFLOW = 1
16897         GO TO 160
16898   80 CONTINUE
16899      GO TO 100
16900*
16901*     Find column with one nonzero in rows K through N
16902*
16903   90 CONTINUE
16904      K = K + 1
16905*
16906  100 CONTINUE
16907      DO 150 J = K, L
16908         DO 110 I = K, LM1
16909            IP1 = I + 1
16910            IF( A( I, J ).NE.CZERO .OR. B( I, J ).NE.CZERO )
16911     $         GO TO 120
16912  110    CONTINUE
16913         I = L
16914         GO TO 140
16915  120    CONTINUE
16916         DO 130 I = IP1, L
16917            IF( A( I, J ).NE.CZERO .OR. B( I, J ).NE.CZERO )
16918     $         GO TO 150
16919  130    CONTINUE
16920         I = IP1 - 1
16921  140    CONTINUE
16922         M = K
16923         IFLOW = 2
16924         GO TO 160
16925  150 CONTINUE
16926      GO TO 190
16927*
16928*     Permute rows M and I
16929*
16930  160 CONTINUE
16931      LSCALE( M ) = I
16932      IF( I.EQ.M )
16933     $   GO TO 170
16934      CALL ZSWAP( N-K+1, A( I, K ), LDA, A( M, K ), LDA )
16935      CALL ZSWAP( N-K+1, B( I, K ), LDB, B( M, K ), LDB )
16936*
16937*     Permute columns M and J
16938*
16939  170 CONTINUE
16940      RSCALE( M ) = J
16941      IF( J.EQ.M )
16942     $   GO TO 180
16943      CALL ZSWAP( L, A( 1, J ), 1, A( 1, M ), 1 )
16944      CALL ZSWAP( L, B( 1, J ), 1, B( 1, M ), 1 )
16945*
16946  180 CONTINUE
16947      GO TO ( 20, 90 )IFLOW
16948*
16949  190 CONTINUE
16950      ILO = K
16951      IHI = L
16952*
16953      IF( LSAME( JOB, 'P' ) ) THEN
16954         DO 195 I = ILO, IHI
16955            LSCALE( I ) = ONE
16956            RSCALE( I ) = ONE
16957  195    CONTINUE
16958         RETURN
16959      END IF
16960*
16961      IF( ILO.EQ.IHI )
16962     $   RETURN
16963*
16964*     Balance the submatrix in rows ILO to IHI.
16965*
16966      NR = IHI - ILO + 1
16967      DO 200 I = ILO, IHI
16968         RSCALE( I ) = ZERO
16969         LSCALE( I ) = ZERO
16970*
16971         WORK( I ) = ZERO
16972         WORK( I+N ) = ZERO
16973         WORK( I+2*N ) = ZERO
16974         WORK( I+3*N ) = ZERO
16975         WORK( I+4*N ) = ZERO
16976         WORK( I+5*N ) = ZERO
16977  200 CONTINUE
16978*
16979*     Compute right side vector in resulting linear equations
16980*
16981      BASL = LOG10( SCLFAC )
16982      DO 240 I = ILO, IHI
16983         DO 230 J = ILO, IHI
16984            IF( A( I, J ).EQ.CZERO ) THEN
16985               TA = ZERO
16986               GO TO 210
16987            END IF
16988            TA = LOG10( CABS1( A( I, J ) ) ) / BASL
16989*
16990  210       CONTINUE
16991            IF( B( I, J ).EQ.CZERO ) THEN
16992               TB = ZERO
16993               GO TO 220
16994            END IF
16995            TB = LOG10( CABS1( B( I, J ) ) ) / BASL
16996*
16997  220       CONTINUE
16998            WORK( I+4*N ) = WORK( I+4*N ) - TA - TB
16999            WORK( J+5*N ) = WORK( J+5*N ) - TA - TB
17000  230    CONTINUE
17001  240 CONTINUE
17002*
17003      COEF = ONE / DBLE( 2*NR )
17004      COEF2 = COEF*COEF
17005      COEF5 = HALF*COEF2
17006      NRP2 = NR + 2
17007      BETA = ZERO
17008      IT = 1
17009*
17010*     Start generalized conjugate gradient iteration
17011*
17012  250 CONTINUE
17013*
17014      GAMMA = DDOT( NR, WORK( ILO+4*N ), 1, WORK( ILO+4*N ), 1 ) +
17015     $        DDOT( NR, WORK( ILO+5*N ), 1, WORK( ILO+5*N ), 1 )
17016*
17017      EW = ZERO
17018      EWC = ZERO
17019      DO 260 I = ILO, IHI
17020         EW = EW + WORK( I+4*N )
17021         EWC = EWC + WORK( I+5*N )
17022  260 CONTINUE
17023*
17024      GAMMA = COEF*GAMMA - COEF2*( EW**2+EWC**2 ) - COEF5*( EW-EWC )**2
17025      IF( GAMMA.EQ.ZERO )
17026     $   GO TO 350
17027      IF( IT.NE.1 )
17028     $   BETA = GAMMA / PGAMMA
17029      T = COEF5*( EWC-THREE*EW )
17030      TC = COEF5*( EW-THREE*EWC )
17031*
17032      CALL DSCAL( NR, BETA, WORK( ILO ), 1 )
17033      CALL DSCAL( NR, BETA, WORK( ILO+N ), 1 )
17034*
17035      CALL DAXPY( NR, COEF, WORK( ILO+4*N ), 1, WORK( ILO+N ), 1 )
17036      CALL DAXPY( NR, COEF, WORK( ILO+5*N ), 1, WORK( ILO ), 1 )
17037*
17038      DO 270 I = ILO, IHI
17039         WORK( I ) = WORK( I ) + TC
17040         WORK( I+N ) = WORK( I+N ) + T
17041  270 CONTINUE
17042*
17043*     Apply matrix to vector
17044*
17045      DO 300 I = ILO, IHI
17046         KOUNT = 0
17047         SUM = ZERO
17048         DO 290 J = ILO, IHI
17049            IF( A( I, J ).EQ.CZERO )
17050     $         GO TO 280
17051            KOUNT = KOUNT + 1
17052            SUM = SUM + WORK( J )
17053  280       CONTINUE
17054            IF( B( I, J ).EQ.CZERO )
17055     $         GO TO 290
17056            KOUNT = KOUNT + 1
17057            SUM = SUM + WORK( J )
17058  290    CONTINUE
17059         WORK( I+2*N ) = DBLE( KOUNT )*WORK( I+N ) + SUM
17060  300 CONTINUE
17061*
17062      DO 330 J = ILO, IHI
17063         KOUNT = 0
17064         SUM = ZERO
17065         DO 320 I = ILO, IHI
17066            IF( A( I, J ).EQ.CZERO )
17067     $         GO TO 310
17068            KOUNT = KOUNT + 1
17069            SUM = SUM + WORK( I+N )
17070  310       CONTINUE
17071            IF( B( I, J ).EQ.CZERO )
17072     $         GO TO 320
17073            KOUNT = KOUNT + 1
17074            SUM = SUM + WORK( I+N )
17075  320    CONTINUE
17076         WORK( J+3*N ) = DBLE( KOUNT )*WORK( J ) + SUM
17077  330 CONTINUE
17078*
17079      SUM = DDOT( NR, WORK( ILO+N ), 1, WORK( ILO+2*N ), 1 ) +
17080     $      DDOT( NR, WORK( ILO ), 1, WORK( ILO+3*N ), 1 )
17081      ALPHA = GAMMA / SUM
17082*
17083*     Determine correction to current iteration
17084*
17085      CMAX = ZERO
17086      DO 340 I = ILO, IHI
17087         COR = ALPHA*WORK( I+N )
17088         IF( ABS( COR ).GT.CMAX )
17089     $      CMAX = ABS( COR )
17090         LSCALE( I ) = LSCALE( I ) + COR
17091         COR = ALPHA*WORK( I )
17092         IF( ABS( COR ).GT.CMAX )
17093     $      CMAX = ABS( COR )
17094         RSCALE( I ) = RSCALE( I ) + COR
17095  340 CONTINUE
17096      IF( CMAX.LT.HALF )
17097     $   GO TO 350
17098*
17099      CALL DAXPY( NR, -ALPHA, WORK( ILO+2*N ), 1, WORK( ILO+4*N ), 1 )
17100      CALL DAXPY( NR, -ALPHA, WORK( ILO+3*N ), 1, WORK( ILO+5*N ), 1 )
17101*
17102      PGAMMA = GAMMA
17103      IT = IT + 1
17104      IF( IT.LE.NRP2 )
17105     $   GO TO 250
17106*
17107*     End generalized conjugate gradient iteration
17108*
17109  350 CONTINUE
17110      SFMIN = DLAMCH( 'S' )
17111      SFMAX = ONE / SFMIN
17112      LSFMIN = INT( LOG10( SFMIN ) / BASL+ONE )
17113      LSFMAX = INT( LOG10( SFMAX ) / BASL )
17114      DO 360 I = ILO, IHI
17115         IRAB = IZAMAX( N-ILO+1, A( I, ILO ), LDA )
17116         RAB = ABS( A( I, IRAB+ILO-1 ) )
17117         IRAB = IZAMAX( N-ILO+1, B( I, ILO ), LDB )
17118         RAB = MAX( RAB, ABS( B( I, IRAB+ILO-1 ) ) )
17119         LRAB = INT( LOG10( RAB+SFMIN ) / BASL+ONE )
17120         IR = INT(LSCALE( I ) + SIGN( HALF, LSCALE( I ) ))
17121         IR = MIN( MAX( IR, LSFMIN ), LSFMAX, LSFMAX-LRAB )
17122         LSCALE( I ) = SCLFAC**IR
17123         ICAB = IZAMAX( IHI, A( 1, I ), 1 )
17124         CAB = ABS( A( ICAB, I ) )
17125         ICAB = IZAMAX( IHI, B( 1, I ), 1 )
17126         CAB = MAX( CAB, ABS( B( ICAB, I ) ) )
17127         LCAB = INT( LOG10( CAB+SFMIN ) / BASL+ONE )
17128         JC = INT(RSCALE( I ) + SIGN( HALF, RSCALE( I ) ))
17129         JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LCAB )
17130         RSCALE( I ) = SCLFAC**JC
17131  360 CONTINUE
17132*
17133*     Row scaling of matrices A and B
17134*
17135      DO 370 I = ILO, IHI
17136         CALL ZDSCAL( N-ILO+1, LSCALE( I ), A( I, ILO ), LDA )
17137         CALL ZDSCAL( N-ILO+1, LSCALE( I ), B( I, ILO ), LDB )
17138  370 CONTINUE
17139*
17140*     Column scaling of matrices A and B
17141*
17142      DO 380 J = ILO, IHI
17143         CALL ZDSCAL( IHI, RSCALE( J ), A( 1, J ), 1 )
17144         CALL ZDSCAL( IHI, RSCALE( J ), B( 1, J ), 1 )
17145  380 CONTINUE
17146*
17147      RETURN
17148*
17149*     End of ZGGBAL
17150*
17151      END
17152*> \brief <b> ZGGES computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE matrices</b>
17153*
17154*  =========== DOCUMENTATION ===========
17155*
17156* Online html documentation available at
17157*            http://www.netlib.org/lapack/explore-html/
17158*
17159*> \htmlonly
17160*> Download ZGGES + dependencies
17161*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgges.f">
17162*> [TGZ]</a>
17163*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgges.f">
17164*> [ZIP]</a>
17165*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgges.f">
17166*> [TXT]</a>
17167*> \endhtmlonly
17168*
17169*  Definition:
17170*  ===========
17171*
17172*       SUBROUTINE ZGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB,
17173*                         SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK,
17174*                         LWORK, RWORK, BWORK, INFO )
17175*
17176*       .. Scalar Arguments ..
17177*       CHARACTER          JOBVSL, JOBVSR, SORT
17178*       INTEGER            INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N, SDIM
17179*       ..
17180*       .. Array Arguments ..
17181*       LOGICAL            BWORK( * )
17182*       DOUBLE PRECISION   RWORK( * )
17183*       COMPLEX*16         A( LDA, * ), ALPHA( * ), B( LDB, * ),
17184*      $                   BETA( * ), VSL( LDVSL, * ), VSR( LDVSR, * ),
17185*      $                   WORK( * )
17186*       ..
17187*       .. Function Arguments ..
17188*       LOGICAL            SELCTG
17189*       EXTERNAL           SELCTG
17190*       ..
17191*
17192*
17193*> \par Purpose:
17194*  =============
17195*>
17196*> \verbatim
17197*>
17198*> ZGGES computes for a pair of N-by-N complex nonsymmetric matrices
17199*> (A,B), the generalized eigenvalues, the generalized complex Schur
17200*> form (S, T), and optionally left and/or right Schur vectors (VSL
17201*> and VSR). This gives the generalized Schur factorization
17202*>
17203*>         (A,B) = ( (VSL)*S*(VSR)**H, (VSL)*T*(VSR)**H )
17204*>
17205*> where (VSR)**H is the conjugate-transpose of VSR.
17206*>
17207*> Optionally, it also orders the eigenvalues so that a selected cluster
17208*> of eigenvalues appears in the leading diagonal blocks of the upper
17209*> triangular matrix S and the upper triangular matrix T. The leading
17210*> columns of VSL and VSR then form an unitary basis for the
17211*> corresponding left and right eigenspaces (deflating subspaces).
17212*>
17213*> (If only the generalized eigenvalues are needed, use the driver
17214*> ZGGEV instead, which is faster.)
17215*>
17216*> A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
17217*> or a ratio alpha/beta = w, such that  A - w*B is singular.  It is
17218*> usually represented as the pair (alpha,beta), as there is a
17219*> reasonable interpretation for beta=0, and even for both being zero.
17220*>
17221*> A pair of matrices (S,T) is in generalized complex Schur form if S
17222*> and T are upper triangular and, in addition, the diagonal elements
17223*> of T are non-negative real numbers.
17224*> \endverbatim
17225*
17226*  Arguments:
17227*  ==========
17228*
17229*> \param[in] JOBVSL
17230*> \verbatim
17231*>          JOBVSL is CHARACTER*1
17232*>          = 'N':  do not compute the left Schur vectors;
17233*>          = 'V':  compute the left Schur vectors.
17234*> \endverbatim
17235*>
17236*> \param[in] JOBVSR
17237*> \verbatim
17238*>          JOBVSR is CHARACTER*1
17239*>          = 'N':  do not compute the right Schur vectors;
17240*>          = 'V':  compute the right Schur vectors.
17241*> \endverbatim
17242*>
17243*> \param[in] SORT
17244*> \verbatim
17245*>          SORT is CHARACTER*1
17246*>          Specifies whether or not to order the eigenvalues on the
17247*>          diagonal of the generalized Schur form.
17248*>          = 'N':  Eigenvalues are not ordered;
17249*>          = 'S':  Eigenvalues are ordered (see SELCTG).
17250*> \endverbatim
17251*>
17252*> \param[in] SELCTG
17253*> \verbatim
17254*>          SELCTG is a LOGICAL FUNCTION of two COMPLEX*16 arguments
17255*>          SELCTG must be declared EXTERNAL in the calling subroutine.
17256*>          If SORT = 'N', SELCTG is not referenced.
17257*>          If SORT = 'S', SELCTG is used to select eigenvalues to sort
17258*>          to the top left of the Schur form.
17259*>          An eigenvalue ALPHA(j)/BETA(j) is selected if
17260*>          SELCTG(ALPHA(j),BETA(j)) is true.
17261*>
17262*>          Note that a selected complex eigenvalue may no longer satisfy
17263*>          SELCTG(ALPHA(j),BETA(j)) = .TRUE. after ordering, since
17264*>          ordering may change the value of complex eigenvalues
17265*>          (especially if the eigenvalue is ill-conditioned), in this
17266*>          case INFO is set to N+2 (See INFO below).
17267*> \endverbatim
17268*>
17269*> \param[in] N
17270*> \verbatim
17271*>          N is INTEGER
17272*>          The order of the matrices A, B, VSL, and VSR.  N >= 0.
17273*> \endverbatim
17274*>
17275*> \param[in,out] A
17276*> \verbatim
17277*>          A is COMPLEX*16 array, dimension (LDA, N)
17278*>          On entry, the first of the pair of matrices.
17279*>          On exit, A has been overwritten by its generalized Schur
17280*>          form S.
17281*> \endverbatim
17282*>
17283*> \param[in] LDA
17284*> \verbatim
17285*>          LDA is INTEGER
17286*>          The leading dimension of A.  LDA >= max(1,N).
17287*> \endverbatim
17288*>
17289*> \param[in,out] B
17290*> \verbatim
17291*>          B is COMPLEX*16 array, dimension (LDB, N)
17292*>          On entry, the second of the pair of matrices.
17293*>          On exit, B has been overwritten by its generalized Schur
17294*>          form T.
17295*> \endverbatim
17296*>
17297*> \param[in] LDB
17298*> \verbatim
17299*>          LDB is INTEGER
17300*>          The leading dimension of B.  LDB >= max(1,N).
17301*> \endverbatim
17302*>
17303*> \param[out] SDIM
17304*> \verbatim
17305*>          SDIM is INTEGER
17306*>          If SORT = 'N', SDIM = 0.
17307*>          If SORT = 'S', SDIM = number of eigenvalues (after sorting)
17308*>          for which SELCTG is true.
17309*> \endverbatim
17310*>
17311*> \param[out] ALPHA
17312*> \verbatim
17313*>          ALPHA is COMPLEX*16 array, dimension (N)
17314*> \endverbatim
17315*>
17316*> \param[out] BETA
17317*> \verbatim
17318*>          BETA is COMPLEX*16 array, dimension (N)
17319*>          On exit,  ALPHA(j)/BETA(j), j=1,...,N, will be the
17320*>          generalized eigenvalues.  ALPHA(j), j=1,...,N  and  BETA(j),
17321*>          j=1,...,N  are the diagonals of the complex Schur form (A,B)
17322*>          output by ZGGES. The  BETA(j) will be non-negative real.
17323*>
17324*>          Note: the quotients ALPHA(j)/BETA(j) may easily over- or
17325*>          underflow, and BETA(j) may even be zero.  Thus, the user
17326*>          should avoid naively computing the ratio alpha/beta.
17327*>          However, ALPHA will be always less than and usually
17328*>          comparable with norm(A) in magnitude, and BETA always less
17329*>          than and usually comparable with norm(B).
17330*> \endverbatim
17331*>
17332*> \param[out] VSL
17333*> \verbatim
17334*>          VSL is COMPLEX*16 array, dimension (LDVSL,N)
17335*>          If JOBVSL = 'V', VSL will contain the left Schur vectors.
17336*>          Not referenced if JOBVSL = 'N'.
17337*> \endverbatim
17338*>
17339*> \param[in] LDVSL
17340*> \verbatim
17341*>          LDVSL is INTEGER
17342*>          The leading dimension of the matrix VSL. LDVSL >= 1, and
17343*>          if JOBVSL = 'V', LDVSL >= N.
17344*> \endverbatim
17345*>
17346*> \param[out] VSR
17347*> \verbatim
17348*>          VSR is COMPLEX*16 array, dimension (LDVSR,N)
17349*>          If JOBVSR = 'V', VSR will contain the right Schur vectors.
17350*>          Not referenced if JOBVSR = 'N'.
17351*> \endverbatim
17352*>
17353*> \param[in] LDVSR
17354*> \verbatim
17355*>          LDVSR is INTEGER
17356*>          The leading dimension of the matrix VSR. LDVSR >= 1, and
17357*>          if JOBVSR = 'V', LDVSR >= N.
17358*> \endverbatim
17359*>
17360*> \param[out] WORK
17361*> \verbatim
17362*>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
17363*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
17364*> \endverbatim
17365*>
17366*> \param[in] LWORK
17367*> \verbatim
17368*>          LWORK is INTEGER
17369*>          The dimension of the array WORK.  LWORK >= max(1,2*N).
17370*>          For good performance, LWORK must generally be larger.
17371*>
17372*>          If LWORK = -1, then a workspace query is assumed; the routine
17373*>          only calculates the optimal size of the WORK array, returns
17374*>          this value as the first entry of the WORK array, and no error
17375*>          message related to LWORK is issued by XERBLA.
17376*> \endverbatim
17377*>
17378*> \param[out] RWORK
17379*> \verbatim
17380*>          RWORK is DOUBLE PRECISION array, dimension (8*N)
17381*> \endverbatim
17382*>
17383*> \param[out] BWORK
17384*> \verbatim
17385*>          BWORK is LOGICAL array, dimension (N)
17386*>          Not referenced if SORT = 'N'.
17387*> \endverbatim
17388*>
17389*> \param[out] INFO
17390*> \verbatim
17391*>          INFO is INTEGER
17392*>          = 0:  successful exit
17393*>          < 0:  if INFO = -i, the i-th argument had an illegal value.
17394*>          =1,...,N:
17395*>                The QZ iteration failed.  (A,B) are not in Schur
17396*>                form, but ALPHA(j) and BETA(j) should be correct for
17397*>                j=INFO+1,...,N.
17398*>          > N:  =N+1: other than QZ iteration failed in ZHGEQZ
17399*>                =N+2: after reordering, roundoff changed values of
17400*>                      some complex eigenvalues so that leading
17401*>                      eigenvalues in the Generalized Schur form no
17402*>                      longer satisfy SELCTG=.TRUE.  This could also
17403*>                      be caused due to scaling.
17404*>                =N+3: reordering failed in ZTGSEN.
17405*> \endverbatim
17406*
17407*  Authors:
17408*  ========
17409*
17410*> \author Univ. of Tennessee
17411*> \author Univ. of California Berkeley
17412*> \author Univ. of Colorado Denver
17413*> \author NAG Ltd.
17414*
17415*> \date December 2016
17416*
17417*> \ingroup complex16GEeigen
17418*
17419*  =====================================================================
17420      SUBROUTINE ZGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB,
17421     $                  SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK,
17422     $                  LWORK, RWORK, BWORK, INFO )
17423*
17424*  -- LAPACK driver routine (version 3.7.0) --
17425*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
17426*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
17427*     December 2016
17428*
17429*     .. Scalar Arguments ..
17430      CHARACTER          JOBVSL, JOBVSR, SORT
17431      INTEGER            INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N, SDIM
17432*     ..
17433*     .. Array Arguments ..
17434      LOGICAL            BWORK( * )
17435      DOUBLE PRECISION   RWORK( * )
17436      COMPLEX*16         A( LDA, * ), ALPHA( * ), B( LDB, * ),
17437     $                   BETA( * ), VSL( LDVSL, * ), VSR( LDVSR, * ),
17438     $                   WORK( * )
17439*     ..
17440*     .. Function Arguments ..
17441      LOGICAL            SELCTG
17442      EXTERNAL           SELCTG
17443*     ..
17444*
17445*  =====================================================================
17446*
17447*     .. Parameters ..
17448      DOUBLE PRECISION   ZERO, ONE
17449      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
17450      COMPLEX*16         CZERO, CONE
17451      PARAMETER          ( CZERO = ( 0.0D0, 0.0D0 ),
17452     $                   CONE = ( 1.0D0, 0.0D0 ) )
17453*     ..
17454*     .. Local Scalars ..
17455      LOGICAL            CURSL, ILASCL, ILBSCL, ILVSL, ILVSR, LASTSL,
17456     $                   LQUERY, WANTST
17457      INTEGER            I, ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT,
17458     $                   ILO, IRIGHT, IROWS, IRWRK, ITAU, IWRK, LWKMIN,
17459     $                   LWKOPT
17460      DOUBLE PRECISION   ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, PVSL,
17461     $                   PVSR, SMLNUM
17462*     ..
17463*     .. Local Arrays ..
17464      INTEGER            IDUM( 1 )
17465      DOUBLE PRECISION   DIF( 2 )
17466*     ..
17467*     .. External Subroutines ..
17468      EXTERNAL           DLABAD, XERBLA, ZGEQRF, ZGGBAK, ZGGBAL, ZGGHRD,
17469     $                   ZHGEQZ, ZLACPY, ZLASCL, ZLASET, ZTGSEN, ZUNGQR,
17470     $                   ZUNMQR
17471*     ..
17472*     .. External Functions ..
17473      LOGICAL            LSAME
17474      INTEGER            ILAENV
17475      DOUBLE PRECISION   DLAMCH, ZLANGE
17476      EXTERNAL           LSAME, ILAENV, DLAMCH, ZLANGE
17477*     ..
17478*     .. Intrinsic Functions ..
17479      INTRINSIC          MAX, SQRT
17480*     ..
17481*     .. Executable Statements ..
17482*
17483*     Decode the input arguments
17484*
17485      IF( LSAME( JOBVSL, 'N' ) ) THEN
17486         IJOBVL = 1
17487         ILVSL = .FALSE.
17488      ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN
17489         IJOBVL = 2
17490         ILVSL = .TRUE.
17491      ELSE
17492         IJOBVL = -1
17493         ILVSL = .FALSE.
17494      END IF
17495*
17496      IF( LSAME( JOBVSR, 'N' ) ) THEN
17497         IJOBVR = 1
17498         ILVSR = .FALSE.
17499      ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN
17500         IJOBVR = 2
17501         ILVSR = .TRUE.
17502      ELSE
17503         IJOBVR = -1
17504         ILVSR = .FALSE.
17505      END IF
17506*
17507      WANTST = LSAME( SORT, 'S' )
17508*
17509*     Test the input arguments
17510*
17511      INFO = 0
17512      LQUERY = ( LWORK.EQ.-1 )
17513      IF( IJOBVL.LE.0 ) THEN
17514         INFO = -1
17515      ELSE IF( IJOBVR.LE.0 ) THEN
17516         INFO = -2
17517      ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN
17518         INFO = -3
17519      ELSE IF( N.LT.0 ) THEN
17520         INFO = -5
17521      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
17522         INFO = -7
17523      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
17524         INFO = -9
17525      ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN
17526         INFO = -14
17527      ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN
17528         INFO = -16
17529      END IF
17530*
17531*     Compute workspace
17532*      (Note: Comments in the code beginning "Workspace:" describe the
17533*       minimal amount of workspace needed at that point in the code,
17534*       as well as the preferred amount for good performance.
17535*       NB refers to the optimal block size for the immediately
17536*       following subroutine, as returned by ILAENV.)
17537*
17538      IF( INFO.EQ.0 ) THEN
17539         LWKMIN = MAX( 1, 2*N )
17540         LWKOPT = MAX( 1, N + N*ILAENV( 1, 'ZGEQRF', ' ', N, 1, N, 0 ) )
17541         LWKOPT = MAX( LWKOPT, N +
17542     $                 N*ILAENV( 1, 'ZUNMQR', ' ', N, 1, N, -1 ) )
17543         IF( ILVSL ) THEN
17544            LWKOPT = MAX( LWKOPT, N +
17545     $                    N*ILAENV( 1, 'ZUNGQR', ' ', N, 1, N, -1 ) )
17546         END IF
17547         WORK( 1 ) = LWKOPT
17548*
17549         IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY )
17550     $      INFO = -18
17551      END IF
17552*
17553      IF( INFO.NE.0 ) THEN
17554         CALL XERBLA( 'ZGGES ', -INFO )
17555         RETURN
17556      ELSE IF( LQUERY ) THEN
17557         RETURN
17558      END IF
17559*
17560*     Quick return if possible
17561*
17562      IF( N.EQ.0 ) THEN
17563         SDIM = 0
17564         RETURN
17565      END IF
17566*
17567*     Get machine constants
17568*
17569      EPS = DLAMCH( 'P' )
17570      SMLNUM = DLAMCH( 'S' )
17571      BIGNUM = ONE / SMLNUM
17572      CALL DLABAD( SMLNUM, BIGNUM )
17573      SMLNUM = SQRT( SMLNUM ) / EPS
17574      BIGNUM = ONE / SMLNUM
17575*
17576*     Scale A if max element outside range [SMLNUM,BIGNUM]
17577*
17578      ANRM = ZLANGE( 'M', N, N, A, LDA, RWORK )
17579      ILASCL = .FALSE.
17580      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
17581         ANRMTO = SMLNUM
17582         ILASCL = .TRUE.
17583      ELSE IF( ANRM.GT.BIGNUM ) THEN
17584         ANRMTO = BIGNUM
17585         ILASCL = .TRUE.
17586      END IF
17587*
17588      IF( ILASCL )
17589     $   CALL ZLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
17590*
17591*     Scale B if max element outside range [SMLNUM,BIGNUM]
17592*
17593      BNRM = ZLANGE( 'M', N, N, B, LDB, RWORK )
17594      ILBSCL = .FALSE.
17595      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
17596         BNRMTO = SMLNUM
17597         ILBSCL = .TRUE.
17598      ELSE IF( BNRM.GT.BIGNUM ) THEN
17599         BNRMTO = BIGNUM
17600         ILBSCL = .TRUE.
17601      END IF
17602*
17603      IF( ILBSCL )
17604     $   CALL ZLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR )
17605*
17606*     Permute the matrix to make it more nearly triangular
17607*     (Real Workspace: need 6*N)
17608*
17609      ILEFT = 1
17610      IRIGHT = N + 1
17611      IRWRK = IRIGHT + N
17612      CALL ZGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, RWORK( ILEFT ),
17613     $             RWORK( IRIGHT ), RWORK( IRWRK ), IERR )
17614*
17615*     Reduce B to triangular form (QR decomposition of B)
17616*     (Complex Workspace: need N, prefer N*NB)
17617*
17618      IROWS = IHI + 1 - ILO
17619      ICOLS = N + 1 - ILO
17620      ITAU = 1
17621      IWRK = ITAU + IROWS
17622      CALL ZGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
17623     $             WORK( IWRK ), LWORK+1-IWRK, IERR )
17624*
17625*     Apply the orthogonal transformation to matrix A
17626*     (Complex Workspace: need N, prefer N*NB)
17627*
17628      CALL ZUNMQR( 'L', 'C', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
17629     $             WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ),
17630     $             LWORK+1-IWRK, IERR )
17631*
17632*     Initialize VSL
17633*     (Complex Workspace: need N, prefer N*NB)
17634*
17635      IF( ILVSL ) THEN
17636         CALL ZLASET( 'Full', N, N, CZERO, CONE, VSL, LDVSL )
17637         IF( IROWS.GT.1 ) THEN
17638            CALL ZLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
17639     $                   VSL( ILO+1, ILO ), LDVSL )
17640         END IF
17641         CALL ZUNGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL,
17642     $                WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
17643      END IF
17644*
17645*     Initialize VSR
17646*
17647      IF( ILVSR )
17648     $   CALL ZLASET( 'Full', N, N, CZERO, CONE, VSR, LDVSR )
17649*
17650*     Reduce to generalized Hessenberg form
17651*     (Workspace: none needed)
17652*
17653      CALL ZGGHRD( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL,
17654     $             LDVSL, VSR, LDVSR, IERR )
17655*
17656      SDIM = 0
17657*
17658*     Perform QZ algorithm, computing Schur vectors if desired
17659*     (Complex Workspace: need N)
17660*     (Real Workspace: need N)
17661*
17662      IWRK = ITAU
17663      CALL ZHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB,
17664     $             ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK( IWRK ),
17665     $             LWORK+1-IWRK, RWORK( IRWRK ), IERR )
17666      IF( IERR.NE.0 ) THEN
17667         IF( IERR.GT.0 .AND. IERR.LE.N ) THEN
17668            INFO = IERR
17669         ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN
17670            INFO = IERR - N
17671         ELSE
17672            INFO = N + 1
17673         END IF
17674         GO TO 30
17675      END IF
17676*
17677*     Sort eigenvalues ALPHA/BETA if desired
17678*     (Workspace: none needed)
17679*
17680      IF( WANTST ) THEN
17681*
17682*        Undo scaling on eigenvalues before selecting
17683*
17684         IF( ILASCL )
17685     $      CALL ZLASCL( 'G', 0, 0, ANRM, ANRMTO, N, 1, ALPHA, N, IERR )
17686         IF( ILBSCL )
17687     $      CALL ZLASCL( 'G', 0, 0, BNRM, BNRMTO, N, 1, BETA, N, IERR )
17688*
17689*        Select eigenvalues
17690*
17691         DO 10 I = 1, N
17692            BWORK( I ) = SELCTG( ALPHA( I ), BETA( I ) )
17693   10    CONTINUE
17694*
17695         CALL ZTGSEN( 0, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB, ALPHA,
17696     $                BETA, VSL, LDVSL, VSR, LDVSR, SDIM, PVSL, PVSR,
17697     $                DIF, WORK( IWRK ), LWORK-IWRK+1, IDUM, 1, IERR )
17698         IF( IERR.EQ.1 )
17699     $      INFO = N + 3
17700*
17701      END IF
17702*
17703*     Apply back-permutation to VSL and VSR
17704*     (Workspace: none needed)
17705*
17706      IF( ILVSL )
17707     $   CALL ZGGBAK( 'P', 'L', N, ILO, IHI, RWORK( ILEFT ),
17708     $                RWORK( IRIGHT ), N, VSL, LDVSL, IERR )
17709      IF( ILVSR )
17710     $   CALL ZGGBAK( 'P', 'R', N, ILO, IHI, RWORK( ILEFT ),
17711     $                RWORK( IRIGHT ), N, VSR, LDVSR, IERR )
17712*
17713*     Undo scaling
17714*
17715      IF( ILASCL ) THEN
17716         CALL ZLASCL( 'U', 0, 0, ANRMTO, ANRM, N, N, A, LDA, IERR )
17717         CALL ZLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHA, N, IERR )
17718      END IF
17719*
17720      IF( ILBSCL ) THEN
17721         CALL ZLASCL( 'U', 0, 0, BNRMTO, BNRM, N, N, B, LDB, IERR )
17722         CALL ZLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
17723      END IF
17724*
17725      IF( WANTST ) THEN
17726*
17727*        Check if reordering is correct
17728*
17729         LASTSL = .TRUE.
17730         SDIM = 0
17731         DO 20 I = 1, N
17732            CURSL = SELCTG( ALPHA( I ), BETA( I ) )
17733            IF( CURSL )
17734     $         SDIM = SDIM + 1
17735            IF( CURSL .AND. .NOT.LASTSL )
17736     $         INFO = N + 2
17737            LASTSL = CURSL
17738   20    CONTINUE
17739*
17740      END IF
17741*
17742   30 CONTINUE
17743*
17744      WORK( 1 ) = LWKOPT
17745*
17746      RETURN
17747*
17748*     End of ZGGES
17749*
17750      END
17751*> \brief <b> ZGGEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices</b>
17752*
17753*  =========== DOCUMENTATION ===========
17754*
17755* Online html documentation available at
17756*            http://www.netlib.org/lapack/explore-html/
17757*
17758*> \htmlonly
17759*> Download ZGGEV + dependencies
17760*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zggev.f">
17761*> [TGZ]</a>
17762*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zggev.f">
17763*> [ZIP]</a>
17764*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zggev.f">
17765*> [TXT]</a>
17766*> \endhtmlonly
17767*
17768*  Definition:
17769*  ===========
17770*
17771*       SUBROUTINE ZGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA,
17772*                         VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO )
17773*
17774*       .. Scalar Arguments ..
17775*       CHARACTER          JOBVL, JOBVR
17776*       INTEGER            INFO, LDA, LDB, LDVL, LDVR, LWORK, N
17777*       ..
17778*       .. Array Arguments ..
17779*       DOUBLE PRECISION   RWORK( * )
17780*       COMPLEX*16         A( LDA, * ), ALPHA( * ), B( LDB, * ),
17781*      $                   BETA( * ), VL( LDVL, * ), VR( LDVR, * ),
17782*      $                   WORK( * )
17783*       ..
17784*
17785*
17786*> \par Purpose:
17787*  =============
17788*>
17789*> \verbatim
17790*>
17791*> ZGGEV computes for a pair of N-by-N complex nonsymmetric matrices
17792*> (A,B), the generalized eigenvalues, and optionally, the left and/or
17793*> right generalized eigenvectors.
17794*>
17795*> A generalized eigenvalue for a pair of matrices (A,B) is a scalar
17796*> lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
17797*> singular. It is usually represented as the pair (alpha,beta), as
17798*> there is a reasonable interpretation for beta=0, and even for both
17799*> being zero.
17800*>
17801*> The right generalized eigenvector v(j) corresponding to the
17802*> generalized eigenvalue lambda(j) of (A,B) satisfies
17803*>
17804*>              A * v(j) = lambda(j) * B * v(j).
17805*>
17806*> The left generalized eigenvector u(j) corresponding to the
17807*> generalized eigenvalues lambda(j) of (A,B) satisfies
17808*>
17809*>              u(j)**H * A = lambda(j) * u(j)**H * B
17810*>
17811*> where u(j)**H is the conjugate-transpose of u(j).
17812*> \endverbatim
17813*
17814*  Arguments:
17815*  ==========
17816*
17817*> \param[in] JOBVL
17818*> \verbatim
17819*>          JOBVL is CHARACTER*1
17820*>          = 'N':  do not compute the left generalized eigenvectors;
17821*>          = 'V':  compute the left generalized eigenvectors.
17822*> \endverbatim
17823*>
17824*> \param[in] JOBVR
17825*> \verbatim
17826*>          JOBVR is CHARACTER*1
17827*>          = 'N':  do not compute the right generalized eigenvectors;
17828*>          = 'V':  compute the right generalized eigenvectors.
17829*> \endverbatim
17830*>
17831*> \param[in] N
17832*> \verbatim
17833*>          N is INTEGER
17834*>          The order of the matrices A, B, VL, and VR.  N >= 0.
17835*> \endverbatim
17836*>
17837*> \param[in,out] A
17838*> \verbatim
17839*>          A is COMPLEX*16 array, dimension (LDA, N)
17840*>          On entry, the matrix A in the pair (A,B).
17841*>          On exit, A has been overwritten.
17842*> \endverbatim
17843*>
17844*> \param[in] LDA
17845*> \verbatim
17846*>          LDA is INTEGER
17847*>          The leading dimension of A.  LDA >= max(1,N).
17848*> \endverbatim
17849*>
17850*> \param[in,out] B
17851*> \verbatim
17852*>          B is COMPLEX*16 array, dimension (LDB, N)
17853*>          On entry, the matrix B in the pair (A,B).
17854*>          On exit, B has been overwritten.
17855*> \endverbatim
17856*>
17857*> \param[in] LDB
17858*> \verbatim
17859*>          LDB is INTEGER
17860*>          The leading dimension of B.  LDB >= max(1,N).
17861*> \endverbatim
17862*>
17863*> \param[out] ALPHA
17864*> \verbatim
17865*>          ALPHA is COMPLEX*16 array, dimension (N)
17866*> \endverbatim
17867*>
17868*> \param[out] BETA
17869*> \verbatim
17870*>          BETA is COMPLEX*16 array, dimension (N)
17871*>          On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the
17872*>          generalized eigenvalues.
17873*>
17874*>          Note: the quotients ALPHA(j)/BETA(j) may easily over- or
17875*>          underflow, and BETA(j) may even be zero.  Thus, the user
17876*>          should avoid naively computing the ratio alpha/beta.
17877*>          However, ALPHA will be always less than and usually
17878*>          comparable with norm(A) in magnitude, and BETA always less
17879*>          than and usually comparable with norm(B).
17880*> \endverbatim
17881*>
17882*> \param[out] VL
17883*> \verbatim
17884*>          VL is COMPLEX*16 array, dimension (LDVL,N)
17885*>          If JOBVL = 'V', the left generalized eigenvectors u(j) are
17886*>          stored one after another in the columns of VL, in the same
17887*>          order as their eigenvalues.
17888*>          Each eigenvector is scaled so the largest component has
17889*>          abs(real part) + abs(imag. part) = 1.
17890*>          Not referenced if JOBVL = 'N'.
17891*> \endverbatim
17892*>
17893*> \param[in] LDVL
17894*> \verbatim
17895*>          LDVL is INTEGER
17896*>          The leading dimension of the matrix VL. LDVL >= 1, and
17897*>          if JOBVL = 'V', LDVL >= N.
17898*> \endverbatim
17899*>
17900*> \param[out] VR
17901*> \verbatim
17902*>          VR is COMPLEX*16 array, dimension (LDVR,N)
17903*>          If JOBVR = 'V', the right generalized eigenvectors v(j) are
17904*>          stored one after another in the columns of VR, in the same
17905*>          order as their eigenvalues.
17906*>          Each eigenvector is scaled so the largest component has
17907*>          abs(real part) + abs(imag. part) = 1.
17908*>          Not referenced if JOBVR = 'N'.
17909*> \endverbatim
17910*>
17911*> \param[in] LDVR
17912*> \verbatim
17913*>          LDVR is INTEGER
17914*>          The leading dimension of the matrix VR. LDVR >= 1, and
17915*>          if JOBVR = 'V', LDVR >= N.
17916*> \endverbatim
17917*>
17918*> \param[out] WORK
17919*> \verbatim
17920*>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
17921*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
17922*> \endverbatim
17923*>
17924*> \param[in] LWORK
17925*> \verbatim
17926*>          LWORK is INTEGER
17927*>          The dimension of the array WORK.  LWORK >= max(1,2*N).
17928*>          For good performance, LWORK must generally be larger.
17929*>
17930*>          If LWORK = -1, then a workspace query is assumed; the routine
17931*>          only calculates the optimal size of the WORK array, returns
17932*>          this value as the first entry of the WORK array, and no error
17933*>          message related to LWORK is issued by XERBLA.
17934*> \endverbatim
17935*>
17936*> \param[out] RWORK
17937*> \verbatim
17938*>          RWORK is DOUBLE PRECISION array, dimension (8*N)
17939*> \endverbatim
17940*>
17941*> \param[out] INFO
17942*> \verbatim
17943*>          INFO is INTEGER
17944*>          = 0:  successful exit
17945*>          < 0:  if INFO = -i, the i-th argument had an illegal value.
17946*>          =1,...,N:
17947*>                The QZ iteration failed.  No eigenvectors have been
17948*>                calculated, but ALPHA(j) and BETA(j) should be
17949*>                correct for j=INFO+1,...,N.
17950*>          > N:  =N+1: other then QZ iteration failed in DHGEQZ,
17951*>                =N+2: error return from DTGEVC.
17952*> \endverbatim
17953*
17954*  Authors:
17955*  ========
17956*
17957*> \author Univ. of Tennessee
17958*> \author Univ. of California Berkeley
17959*> \author Univ. of Colorado Denver
17960*> \author NAG Ltd.
17961*
17962*> \date April 2012
17963*
17964*> \ingroup complex16GEeigen
17965*
17966*  =====================================================================
17967      SUBROUTINE ZGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA,
17968     $                  VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO )
17969*
17970*  -- LAPACK driver routine (version 3.7.0) --
17971*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
17972*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
17973*     April 2012
17974*
17975*     .. Scalar Arguments ..
17976      CHARACTER          JOBVL, JOBVR
17977      INTEGER            INFO, LDA, LDB, LDVL, LDVR, LWORK, N
17978*     ..
17979*     .. Array Arguments ..
17980      DOUBLE PRECISION   RWORK( * )
17981      COMPLEX*16         A( LDA, * ), ALPHA( * ), B( LDB, * ),
17982     $                   BETA( * ), VL( LDVL, * ), VR( LDVR, * ),
17983     $                   WORK( * )
17984*     ..
17985*
17986*  =====================================================================
17987*
17988*     .. Parameters ..
17989      DOUBLE PRECISION   ZERO, ONE
17990      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
17991      COMPLEX*16         CZERO, CONE
17992      PARAMETER          ( CZERO = ( 0.0D0, 0.0D0 ),
17993     $                   CONE = ( 1.0D0, 0.0D0 ) )
17994*     ..
17995*     .. Local Scalars ..
17996      LOGICAL            ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY
17997      CHARACTER          CHTEMP
17998      INTEGER            ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, ILO,
17999     $                   IN, IRIGHT, IROWS, IRWRK, ITAU, IWRK, JC, JR,
18000     $                   LWKMIN, LWKOPT
18001      DOUBLE PRECISION   ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
18002     $                   SMLNUM, TEMP
18003      COMPLEX*16         X
18004*     ..
18005*     .. Local Arrays ..
18006      LOGICAL            LDUMMA( 1 )
18007*     ..
18008*     .. External Subroutines ..
18009      EXTERNAL           DLABAD, XERBLA, ZGEQRF, ZGGBAK, ZGGBAL, ZGGHRD,
18010     $                   ZHGEQZ, ZLACPY, ZLASCL, ZLASET, ZTGEVC, ZUNGQR,
18011     $                   ZUNMQR
18012*     ..
18013*     .. External Functions ..
18014      LOGICAL            LSAME
18015      INTEGER            ILAENV
18016      DOUBLE PRECISION   DLAMCH, ZLANGE
18017      EXTERNAL           LSAME, ILAENV, DLAMCH, ZLANGE
18018*     ..
18019*     .. Intrinsic Functions ..
18020      INTRINSIC          ABS, DBLE, DIMAG, MAX, SQRT
18021*     ..
18022*     .. Statement Functions ..
18023      DOUBLE PRECISION   ABS1
18024*     ..
18025*     .. Statement Function definitions ..
18026      ABS1( X ) = ABS( DBLE( X ) ) + ABS( DIMAG( X ) )
18027*     ..
18028*     .. Executable Statements ..
18029*
18030*     Decode the input arguments
18031*
18032      IF( LSAME( JOBVL, 'N' ) ) THEN
18033         IJOBVL = 1
18034         ILVL = .FALSE.
18035      ELSE IF( LSAME( JOBVL, 'V' ) ) THEN
18036         IJOBVL = 2
18037         ILVL = .TRUE.
18038      ELSE
18039         IJOBVL = -1
18040         ILVL = .FALSE.
18041      END IF
18042*
18043      IF( LSAME( JOBVR, 'N' ) ) THEN
18044         IJOBVR = 1
18045         ILVR = .FALSE.
18046      ELSE IF( LSAME( JOBVR, 'V' ) ) THEN
18047         IJOBVR = 2
18048         ILVR = .TRUE.
18049      ELSE
18050         IJOBVR = -1
18051         ILVR = .FALSE.
18052      END IF
18053      ILV = ILVL .OR. ILVR
18054*
18055*     Test the input arguments
18056*
18057      INFO = 0
18058      LQUERY = ( LWORK.EQ.-1 )
18059      IF( IJOBVL.LE.0 ) THEN
18060         INFO = -1
18061      ELSE IF( IJOBVR.LE.0 ) THEN
18062         INFO = -2
18063      ELSE IF( N.LT.0 ) THEN
18064         INFO = -3
18065      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
18066         INFO = -5
18067      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
18068         INFO = -7
18069      ELSE IF( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN
18070         INFO = -11
18071      ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN
18072         INFO = -13
18073      END IF
18074*
18075*     Compute workspace
18076*      (Note: Comments in the code beginning "Workspace:" describe the
18077*       minimal amount of workspace needed at that point in the code,
18078*       as well as the preferred amount for good performance.
18079*       NB refers to the optimal block size for the immediately
18080*       following subroutine, as returned by ILAENV. The workspace is
18081*       computed assuming ILO = 1 and IHI = N, the worst case.)
18082*
18083      IF( INFO.EQ.0 ) THEN
18084         LWKMIN = MAX( 1, 2*N )
18085         LWKOPT = MAX( 1, N + N*ILAENV( 1, 'ZGEQRF', ' ', N, 1, N, 0 ) )
18086         LWKOPT = MAX( LWKOPT, N +
18087     $                 N*ILAENV( 1, 'ZUNMQR', ' ', N, 1, N, 0 ) )
18088         IF( ILVL ) THEN
18089            LWKOPT = MAX( LWKOPT, N +
18090     $                    N*ILAENV( 1, 'ZUNGQR', ' ', N, 1, N, -1 ) )
18091         END IF
18092         WORK( 1 ) = LWKOPT
18093*
18094         IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY )
18095     $      INFO = -15
18096      END IF
18097*
18098      IF( INFO.NE.0 ) THEN
18099         CALL XERBLA( 'ZGGEV ', -INFO )
18100         RETURN
18101      ELSE IF( LQUERY ) THEN
18102         RETURN
18103      END IF
18104*
18105*     Quick return if possible
18106*
18107      IF( N.EQ.0 )
18108     $   RETURN
18109*
18110*     Get machine constants
18111*
18112      EPS = DLAMCH( 'E' )*DLAMCH( 'B' )
18113      SMLNUM = DLAMCH( 'S' )
18114      BIGNUM = ONE / SMLNUM
18115      CALL DLABAD( SMLNUM, BIGNUM )
18116      SMLNUM = SQRT( SMLNUM ) / EPS
18117      BIGNUM = ONE / SMLNUM
18118*
18119*     Scale A if max element outside range [SMLNUM,BIGNUM]
18120*
18121      ANRM = ZLANGE( 'M', N, N, A, LDA, RWORK )
18122      ILASCL = .FALSE.
18123      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
18124         ANRMTO = SMLNUM
18125         ILASCL = .TRUE.
18126      ELSE IF( ANRM.GT.BIGNUM ) THEN
18127         ANRMTO = BIGNUM
18128         ILASCL = .TRUE.
18129      END IF
18130      IF( ILASCL )
18131     $   CALL ZLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
18132*
18133*     Scale B if max element outside range [SMLNUM,BIGNUM]
18134*
18135      BNRM = ZLANGE( 'M', N, N, B, LDB, RWORK )
18136      ILBSCL = .FALSE.
18137      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
18138         BNRMTO = SMLNUM
18139         ILBSCL = .TRUE.
18140      ELSE IF( BNRM.GT.BIGNUM ) THEN
18141         BNRMTO = BIGNUM
18142         ILBSCL = .TRUE.
18143      END IF
18144      IF( ILBSCL )
18145     $   CALL ZLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR )
18146*
18147*     Permute the matrices A, B to isolate eigenvalues if possible
18148*     (Real Workspace: need 6*N)
18149*
18150      ILEFT = 1
18151      IRIGHT = N + 1
18152      IRWRK = IRIGHT + N
18153      CALL ZGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, RWORK( ILEFT ),
18154     $             RWORK( IRIGHT ), RWORK( IRWRK ), IERR )
18155*
18156*     Reduce B to triangular form (QR decomposition of B)
18157*     (Complex Workspace: need N, prefer N*NB)
18158*
18159      IROWS = IHI + 1 - ILO
18160      IF( ILV ) THEN
18161         ICOLS = N + 1 - ILO
18162      ELSE
18163         ICOLS = IROWS
18164      END IF
18165      ITAU = 1
18166      IWRK = ITAU + IROWS
18167      CALL ZGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
18168     $             WORK( IWRK ), LWORK+1-IWRK, IERR )
18169*
18170*     Apply the orthogonal transformation to matrix A
18171*     (Complex Workspace: need N, prefer N*NB)
18172*
18173      CALL ZUNMQR( 'L', 'C', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
18174     $             WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ),
18175     $             LWORK+1-IWRK, IERR )
18176*
18177*     Initialize VL
18178*     (Complex Workspace: need N, prefer N*NB)
18179*
18180      IF( ILVL ) THEN
18181         CALL ZLASET( 'Full', N, N, CZERO, CONE, VL, LDVL )
18182         IF( IROWS.GT.1 ) THEN
18183            CALL ZLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
18184     $                   VL( ILO+1, ILO ), LDVL )
18185         END IF
18186         CALL ZUNGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL,
18187     $                WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
18188      END IF
18189*
18190*     Initialize VR
18191*
18192      IF( ILVR )
18193     $   CALL ZLASET( 'Full', N, N, CZERO, CONE, VR, LDVR )
18194*
18195*     Reduce to generalized Hessenberg form
18196*
18197      IF( ILV ) THEN
18198*
18199*        Eigenvectors requested -- work on whole matrix.
18200*
18201         CALL ZGGHRD( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL,
18202     $                LDVL, VR, LDVR, IERR )
18203      ELSE
18204         CALL ZGGHRD( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA,
18205     $                B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, IERR )
18206      END IF
18207*
18208*     Perform QZ algorithm (Compute eigenvalues, and optionally, the
18209*     Schur form and Schur vectors)
18210*     (Complex Workspace: need N)
18211*     (Real Workspace: need N)
18212*
18213      IWRK = ITAU
18214      IF( ILV ) THEN
18215         CHTEMP = 'S'
18216      ELSE
18217         CHTEMP = 'E'
18218      END IF
18219      CALL ZHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB,
18220     $             ALPHA, BETA, VL, LDVL, VR, LDVR, WORK( IWRK ),
18221     $             LWORK+1-IWRK, RWORK( IRWRK ), IERR )
18222      IF( IERR.NE.0 ) THEN
18223         IF( IERR.GT.0 .AND. IERR.LE.N ) THEN
18224            INFO = IERR
18225         ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN
18226            INFO = IERR - N
18227         ELSE
18228            INFO = N + 1
18229         END IF
18230         GO TO 70
18231      END IF
18232*
18233*     Compute Eigenvectors
18234*     (Real Workspace: need 2*N)
18235*     (Complex Workspace: need 2*N)
18236*
18237      IF( ILV ) THEN
18238         IF( ILVL ) THEN
18239            IF( ILVR ) THEN
18240               CHTEMP = 'B'
18241            ELSE
18242               CHTEMP = 'L'
18243            END IF
18244         ELSE
18245            CHTEMP = 'R'
18246         END IF
18247*
18248         CALL ZTGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL, LDVL,
18249     $                VR, LDVR, N, IN, WORK( IWRK ), RWORK( IRWRK ),
18250     $                IERR )
18251         IF( IERR.NE.0 ) THEN
18252            INFO = N + 2
18253            GO TO 70
18254         END IF
18255*
18256*        Undo balancing on VL and VR and normalization
18257*        (Workspace: none needed)
18258*
18259         IF( ILVL ) THEN
18260            CALL ZGGBAK( 'P', 'L', N, ILO, IHI, RWORK( ILEFT ),
18261     $                   RWORK( IRIGHT ), N, VL, LDVL, IERR )
18262            DO 30 JC = 1, N
18263               TEMP = ZERO
18264               DO 10 JR = 1, N
18265                  TEMP = MAX( TEMP, ABS1( VL( JR, JC ) ) )
18266   10          CONTINUE
18267               IF( TEMP.LT.SMLNUM )
18268     $            GO TO 30
18269               TEMP = ONE / TEMP
18270               DO 20 JR = 1, N
18271                  VL( JR, JC ) = VL( JR, JC )*TEMP
18272   20          CONTINUE
18273   30       CONTINUE
18274         END IF
18275         IF( ILVR ) THEN
18276            CALL ZGGBAK( 'P', 'R', N, ILO, IHI, RWORK( ILEFT ),
18277     $                   RWORK( IRIGHT ), N, VR, LDVR, IERR )
18278            DO 60 JC = 1, N
18279               TEMP = ZERO
18280               DO 40 JR = 1, N
18281                  TEMP = MAX( TEMP, ABS1( VR( JR, JC ) ) )
18282   40          CONTINUE
18283               IF( TEMP.LT.SMLNUM )
18284     $            GO TO 60
18285               TEMP = ONE / TEMP
18286               DO 50 JR = 1, N
18287                  VR( JR, JC ) = VR( JR, JC )*TEMP
18288   50          CONTINUE
18289   60       CONTINUE
18290         END IF
18291      END IF
18292*
18293*     Undo scaling if necessary
18294*
18295   70 CONTINUE
18296*
18297      IF( ILASCL )
18298     $   CALL ZLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHA, N, IERR )
18299*
18300      IF( ILBSCL )
18301     $   CALL ZLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
18302*
18303      WORK( 1 ) = LWKOPT
18304      RETURN
18305*
18306*     End of ZGGEV
18307*
18308      END
18309*> \brief \b ZGGHRD
18310*
18311*  =========== DOCUMENTATION ===========
18312*
18313* Online html documentation available at
18314*            http://www.netlib.org/lapack/explore-html/
18315*
18316*> \htmlonly
18317*> Download ZGGHRD + dependencies
18318*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgghrd.f">
18319*> [TGZ]</a>
18320*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgghrd.f">
18321*> [ZIP]</a>
18322*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgghrd.f">
18323*> [TXT]</a>
18324*> \endhtmlonly
18325*
18326*  Definition:
18327*  ===========
18328*
18329*       SUBROUTINE ZGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q,
18330*                          LDQ, Z, LDZ, INFO )
18331*
18332*       .. Scalar Arguments ..
18333*       CHARACTER          COMPQ, COMPZ
18334*       INTEGER            IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N
18335*       ..
18336*       .. Array Arguments ..
18337*       COMPLEX*16         A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
18338*      $                   Z( LDZ, * )
18339*       ..
18340*
18341*
18342*> \par Purpose:
18343*  =============
18344*>
18345*> \verbatim
18346*>
18347*> ZGGHRD reduces a pair of complex matrices (A,B) to generalized upper
18348*> Hessenberg form using unitary transformations, where A is a
18349*> general matrix and B is upper triangular.  The form of the
18350*> generalized eigenvalue problem is
18351*>    A*x = lambda*B*x,
18352*> and B is typically made upper triangular by computing its QR
18353*> factorization and moving the unitary matrix Q to the left side
18354*> of the equation.
18355*>
18356*> This subroutine simultaneously reduces A to a Hessenberg matrix H:
18357*>    Q**H*A*Z = H
18358*> and transforms B to another upper triangular matrix T:
18359*>    Q**H*B*Z = T
18360*> in order to reduce the problem to its standard form
18361*>    H*y = lambda*T*y
18362*> where y = Z**H*x.
18363*>
18364*> The unitary matrices Q and Z are determined as products of Givens
18365*> rotations.  They may either be formed explicitly, or they may be
18366*> postmultiplied into input matrices Q1 and Z1, so that
18367*>      Q1 * A * Z1**H = (Q1*Q) * H * (Z1*Z)**H
18368*>      Q1 * B * Z1**H = (Q1*Q) * T * (Z1*Z)**H
18369*> If Q1 is the unitary matrix from the QR factorization of B in the
18370*> original equation A*x = lambda*B*x, then ZGGHRD reduces the original
18371*> problem to generalized Hessenberg form.
18372*> \endverbatim
18373*
18374*  Arguments:
18375*  ==========
18376*
18377*> \param[in] COMPQ
18378*> \verbatim
18379*>          COMPQ is CHARACTER*1
18380*>          = 'N': do not compute Q;
18381*>          = 'I': Q is initialized to the unit matrix, and the
18382*>                 unitary matrix Q is returned;
18383*>          = 'V': Q must contain a unitary matrix Q1 on entry,
18384*>                 and the product Q1*Q is returned.
18385*> \endverbatim
18386*>
18387*> \param[in] COMPZ
18388*> \verbatim
18389*>          COMPZ is CHARACTER*1
18390*>          = 'N': do not compute Z;
18391*>          = 'I': Z is initialized to the unit matrix, and the
18392*>                 unitary matrix Z is returned;
18393*>          = 'V': Z must contain a unitary matrix Z1 on entry,
18394*>                 and the product Z1*Z is returned.
18395*> \endverbatim
18396*>
18397*> \param[in] N
18398*> \verbatim
18399*>          N is INTEGER
18400*>          The order of the matrices A and B.  N >= 0.
18401*> \endverbatim
18402*>
18403*> \param[in] ILO
18404*> \verbatim
18405*>          ILO is INTEGER
18406*> \endverbatim
18407*>
18408*> \param[in] IHI
18409*> \verbatim
18410*>          IHI is INTEGER
18411*>
18412*>          ILO and IHI mark the rows and columns of A which are to be
18413*>          reduced.  It is assumed that A is already upper triangular
18414*>          in rows and columns 1:ILO-1 and IHI+1:N.  ILO and IHI are
18415*>          normally set by a previous call to ZGGBAL; otherwise they
18416*>          should be set to 1 and N respectively.
18417*>          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
18418*> \endverbatim
18419*>
18420*> \param[in,out] A
18421*> \verbatim
18422*>          A is COMPLEX*16 array, dimension (LDA, N)
18423*>          On entry, the N-by-N general matrix to be reduced.
18424*>          On exit, the upper triangle and the first subdiagonal of A
18425*>          are overwritten with the upper Hessenberg matrix H, and the
18426*>          rest is set to zero.
18427*> \endverbatim
18428*>
18429*> \param[in] LDA
18430*> \verbatim
18431*>          LDA is INTEGER
18432*>          The leading dimension of the array A.  LDA >= max(1,N).
18433*> \endverbatim
18434*>
18435*> \param[in,out] B
18436*> \verbatim
18437*>          B is COMPLEX*16 array, dimension (LDB, N)
18438*>          On entry, the N-by-N upper triangular matrix B.
18439*>          On exit, the upper triangular matrix T = Q**H B Z.  The
18440*>          elements below the diagonal are set to zero.
18441*> \endverbatim
18442*>
18443*> \param[in] LDB
18444*> \verbatim
18445*>          LDB is INTEGER
18446*>          The leading dimension of the array B.  LDB >= max(1,N).
18447*> \endverbatim
18448*>
18449*> \param[in,out] Q
18450*> \verbatim
18451*>          Q is COMPLEX*16 array, dimension (LDQ, N)
18452*>          On entry, if COMPQ = 'V', the unitary matrix Q1, typically
18453*>          from the QR factorization of B.
18454*>          On exit, if COMPQ='I', the unitary matrix Q, and if
18455*>          COMPQ = 'V', the product Q1*Q.
18456*>          Not referenced if COMPQ='N'.
18457*> \endverbatim
18458*>
18459*> \param[in] LDQ
18460*> \verbatim
18461*>          LDQ is INTEGER
18462*>          The leading dimension of the array Q.
18463*>          LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise.
18464*> \endverbatim
18465*>
18466*> \param[in,out] Z
18467*> \verbatim
18468*>          Z is COMPLEX*16 array, dimension (LDZ, N)
18469*>          On entry, if COMPZ = 'V', the unitary matrix Z1.
18470*>          On exit, if COMPZ='I', the unitary matrix Z, and if
18471*>          COMPZ = 'V', the product Z1*Z.
18472*>          Not referenced if COMPZ='N'.
18473*> \endverbatim
18474*>
18475*> \param[in] LDZ
18476*> \verbatim
18477*>          LDZ is INTEGER
18478*>          The leading dimension of the array Z.
18479*>          LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise.
18480*> \endverbatim
18481*>
18482*> \param[out] INFO
18483*> \verbatim
18484*>          INFO is INTEGER
18485*>          = 0:  successful exit.
18486*>          < 0:  if INFO = -i, the i-th argument had an illegal value.
18487*> \endverbatim
18488*
18489*  Authors:
18490*  ========
18491*
18492*> \author Univ. of Tennessee
18493*> \author Univ. of California Berkeley
18494*> \author Univ. of Colorado Denver
18495*> \author NAG Ltd.
18496*
18497*> \date December 2016
18498*
18499*> \ingroup complex16OTHERcomputational
18500*
18501*> \par Further Details:
18502*  =====================
18503*>
18504*> \verbatim
18505*>
18506*>  This routine reduces A to Hessenberg and B to triangular form by
18507*>  an unblocked reduction, as described in _Matrix_Computations_,
18508*>  by Golub and van Loan (Johns Hopkins Press).
18509*> \endverbatim
18510*>
18511*  =====================================================================
18512      SUBROUTINE ZGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q,
18513     $                   LDQ, Z, LDZ, INFO )
18514*
18515*  -- LAPACK computational routine (version 3.7.0) --
18516*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
18517*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
18518*     December 2016
18519*
18520*     .. Scalar Arguments ..
18521      CHARACTER          COMPQ, COMPZ
18522      INTEGER            IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N
18523*     ..
18524*     .. Array Arguments ..
18525      COMPLEX*16         A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
18526     $                   Z( LDZ, * )
18527*     ..
18528*
18529*  =====================================================================
18530*
18531*     .. Parameters ..
18532      COMPLEX*16         CONE, CZERO
18533      PARAMETER          ( CONE = ( 1.0D+0, 0.0D+0 ),
18534     $                   CZERO = ( 0.0D+0, 0.0D+0 ) )
18535*     ..
18536*     .. Local Scalars ..
18537      LOGICAL            ILQ, ILZ
18538      INTEGER            ICOMPQ, ICOMPZ, JCOL, JROW
18539      DOUBLE PRECISION   C
18540      COMPLEX*16         CTEMP, S
18541*     ..
18542*     .. External Functions ..
18543      LOGICAL            LSAME
18544      EXTERNAL           LSAME
18545*     ..
18546*     .. External Subroutines ..
18547      EXTERNAL           XERBLA, ZLARTG, ZLASET, ZROT
18548*     ..
18549*     .. Intrinsic Functions ..
18550      INTRINSIC          DCONJG, MAX
18551*     ..
18552*     .. Executable Statements ..
18553*
18554*     Decode COMPQ
18555*
18556      IF( LSAME( COMPQ, 'N' ) ) THEN
18557         ILQ = .FALSE.
18558         ICOMPQ = 1
18559      ELSE IF( LSAME( COMPQ, 'V' ) ) THEN
18560         ILQ = .TRUE.
18561         ICOMPQ = 2
18562      ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
18563         ILQ = .TRUE.
18564         ICOMPQ = 3
18565      ELSE
18566         ICOMPQ = 0
18567      END IF
18568*
18569*     Decode COMPZ
18570*
18571      IF( LSAME( COMPZ, 'N' ) ) THEN
18572         ILZ = .FALSE.
18573         ICOMPZ = 1
18574      ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
18575         ILZ = .TRUE.
18576         ICOMPZ = 2
18577      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
18578         ILZ = .TRUE.
18579         ICOMPZ = 3
18580      ELSE
18581         ICOMPZ = 0
18582      END IF
18583*
18584*     Test the input parameters.
18585*
18586      INFO = 0
18587      IF( ICOMPQ.LE.0 ) THEN
18588         INFO = -1
18589      ELSE IF( ICOMPZ.LE.0 ) THEN
18590         INFO = -2
18591      ELSE IF( N.LT.0 ) THEN
18592         INFO = -3
18593      ELSE IF( ILO.LT.1 ) THEN
18594         INFO = -4
18595      ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN
18596         INFO = -5
18597      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
18598         INFO = -7
18599      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
18600         INFO = -9
18601      ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN
18602         INFO = -11
18603      ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN
18604         INFO = -13
18605      END IF
18606      IF( INFO.NE.0 ) THEN
18607         CALL XERBLA( 'ZGGHRD', -INFO )
18608         RETURN
18609      END IF
18610*
18611*     Initialize Q and Z if desired.
18612*
18613      IF( ICOMPQ.EQ.3 )
18614     $   CALL ZLASET( 'Full', N, N, CZERO, CONE, Q, LDQ )
18615      IF( ICOMPZ.EQ.3 )
18616     $   CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDZ )
18617*
18618*     Quick return if possible
18619*
18620      IF( N.LE.1 )
18621     $   RETURN
18622*
18623*     Zero out lower triangle of B
18624*
18625      DO 20 JCOL = 1, N - 1
18626         DO 10 JROW = JCOL + 1, N
18627            B( JROW, JCOL ) = CZERO
18628   10    CONTINUE
18629   20 CONTINUE
18630*
18631*     Reduce A and B
18632*
18633      DO 40 JCOL = ILO, IHI - 2
18634*
18635         DO 30 JROW = IHI, JCOL + 2, -1
18636*
18637*           Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL)
18638*
18639            CTEMP = A( JROW-1, JCOL )
18640            CALL ZLARTG( CTEMP, A( JROW, JCOL ), C, S,
18641     $                   A( JROW-1, JCOL ) )
18642            A( JROW, JCOL ) = CZERO
18643            CALL ZROT( N-JCOL, A( JROW-1, JCOL+1 ), LDA,
18644     $                 A( JROW, JCOL+1 ), LDA, C, S )
18645            CALL ZROT( N+2-JROW, B( JROW-1, JROW-1 ), LDB,
18646     $                 B( JROW, JROW-1 ), LDB, C, S )
18647            IF( ILQ )
18648     $         CALL ZROT( N, Q( 1, JROW-1 ), 1, Q( 1, JROW ), 1, C,
18649     $                    DCONJG( S ) )
18650*
18651*           Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1)
18652*
18653            CTEMP = B( JROW, JROW )
18654            CALL ZLARTG( CTEMP, B( JROW, JROW-1 ), C, S,
18655     $                   B( JROW, JROW ) )
18656            B( JROW, JROW-1 ) = CZERO
18657            CALL ZROT( IHI, A( 1, JROW ), 1, A( 1, JROW-1 ), 1, C, S )
18658            CALL ZROT( JROW-1, B( 1, JROW ), 1, B( 1, JROW-1 ), 1, C,
18659     $                 S )
18660            IF( ILZ )
18661     $         CALL ZROT( N, Z( 1, JROW ), 1, Z( 1, JROW-1 ), 1, C, S )
18662   30    CONTINUE
18663   40 CONTINUE
18664*
18665      RETURN
18666*
18667*     End of ZGGHRD
18668*
18669      END
18670*> \brief <b> ZHEEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for HE matrices</b>
18671*
18672*  =========== DOCUMENTATION ===========
18673*
18674* Online html documentation available at
18675*            http://www.netlib.org/lapack/explore-html/
18676*
18677*> \htmlonly
18678*> Download ZHEEV + dependencies
18679*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zheev.f">
18680*> [TGZ]</a>
18681*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zheev.f">
18682*> [ZIP]</a>
18683*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zheev.f">
18684*> [TXT]</a>
18685*> \endhtmlonly
18686*
18687*  Definition:
18688*  ===========
18689*
18690*       SUBROUTINE ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK,
18691*                         INFO )
18692*
18693*       .. Scalar Arguments ..
18694*       CHARACTER          JOBZ, UPLO
18695*       INTEGER            INFO, LDA, LWORK, N
18696*       ..
18697*       .. Array Arguments ..
18698*       DOUBLE PRECISION   RWORK( * ), W( * )
18699*       COMPLEX*16         A( LDA, * ), WORK( * )
18700*       ..
18701*
18702*
18703*> \par Purpose:
18704*  =============
18705*>
18706*> \verbatim
18707*>
18708*> ZHEEV computes all eigenvalues and, optionally, eigenvectors of a
18709*> complex Hermitian matrix A.
18710*> \endverbatim
18711*
18712*  Arguments:
18713*  ==========
18714*
18715*> \param[in] JOBZ
18716*> \verbatim
18717*>          JOBZ is CHARACTER*1
18718*>          = 'N':  Compute eigenvalues only;
18719*>          = 'V':  Compute eigenvalues and eigenvectors.
18720*> \endverbatim
18721*>
18722*> \param[in] UPLO
18723*> \verbatim
18724*>          UPLO is CHARACTER*1
18725*>          = 'U':  Upper triangle of A is stored;
18726*>          = 'L':  Lower triangle of A is stored.
18727*> \endverbatim
18728*>
18729*> \param[in] N
18730*> \verbatim
18731*>          N is INTEGER
18732*>          The order of the matrix A.  N >= 0.
18733*> \endverbatim
18734*>
18735*> \param[in,out] A
18736*> \verbatim
18737*>          A is COMPLEX*16 array, dimension (LDA, N)
18738*>          On entry, the Hermitian matrix A.  If UPLO = 'U', the
18739*>          leading N-by-N upper triangular part of A contains the
18740*>          upper triangular part of the matrix A.  If UPLO = 'L',
18741*>          the leading N-by-N lower triangular part of A contains
18742*>          the lower triangular part of the matrix A.
18743*>          On exit, if JOBZ = 'V', then if INFO = 0, A contains the
18744*>          orthonormal eigenvectors of the matrix A.
18745*>          If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
18746*>          or the upper triangle (if UPLO='U') of A, including the
18747*>          diagonal, is destroyed.
18748*> \endverbatim
18749*>
18750*> \param[in] LDA
18751*> \verbatim
18752*>          LDA is INTEGER
18753*>          The leading dimension of the array A.  LDA >= max(1,N).
18754*> \endverbatim
18755*>
18756*> \param[out] W
18757*> \verbatim
18758*>          W is DOUBLE PRECISION array, dimension (N)
18759*>          If INFO = 0, the eigenvalues in ascending order.
18760*> \endverbatim
18761*>
18762*> \param[out] WORK
18763*> \verbatim
18764*>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
18765*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
18766*> \endverbatim
18767*>
18768*> \param[in] LWORK
18769*> \verbatim
18770*>          LWORK is INTEGER
18771*>          The length of the array WORK.  LWORK >= max(1,2*N-1).
18772*>          For optimal efficiency, LWORK >= (NB+1)*N,
18773*>          where NB is the blocksize for ZHETRD returned by ILAENV.
18774*>
18775*>          If LWORK = -1, then a workspace query is assumed; the routine
18776*>          only calculates the optimal size of the WORK array, returns
18777*>          this value as the first entry of the WORK array, and no error
18778*>          message related to LWORK is issued by XERBLA.
18779*> \endverbatim
18780*>
18781*> \param[out] RWORK
18782*> \verbatim
18783*>          RWORK is DOUBLE PRECISION array, dimension (max(1, 3*N-2))
18784*> \endverbatim
18785*>
18786*> \param[out] INFO
18787*> \verbatim
18788*>          INFO is INTEGER
18789*>          = 0:  successful exit
18790*>          < 0:  if INFO = -i, the i-th argument had an illegal value
18791*>          > 0:  if INFO = i, the algorithm failed to converge; i
18792*>                off-diagonal elements of an intermediate tridiagonal
18793*>                form did not converge to zero.
18794*> \endverbatim
18795*
18796*  Authors:
18797*  ========
18798*
18799*> \author Univ. of Tennessee
18800*> \author Univ. of California Berkeley
18801*> \author Univ. of Colorado Denver
18802*> \author NAG Ltd.
18803*
18804*> \date December 2016
18805*
18806*> \ingroup complex16HEeigen
18807*
18808*  =====================================================================
18809      SUBROUTINE ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK,
18810     $                  INFO )
18811*
18812*  -- LAPACK driver routine (version 3.7.0) --
18813*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
18814*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
18815*     December 2016
18816*
18817*     .. Scalar Arguments ..
18818      CHARACTER          JOBZ, UPLO
18819      INTEGER            INFO, LDA, LWORK, N
18820*     ..
18821*     .. Array Arguments ..
18822      DOUBLE PRECISION   RWORK( * ), W( * )
18823      COMPLEX*16         A( LDA, * ), WORK( * )
18824*     ..
18825*
18826*  =====================================================================
18827*
18828*     .. Parameters ..
18829      DOUBLE PRECISION   ZERO, ONE
18830      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
18831      COMPLEX*16         CONE
18832      PARAMETER          ( CONE = ( 1.0D0, 0.0D0 ) )
18833*     ..
18834*     .. Local Scalars ..
18835      LOGICAL            LOWER, LQUERY, WANTZ
18836      INTEGER            IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE,
18837     $                   LLWORK, LWKOPT, NB
18838      DOUBLE PRECISION   ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
18839     $                   SMLNUM
18840*     ..
18841*     .. External Functions ..
18842      LOGICAL            LSAME
18843      INTEGER            ILAENV
18844      DOUBLE PRECISION   DLAMCH, ZLANHE
18845      EXTERNAL           LSAME, ILAENV, DLAMCH, ZLANHE
18846*     ..
18847*     .. External Subroutines ..
18848      EXTERNAL           DSCAL, DSTERF, XERBLA, ZHETRD, ZLASCL, ZSTEQR,
18849     $                   ZUNGTR
18850*     ..
18851*     .. Intrinsic Functions ..
18852      INTRINSIC          MAX, SQRT
18853*     ..
18854*     .. Executable Statements ..
18855*
18856*     Test the input parameters.
18857*
18858      WANTZ = LSAME( JOBZ, 'V' )
18859      LOWER = LSAME( UPLO, 'L' )
18860      LQUERY = ( LWORK.EQ.-1 )
18861*
18862      INFO = 0
18863      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
18864         INFO = -1
18865      ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
18866         INFO = -2
18867      ELSE IF( N.LT.0 ) THEN
18868         INFO = -3
18869      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
18870         INFO = -5
18871      END IF
18872*
18873      IF( INFO.EQ.0 ) THEN
18874         NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 )
18875         LWKOPT = MAX( 1, ( NB+1 )*N )
18876         WORK( 1 ) = LWKOPT
18877*
18878         IF( LWORK.LT.MAX( 1, 2*N-1 ) .AND. .NOT.LQUERY )
18879     $      INFO = -8
18880      END IF
18881*
18882      IF( INFO.NE.0 ) THEN
18883         CALL XERBLA( 'ZHEEV ', -INFO )
18884         RETURN
18885      ELSE IF( LQUERY ) THEN
18886         RETURN
18887      END IF
18888*
18889*     Quick return if possible
18890*
18891      IF( N.EQ.0 ) THEN
18892         RETURN
18893      END IF
18894*
18895      IF( N.EQ.1 ) THEN
18896         W( 1 ) = A( 1, 1 )
18897         WORK( 1 ) = 1
18898         IF( WANTZ )
18899     $      A( 1, 1 ) = CONE
18900         RETURN
18901      END IF
18902*
18903*     Get machine constants.
18904*
18905      SAFMIN = DLAMCH( 'Safe minimum' )
18906      EPS = DLAMCH( 'Precision' )
18907      SMLNUM = SAFMIN / EPS
18908      BIGNUM = ONE / SMLNUM
18909      RMIN = SQRT( SMLNUM )
18910      RMAX = SQRT( BIGNUM )
18911*
18912*     Scale matrix to allowable range, if necessary.
18913*
18914      ANRM = ZLANHE( 'M', UPLO, N, A, LDA, RWORK )
18915      ISCALE = 0
18916      IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
18917         ISCALE = 1
18918         SIGMA = RMIN / ANRM
18919      ELSE IF( ANRM.GT.RMAX ) THEN
18920         ISCALE = 1
18921         SIGMA = RMAX / ANRM
18922      END IF
18923      IF( ISCALE.EQ.1 )
18924     $   CALL ZLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO )
18925*
18926*     Call ZHETRD to reduce Hermitian matrix to tridiagonal form.
18927*
18928      INDE = 1
18929      INDTAU = 1
18930      INDWRK = INDTAU + N
18931      LLWORK = LWORK - INDWRK + 1
18932      CALL ZHETRD( UPLO, N, A, LDA, W, RWORK( INDE ), WORK( INDTAU ),
18933     $             WORK( INDWRK ), LLWORK, IINFO )
18934*
18935*     For eigenvalues only, call DSTERF.  For eigenvectors, first call
18936*     ZUNGTR to generate the unitary matrix, then call ZSTEQR.
18937*
18938      IF( .NOT.WANTZ ) THEN
18939         CALL DSTERF( N, W, RWORK( INDE ), INFO )
18940      ELSE
18941         CALL ZUNGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ),
18942     $                LLWORK, IINFO )
18943         INDWRK = INDE + N
18944         CALL ZSTEQR( JOBZ, N, W, RWORK( INDE ), A, LDA,
18945     $                RWORK( INDWRK ), INFO )
18946      END IF
18947*
18948*     If matrix was scaled, then rescale eigenvalues appropriately.
18949*
18950      IF( ISCALE.EQ.1 ) THEN
18951         IF( INFO.EQ.0 ) THEN
18952            IMAX = N
18953         ELSE
18954            IMAX = INFO - 1
18955         END IF
18956         CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
18957      END IF
18958*
18959*     Set WORK(1) to optimal complex workspace size.
18960*
18961      WORK( 1 ) = LWKOPT
18962*
18963      RETURN
18964*
18965*     End of ZHEEV
18966*
18967      END
18968*> \brief <b> ZHEEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for HE matrices</b>
18969*
18970*  =========== DOCUMENTATION ===========
18971*
18972* Online html documentation available at
18973*            http://www.netlib.org/lapack/explore-html/
18974*
18975*> \htmlonly
18976*> Download ZHEEVD + dependencies
18977*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zheevd.f">
18978*> [TGZ]</a>
18979*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zheevd.f">
18980*> [ZIP]</a>
18981*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zheevd.f">
18982*> [TXT]</a>
18983*> \endhtmlonly
18984*
18985*  Definition:
18986*  ===========
18987*
18988*       SUBROUTINE ZHEEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK,
18989*                          LRWORK, IWORK, LIWORK, INFO )
18990*
18991*       .. Scalar Arguments ..
18992*       CHARACTER          JOBZ, UPLO
18993*       INTEGER            INFO, LDA, LIWORK, LRWORK, LWORK, N
18994*       ..
18995*       .. Array Arguments ..
18996*       INTEGER            IWORK( * )
18997*       DOUBLE PRECISION   RWORK( * ), W( * )
18998*       COMPLEX*16         A( LDA, * ), WORK( * )
18999*       ..
19000*
19001*
19002*> \par Purpose:
19003*  =============
19004*>
19005*> \verbatim
19006*>
19007*> ZHEEVD computes all eigenvalues and, optionally, eigenvectors of a
19008*> complex Hermitian matrix A.  If eigenvectors are desired, it uses a
19009*> divide and conquer algorithm.
19010*>
19011*> The divide and conquer algorithm makes very mild assumptions about
19012*> floating point arithmetic. It will work on machines with a guard
19013*> digit in add/subtract, or on those binary machines without guard
19014*> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
19015*> Cray-2. It could conceivably fail on hexadecimal or decimal machines
19016*> without guard digits, but we know of none.
19017*> \endverbatim
19018*
19019*  Arguments:
19020*  ==========
19021*
19022*> \param[in] JOBZ
19023*> \verbatim
19024*>          JOBZ is CHARACTER*1
19025*>          = 'N':  Compute eigenvalues only;
19026*>          = 'V':  Compute eigenvalues and eigenvectors.
19027*> \endverbatim
19028*>
19029*> \param[in] UPLO
19030*> \verbatim
19031*>          UPLO is CHARACTER*1
19032*>          = 'U':  Upper triangle of A is stored;
19033*>          = 'L':  Lower triangle of A is stored.
19034*> \endverbatim
19035*>
19036*> \param[in] N
19037*> \verbatim
19038*>          N is INTEGER
19039*>          The order of the matrix A.  N >= 0.
19040*> \endverbatim
19041*>
19042*> \param[in,out] A
19043*> \verbatim
19044*>          A is COMPLEX*16 array, dimension (LDA, N)
19045*>          On entry, the Hermitian matrix A.  If UPLO = 'U', the
19046*>          leading N-by-N upper triangular part of A contains the
19047*>          upper triangular part of the matrix A.  If UPLO = 'L',
19048*>          the leading N-by-N lower triangular part of A contains
19049*>          the lower triangular part of the matrix A.
19050*>          On exit, if JOBZ = 'V', then if INFO = 0, A contains the
19051*>          orthonormal eigenvectors of the matrix A.
19052*>          If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
19053*>          or the upper triangle (if UPLO='U') of A, including the
19054*>          diagonal, is destroyed.
19055*> \endverbatim
19056*>
19057*> \param[in] LDA
19058*> \verbatim
19059*>          LDA is INTEGER
19060*>          The leading dimension of the array A.  LDA >= max(1,N).
19061*> \endverbatim
19062*>
19063*> \param[out] W
19064*> \verbatim
19065*>          W is DOUBLE PRECISION array, dimension (N)
19066*>          If INFO = 0, the eigenvalues in ascending order.
19067*> \endverbatim
19068*>
19069*> \param[out] WORK
19070*> \verbatim
19071*>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
19072*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
19073*> \endverbatim
19074*>
19075*> \param[in] LWORK
19076*> \verbatim
19077*>          LWORK is INTEGER
19078*>          The length of the array WORK.
19079*>          If N <= 1,                LWORK must be at least 1.
19080*>          If JOBZ  = 'N' and N > 1, LWORK must be at least N + 1.
19081*>          If JOBZ  = 'V' and N > 1, LWORK must be at least 2*N + N**2.
19082*>
19083*>          If LWORK = -1, then a workspace query is assumed; the routine
19084*>          only calculates the optimal sizes of the WORK, RWORK and
19085*>          IWORK arrays, returns these values as the first entries of
19086*>          the WORK, RWORK and IWORK arrays, and no error message
19087*>          related to LWORK or LRWORK or LIWORK is issued by XERBLA.
19088*> \endverbatim
19089*>
19090*> \param[out] RWORK
19091*> \verbatim
19092*>          RWORK is DOUBLE PRECISION array,
19093*>                                         dimension (LRWORK)
19094*>          On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.
19095*> \endverbatim
19096*>
19097*> \param[in] LRWORK
19098*> \verbatim
19099*>          LRWORK is INTEGER
19100*>          The dimension of the array RWORK.
19101*>          If N <= 1,                LRWORK must be at least 1.
19102*>          If JOBZ  = 'N' and N > 1, LRWORK must be at least N.
19103*>          If JOBZ  = 'V' and N > 1, LRWORK must be at least
19104*>                         1 + 5*N + 2*N**2.
19105*>
19106*>          If LRWORK = -1, then a workspace query is assumed; the
19107*>          routine only calculates the optimal sizes of the WORK, RWORK
19108*>          and IWORK arrays, returns these values as the first entries
19109*>          of the WORK, RWORK and IWORK arrays, and no error message
19110*>          related to LWORK or LRWORK or LIWORK is issued by XERBLA.
19111*> \endverbatim
19112*>
19113*> \param[out] IWORK
19114*> \verbatim
19115*>          IWORK is INTEGER array, dimension (MAX(1,LIWORK))
19116*>          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
19117*> \endverbatim
19118*>
19119*> \param[in] LIWORK
19120*> \verbatim
19121*>          LIWORK is INTEGER
19122*>          The dimension of the array IWORK.
19123*>          If N <= 1,                LIWORK must be at least 1.
19124*>          If JOBZ  = 'N' and N > 1, LIWORK must be at least 1.
19125*>          If JOBZ  = 'V' and N > 1, LIWORK must be at least 3 + 5*N.
19126*>
19127*>          If LIWORK = -1, then a workspace query is assumed; the
19128*>          routine only calculates the optimal sizes of the WORK, RWORK
19129*>          and IWORK arrays, returns these values as the first entries
19130*>          of the WORK, RWORK and IWORK arrays, and no error message
19131*>          related to LWORK or LRWORK or LIWORK is issued by XERBLA.
19132*> \endverbatim
19133*>
19134*> \param[out] INFO
19135*> \verbatim
19136*>          INFO is INTEGER
19137*>          = 0:  successful exit
19138*>          < 0:  if INFO = -i, the i-th argument had an illegal value
19139*>          > 0:  if INFO = i and JOBZ = 'N', then the algorithm failed
19140*>                to converge; i off-diagonal elements of an intermediate
19141*>                tridiagonal form did not converge to zero;
19142*>                if INFO = i and JOBZ = 'V', then the algorithm failed
19143*>                to compute an eigenvalue while working on the submatrix
19144*>                lying in rows and columns INFO/(N+1) through
19145*>                mod(INFO,N+1).
19146*> \endverbatim
19147*
19148*  Authors:
19149*  ========
19150*
19151*> \author Univ. of Tennessee
19152*> \author Univ. of California Berkeley
19153*> \author Univ. of Colorado Denver
19154*> \author NAG Ltd.
19155*
19156*> \date December 2016
19157*
19158*> \ingroup complex16HEeigen
19159*
19160*> \par Further Details:
19161*  =====================
19162*>
19163*>  Modified description of INFO. Sven, 16 Feb 05.
19164*
19165*> \par Contributors:
19166*  ==================
19167*>
19168*> Jeff Rutter, Computer Science Division, University of California
19169*> at Berkeley, USA
19170*>
19171*  =====================================================================
19172      SUBROUTINE ZHEEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK,
19173     $                   LRWORK, IWORK, LIWORK, INFO )
19174*
19175*  -- LAPACK driver routine (version 3.7.0) --
19176*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
19177*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
19178*     December 2016
19179*
19180*     .. Scalar Arguments ..
19181      CHARACTER          JOBZ, UPLO
19182      INTEGER            INFO, LDA, LIWORK, LRWORK, LWORK, N
19183*     ..
19184*     .. Array Arguments ..
19185      INTEGER            IWORK( * )
19186      DOUBLE PRECISION   RWORK( * ), W( * )
19187      COMPLEX*16         A( LDA, * ), WORK( * )
19188*     ..
19189*
19190*  =====================================================================
19191*
19192*     .. Parameters ..
19193      DOUBLE PRECISION   ZERO, ONE
19194      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
19195      COMPLEX*16         CONE
19196      PARAMETER          ( CONE = ( 1.0D0, 0.0D0 ) )
19197*     ..
19198*     .. Local Scalars ..
19199      LOGICAL            LOWER, LQUERY, WANTZ
19200      INTEGER            IINFO, IMAX, INDE, INDRWK, INDTAU, INDWK2,
19201     $                   INDWRK, ISCALE, LIOPT, LIWMIN, LLRWK, LLWORK,
19202     $                   LLWRK2, LOPT, LROPT, LRWMIN, LWMIN
19203      DOUBLE PRECISION   ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
19204     $                   SMLNUM
19205*     ..
19206*     .. External Functions ..
19207      LOGICAL            LSAME
19208      INTEGER            ILAENV
19209      DOUBLE PRECISION   DLAMCH, ZLANHE
19210      EXTERNAL           LSAME, ILAENV, DLAMCH, ZLANHE
19211*     ..
19212*     .. External Subroutines ..
19213      EXTERNAL           DSCAL, DSTERF, XERBLA, ZHETRD, ZLACPY, ZLASCL,
19214     $                   ZSTEDC, ZUNMTR
19215*     ..
19216*     .. Intrinsic Functions ..
19217      INTRINSIC          MAX, SQRT
19218*     ..
19219*     .. Executable Statements ..
19220*
19221*     Test the input parameters.
19222*
19223      WANTZ = LSAME( JOBZ, 'V' )
19224      LOWER = LSAME( UPLO, 'L' )
19225      LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
19226*
19227      INFO = 0
19228      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
19229         INFO = -1
19230      ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
19231         INFO = -2
19232      ELSE IF( N.LT.0 ) THEN
19233         INFO = -3
19234      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
19235         INFO = -5
19236      END IF
19237*
19238      IF( INFO.EQ.0 ) THEN
19239         IF( N.LE.1 ) THEN
19240            LWMIN = 1
19241            LRWMIN = 1
19242            LIWMIN = 1
19243            LOPT = LWMIN
19244            LROPT = LRWMIN
19245            LIOPT = LIWMIN
19246         ELSE
19247            IF( WANTZ ) THEN
19248               LWMIN = 2*N + N*N
19249               LRWMIN = 1 + 5*N + 2*N**2
19250               LIWMIN = 3 + 5*N
19251            ELSE
19252               LWMIN = N + 1
19253               LRWMIN = N
19254               LIWMIN = 1
19255            END IF
19256            LOPT = MAX( LWMIN, N +
19257     $                  ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 ) )
19258            LROPT = LRWMIN
19259            LIOPT = LIWMIN
19260         END IF
19261         WORK( 1 ) = LOPT
19262         RWORK( 1 ) = LROPT
19263         IWORK( 1 ) = LIOPT
19264*
19265         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
19266            INFO = -8
19267         ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN
19268            INFO = -10
19269         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
19270            INFO = -12
19271         END IF
19272      END IF
19273*
19274      IF( INFO.NE.0 ) THEN
19275         CALL XERBLA( 'ZHEEVD', -INFO )
19276         RETURN
19277      ELSE IF( LQUERY ) THEN
19278         RETURN
19279      END IF
19280*
19281*     Quick return if possible
19282*
19283      IF( N.EQ.0 )
19284     $   RETURN
19285*
19286      IF( N.EQ.1 ) THEN
19287         W( 1 ) = A( 1, 1 )
19288         IF( WANTZ )
19289     $      A( 1, 1 ) = CONE
19290         RETURN
19291      END IF
19292*
19293*     Get machine constants.
19294*
19295      SAFMIN = DLAMCH( 'Safe minimum' )
19296      EPS = DLAMCH( 'Precision' )
19297      SMLNUM = SAFMIN / EPS
19298      BIGNUM = ONE / SMLNUM
19299      RMIN = SQRT( SMLNUM )
19300      RMAX = SQRT( BIGNUM )
19301*
19302*     Scale matrix to allowable range, if necessary.
19303*
19304      ANRM = ZLANHE( 'M', UPLO, N, A, LDA, RWORK )
19305      ISCALE = 0
19306      IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
19307         ISCALE = 1
19308         SIGMA = RMIN / ANRM
19309      ELSE IF( ANRM.GT.RMAX ) THEN
19310         ISCALE = 1
19311         SIGMA = RMAX / ANRM
19312      END IF
19313      IF( ISCALE.EQ.1 )
19314     $   CALL ZLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO )
19315*
19316*     Call ZHETRD to reduce Hermitian matrix to tridiagonal form.
19317*
19318      INDE = 1
19319      INDTAU = 1
19320      INDWRK = INDTAU + N
19321      INDRWK = INDE + N
19322      INDWK2 = INDWRK + N*N
19323      LLWORK = LWORK - INDWRK + 1
19324      LLWRK2 = LWORK - INDWK2 + 1
19325      LLRWK = LRWORK - INDRWK + 1
19326      CALL ZHETRD( UPLO, N, A, LDA, W, RWORK( INDE ), WORK( INDTAU ),
19327     $             WORK( INDWRK ), LLWORK, IINFO )
19328*
19329*     For eigenvalues only, call DSTERF.  For eigenvectors, first call
19330*     ZSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the
19331*     tridiagonal matrix, then call ZUNMTR to multiply it to the
19332*     Householder transformations represented as Householder vectors in
19333*     A.
19334*
19335      IF( .NOT.WANTZ ) THEN
19336         CALL DSTERF( N, W, RWORK( INDE ), INFO )
19337      ELSE
19338         CALL ZSTEDC( 'I', N, W, RWORK( INDE ), WORK( INDWRK ), N,
19339     $                WORK( INDWK2 ), LLWRK2, RWORK( INDRWK ), LLRWK,
19340     $                IWORK, LIWORK, INFO )
19341         CALL ZUNMTR( 'L', UPLO, 'N', N, N, A, LDA, WORK( INDTAU ),
19342     $                WORK( INDWRK ), N, WORK( INDWK2 ), LLWRK2, IINFO )
19343         CALL ZLACPY( 'A', N, N, WORK( INDWRK ), N, A, LDA )
19344      END IF
19345*
19346*     If matrix was scaled, then rescale eigenvalues appropriately.
19347*
19348      IF( ISCALE.EQ.1 ) THEN
19349         IF( INFO.EQ.0 ) THEN
19350            IMAX = N
19351         ELSE
19352            IMAX = INFO - 1
19353         END IF
19354         CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
19355      END IF
19356*
19357      WORK( 1 ) = LOPT
19358      RWORK( 1 ) = LROPT
19359      IWORK( 1 ) = LIOPT
19360*
19361      RETURN
19362*
19363*     End of ZHEEVD
19364*
19365      END
19366*> \brief \b ZHETD2 reduces a Hermitian matrix to real symmetric tridiagonal form by an unitary similarity transformation (unblocked algorithm).
19367*
19368*  =========== DOCUMENTATION ===========
19369*
19370* Online html documentation available at
19371*            http://www.netlib.org/lapack/explore-html/
19372*
19373*> \htmlonly
19374*> Download ZHETD2 + dependencies
19375*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zhetd2.f">
19376*> [TGZ]</a>
19377*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zhetd2.f">
19378*> [ZIP]</a>
19379*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zhetd2.f">
19380*> [TXT]</a>
19381*> \endhtmlonly
19382*
19383*  Definition:
19384*  ===========
19385*
19386*       SUBROUTINE ZHETD2( UPLO, N, A, LDA, D, E, TAU, INFO )
19387*
19388*       .. Scalar Arguments ..
19389*       CHARACTER          UPLO
19390*       INTEGER            INFO, LDA, N
19391*       ..
19392*       .. Array Arguments ..
19393*       DOUBLE PRECISION   D( * ), E( * )
19394*       COMPLEX*16         A( LDA, * ), TAU( * )
19395*       ..
19396*
19397*
19398*> \par Purpose:
19399*  =============
19400*>
19401*> \verbatim
19402*>
19403*> ZHETD2 reduces a complex Hermitian matrix A to real symmetric
19404*> tridiagonal form T by a unitary similarity transformation:
19405*> Q**H * A * Q = T.
19406*> \endverbatim
19407*
19408*  Arguments:
19409*  ==========
19410*
19411*> \param[in] UPLO
19412*> \verbatim
19413*>          UPLO is CHARACTER*1
19414*>          Specifies whether the upper or lower triangular part of the
19415*>          Hermitian matrix A is stored:
19416*>          = 'U':  Upper triangular
19417*>          = 'L':  Lower triangular
19418*> \endverbatim
19419*>
19420*> \param[in] N
19421*> \verbatim
19422*>          N is INTEGER
19423*>          The order of the matrix A.  N >= 0.
19424*> \endverbatim
19425*>
19426*> \param[in,out] A
19427*> \verbatim
19428*>          A is COMPLEX*16 array, dimension (LDA,N)
19429*>          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading
19430*>          n-by-n upper triangular part of A contains the upper
19431*>          triangular part of the matrix A, and the strictly lower
19432*>          triangular part of A is not referenced.  If UPLO = 'L', the
19433*>          leading n-by-n lower triangular part of A contains the lower
19434*>          triangular part of the matrix A, and the strictly upper
19435*>          triangular part of A is not referenced.
19436*>          On exit, if UPLO = 'U', the diagonal and first superdiagonal
19437*>          of A are overwritten by the corresponding elements of the
19438*>          tridiagonal matrix T, and the elements above the first
19439*>          superdiagonal, with the array TAU, represent the unitary
19440*>          matrix Q as a product of elementary reflectors; if UPLO
19441*>          = 'L', the diagonal and first subdiagonal of A are over-
19442*>          written by the corresponding elements of the tridiagonal
19443*>          matrix T, and the elements below the first subdiagonal, with
19444*>          the array TAU, represent the unitary matrix Q as a product
19445*>          of elementary reflectors. See Further Details.
19446*> \endverbatim
19447*>
19448*> \param[in] LDA
19449*> \verbatim
19450*>          LDA is INTEGER
19451*>          The leading dimension of the array A.  LDA >= max(1,N).
19452*> \endverbatim
19453*>
19454*> \param[out] D
19455*> \verbatim
19456*>          D is DOUBLE PRECISION array, dimension (N)
19457*>          The diagonal elements of the tridiagonal matrix T:
19458*>          D(i) = A(i,i).
19459*> \endverbatim
19460*>
19461*> \param[out] E
19462*> \verbatim
19463*>          E is DOUBLE PRECISION array, dimension (N-1)
19464*>          The off-diagonal elements of the tridiagonal matrix T:
19465*>          E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
19466*> \endverbatim
19467*>
19468*> \param[out] TAU
19469*> \verbatim
19470*>          TAU is COMPLEX*16 array, dimension (N-1)
19471*>          The scalar factors of the elementary reflectors (see Further
19472*>          Details).
19473*> \endverbatim
19474*>
19475*> \param[out] INFO
19476*> \verbatim
19477*>          INFO is INTEGER
19478*>          = 0:  successful exit
19479*>          < 0:  if INFO = -i, the i-th argument had an illegal value.
19480*> \endverbatim
19481*
19482*  Authors:
19483*  ========
19484*
19485*> \author Univ. of Tennessee
19486*> \author Univ. of California Berkeley
19487*> \author Univ. of Colorado Denver
19488*> \author NAG Ltd.
19489*
19490*> \date December 2016
19491*
19492*> \ingroup complex16HEcomputational
19493*
19494*> \par Further Details:
19495*  =====================
19496*>
19497*> \verbatim
19498*>
19499*>  If UPLO = 'U', the matrix Q is represented as a product of elementary
19500*>  reflectors
19501*>
19502*>     Q = H(n-1) . . . H(2) H(1).
19503*>
19504*>  Each H(i) has the form
19505*>
19506*>     H(i) = I - tau * v * v**H
19507*>
19508*>  where tau is a complex scalar, and v is a complex vector with
19509*>  v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
19510*>  A(1:i-1,i+1), and tau in TAU(i).
19511*>
19512*>  If UPLO = 'L', the matrix Q is represented as a product of elementary
19513*>  reflectors
19514*>
19515*>     Q = H(1) H(2) . . . H(n-1).
19516*>
19517*>  Each H(i) has the form
19518*>
19519*>     H(i) = I - tau * v * v**H
19520*>
19521*>  where tau is a complex scalar, and v is a complex vector with
19522*>  v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
19523*>  and tau in TAU(i).
19524*>
19525*>  The contents of A on exit are illustrated by the following examples
19526*>  with n = 5:
19527*>
19528*>  if UPLO = 'U':                       if UPLO = 'L':
19529*>
19530*>    (  d   e   v2  v3  v4 )              (  d                  )
19531*>    (      d   e   v3  v4 )              (  e   d              )
19532*>    (          d   e   v4 )              (  v1  e   d          )
19533*>    (              d   e  )              (  v1  v2  e   d      )
19534*>    (                  d  )              (  v1  v2  v3  e   d  )
19535*>
19536*>  where d and e denote diagonal and off-diagonal elements of T, and vi
19537*>  denotes an element of the vector defining H(i).
19538*> \endverbatim
19539*>
19540*  =====================================================================
19541      SUBROUTINE ZHETD2( UPLO, N, A, LDA, D, E, TAU, INFO )
19542*
19543*  -- LAPACK computational routine (version 3.7.0) --
19544*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
19545*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
19546*     December 2016
19547*
19548*     .. Scalar Arguments ..
19549      CHARACTER          UPLO
19550      INTEGER            INFO, LDA, N
19551*     ..
19552*     .. Array Arguments ..
19553      DOUBLE PRECISION   D( * ), E( * )
19554      COMPLEX*16         A( LDA, * ), TAU( * )
19555*     ..
19556*
19557*  =====================================================================
19558*
19559*     .. Parameters ..
19560      COMPLEX*16         ONE, ZERO, HALF
19561      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),
19562     $                   ZERO = ( 0.0D+0, 0.0D+0 ),
19563     $                   HALF = ( 0.5D+0, 0.0D+0 ) )
19564*     ..
19565*     .. Local Scalars ..
19566      LOGICAL            UPPER
19567      INTEGER            I
19568      COMPLEX*16         ALPHA, TAUI
19569*     ..
19570*     .. External Subroutines ..
19571      EXTERNAL           XERBLA, ZAXPY, ZHEMV, ZHER2, ZLARFG
19572*     ..
19573*     .. External Functions ..
19574      LOGICAL            LSAME
19575      COMPLEX*16         ZDOTC
19576      EXTERNAL           LSAME, ZDOTC
19577*     ..
19578*     .. Intrinsic Functions ..
19579      INTRINSIC          DBLE, MAX, MIN
19580*     ..
19581*     .. Executable Statements ..
19582*
19583*     Test the input parameters
19584*
19585      INFO = 0
19586      UPPER = LSAME( UPLO, 'U')
19587      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
19588         INFO = -1
19589      ELSE IF( N.LT.0 ) THEN
19590         INFO = -2
19591      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
19592         INFO = -4
19593      END IF
19594      IF( INFO.NE.0 ) THEN
19595         CALL XERBLA( 'ZHETD2', -INFO )
19596         RETURN
19597      END IF
19598*
19599*     Quick return if possible
19600*
19601      IF( N.LE.0 )
19602     $   RETURN
19603*
19604      IF( UPPER ) THEN
19605*
19606*        Reduce the upper triangle of A
19607*
19608         A( N, N ) = DBLE( A( N, N ) )
19609         DO 10 I = N - 1, 1, -1
19610*
19611*           Generate elementary reflector H(i) = I - tau * v * v**H
19612*           to annihilate A(1:i-1,i+1)
19613*
19614            ALPHA = A( I, I+1 )
19615            CALL ZLARFG( I, ALPHA, A( 1, I+1 ), 1, TAUI )
19616            E( I ) = ALPHA
19617*
19618            IF( TAUI.NE.ZERO ) THEN
19619*
19620*              Apply H(i) from both sides to A(1:i,1:i)
19621*
19622               A( I, I+1 ) = ONE
19623*
19624*              Compute  x := tau * A * v  storing x in TAU(1:i)
19625*
19626               CALL ZHEMV( UPLO, I, TAUI, A, LDA, A( 1, I+1 ), 1, ZERO,
19627     $                     TAU, 1 )
19628*
19629*              Compute  w := x - 1/2 * tau * (x**H * v) * v
19630*
19631               ALPHA = -HALF*TAUI*ZDOTC( I, TAU, 1, A( 1, I+1 ), 1 )
19632               CALL ZAXPY( I, ALPHA, A( 1, I+1 ), 1, TAU, 1 )
19633*
19634*              Apply the transformation as a rank-2 update:
19635*                 A := A - v * w**H - w * v**H
19636*
19637               CALL ZHER2( UPLO, I, -ONE, A( 1, I+1 ), 1, TAU, 1, A,
19638     $                     LDA )
19639*
19640            ELSE
19641               A( I, I ) = DBLE( A( I, I ) )
19642            END IF
19643            A( I, I+1 ) = E( I )
19644            D( I+1 ) = A( I+1, I+1 )
19645            TAU( I ) = TAUI
19646   10    CONTINUE
19647         D( 1 ) = A( 1, 1 )
19648      ELSE
19649*
19650*        Reduce the lower triangle of A
19651*
19652         A( 1, 1 ) = DBLE( A( 1, 1 ) )
19653         DO 20 I = 1, N - 1
19654*
19655*           Generate elementary reflector H(i) = I - tau * v * v**H
19656*           to annihilate A(i+2:n,i)
19657*
19658            ALPHA = A( I+1, I )
19659            CALL ZLARFG( N-I, ALPHA, A( MIN( I+2, N ), I ), 1, TAUI )
19660            E( I ) = ALPHA
19661*
19662            IF( TAUI.NE.ZERO ) THEN
19663*
19664*              Apply H(i) from both sides to A(i+1:n,i+1:n)
19665*
19666               A( I+1, I ) = ONE
19667*
19668*              Compute  x := tau * A * v  storing y in TAU(i:n-1)
19669*
19670               CALL ZHEMV( UPLO, N-I, TAUI, A( I+1, I+1 ), LDA,
19671     $                     A( I+1, I ), 1, ZERO, TAU( I ), 1 )
19672*
19673*              Compute  w := x - 1/2 * tau * (x**H * v) * v
19674*
19675               ALPHA = -HALF*TAUI*ZDOTC( N-I, TAU( I ), 1, A( I+1, I ),
19676     $                 1 )
19677               CALL ZAXPY( N-I, ALPHA, A( I+1, I ), 1, TAU( I ), 1 )
19678*
19679*              Apply the transformation as a rank-2 update:
19680*                 A := A - v * w**H - w * v**H
19681*
19682               CALL ZHER2( UPLO, N-I, -ONE, A( I+1, I ), 1, TAU( I ), 1,
19683     $                     A( I+1, I+1 ), LDA )
19684*
19685            ELSE
19686               A( I+1, I+1 ) = DBLE( A( I+1, I+1 ) )
19687            END IF
19688            A( I+1, I ) = E( I )
19689            D( I ) = A( I, I )
19690            TAU( I ) = TAUI
19691   20    CONTINUE
19692         D( N ) = A( N, N )
19693      END IF
19694*
19695      RETURN
19696*
19697*     End of ZHETD2
19698*
19699      END
19700*> \brief \b ZHETRD
19701*
19702*  =========== DOCUMENTATION ===========
19703*
19704* Online html documentation available at
19705*            http://www.netlib.org/lapack/explore-html/
19706*
19707*> \htmlonly
19708*> Download ZHETRD + dependencies
19709*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zhetrd.f">
19710*> [TGZ]</a>
19711*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zhetrd.f">
19712*> [ZIP]</a>
19713*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zhetrd.f">
19714*> [TXT]</a>
19715*> \endhtmlonly
19716*
19717*  Definition:
19718*  ===========
19719*
19720*       SUBROUTINE ZHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )
19721*
19722*       .. Scalar Arguments ..
19723*       CHARACTER          UPLO
19724*       INTEGER            INFO, LDA, LWORK, N
19725*       ..
19726*       .. Array Arguments ..
19727*       DOUBLE PRECISION   D( * ), E( * )
19728*       COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
19729*       ..
19730*
19731*
19732*> \par Purpose:
19733*  =============
19734*>
19735*> \verbatim
19736*>
19737*> ZHETRD reduces a complex Hermitian matrix A to real symmetric
19738*> tridiagonal form T by a unitary similarity transformation:
19739*> Q**H * A * Q = T.
19740*> \endverbatim
19741*
19742*  Arguments:
19743*  ==========
19744*
19745*> \param[in] UPLO
19746*> \verbatim
19747*>          UPLO is CHARACTER*1
19748*>          = 'U':  Upper triangle of A is stored;
19749*>          = 'L':  Lower triangle of A is stored.
19750*> \endverbatim
19751*>
19752*> \param[in] N
19753*> \verbatim
19754*>          N is INTEGER
19755*>          The order of the matrix A.  N >= 0.
19756*> \endverbatim
19757*>
19758*> \param[in,out] A
19759*> \verbatim
19760*>          A is COMPLEX*16 array, dimension (LDA,N)
19761*>          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading
19762*>          N-by-N upper triangular part of A contains the upper
19763*>          triangular part of the matrix A, and the strictly lower
19764*>          triangular part of A is not referenced.  If UPLO = 'L', the
19765*>          leading N-by-N lower triangular part of A contains the lower
19766*>          triangular part of the matrix A, and the strictly upper
19767*>          triangular part of A is not referenced.
19768*>          On exit, if UPLO = 'U', the diagonal and first superdiagonal
19769*>          of A are overwritten by the corresponding elements of the
19770*>          tridiagonal matrix T, and the elements above the first
19771*>          superdiagonal, with the array TAU, represent the unitary
19772*>          matrix Q as a product of elementary reflectors; if UPLO
19773*>          = 'L', the diagonal and first subdiagonal of A are over-
19774*>          written by the corresponding elements of the tridiagonal
19775*>          matrix T, and the elements below the first subdiagonal, with
19776*>          the array TAU, represent the unitary matrix Q as a product
19777*>          of elementary reflectors. See Further Details.
19778*> \endverbatim
19779*>
19780*> \param[in] LDA
19781*> \verbatim
19782*>          LDA is INTEGER
19783*>          The leading dimension of the array A.  LDA >= max(1,N).
19784*> \endverbatim
19785*>
19786*> \param[out] D
19787*> \verbatim
19788*>          D is DOUBLE PRECISION array, dimension (N)
19789*>          The diagonal elements of the tridiagonal matrix T:
19790*>          D(i) = A(i,i).
19791*> \endverbatim
19792*>
19793*> \param[out] E
19794*> \verbatim
19795*>          E is DOUBLE PRECISION array, dimension (N-1)
19796*>          The off-diagonal elements of the tridiagonal matrix T:
19797*>          E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
19798*> \endverbatim
19799*>
19800*> \param[out] TAU
19801*> \verbatim
19802*>          TAU is COMPLEX*16 array, dimension (N-1)
19803*>          The scalar factors of the elementary reflectors (see Further
19804*>          Details).
19805*> \endverbatim
19806*>
19807*> \param[out] WORK
19808*> \verbatim
19809*>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
19810*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
19811*> \endverbatim
19812*>
19813*> \param[in] LWORK
19814*> \verbatim
19815*>          LWORK is INTEGER
19816*>          The dimension of the array WORK.  LWORK >= 1.
19817*>          For optimum performance LWORK >= N*NB, where NB is the
19818*>          optimal blocksize.
19819*>
19820*>          If LWORK = -1, then a workspace query is assumed; the routine
19821*>          only calculates the optimal size of the WORK array, returns
19822*>          this value as the first entry of the WORK array, and no error
19823*>          message related to LWORK is issued by XERBLA.
19824*> \endverbatim
19825*>
19826*> \param[out] INFO
19827*> \verbatim
19828*>          INFO is INTEGER
19829*>          = 0:  successful exit
19830*>          < 0:  if INFO = -i, the i-th argument had an illegal value
19831*> \endverbatim
19832*
19833*  Authors:
19834*  ========
19835*
19836*> \author Univ. of Tennessee
19837*> \author Univ. of California Berkeley
19838*> \author Univ. of Colorado Denver
19839*> \author NAG Ltd.
19840*
19841*> \date December 2016
19842*
19843*> \ingroup complex16HEcomputational
19844*
19845*> \par Further Details:
19846*  =====================
19847*>
19848*> \verbatim
19849*>
19850*>  If UPLO = 'U', the matrix Q is represented as a product of elementary
19851*>  reflectors
19852*>
19853*>     Q = H(n-1) . . . H(2) H(1).
19854*>
19855*>  Each H(i) has the form
19856*>
19857*>     H(i) = I - tau * v * v**H
19858*>
19859*>  where tau is a complex scalar, and v is a complex vector with
19860*>  v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
19861*>  A(1:i-1,i+1), and tau in TAU(i).
19862*>
19863*>  If UPLO = 'L', the matrix Q is represented as a product of elementary
19864*>  reflectors
19865*>
19866*>     Q = H(1) H(2) . . . H(n-1).
19867*>
19868*>  Each H(i) has the form
19869*>
19870*>     H(i) = I - tau * v * v**H
19871*>
19872*>  where tau is a complex scalar, and v is a complex vector with
19873*>  v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
19874*>  and tau in TAU(i).
19875*>
19876*>  The contents of A on exit are illustrated by the following examples
19877*>  with n = 5:
19878*>
19879*>  if UPLO = 'U':                       if UPLO = 'L':
19880*>
19881*>    (  d   e   v2  v3  v4 )              (  d                  )
19882*>    (      d   e   v3  v4 )              (  e   d              )
19883*>    (          d   e   v4 )              (  v1  e   d          )
19884*>    (              d   e  )              (  v1  v2  e   d      )
19885*>    (                  d  )              (  v1  v2  v3  e   d  )
19886*>
19887*>  where d and e denote diagonal and off-diagonal elements of T, and vi
19888*>  denotes an element of the vector defining H(i).
19889*> \endverbatim
19890*>
19891*  =====================================================================
19892      SUBROUTINE ZHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )
19893*
19894*  -- LAPACK computational routine (version 3.7.0) --
19895*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
19896*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
19897*     December 2016
19898*
19899*     .. Scalar Arguments ..
19900      CHARACTER          UPLO
19901      INTEGER            INFO, LDA, LWORK, N
19902*     ..
19903*     .. Array Arguments ..
19904      DOUBLE PRECISION   D( * ), E( * )
19905      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
19906*     ..
19907*
19908*  =====================================================================
19909*
19910*     .. Parameters ..
19911      DOUBLE PRECISION   ONE
19912      PARAMETER          ( ONE = 1.0D+0 )
19913      COMPLEX*16         CONE
19914      PARAMETER          ( CONE = ( 1.0D+0, 0.0D+0 ) )
19915*     ..
19916*     .. Local Scalars ..
19917      LOGICAL            LQUERY, UPPER
19918      INTEGER            I, IINFO, IWS, J, KK, LDWORK, LWKOPT, NB,
19919     $                   NBMIN, NX
19920*     ..
19921*     .. External Subroutines ..
19922      EXTERNAL           XERBLA, ZHER2K, ZHETD2, ZLATRD
19923*     ..
19924*     .. Intrinsic Functions ..
19925      INTRINSIC          MAX
19926*     ..
19927*     .. External Functions ..
19928      LOGICAL            LSAME
19929      INTEGER            ILAENV
19930      EXTERNAL           LSAME, ILAENV
19931*     ..
19932*     .. Executable Statements ..
19933*
19934*     Test the input parameters
19935*
19936      INFO = 0
19937      UPPER = LSAME( UPLO, 'U' )
19938      LQUERY = ( LWORK.EQ.-1 )
19939      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
19940         INFO = -1
19941      ELSE IF( N.LT.0 ) THEN
19942         INFO = -2
19943      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
19944         INFO = -4
19945      ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
19946         INFO = -9
19947      END IF
19948*
19949      IF( INFO.EQ.0 ) THEN
19950*
19951*        Determine the block size.
19952*
19953         NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 )
19954         LWKOPT = N*NB
19955         WORK( 1 ) = LWKOPT
19956      END IF
19957*
19958      IF( INFO.NE.0 ) THEN
19959         CALL XERBLA( 'ZHETRD', -INFO )
19960         RETURN
19961      ELSE IF( LQUERY ) THEN
19962         RETURN
19963      END IF
19964*
19965*     Quick return if possible
19966*
19967      IF( N.EQ.0 ) THEN
19968         WORK( 1 ) = 1
19969         RETURN
19970      END IF
19971*
19972      NX = N
19973      IWS = 1
19974      IF( NB.GT.1 .AND. NB.LT.N ) THEN
19975*
19976*        Determine when to cross over from blocked to unblocked code
19977*        (last block is always handled by unblocked code).
19978*
19979         NX = MAX( NB, ILAENV( 3, 'ZHETRD', UPLO, N, -1, -1, -1 ) )
19980         IF( NX.LT.N ) THEN
19981*
19982*           Determine if workspace is large enough for blocked code.
19983*
19984            LDWORK = N
19985            IWS = LDWORK*NB
19986            IF( LWORK.LT.IWS ) THEN
19987*
19988*              Not enough workspace to use optimal NB:  determine the
19989*              minimum value of NB, and reduce NB or force use of
19990*              unblocked code by setting NX = N.
19991*
19992               NB = MAX( LWORK / LDWORK, 1 )
19993               NBMIN = ILAENV( 2, 'ZHETRD', UPLO, N, -1, -1, -1 )
19994               IF( NB.LT.NBMIN )
19995     $            NX = N
19996            END IF
19997         ELSE
19998            NX = N
19999         END IF
20000      ELSE
20001         NB = 1
20002      END IF
20003*
20004      IF( UPPER ) THEN
20005*
20006*        Reduce the upper triangle of A.
20007*        Columns 1:kk are handled by the unblocked method.
20008*
20009         KK = N - ( ( N-NX+NB-1 ) / NB )*NB
20010         DO 20 I = N - NB + 1, KK + 1, -NB
20011*
20012*           Reduce columns i:i+nb-1 to tridiagonal form and form the
20013*           matrix W which is needed to update the unreduced part of
20014*           the matrix
20015*
20016            CALL ZLATRD( UPLO, I+NB-1, NB, A, LDA, E, TAU, WORK,
20017     $                   LDWORK )
20018*
20019*           Update the unreduced submatrix A(1:i-1,1:i-1), using an
20020*           update of the form:  A := A - V*W**H - W*V**H
20021*
20022            CALL ZHER2K( UPLO, 'No transpose', I-1, NB, -CONE,
20023     $                   A( 1, I ), LDA, WORK, LDWORK, ONE, A, LDA )
20024*
20025*           Copy superdiagonal elements back into A, and diagonal
20026*           elements into D
20027*
20028            DO 10 J = I, I + NB - 1
20029               A( J-1, J ) = E( J-1 )
20030               D( J ) = A( J, J )
20031   10       CONTINUE
20032   20    CONTINUE
20033*
20034*        Use unblocked code to reduce the last or only block
20035*
20036         CALL ZHETD2( UPLO, KK, A, LDA, D, E, TAU, IINFO )
20037      ELSE
20038*
20039*        Reduce the lower triangle of A
20040*
20041         DO 40 I = 1, N - NX, NB
20042*
20043*           Reduce columns i:i+nb-1 to tridiagonal form and form the
20044*           matrix W which is needed to update the unreduced part of
20045*           the matrix
20046*
20047            CALL ZLATRD( UPLO, N-I+1, NB, A( I, I ), LDA, E( I ),
20048     $                   TAU( I ), WORK, LDWORK )
20049*
20050*           Update the unreduced submatrix A(i+nb:n,i+nb:n), using
20051*           an update of the form:  A := A - V*W**H - W*V**H
20052*
20053            CALL ZHER2K( UPLO, 'No transpose', N-I-NB+1, NB, -CONE,
20054     $                   A( I+NB, I ), LDA, WORK( NB+1 ), LDWORK, ONE,
20055     $                   A( I+NB, I+NB ), LDA )
20056*
20057*           Copy subdiagonal elements back into A, and diagonal
20058*           elements into D
20059*
20060            DO 30 J = I, I + NB - 1
20061               A( J+1, J ) = E( J )
20062               D( J ) = A( J, J )
20063   30       CONTINUE
20064   40    CONTINUE
20065*
20066*        Use unblocked code to reduce the last or only block
20067*
20068         CALL ZHETD2( UPLO, N-I+1, A( I, I ), LDA, D( I ), E( I ),
20069     $                TAU( I ), IINFO )
20070      END IF
20071*
20072      WORK( 1 ) = LWKOPT
20073      RETURN
20074*
20075*     End of ZHETRD
20076*
20077      END
20078*> \brief \b ZHGEQZ
20079*
20080*  =========== DOCUMENTATION ===========
20081*
20082* Online html documentation available at
20083*            http://www.netlib.org/lapack/explore-html/
20084*
20085*> \htmlonly
20086*> Download ZHGEQZ + dependencies
20087*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zhgeqz.f">
20088*> [TGZ]</a>
20089*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zhgeqz.f">
20090*> [ZIP]</a>
20091*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zhgeqz.f">
20092*> [TXT]</a>
20093*> \endhtmlonly
20094*
20095*  Definition:
20096*  ===========
20097*
20098*       SUBROUTINE ZHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT,
20099*                          ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK,
20100*                          RWORK, INFO )
20101*
20102*       .. Scalar Arguments ..
20103*       CHARACTER          COMPQ, COMPZ, JOB
20104*       INTEGER            IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N
20105*       ..
20106*       .. Array Arguments ..
20107*       DOUBLE PRECISION   RWORK( * )
20108*       COMPLEX*16         ALPHA( * ), BETA( * ), H( LDH, * ),
20109*      $                   Q( LDQ, * ), T( LDT, * ), WORK( * ),
20110*      $                   Z( LDZ, * )
20111*       ..
20112*
20113*
20114*> \par Purpose:
20115*  =============
20116*>
20117*> \verbatim
20118*>
20119*> ZHGEQZ computes the eigenvalues of a complex matrix pair (H,T),
20120*> where H is an upper Hessenberg matrix and T is upper triangular,
20121*> using the single-shift QZ method.
20122*> Matrix pairs of this type are produced by the reduction to
20123*> generalized upper Hessenberg form of a complex matrix pair (A,B):
20124*>
20125*>    A = Q1*H*Z1**H,  B = Q1*T*Z1**H,
20126*>
20127*> as computed by ZGGHRD.
20128*>
20129*> If JOB='S', then the Hessenberg-triangular pair (H,T) is
20130*> also reduced to generalized Schur form,
20131*>
20132*>    H = Q*S*Z**H,  T = Q*P*Z**H,
20133*>
20134*> where Q and Z are unitary matrices and S and P are upper triangular.
20135*>
20136*> Optionally, the unitary matrix Q from the generalized Schur
20137*> factorization may be postmultiplied into an input matrix Q1, and the
20138*> unitary matrix Z may be postmultiplied into an input matrix Z1.
20139*> If Q1 and Z1 are the unitary matrices from ZGGHRD that reduced
20140*> the matrix pair (A,B) to generalized Hessenberg form, then the output
20141*> matrices Q1*Q and Z1*Z are the unitary factors from the generalized
20142*> Schur factorization of (A,B):
20143*>
20144*>    A = (Q1*Q)*S*(Z1*Z)**H,  B = (Q1*Q)*P*(Z1*Z)**H.
20145*>
20146*> To avoid overflow, eigenvalues of the matrix pair (H,T)
20147*> (equivalently, of (A,B)) are computed as a pair of complex values
20148*> (alpha,beta).  If beta is nonzero, lambda = alpha / beta is an
20149*> eigenvalue of the generalized nonsymmetric eigenvalue problem (GNEP)
20150*>    A*x = lambda*B*x
20151*> and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the
20152*> alternate form of the GNEP
20153*>    mu*A*y = B*y.
20154*> The values of alpha and beta for the i-th eigenvalue can be read
20155*> directly from the generalized Schur form:  alpha = S(i,i),
20156*> beta = P(i,i).
20157*>
20158*> Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix
20159*>      Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973),
20160*>      pp. 241--256.
20161*> \endverbatim
20162*
20163*  Arguments:
20164*  ==========
20165*
20166*> \param[in] JOB
20167*> \verbatim
20168*>          JOB is CHARACTER*1
20169*>          = 'E': Compute eigenvalues only;
20170*>          = 'S': Computer eigenvalues and the Schur form.
20171*> \endverbatim
20172*>
20173*> \param[in] COMPQ
20174*> \verbatim
20175*>          COMPQ is CHARACTER*1
20176*>          = 'N': Left Schur vectors (Q) are not computed;
20177*>          = 'I': Q is initialized to the unit matrix and the matrix Q
20178*>                 of left Schur vectors of (H,T) is returned;
20179*>          = 'V': Q must contain a unitary matrix Q1 on entry and
20180*>                 the product Q1*Q is returned.
20181*> \endverbatim
20182*>
20183*> \param[in] COMPZ
20184*> \verbatim
20185*>          COMPZ is CHARACTER*1
20186*>          = 'N': Right Schur vectors (Z) are not computed;
20187*>          = 'I': Q is initialized to the unit matrix and the matrix Z
20188*>                 of right Schur vectors of (H,T) is returned;
20189*>          = 'V': Z must contain a unitary matrix Z1 on entry and
20190*>                 the product Z1*Z is returned.
20191*> \endverbatim
20192*>
20193*> \param[in] N
20194*> \verbatim
20195*>          N is INTEGER
20196*>          The order of the matrices H, T, Q, and Z.  N >= 0.
20197*> \endverbatim
20198*>
20199*> \param[in] ILO
20200*> \verbatim
20201*>          ILO is INTEGER
20202*> \endverbatim
20203*>
20204*> \param[in] IHI
20205*> \verbatim
20206*>          IHI is INTEGER
20207*>          ILO and IHI mark the rows and columns of H which are in
20208*>          Hessenberg form.  It is assumed that A is already upper
20209*>          triangular in rows and columns 1:ILO-1 and IHI+1:N.
20210*>          If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0.
20211*> \endverbatim
20212*>
20213*> \param[in,out] H
20214*> \verbatim
20215*>          H is COMPLEX*16 array, dimension (LDH, N)
20216*>          On entry, the N-by-N upper Hessenberg matrix H.
20217*>          On exit, if JOB = 'S', H contains the upper triangular
20218*>          matrix S from the generalized Schur factorization.
20219*>          If JOB = 'E', the diagonal of H matches that of S, but
20220*>          the rest of H is unspecified.
20221*> \endverbatim
20222*>
20223*> \param[in] LDH
20224*> \verbatim
20225*>          LDH is INTEGER
20226*>          The leading dimension of the array H.  LDH >= max( 1, N ).
20227*> \endverbatim
20228*>
20229*> \param[in,out] T
20230*> \verbatim
20231*>          T is COMPLEX*16 array, dimension (LDT, N)
20232*>          On entry, the N-by-N upper triangular matrix T.
20233*>          On exit, if JOB = 'S', T contains the upper triangular
20234*>          matrix P from the generalized Schur factorization.
20235*>          If JOB = 'E', the diagonal of T matches that of P, but
20236*>          the rest of T is unspecified.
20237*> \endverbatim
20238*>
20239*> \param[in] LDT
20240*> \verbatim
20241*>          LDT is INTEGER
20242*>          The leading dimension of the array T.  LDT >= max( 1, N ).
20243*> \endverbatim
20244*>
20245*> \param[out] ALPHA
20246*> \verbatim
20247*>          ALPHA is COMPLEX*16 array, dimension (N)
20248*>          The complex scalars alpha that define the eigenvalues of
20249*>          GNEP.  ALPHA(i) = S(i,i) in the generalized Schur
20250*>          factorization.
20251*> \endverbatim
20252*>
20253*> \param[out] BETA
20254*> \verbatim
20255*>          BETA is COMPLEX*16 array, dimension (N)
20256*>          The real non-negative scalars beta that define the
20257*>          eigenvalues of GNEP.  BETA(i) = P(i,i) in the generalized
20258*>          Schur factorization.
20259*>
20260*>          Together, the quantities alpha = ALPHA(j) and beta = BETA(j)
20261*>          represent the j-th eigenvalue of the matrix pair (A,B), in
20262*>          one of the forms lambda = alpha/beta or mu = beta/alpha.
20263*>          Since either lambda or mu may overflow, they should not,
20264*>          in general, be computed.
20265*> \endverbatim
20266*>
20267*> \param[in,out] Q
20268*> \verbatim
20269*>          Q is COMPLEX*16 array, dimension (LDQ, N)
20270*>          On entry, if COMPQ = 'V', the unitary matrix Q1 used in the
20271*>          reduction of (A,B) to generalized Hessenberg form.
20272*>          On exit, if COMPQ = 'I', the unitary matrix of left Schur
20273*>          vectors of (H,T), and if COMPQ = 'V', the unitary matrix of
20274*>          left Schur vectors of (A,B).
20275*>          Not referenced if COMPQ = 'N'.
20276*> \endverbatim
20277*>
20278*> \param[in] LDQ
20279*> \verbatim
20280*>          LDQ is INTEGER
20281*>          The leading dimension of the array Q.  LDQ >= 1.
20282*>          If COMPQ='V' or 'I', then LDQ >= N.
20283*> \endverbatim
20284*>
20285*> \param[in,out] Z
20286*> \verbatim
20287*>          Z is COMPLEX*16 array, dimension (LDZ, N)
20288*>          On entry, if COMPZ = 'V', the unitary matrix Z1 used in the
20289*>          reduction of (A,B) to generalized Hessenberg form.
20290*>          On exit, if COMPZ = 'I', the unitary matrix of right Schur
20291*>          vectors of (H,T), and if COMPZ = 'V', the unitary matrix of
20292*>          right Schur vectors of (A,B).
20293*>          Not referenced if COMPZ = 'N'.
20294*> \endverbatim
20295*>
20296*> \param[in] LDZ
20297*> \verbatim
20298*>          LDZ is INTEGER
20299*>          The leading dimension of the array Z.  LDZ >= 1.
20300*>          If COMPZ='V' or 'I', then LDZ >= N.
20301*> \endverbatim
20302*>
20303*> \param[out] WORK
20304*> \verbatim
20305*>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
20306*>          On exit, if INFO >= 0, WORK(1) returns the optimal LWORK.
20307*> \endverbatim
20308*>
20309*> \param[in] LWORK
20310*> \verbatim
20311*>          LWORK is INTEGER
20312*>          The dimension of the array WORK.  LWORK >= max(1,N).
20313*>
20314*>          If LWORK = -1, then a workspace query is assumed; the routine
20315*>          only calculates the optimal size of the WORK array, returns
20316*>          this value as the first entry of the WORK array, and no error
20317*>          message related to LWORK is issued by XERBLA.
20318*> \endverbatim
20319*>
20320*> \param[out] RWORK
20321*> \verbatim
20322*>          RWORK is DOUBLE PRECISION array, dimension (N)
20323*> \endverbatim
20324*>
20325*> \param[out] INFO
20326*> \verbatim
20327*>          INFO is INTEGER
20328*>          = 0: successful exit
20329*>          < 0: if INFO = -i, the i-th argument had an illegal value
20330*>          = 1,...,N: the QZ iteration did not converge.  (H,T) is not
20331*>                     in Schur form, but ALPHA(i) and BETA(i),
20332*>                     i=INFO+1,...,N should be correct.
20333*>          = N+1,...,2*N: the shift calculation failed.  (H,T) is not
20334*>                     in Schur form, but ALPHA(i) and BETA(i),
20335*>                     i=INFO-N+1,...,N should be correct.
20336*> \endverbatim
20337*
20338*  Authors:
20339*  ========
20340*
20341*> \author Univ. of Tennessee
20342*> \author Univ. of California Berkeley
20343*> \author Univ. of Colorado Denver
20344*> \author NAG Ltd.
20345*
20346*> \date April 2012
20347*
20348*> \ingroup complex16GEcomputational
20349*
20350*> \par Further Details:
20351*  =====================
20352*>
20353*> \verbatim
20354*>
20355*>  We assume that complex ABS works as long as its value is less than
20356*>  overflow.
20357*> \endverbatim
20358*>
20359*  =====================================================================
20360      SUBROUTINE ZHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT,
20361     $                   ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK,
20362     $                   RWORK, INFO )
20363*
20364*  -- LAPACK computational routine (version 3.7.0) --
20365*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
20366*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
20367*     April 2012
20368*
20369*     .. Scalar Arguments ..
20370      CHARACTER          COMPQ, COMPZ, JOB
20371      INTEGER            IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N
20372*     ..
20373*     .. Array Arguments ..
20374      DOUBLE PRECISION   RWORK( * )
20375      COMPLEX*16         ALPHA( * ), BETA( * ), H( LDH, * ),
20376     $                   Q( LDQ, * ), T( LDT, * ), WORK( * ),
20377     $                   Z( LDZ, * )
20378*     ..
20379*
20380*  =====================================================================
20381*
20382*     .. Parameters ..
20383      COMPLEX*16         CZERO, CONE
20384      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ),
20385     $                   CONE = ( 1.0D+0, 0.0D+0 ) )
20386      DOUBLE PRECISION   ZERO, ONE
20387      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
20388      DOUBLE PRECISION   HALF
20389      PARAMETER          ( HALF = 0.5D+0 )
20390*     ..
20391*     .. Local Scalars ..
20392      LOGICAL            ILAZR2, ILAZRO, ILQ, ILSCHR, ILZ, LQUERY
20393      INTEGER            ICOMPQ, ICOMPZ, IFIRST, IFRSTM, IITER, ILAST,
20394     $                   ILASTM, IN, ISCHUR, ISTART, J, JC, JCH, JITER,
20395     $                   JR, MAXIT
20396      DOUBLE PRECISION   ABSB, ANORM, ASCALE, ATOL, BNORM, BSCALE, BTOL,
20397     $                   C, SAFMIN, TEMP, TEMP2, TEMPR, ULP
20398      COMPLEX*16         ABI22, AD11, AD12, AD21, AD22, CTEMP, CTEMP2,
20399     $                   CTEMP3, ESHIFT, RTDISC, S, SHIFT, SIGNBC, T1,
20400     $                   U12, X
20401*     ..
20402*     .. External Functions ..
20403      LOGICAL            LSAME
20404      DOUBLE PRECISION   DLAMCH, ZLANHS
20405      EXTERNAL           LSAME, DLAMCH, ZLANHS
20406*     ..
20407*     .. External Subroutines ..
20408      EXTERNAL           XERBLA, ZLARTG, ZLASET, ZROT, ZSCAL
20409*     ..
20410*     .. Intrinsic Functions ..
20411      INTRINSIC          ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN,
20412     $                   SQRT
20413*     ..
20414*     .. Statement Functions ..
20415      DOUBLE PRECISION   ABS1
20416*     ..
20417*     .. Statement Function definitions ..
20418      ABS1( X ) = ABS( DBLE( X ) ) + ABS( DIMAG( X ) )
20419*     ..
20420*     .. Executable Statements ..
20421*
20422*     Decode JOB, COMPQ, COMPZ
20423*
20424      IF( LSAME( JOB, 'E' ) ) THEN
20425         ILSCHR = .FALSE.
20426         ISCHUR = 1
20427      ELSE IF( LSAME( JOB, 'S' ) ) THEN
20428         ILSCHR = .TRUE.
20429         ISCHUR = 2
20430      ELSE
20431         ISCHUR = 0
20432      END IF
20433*
20434      IF( LSAME( COMPQ, 'N' ) ) THEN
20435         ILQ = .FALSE.
20436         ICOMPQ = 1
20437      ELSE IF( LSAME( COMPQ, 'V' ) ) THEN
20438         ILQ = .TRUE.
20439         ICOMPQ = 2
20440      ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
20441         ILQ = .TRUE.
20442         ICOMPQ = 3
20443      ELSE
20444         ICOMPQ = 0
20445      END IF
20446*
20447      IF( LSAME( COMPZ, 'N' ) ) THEN
20448         ILZ = .FALSE.
20449         ICOMPZ = 1
20450      ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
20451         ILZ = .TRUE.
20452         ICOMPZ = 2
20453      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
20454         ILZ = .TRUE.
20455         ICOMPZ = 3
20456      ELSE
20457         ICOMPZ = 0
20458      END IF
20459*
20460*     Check Argument Values
20461*
20462      INFO = 0
20463      WORK( 1 ) = MAX( 1, N )
20464      LQUERY = ( LWORK.EQ.-1 )
20465      IF( ISCHUR.EQ.0 ) THEN
20466         INFO = -1
20467      ELSE IF( ICOMPQ.EQ.0 ) THEN
20468         INFO = -2
20469      ELSE IF( ICOMPZ.EQ.0 ) THEN
20470         INFO = -3
20471      ELSE IF( N.LT.0 ) THEN
20472         INFO = -4
20473      ELSE IF( ILO.LT.1 ) THEN
20474         INFO = -5
20475      ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN
20476         INFO = -6
20477      ELSE IF( LDH.LT.N ) THEN
20478         INFO = -8
20479      ELSE IF( LDT.LT.N ) THEN
20480         INFO = -10
20481      ELSE IF( LDQ.LT.1 .OR. ( ILQ .AND. LDQ.LT.N ) ) THEN
20482         INFO = -14
20483      ELSE IF( LDZ.LT.1 .OR. ( ILZ .AND. LDZ.LT.N ) ) THEN
20484         INFO = -16
20485      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
20486         INFO = -18
20487      END IF
20488      IF( INFO.NE.0 ) THEN
20489         CALL XERBLA( 'ZHGEQZ', -INFO )
20490         RETURN
20491      ELSE IF( LQUERY ) THEN
20492         RETURN
20493      END IF
20494*
20495*     Quick return if possible
20496*
20497*     WORK( 1 ) = CMPLX( 1 )
20498      IF( N.LE.0 ) THEN
20499         WORK( 1 ) = DCMPLX( 1 )
20500         RETURN
20501      END IF
20502*
20503*     Initialize Q and Z
20504*
20505      IF( ICOMPQ.EQ.3 )
20506     $   CALL ZLASET( 'Full', N, N, CZERO, CONE, Q, LDQ )
20507      IF( ICOMPZ.EQ.3 )
20508     $   CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDZ )
20509*
20510*     Machine Constants
20511*
20512      IN = IHI + 1 - ILO
20513      SAFMIN = DLAMCH( 'S' )
20514      ULP = DLAMCH( 'E' )*DLAMCH( 'B' )
20515      ANORM = ZLANHS( 'F', IN, H( ILO, ILO ), LDH, RWORK )
20516      BNORM = ZLANHS( 'F', IN, T( ILO, ILO ), LDT, RWORK )
20517      ATOL = MAX( SAFMIN, ULP*ANORM )
20518      BTOL = MAX( SAFMIN, ULP*BNORM )
20519      ASCALE = ONE / MAX( SAFMIN, ANORM )
20520      BSCALE = ONE / MAX( SAFMIN, BNORM )
20521*
20522*
20523*     Set Eigenvalues IHI+1:N
20524*
20525      DO 10 J = IHI + 1, N
20526         ABSB = ABS( T( J, J ) )
20527         IF( ABSB.GT.SAFMIN ) THEN
20528            SIGNBC = DCONJG( T( J, J ) / ABSB )
20529            T( J, J ) = ABSB
20530            IF( ILSCHR ) THEN
20531               CALL ZSCAL( J-1, SIGNBC, T( 1, J ), 1 )
20532               CALL ZSCAL( J, SIGNBC, H( 1, J ), 1 )
20533            ELSE
20534               CALL ZSCAL( 1, SIGNBC, H( J, J ), 1 )
20535            END IF
20536            IF( ILZ )
20537     $         CALL ZSCAL( N, SIGNBC, Z( 1, J ), 1 )
20538         ELSE
20539            T( J, J ) = CZERO
20540         END IF
20541         ALPHA( J ) = H( J, J )
20542         BETA( J ) = T( J, J )
20543   10 CONTINUE
20544*
20545*     If IHI < ILO, skip QZ steps
20546*
20547      IF( IHI.LT.ILO )
20548     $   GO TO 190
20549*
20550*     MAIN QZ ITERATION LOOP
20551*
20552*     Initialize dynamic indices
20553*
20554*     Eigenvalues ILAST+1:N have been found.
20555*        Column operations modify rows IFRSTM:whatever
20556*        Row operations modify columns whatever:ILASTM
20557*
20558*     If only eigenvalues are being computed, then
20559*        IFRSTM is the row of the last splitting row above row ILAST;
20560*        this is always at least ILO.
20561*     IITER counts iterations since the last eigenvalue was found,
20562*        to tell when to use an extraordinary shift.
20563*     MAXIT is the maximum number of QZ sweeps allowed.
20564*
20565      ILAST = IHI
20566      IF( ILSCHR ) THEN
20567         IFRSTM = 1
20568         ILASTM = N
20569      ELSE
20570         IFRSTM = ILO
20571         ILASTM = IHI
20572      END IF
20573      IITER = 0
20574      ESHIFT = CZERO
20575      MAXIT = 30*( IHI-ILO+1 )
20576*
20577      DO 170 JITER = 1, MAXIT
20578*
20579*        Check for too many iterations.
20580*
20581         IF( JITER.GT.MAXIT )
20582     $      GO TO 180
20583*
20584*        Split the matrix if possible.
20585*
20586*        Two tests:
20587*           1: H(j,j-1)=0  or  j=ILO
20588*           2: T(j,j)=0
20589*
20590*        Special case: j=ILAST
20591*
20592         IF( ILAST.EQ.ILO ) THEN
20593            GO TO 60
20594         ELSE
20595            IF( ABS1( H( ILAST, ILAST-1 ) ).LE.ATOL ) THEN
20596               H( ILAST, ILAST-1 ) = CZERO
20597               GO TO 60
20598            END IF
20599         END IF
20600*
20601         IF( ABS( T( ILAST, ILAST ) ).LE.BTOL ) THEN
20602            T( ILAST, ILAST ) = CZERO
20603            GO TO 50
20604         END IF
20605*
20606*        General case: j<ILAST
20607*
20608         DO 40 J = ILAST - 1, ILO, -1
20609*
20610*           Test 1: for H(j,j-1)=0 or j=ILO
20611*
20612            IF( J.EQ.ILO ) THEN
20613               ILAZRO = .TRUE.
20614            ELSE
20615               IF( ABS1( H( J, J-1 ) ).LE.ATOL ) THEN
20616                  H( J, J-1 ) = CZERO
20617                  ILAZRO = .TRUE.
20618               ELSE
20619                  ILAZRO = .FALSE.
20620               END IF
20621            END IF
20622*
20623*           Test 2: for T(j,j)=0
20624*
20625            IF( ABS( T( J, J ) ).LT.BTOL ) THEN
20626               T( J, J ) = CZERO
20627*
20628*              Test 1a: Check for 2 consecutive small subdiagonals in A
20629*
20630               ILAZR2 = .FALSE.
20631               IF( .NOT.ILAZRO ) THEN
20632                  IF( ABS1( H( J, J-1 ) )*( ASCALE*ABS1( H( J+1,
20633     $                J ) ) ).LE.ABS1( H( J, J ) )*( ASCALE*ATOL ) )
20634     $                ILAZR2 = .TRUE.
20635               END IF
20636*
20637*              If both tests pass (1 & 2), i.e., the leading diagonal
20638*              element of B in the block is zero, split a 1x1 block off
20639*              at the top. (I.e., at the J-th row/column) The leading
20640*              diagonal element of the remainder can also be zero, so
20641*              this may have to be done repeatedly.
20642*
20643               IF( ILAZRO .OR. ILAZR2 ) THEN
20644                  DO 20 JCH = J, ILAST - 1
20645                     CTEMP = H( JCH, JCH )
20646                     CALL ZLARTG( CTEMP, H( JCH+1, JCH ), C, S,
20647     $                            H( JCH, JCH ) )
20648                     H( JCH+1, JCH ) = CZERO
20649                     CALL ZROT( ILASTM-JCH, H( JCH, JCH+1 ), LDH,
20650     $                          H( JCH+1, JCH+1 ), LDH, C, S )
20651                     CALL ZROT( ILASTM-JCH, T( JCH, JCH+1 ), LDT,
20652     $                          T( JCH+1, JCH+1 ), LDT, C, S )
20653                     IF( ILQ )
20654     $                  CALL ZROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1,
20655     $                             C, DCONJG( S ) )
20656                     IF( ILAZR2 )
20657     $                  H( JCH, JCH-1 ) = H( JCH, JCH-1 )*C
20658                     ILAZR2 = .FALSE.
20659                     IF( ABS1( T( JCH+1, JCH+1 ) ).GE.BTOL ) THEN
20660                        IF( JCH+1.GE.ILAST ) THEN
20661                           GO TO 60
20662                        ELSE
20663                           IFIRST = JCH + 1
20664                           GO TO 70
20665                        END IF
20666                     END IF
20667                     T( JCH+1, JCH+1 ) = CZERO
20668   20             CONTINUE
20669                  GO TO 50
20670               ELSE
20671*
20672*                 Only test 2 passed -- chase the zero to T(ILAST,ILAST)
20673*                 Then process as in the case T(ILAST,ILAST)=0
20674*
20675                  DO 30 JCH = J, ILAST - 1
20676                     CTEMP = T( JCH, JCH+1 )
20677                     CALL ZLARTG( CTEMP, T( JCH+1, JCH+1 ), C, S,
20678     $                            T( JCH, JCH+1 ) )
20679                     T( JCH+1, JCH+1 ) = CZERO
20680                     IF( JCH.LT.ILASTM-1 )
20681     $                  CALL ZROT( ILASTM-JCH-1, T( JCH, JCH+2 ), LDT,
20682     $                             T( JCH+1, JCH+2 ), LDT, C, S )
20683                     CALL ZROT( ILASTM-JCH+2, H( JCH, JCH-1 ), LDH,
20684     $                          H( JCH+1, JCH-1 ), LDH, C, S )
20685                     IF( ILQ )
20686     $                  CALL ZROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1,
20687     $                             C, DCONJG( S ) )
20688                     CTEMP = H( JCH+1, JCH )
20689                     CALL ZLARTG( CTEMP, H( JCH+1, JCH-1 ), C, S,
20690     $                            H( JCH+1, JCH ) )
20691                     H( JCH+1, JCH-1 ) = CZERO
20692                     CALL ZROT( JCH+1-IFRSTM, H( IFRSTM, JCH ), 1,
20693     $                          H( IFRSTM, JCH-1 ), 1, C, S )
20694                     CALL ZROT( JCH-IFRSTM, T( IFRSTM, JCH ), 1,
20695     $                          T( IFRSTM, JCH-1 ), 1, C, S )
20696                     IF( ILZ )
20697     $                  CALL ZROT( N, Z( 1, JCH ), 1, Z( 1, JCH-1 ), 1,
20698     $                             C, S )
20699   30             CONTINUE
20700                  GO TO 50
20701               END IF
20702            ELSE IF( ILAZRO ) THEN
20703*
20704*              Only test 1 passed -- work on J:ILAST
20705*
20706               IFIRST = J
20707               GO TO 70
20708            END IF
20709*
20710*           Neither test passed -- try next J
20711*
20712   40    CONTINUE
20713*
20714*        (Drop-through is "impossible")
20715*
20716         INFO = 2*N + 1
20717         GO TO 210
20718*
20719*        T(ILAST,ILAST)=0 -- clear H(ILAST,ILAST-1) to split off a
20720*        1x1 block.
20721*
20722   50    CONTINUE
20723         CTEMP = H( ILAST, ILAST )
20724         CALL ZLARTG( CTEMP, H( ILAST, ILAST-1 ), C, S,
20725     $                H( ILAST, ILAST ) )
20726         H( ILAST, ILAST-1 ) = CZERO
20727         CALL ZROT( ILAST-IFRSTM, H( IFRSTM, ILAST ), 1,
20728     $              H( IFRSTM, ILAST-1 ), 1, C, S )
20729         CALL ZROT( ILAST-IFRSTM, T( IFRSTM, ILAST ), 1,
20730     $              T( IFRSTM, ILAST-1 ), 1, C, S )
20731         IF( ILZ )
20732     $      CALL ZROT( N, Z( 1, ILAST ), 1, Z( 1, ILAST-1 ), 1, C, S )
20733*
20734*        H(ILAST,ILAST-1)=0 -- Standardize B, set ALPHA and BETA
20735*
20736   60    CONTINUE
20737         ABSB = ABS( T( ILAST, ILAST ) )
20738         IF( ABSB.GT.SAFMIN ) THEN
20739            SIGNBC = DCONJG( T( ILAST, ILAST ) / ABSB )
20740            T( ILAST, ILAST ) = ABSB
20741            IF( ILSCHR ) THEN
20742               CALL ZSCAL( ILAST-IFRSTM, SIGNBC, T( IFRSTM, ILAST ), 1 )
20743               CALL ZSCAL( ILAST+1-IFRSTM, SIGNBC, H( IFRSTM, ILAST ),
20744     $                     1 )
20745            ELSE
20746               CALL ZSCAL( 1, SIGNBC, H( ILAST, ILAST ), 1 )
20747            END IF
20748            IF( ILZ )
20749     $         CALL ZSCAL( N, SIGNBC, Z( 1, ILAST ), 1 )
20750         ELSE
20751            T( ILAST, ILAST ) = CZERO
20752         END IF
20753         ALPHA( ILAST ) = H( ILAST, ILAST )
20754         BETA( ILAST ) = T( ILAST, ILAST )
20755*
20756*        Go to next block -- exit if finished.
20757*
20758         ILAST = ILAST - 1
20759         IF( ILAST.LT.ILO )
20760     $      GO TO 190
20761*
20762*        Reset counters
20763*
20764         IITER = 0
20765         ESHIFT = CZERO
20766         IF( .NOT.ILSCHR ) THEN
20767            ILASTM = ILAST
20768            IF( IFRSTM.GT.ILAST )
20769     $         IFRSTM = ILO
20770         END IF
20771         GO TO 160
20772*
20773*        QZ step
20774*
20775*        This iteration only involves rows/columns IFIRST:ILAST.  We
20776*        assume IFIRST < ILAST, and that the diagonal of B is non-zero.
20777*
20778   70    CONTINUE
20779         IITER = IITER + 1
20780         IF( .NOT.ILSCHR ) THEN
20781            IFRSTM = IFIRST
20782         END IF
20783*
20784*        Compute the Shift.
20785*
20786*        At this point, IFIRST < ILAST, and the diagonal elements of
20787*        T(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in
20788*        magnitude)
20789*
20790         IF( ( IITER / 10 )*10.NE.IITER ) THEN
20791*
20792*           The Wilkinson shift (AEP p.512), i.e., the eigenvalue of
20793*           the bottom-right 2x2 block of A inv(B) which is nearest to
20794*           the bottom-right element.
20795*
20796*           We factor B as U*D, where U has unit diagonals, and
20797*           compute (A*inv(D))*inv(U).
20798*
20799            U12 = ( BSCALE*T( ILAST-1, ILAST ) ) /
20800     $            ( BSCALE*T( ILAST, ILAST ) )
20801            AD11 = ( ASCALE*H( ILAST-1, ILAST-1 ) ) /
20802     $             ( BSCALE*T( ILAST-1, ILAST-1 ) )
20803            AD21 = ( ASCALE*H( ILAST, ILAST-1 ) ) /
20804     $             ( BSCALE*T( ILAST-1, ILAST-1 ) )
20805            AD12 = ( ASCALE*H( ILAST-1, ILAST ) ) /
20806     $             ( BSCALE*T( ILAST, ILAST ) )
20807            AD22 = ( ASCALE*H( ILAST, ILAST ) ) /
20808     $             ( BSCALE*T( ILAST, ILAST ) )
20809            ABI22 = AD22 - U12*AD21
20810*
20811            T1 = HALF*( AD11+ABI22 )
20812            RTDISC = SQRT( T1**2+AD12*AD21-AD11*AD22 )
20813            TEMP = DBLE( T1-ABI22 )*DBLE( RTDISC ) +
20814     $             DIMAG( T1-ABI22 )*DIMAG( RTDISC )
20815            IF( TEMP.LE.ZERO ) THEN
20816               SHIFT = T1 + RTDISC
20817            ELSE
20818               SHIFT = T1 - RTDISC
20819            END IF
20820         ELSE
20821*
20822*           Exceptional shift.  Chosen for no particularly good reason.
20823*
20824            ESHIFT = ESHIFT + (ASCALE*H(ILAST,ILAST-1))/
20825     $                        (BSCALE*T(ILAST-1,ILAST-1))
20826            SHIFT = ESHIFT
20827         END IF
20828*
20829*        Now check for two consecutive small subdiagonals.
20830*
20831         DO 80 J = ILAST - 1, IFIRST + 1, -1
20832            ISTART = J
20833            CTEMP = ASCALE*H( J, J ) - SHIFT*( BSCALE*T( J, J ) )
20834            TEMP = ABS1( CTEMP )
20835            TEMP2 = ASCALE*ABS1( H( J+1, J ) )
20836            TEMPR = MAX( TEMP, TEMP2 )
20837            IF( TEMPR.LT.ONE .AND. TEMPR.NE.ZERO ) THEN
20838               TEMP = TEMP / TEMPR
20839               TEMP2 = TEMP2 / TEMPR
20840            END IF
20841            IF( ABS1( H( J, J-1 ) )*TEMP2.LE.TEMP*ATOL )
20842     $         GO TO 90
20843   80    CONTINUE
20844*
20845         ISTART = IFIRST
20846         CTEMP = ASCALE*H( IFIRST, IFIRST ) -
20847     $           SHIFT*( BSCALE*T( IFIRST, IFIRST ) )
20848   90    CONTINUE
20849*
20850*        Do an implicit-shift QZ sweep.
20851*
20852*        Initial Q
20853*
20854         CTEMP2 = ASCALE*H( ISTART+1, ISTART )
20855         CALL ZLARTG( CTEMP, CTEMP2, C, S, CTEMP3 )
20856*
20857*        Sweep
20858*
20859         DO 150 J = ISTART, ILAST - 1
20860            IF( J.GT.ISTART ) THEN
20861               CTEMP = H( J, J-1 )
20862               CALL ZLARTG( CTEMP, H( J+1, J-1 ), C, S, H( J, J-1 ) )
20863               H( J+1, J-1 ) = CZERO
20864            END IF
20865*
20866            DO 100 JC = J, ILASTM
20867               CTEMP = C*H( J, JC ) + S*H( J+1, JC )
20868               H( J+1, JC ) = -DCONJG( S )*H( J, JC ) + C*H( J+1, JC )
20869               H( J, JC ) = CTEMP
20870               CTEMP2 = C*T( J, JC ) + S*T( J+1, JC )
20871               T( J+1, JC ) = -DCONJG( S )*T( J, JC ) + C*T( J+1, JC )
20872               T( J, JC ) = CTEMP2
20873  100       CONTINUE
20874            IF( ILQ ) THEN
20875               DO 110 JR = 1, N
20876                  CTEMP = C*Q( JR, J ) + DCONJG( S )*Q( JR, J+1 )
20877                  Q( JR, J+1 ) = -S*Q( JR, J ) + C*Q( JR, J+1 )
20878                  Q( JR, J ) = CTEMP
20879  110          CONTINUE
20880            END IF
20881*
20882            CTEMP = T( J+1, J+1 )
20883            CALL ZLARTG( CTEMP, T( J+1, J ), C, S, T( J+1, J+1 ) )
20884            T( J+1, J ) = CZERO
20885*
20886            DO 120 JR = IFRSTM, MIN( J+2, ILAST )
20887               CTEMP = C*H( JR, J+1 ) + S*H( JR, J )
20888               H( JR, J ) = -DCONJG( S )*H( JR, J+1 ) + C*H( JR, J )
20889               H( JR, J+1 ) = CTEMP
20890  120       CONTINUE
20891            DO 130 JR = IFRSTM, J
20892               CTEMP = C*T( JR, J+1 ) + S*T( JR, J )
20893               T( JR, J ) = -DCONJG( S )*T( JR, J+1 ) + C*T( JR, J )
20894               T( JR, J+1 ) = CTEMP
20895  130       CONTINUE
20896            IF( ILZ ) THEN
20897               DO 140 JR = 1, N
20898                  CTEMP = C*Z( JR, J+1 ) + S*Z( JR, J )
20899                  Z( JR, J ) = -DCONJG( S )*Z( JR, J+1 ) + C*Z( JR, J )
20900                  Z( JR, J+1 ) = CTEMP
20901  140          CONTINUE
20902            END IF
20903  150    CONTINUE
20904*
20905  160    CONTINUE
20906*
20907  170 CONTINUE
20908*
20909*     Drop-through = non-convergence
20910*
20911  180 CONTINUE
20912      INFO = ILAST
20913      GO TO 210
20914*
20915*     Successful completion of all QZ steps
20916*
20917  190 CONTINUE
20918*
20919*     Set Eigenvalues 1:ILO-1
20920*
20921      DO 200 J = 1, ILO - 1
20922         ABSB = ABS( T( J, J ) )
20923         IF( ABSB.GT.SAFMIN ) THEN
20924            SIGNBC = DCONJG( T( J, J ) / ABSB )
20925            T( J, J ) = ABSB
20926            IF( ILSCHR ) THEN
20927               CALL ZSCAL( J-1, SIGNBC, T( 1, J ), 1 )
20928               CALL ZSCAL( J, SIGNBC, H( 1, J ), 1 )
20929            ELSE
20930               CALL ZSCAL( 1, SIGNBC, H( J, J ), 1 )
20931            END IF
20932            IF( ILZ )
20933     $         CALL ZSCAL( N, SIGNBC, Z( 1, J ), 1 )
20934         ELSE
20935            T( J, J ) = CZERO
20936         END IF
20937         ALPHA( J ) = H( J, J )
20938         BETA( J ) = T( J, J )
20939  200 CONTINUE
20940*
20941*     Normal Termination
20942*
20943      INFO = 0
20944*
20945*     Exit (other than argument error) -- return optimal workspace size
20946*
20947  210 CONTINUE
20948      WORK( 1 ) = DCMPLX( N )
20949      RETURN
20950*
20951*     End of ZHGEQZ
20952*
20953      END
20954*> \brief \b ZHSEQR
20955*
20956*  =========== DOCUMENTATION ===========
20957*
20958* Online html documentation available at
20959*            http://www.netlib.org/lapack/explore-html/
20960*
20961*> \htmlonly
20962*> Download ZHSEQR + dependencies
20963*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zhseqr.f">
20964*> [TGZ]</a>
20965*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zhseqr.f">
20966*> [ZIP]</a>
20967*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zhseqr.f">
20968*> [TXT]</a>
20969*> \endhtmlonly
20970*
20971*  Definition:
20972*  ===========
20973*
20974*       SUBROUTINE ZHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ,
20975*                          WORK, LWORK, INFO )
20976*
20977*       .. Scalar Arguments ..
20978*       INTEGER            IHI, ILO, INFO, LDH, LDZ, LWORK, N
20979*       CHARACTER          COMPZ, JOB
20980*       ..
20981*       .. Array Arguments ..
20982*       COMPLEX*16         H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * )
20983*       ..
20984*
20985*
20986*> \par Purpose:
20987*  =============
20988*>
20989*> \verbatim
20990*>
20991*>    ZHSEQR computes the eigenvalues of a Hessenberg matrix H
20992*>    and, optionally, the matrices T and Z from the Schur decomposition
20993*>    H = Z T Z**H, where T is an upper triangular matrix (the
20994*>    Schur form), and Z is the unitary matrix of Schur vectors.
20995*>
20996*>    Optionally Z may be postmultiplied into an input unitary
20997*>    matrix Q so that this routine can give the Schur factorization
20998*>    of a matrix A which has been reduced to the Hessenberg form H
20999*>    by the unitary matrix Q:  A = Q*H*Q**H = (QZ)*T*(QZ)**H.
21000*> \endverbatim
21001*
21002*  Arguments:
21003*  ==========
21004*
21005*> \param[in] JOB
21006*> \verbatim
21007*>          JOB is CHARACTER*1
21008*>           = 'E':  compute eigenvalues only;
21009*>           = 'S':  compute eigenvalues and the Schur form T.
21010*> \endverbatim
21011*>
21012*> \param[in] COMPZ
21013*> \verbatim
21014*>          COMPZ is CHARACTER*1
21015*>           = 'N':  no Schur vectors are computed;
21016*>           = 'I':  Z is initialized to the unit matrix and the matrix Z
21017*>                   of Schur vectors of H is returned;
21018*>           = 'V':  Z must contain an unitary matrix Q on entry, and
21019*>                   the product Q*Z is returned.
21020*> \endverbatim
21021*>
21022*> \param[in] N
21023*> \verbatim
21024*>          N is INTEGER
21025*>           The order of the matrix H.  N >= 0.
21026*> \endverbatim
21027*>
21028*> \param[in] ILO
21029*> \verbatim
21030*>          ILO is INTEGER
21031*> \endverbatim
21032*>
21033*> \param[in] IHI
21034*> \verbatim
21035*>          IHI is INTEGER
21036*>
21037*>           It is assumed that H is already upper triangular in rows
21038*>           and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
21039*>           set by a previous call to ZGEBAL, and then passed to ZGEHRD
21040*>           when the matrix output by ZGEBAL is reduced to Hessenberg
21041*>           form. Otherwise ILO and IHI should be set to 1 and N
21042*>           respectively.  If N > 0, then 1 <= ILO <= IHI <= N.
21043*>           If N = 0, then ILO = 1 and IHI = 0.
21044*> \endverbatim
21045*>
21046*> \param[in,out] H
21047*> \verbatim
21048*>          H is COMPLEX*16 array, dimension (LDH,N)
21049*>           On entry, the upper Hessenberg matrix H.
21050*>           On exit, if INFO = 0 and JOB = 'S', H contains the upper
21051*>           triangular matrix T from the Schur decomposition (the
21052*>           Schur form). If INFO = 0 and JOB = 'E', the contents of
21053*>           H are unspecified on exit.  (The output value of H when
21054*>           INFO > 0 is given under the description of INFO below.)
21055*>
21056*>           Unlike earlier versions of ZHSEQR, this subroutine may
21057*>           explicitly H(i,j) = 0 for i > j and j = 1, 2, ... ILO-1
21058*>           or j = IHI+1, IHI+2, ... N.
21059*> \endverbatim
21060*>
21061*> \param[in] LDH
21062*> \verbatim
21063*>          LDH is INTEGER
21064*>           The leading dimension of the array H. LDH >= max(1,N).
21065*> \endverbatim
21066*>
21067*> \param[out] W
21068*> \verbatim
21069*>          W is COMPLEX*16 array, dimension (N)
21070*>           The computed eigenvalues. If JOB = 'S', the eigenvalues are
21071*>           stored in the same order as on the diagonal of the Schur
21072*>           form returned in H, with W(i) = H(i,i).
21073*> \endverbatim
21074*>
21075*> \param[in,out] Z
21076*> \verbatim
21077*>          Z is COMPLEX*16 array, dimension (LDZ,N)
21078*>           If COMPZ = 'N', Z is not referenced.
21079*>           If COMPZ = 'I', on entry Z need not be set and on exit,
21080*>           if INFO = 0, Z contains the unitary matrix Z of the Schur
21081*>           vectors of H.  If COMPZ = 'V', on entry Z must contain an
21082*>           N-by-N matrix Q, which is assumed to be equal to the unit
21083*>           matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit,
21084*>           if INFO = 0, Z contains Q*Z.
21085*>           Normally Q is the unitary matrix generated by ZUNGHR
21086*>           after the call to ZGEHRD which formed the Hessenberg matrix
21087*>           H. (The output value of Z when INFO > 0 is given under
21088*>           the description of INFO below.)
21089*> \endverbatim
21090*>
21091*> \param[in] LDZ
21092*> \verbatim
21093*>          LDZ is INTEGER
21094*>           The leading dimension of the array Z.  if COMPZ = 'I' or
21095*>           COMPZ = 'V', then LDZ >= MAX(1,N).  Otherwise, LDZ >= 1.
21096*> \endverbatim
21097*>
21098*> \param[out] WORK
21099*> \verbatim
21100*>          WORK is COMPLEX*16 array, dimension (LWORK)
21101*>           On exit, if INFO = 0, WORK(1) returns an estimate of
21102*>           the optimal value for LWORK.
21103*> \endverbatim
21104*>
21105*> \param[in] LWORK
21106*> \verbatim
21107*>          LWORK is INTEGER
21108*>           The dimension of the array WORK.  LWORK >= max(1,N)
21109*>           is sufficient and delivers very good and sometimes
21110*>           optimal performance.  However, LWORK as large as 11*N
21111*>           may be required for optimal performance.  A workspace
21112*>           query is recommended to determine the optimal workspace
21113*>           size.
21114*>
21115*>           If LWORK = -1, then ZHSEQR does a workspace query.
21116*>           In this case, ZHSEQR checks the input parameters and
21117*>           estimates the optimal workspace size for the given
21118*>           values of N, ILO and IHI.  The estimate is returned
21119*>           in WORK(1).  No error message related to LWORK is
21120*>           issued by XERBLA.  Neither H nor Z are accessed.
21121*> \endverbatim
21122*>
21123*> \param[out] INFO
21124*> \verbatim
21125*>          INFO is INTEGER
21126*>             = 0:  successful exit
21127*>             < 0:  if INFO = -i, the i-th argument had an illegal
21128*>                    value
21129*>             > 0:  if INFO = i, ZHSEQR failed to compute all of
21130*>                the eigenvalues.  Elements 1:ilo-1 and i+1:n of W
21131*>                contain those eigenvalues which have been
21132*>                successfully computed.  (Failures are rare.)
21133*>
21134*>                If INFO > 0 and JOB = 'E', then on exit, the
21135*>                remaining unconverged eigenvalues are the eigen-
21136*>                values of the upper Hessenberg matrix rows and
21137*>                columns ILO through INFO of the final, output
21138*>                value of H.
21139*>
21140*>                If INFO > 0 and JOB   = 'S', then on exit
21141*>
21142*>           (*)  (initial value of H)*U  = U*(final value of H)
21143*>
21144*>                where U is a unitary matrix.  The final
21145*>                value of  H is upper Hessenberg and triangular in
21146*>                rows and columns INFO+1 through IHI.
21147*>
21148*>                If INFO > 0 and COMPZ = 'V', then on exit
21149*>
21150*>                  (final value of Z)  =  (initial value of Z)*U
21151*>
21152*>                where U is the unitary matrix in (*) (regard-
21153*>                less of the value of JOB.)
21154*>
21155*>                If INFO > 0 and COMPZ = 'I', then on exit
21156*>                      (final value of Z)  = U
21157*>                where U is the unitary matrix in (*) (regard-
21158*>                less of the value of JOB.)
21159*>
21160*>                If INFO > 0 and COMPZ = 'N', then Z is not
21161*>                accessed.
21162*> \endverbatim
21163*
21164*  Authors:
21165*  ========
21166*
21167*> \author Univ. of Tennessee
21168*> \author Univ. of California Berkeley
21169*> \author Univ. of Colorado Denver
21170*> \author NAG Ltd.
21171*
21172*> \date December 2016
21173*
21174*> \ingroup complex16OTHERcomputational
21175*
21176*> \par Contributors:
21177*  ==================
21178*>
21179*>       Karen Braman and Ralph Byers, Department of Mathematics,
21180*>       University of Kansas, USA
21181*
21182*> \par Further Details:
21183*  =====================
21184*>
21185*> \verbatim
21186*>
21187*>             Default values supplied by
21188*>             ILAENV(ISPEC,'ZHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK).
21189*>             It is suggested that these defaults be adjusted in order
21190*>             to attain best performance in each particular
21191*>             computational environment.
21192*>
21193*>            ISPEC=12: The ZLAHQR vs ZLAQR0 crossover point.
21194*>                      Default: 75. (Must be at least 11.)
21195*>
21196*>            ISPEC=13: Recommended deflation window size.
21197*>                      This depends on ILO, IHI and NS.  NS is the
21198*>                      number of simultaneous shifts returned
21199*>                      by ILAENV(ISPEC=15).  (See ISPEC=15 below.)
21200*>                      The default for (IHI-ILO+1) <= 500 is NS.
21201*>                      The default for (IHI-ILO+1) >  500 is 3*NS/2.
21202*>
21203*>            ISPEC=14: Nibble crossover point. (See IPARMQ for
21204*>                      details.)  Default: 14% of deflation window
21205*>                      size.
21206*>
21207*>            ISPEC=15: Number of simultaneous shifts in a multishift
21208*>                      QR iteration.
21209*>
21210*>                      If IHI-ILO+1 is ...
21211*>
21212*>                      greater than      ...but less    ... the
21213*>                      or equal to ...      than        default is
21214*>
21215*>                           1               30          NS =   2(+)
21216*>                          30               60          NS =   4(+)
21217*>                          60              150          NS =  10(+)
21218*>                         150              590          NS =  **
21219*>                         590             3000          NS =  64
21220*>                        3000             6000          NS = 128
21221*>                        6000             infinity      NS = 256
21222*>
21223*>                  (+)  By default some or all matrices of this order
21224*>                       are passed to the implicit double shift routine
21225*>                       ZLAHQR and this parameter is ignored.  See
21226*>                       ISPEC=12 above and comments in IPARMQ for
21227*>                       details.
21228*>
21229*>                 (**)  The asterisks (**) indicate an ad-hoc
21230*>                       function of N increasing from 10 to 64.
21231*>
21232*>            ISPEC=16: Select structured matrix multiply.
21233*>                      If the number of simultaneous shifts (specified
21234*>                      by ISPEC=15) is less than 14, then the default
21235*>                      for ISPEC=16 is 0.  Otherwise the default for
21236*>                      ISPEC=16 is 2.
21237*> \endverbatim
21238*
21239*> \par References:
21240*  ================
21241*>
21242*>       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
21243*>       Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
21244*>       Performance, SIAM Journal of Matrix Analysis, volume 23, pages
21245*>       929--947, 2002.
21246*> \n
21247*>       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
21248*>       Algorithm Part II: Aggressive Early Deflation, SIAM Journal
21249*>       of Matrix Analysis, volume 23, pages 948--973, 2002.
21250*
21251*  =====================================================================
21252      SUBROUTINE ZHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ,
21253     $                   WORK, LWORK, INFO )
21254*
21255*  -- LAPACK computational routine (version 3.7.0) --
21256*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
21257*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
21258*     December 2016
21259*
21260*     .. Scalar Arguments ..
21261      INTEGER            IHI, ILO, INFO, LDH, LDZ, LWORK, N
21262      CHARACTER          COMPZ, JOB
21263*     ..
21264*     .. Array Arguments ..
21265      COMPLEX*16         H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * )
21266*     ..
21267*
21268*  =====================================================================
21269*
21270*     .. Parameters ..
21271*
21272*     ==== Matrices of order NTINY or smaller must be processed by
21273*     .    ZLAHQR because of insufficient subdiagonal scratch space.
21274*     .    (This is a hard limit.) ====
21275      INTEGER            NTINY
21276      PARAMETER          ( NTINY = 11 )
21277*
21278*     ==== NL allocates some local workspace to help small matrices
21279*     .    through a rare ZLAHQR failure.  NL > NTINY = 11 is
21280*     .    required and NL <= NMIN = ILAENV(ISPEC=12,...) is recom-
21281*     .    mended.  (The default value of NMIN is 75.)  Using NL = 49
21282*     .    allows up to six simultaneous shifts and a 16-by-16
21283*     .    deflation window.  ====
21284      INTEGER            NL
21285      PARAMETER          ( NL = 49 )
21286      COMPLEX*16         ZERO, ONE
21287      PARAMETER          ( ZERO = ( 0.0d0, 0.0d0 ),
21288     $                   ONE = ( 1.0d0, 0.0d0 ) )
21289      DOUBLE PRECISION   RZERO
21290      PARAMETER          ( RZERO = 0.0d0 )
21291*     ..
21292*     .. Local Arrays ..
21293      COMPLEX*16         HL( NL, NL ), WORKL( NL )
21294*     ..
21295*     .. Local Scalars ..
21296      INTEGER            KBOT, NMIN
21297      LOGICAL            INITZ, LQUERY, WANTT, WANTZ
21298*     ..
21299*     .. External Functions ..
21300      INTEGER            ILAENV
21301      LOGICAL            LSAME
21302      EXTERNAL           ILAENV, LSAME
21303*     ..
21304*     .. External Subroutines ..
21305      EXTERNAL           XERBLA, ZCOPY, ZLACPY, ZLAHQR, ZLAQR0, ZLASET
21306*     ..
21307*     .. Intrinsic Functions ..
21308      INTRINSIC          DBLE, DCMPLX, MAX, MIN
21309*     ..
21310*     .. Executable Statements ..
21311*
21312*     ==== Decode and check the input parameters. ====
21313*
21314      WANTT = LSAME( JOB, 'S' )
21315      INITZ = LSAME( COMPZ, 'I' )
21316      WANTZ = INITZ .OR. LSAME( COMPZ, 'V' )
21317      WORK( 1 ) = DCMPLX( DBLE( MAX( 1, N ) ), RZERO )
21318      LQUERY = LWORK.EQ.-1
21319*
21320      INFO = 0
21321      IF( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN
21322         INFO = -1
21323      ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN
21324         INFO = -2
21325      ELSE IF( N.LT.0 ) THEN
21326         INFO = -3
21327      ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
21328         INFO = -4
21329      ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
21330         INFO = -5
21331      ELSE IF( LDH.LT.MAX( 1, N ) ) THEN
21332         INFO = -7
21333      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.MAX( 1, N ) ) ) THEN
21334         INFO = -10
21335      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
21336         INFO = -12
21337      END IF
21338*
21339      IF( INFO.NE.0 ) THEN
21340*
21341*        ==== Quick return in case of invalid argument. ====
21342*
21343         CALL XERBLA( 'ZHSEQR', -INFO )
21344         RETURN
21345*
21346      ELSE IF( N.EQ.0 ) THEN
21347*
21348*        ==== Quick return in case N = 0; nothing to do. ====
21349*
21350         RETURN
21351*
21352      ELSE IF( LQUERY ) THEN
21353*
21354*        ==== Quick return in case of a workspace query ====
21355*
21356         CALL ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI, Z,
21357     $                LDZ, WORK, LWORK, INFO )
21358*        ==== Ensure reported workspace size is backward-compatible with
21359*        .    previous LAPACK versions. ====
21360         WORK( 1 ) = DCMPLX( MAX( DBLE( WORK( 1 ) ), DBLE( MAX( 1,
21361     $               N ) ) ), RZERO )
21362         RETURN
21363*
21364      ELSE
21365*
21366*        ==== copy eigenvalues isolated by ZGEBAL ====
21367*
21368         IF( ILO.GT.1 )
21369     $      CALL ZCOPY( ILO-1, H, LDH+1, W, 1 )
21370         IF( IHI.LT.N )
21371     $      CALL ZCOPY( N-IHI, H( IHI+1, IHI+1 ), LDH+1, W( IHI+1 ), 1 )
21372*
21373*        ==== Initialize Z, if requested ====
21374*
21375         IF( INITZ )
21376     $      CALL ZLASET( 'A', N, N, ZERO, ONE, Z, LDZ )
21377*
21378*        ==== Quick return if possible ====
21379*
21380         IF( ILO.EQ.IHI ) THEN
21381            W( ILO ) = H( ILO, ILO )
21382            RETURN
21383         END IF
21384*
21385*        ==== ZLAHQR/ZLAQR0 crossover point ====
21386*
21387         NMIN = ILAENV( 12, 'ZHSEQR', JOB( : 1 ) // COMPZ( : 1 ), N,
21388     $          ILO, IHI, LWORK )
21389         NMIN = MAX( NTINY, NMIN )
21390*
21391*        ==== ZLAQR0 for big matrices; ZLAHQR for small ones ====
21392*
21393         IF( N.GT.NMIN ) THEN
21394            CALL ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI,
21395     $                   Z, LDZ, WORK, LWORK, INFO )
21396         ELSE
21397*
21398*           ==== Small matrix ====
21399*
21400            CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI,
21401     $                   Z, LDZ, INFO )
21402*
21403            IF( INFO.GT.0 ) THEN
21404*
21405*              ==== A rare ZLAHQR failure!  ZLAQR0 sometimes succeeds
21406*              .    when ZLAHQR fails. ====
21407*
21408               KBOT = INFO
21409*
21410               IF( N.GE.NL ) THEN
21411*
21412*                 ==== Larger matrices have enough subdiagonal scratch
21413*                 .    space to call ZLAQR0 directly. ====
21414*
21415                  CALL ZLAQR0( WANTT, WANTZ, N, ILO, KBOT, H, LDH, W,
21416     $                         ILO, IHI, Z, LDZ, WORK, LWORK, INFO )
21417*
21418               ELSE
21419*
21420*                 ==== Tiny matrices don't have enough subdiagonal
21421*                 .    scratch space to benefit from ZLAQR0.  Hence,
21422*                 .    tiny matrices must be copied into a larger
21423*                 .    array before calling ZLAQR0. ====
21424*
21425                  CALL ZLACPY( 'A', N, N, H, LDH, HL, NL )
21426                  HL( N+1, N ) = ZERO
21427                  CALL ZLASET( 'A', NL, NL-N, ZERO, ZERO, HL( 1, N+1 ),
21428     $                         NL )
21429                  CALL ZLAQR0( WANTT, WANTZ, NL, ILO, KBOT, HL, NL, W,
21430     $                         ILO, IHI, Z, LDZ, WORKL, NL, INFO )
21431                  IF( WANTT .OR. INFO.NE.0 )
21432     $               CALL ZLACPY( 'A', N, N, HL, NL, H, LDH )
21433               END IF
21434            END IF
21435         END IF
21436*
21437*        ==== Clear out the trash, if necessary. ====
21438*
21439         IF( ( WANTT .OR. INFO.NE.0 ) .AND. N.GT.2 )
21440     $      CALL ZLASET( 'L', N-2, N-2, ZERO, ZERO, H( 3, 1 ), LDH )
21441*
21442*        ==== Ensure reported workspace size is backward-compatible with
21443*        .    previous LAPACK versions. ====
21444*
21445         WORK( 1 ) = DCMPLX( MAX( DBLE( MAX( 1, N ) ),
21446     $               DBLE( WORK( 1 ) ) ), RZERO )
21447      END IF
21448*
21449*     ==== End of ZHSEQR ====
21450*
21451      END
21452*> \brief \b ZLABRD reduces the first nb rows and columns of a general matrix to a bidiagonal form.
21453*
21454*  =========== DOCUMENTATION ===========
21455*
21456* Online html documentation available at
21457*            http://www.netlib.org/lapack/explore-html/
21458*
21459*> \htmlonly
21460*> Download ZLABRD + dependencies
21461*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlabrd.f">
21462*> [TGZ]</a>
21463*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlabrd.f">
21464*> [ZIP]</a>
21465*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlabrd.f">
21466*> [TXT]</a>
21467*> \endhtmlonly
21468*
21469*  Definition:
21470*  ===========
21471*
21472*       SUBROUTINE ZLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y,
21473*                          LDY )
21474*
21475*       .. Scalar Arguments ..
21476*       INTEGER            LDA, LDX, LDY, M, N, NB
21477*       ..
21478*       .. Array Arguments ..
21479*       DOUBLE PRECISION   D( * ), E( * )
21480*       COMPLEX*16         A( LDA, * ), TAUP( * ), TAUQ( * ), X( LDX, * ),
21481*      $                   Y( LDY, * )
21482*       ..
21483*
21484*
21485*> \par Purpose:
21486*  =============
21487*>
21488*> \verbatim
21489*>
21490*> ZLABRD reduces the first NB rows and columns of a complex general
21491*> m by n matrix A to upper or lower real bidiagonal form by a unitary
21492*> transformation Q**H * A * P, and returns the matrices X and Y which
21493*> are needed to apply the transformation to the unreduced part of A.
21494*>
21495*> If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower
21496*> bidiagonal form.
21497*>
21498*> This is an auxiliary routine called by ZGEBRD
21499*> \endverbatim
21500*
21501*  Arguments:
21502*  ==========
21503*
21504*> \param[in] M
21505*> \verbatim
21506*>          M is INTEGER
21507*>          The number of rows in the matrix A.
21508*> \endverbatim
21509*>
21510*> \param[in] N
21511*> \verbatim
21512*>          N is INTEGER
21513*>          The number of columns in the matrix A.
21514*> \endverbatim
21515*>
21516*> \param[in] NB
21517*> \verbatim
21518*>          NB is INTEGER
21519*>          The number of leading rows and columns of A to be reduced.
21520*> \endverbatim
21521*>
21522*> \param[in,out] A
21523*> \verbatim
21524*>          A is COMPLEX*16 array, dimension (LDA,N)
21525*>          On entry, the m by n general matrix to be reduced.
21526*>          On exit, the first NB rows and columns of the matrix are
21527*>          overwritten; the rest of the array is unchanged.
21528*>          If m >= n, elements on and below the diagonal in the first NB
21529*>            columns, with the array TAUQ, represent the unitary
21530*>            matrix Q as a product of elementary reflectors; and
21531*>            elements above the diagonal in the first NB rows, with the
21532*>            array TAUP, represent the unitary matrix P as a product
21533*>            of elementary reflectors.
21534*>          If m < n, elements below the diagonal in the first NB
21535*>            columns, with the array TAUQ, represent the unitary
21536*>            matrix Q as a product of elementary reflectors, and
21537*>            elements on and above the diagonal in the first NB rows,
21538*>            with the array TAUP, represent the unitary matrix P as
21539*>            a product of elementary reflectors.
21540*>          See Further Details.
21541*> \endverbatim
21542*>
21543*> \param[in] LDA
21544*> \verbatim
21545*>          LDA is INTEGER
21546*>          The leading dimension of the array A.  LDA >= max(1,M).
21547*> \endverbatim
21548*>
21549*> \param[out] D
21550*> \verbatim
21551*>          D is DOUBLE PRECISION array, dimension (NB)
21552*>          The diagonal elements of the first NB rows and columns of
21553*>          the reduced matrix.  D(i) = A(i,i).
21554*> \endverbatim
21555*>
21556*> \param[out] E
21557*> \verbatim
21558*>          E is DOUBLE PRECISION array, dimension (NB)
21559*>          The off-diagonal elements of the first NB rows and columns of
21560*>          the reduced matrix.
21561*> \endverbatim
21562*>
21563*> \param[out] TAUQ
21564*> \verbatim
21565*>          TAUQ is COMPLEX*16 array, dimension (NB)
21566*>          The scalar factors of the elementary reflectors which
21567*>          represent the unitary matrix Q. See Further Details.
21568*> \endverbatim
21569*>
21570*> \param[out] TAUP
21571*> \verbatim
21572*>          TAUP is COMPLEX*16 array, dimension (NB)
21573*>          The scalar factors of the elementary reflectors which
21574*>          represent the unitary matrix P. See Further Details.
21575*> \endverbatim
21576*>
21577*> \param[out] X
21578*> \verbatim
21579*>          X is COMPLEX*16 array, dimension (LDX,NB)
21580*>          The m-by-nb matrix X required to update the unreduced part
21581*>          of A.
21582*> \endverbatim
21583*>
21584*> \param[in] LDX
21585*> \verbatim
21586*>          LDX is INTEGER
21587*>          The leading dimension of the array X. LDX >= max(1,M).
21588*> \endverbatim
21589*>
21590*> \param[out] Y
21591*> \verbatim
21592*>          Y is COMPLEX*16 array, dimension (LDY,NB)
21593*>          The n-by-nb matrix Y required to update the unreduced part
21594*>          of A.
21595*> \endverbatim
21596*>
21597*> \param[in] LDY
21598*> \verbatim
21599*>          LDY is INTEGER
21600*>          The leading dimension of the array Y. LDY >= max(1,N).
21601*> \endverbatim
21602*
21603*  Authors:
21604*  ========
21605*
21606*> \author Univ. of Tennessee
21607*> \author Univ. of California Berkeley
21608*> \author Univ. of Colorado Denver
21609*> \author NAG Ltd.
21610*
21611*> \date June 2017
21612*
21613*> \ingroup complex16OTHERauxiliary
21614*
21615*> \par Further Details:
21616*  =====================
21617*>
21618*> \verbatim
21619*>
21620*>  The matrices Q and P are represented as products of elementary
21621*>  reflectors:
21622*>
21623*>     Q = H(1) H(2) . . . H(nb)  and  P = G(1) G(2) . . . G(nb)
21624*>
21625*>  Each H(i) and G(i) has the form:
21626*>
21627*>     H(i) = I - tauq * v * v**H  and G(i) = I - taup * u * u**H
21628*>
21629*>  where tauq and taup are complex scalars, and v and u are complex
21630*>  vectors.
21631*>
21632*>  If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in
21633*>  A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in
21634*>  A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
21635*>
21636*>  If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in
21637*>  A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in
21638*>  A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
21639*>
21640*>  The elements of the vectors v and u together form the m-by-nb matrix
21641*>  V and the nb-by-n matrix U**H which are needed, with X and Y, to apply
21642*>  the transformation to the unreduced part of the matrix, using a block
21643*>  update of the form:  A := A - V*Y**H - X*U**H.
21644*>
21645*>  The contents of A on exit are illustrated by the following examples
21646*>  with nb = 2:
21647*>
21648*>  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n):
21649*>
21650*>    (  1   1   u1  u1  u1 )           (  1   u1  u1  u1  u1  u1 )
21651*>    (  v1  1   1   u2  u2 )           (  1   1   u2  u2  u2  u2 )
21652*>    (  v1  v2  a   a   a  )           (  v1  1   a   a   a   a  )
21653*>    (  v1  v2  a   a   a  )           (  v1  v2  a   a   a   a  )
21654*>    (  v1  v2  a   a   a  )           (  v1  v2  a   a   a   a  )
21655*>    (  v1  v2  a   a   a  )
21656*>
21657*>  where a denotes an element of the original matrix which is unchanged,
21658*>  vi denotes an element of the vector defining H(i), and ui an element
21659*>  of the vector defining G(i).
21660*> \endverbatim
21661*>
21662*  =====================================================================
21663      SUBROUTINE ZLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y,
21664     $                   LDY )
21665*
21666*  -- LAPACK auxiliary routine (version 3.7.1) --
21667*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
21668*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
21669*     June 2017
21670*
21671*     .. Scalar Arguments ..
21672      INTEGER            LDA, LDX, LDY, M, N, NB
21673*     ..
21674*     .. Array Arguments ..
21675      DOUBLE PRECISION   D( * ), E( * )
21676      COMPLEX*16         A( LDA, * ), TAUP( * ), TAUQ( * ), X( LDX, * ),
21677     $                   Y( LDY, * )
21678*     ..
21679*
21680*  =====================================================================
21681*
21682*     .. Parameters ..
21683      COMPLEX*16         ZERO, ONE
21684      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ),
21685     $                   ONE = ( 1.0D+0, 0.0D+0 ) )
21686*     ..
21687*     .. Local Scalars ..
21688      INTEGER            I
21689      COMPLEX*16         ALPHA
21690*     ..
21691*     .. External Subroutines ..
21692      EXTERNAL           ZGEMV, ZLACGV, ZLARFG, ZSCAL
21693*     ..
21694*     .. Intrinsic Functions ..
21695      INTRINSIC          MIN
21696*     ..
21697*     .. Executable Statements ..
21698*
21699*     Quick return if possible
21700*
21701      IF( M.LE.0 .OR. N.LE.0 )
21702     $   RETURN
21703*
21704      IF( M.GE.N ) THEN
21705*
21706*        Reduce to upper bidiagonal form
21707*
21708         DO 10 I = 1, NB
21709*
21710*           Update A(i:m,i)
21711*
21712            CALL ZLACGV( I-1, Y( I, 1 ), LDY )
21713            CALL ZGEMV( 'No transpose', M-I+1, I-1, -ONE, A( I, 1 ),
21714     $                  LDA, Y( I, 1 ), LDY, ONE, A( I, I ), 1 )
21715            CALL ZLACGV( I-1, Y( I, 1 ), LDY )
21716            CALL ZGEMV( 'No transpose', M-I+1, I-1, -ONE, X( I, 1 ),
21717     $                  LDX, A( 1, I ), 1, ONE, A( I, I ), 1 )
21718*
21719*           Generate reflection Q(i) to annihilate A(i+1:m,i)
21720*
21721            ALPHA = A( I, I )
21722            CALL ZLARFG( M-I+1, ALPHA, A( MIN( I+1, M ), I ), 1,
21723     $                   TAUQ( I ) )
21724            D( I ) = ALPHA
21725            IF( I.LT.N ) THEN
21726               A( I, I ) = ONE
21727*
21728*              Compute Y(i+1:n,i)
21729*
21730               CALL ZGEMV( 'Conjugate transpose', M-I+1, N-I, ONE,
21731     $                     A( I, I+1 ), LDA, A( I, I ), 1, ZERO,
21732     $                     Y( I+1, I ), 1 )
21733               CALL ZGEMV( 'Conjugate transpose', M-I+1, I-1, ONE,
21734     $                     A( I, 1 ), LDA, A( I, I ), 1, ZERO,
21735     $                     Y( 1, I ), 1 )
21736               CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ),
21737     $                     LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
21738               CALL ZGEMV( 'Conjugate transpose', M-I+1, I-1, ONE,
21739     $                     X( I, 1 ), LDX, A( I, I ), 1, ZERO,
21740     $                     Y( 1, I ), 1 )
21741               CALL ZGEMV( 'Conjugate transpose', I-1, N-I, -ONE,
21742     $                     A( 1, I+1 ), LDA, Y( 1, I ), 1, ONE,
21743     $                     Y( I+1, I ), 1 )
21744               CALL ZSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 )
21745*
21746*              Update A(i,i+1:n)
21747*
21748               CALL ZLACGV( N-I, A( I, I+1 ), LDA )
21749               CALL ZLACGV( I, A( I, 1 ), LDA )
21750               CALL ZGEMV( 'No transpose', N-I, I, -ONE, Y( I+1, 1 ),
21751     $                     LDY, A( I, 1 ), LDA, ONE, A( I, I+1 ), LDA )
21752               CALL ZLACGV( I, A( I, 1 ), LDA )
21753               CALL ZLACGV( I-1, X( I, 1 ), LDX )
21754               CALL ZGEMV( 'Conjugate transpose', I-1, N-I, -ONE,
21755     $                     A( 1, I+1 ), LDA, X( I, 1 ), LDX, ONE,
21756     $                     A( I, I+1 ), LDA )
21757               CALL ZLACGV( I-1, X( I, 1 ), LDX )
21758*
21759*              Generate reflection P(i) to annihilate A(i,i+2:n)
21760*
21761               ALPHA = A( I, I+1 )
21762               CALL ZLARFG( N-I, ALPHA, A( I, MIN( I+2, N ) ), LDA,
21763     $                      TAUP( I ) )
21764               E( I ) = ALPHA
21765               A( I, I+1 ) = ONE
21766*
21767*              Compute X(i+1:m,i)
21768*
21769               CALL ZGEMV( 'No transpose', M-I, N-I, ONE, A( I+1, I+1 ),
21770     $                     LDA, A( I, I+1 ), LDA, ZERO, X( I+1, I ), 1 )
21771               CALL ZGEMV( 'Conjugate transpose', N-I, I, ONE,
21772     $                     Y( I+1, 1 ), LDY, A( I, I+1 ), LDA, ZERO,
21773     $                     X( 1, I ), 1 )
21774               CALL ZGEMV( 'No transpose', M-I, I, -ONE, A( I+1, 1 ),
21775     $                     LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
21776               CALL ZGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ),
21777     $                     LDA, A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 )
21778               CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ),
21779     $                     LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
21780               CALL ZSCAL( M-I, TAUP( I ), X( I+1, I ), 1 )
21781               CALL ZLACGV( N-I, A( I, I+1 ), LDA )
21782            END IF
21783   10    CONTINUE
21784      ELSE
21785*
21786*        Reduce to lower bidiagonal form
21787*
21788         DO 20 I = 1, NB
21789*
21790*           Update A(i,i:n)
21791*
21792            CALL ZLACGV( N-I+1, A( I, I ), LDA )
21793            CALL ZLACGV( I-1, A( I, 1 ), LDA )
21794            CALL ZGEMV( 'No transpose', N-I+1, I-1, -ONE, Y( I, 1 ),
21795     $                  LDY, A( I, 1 ), LDA, ONE, A( I, I ), LDA )
21796            CALL ZLACGV( I-1, A( I, 1 ), LDA )
21797            CALL ZLACGV( I-1, X( I, 1 ), LDX )
21798            CALL ZGEMV( 'Conjugate transpose', I-1, N-I+1, -ONE,
21799     $                  A( 1, I ), LDA, X( I, 1 ), LDX, ONE, A( I, I ),
21800     $                  LDA )
21801            CALL ZLACGV( I-1, X( I, 1 ), LDX )
21802*
21803*           Generate reflection P(i) to annihilate A(i,i+1:n)
21804*
21805            ALPHA = A( I, I )
21806            CALL ZLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA,
21807     $                   TAUP( I ) )
21808            D( I ) = ALPHA
21809            IF( I.LT.M ) THEN
21810               A( I, I ) = ONE
21811*
21812*              Compute X(i+1:m,i)
21813*
21814               CALL ZGEMV( 'No transpose', M-I, N-I+1, ONE, A( I+1, I ),
21815     $                     LDA, A( I, I ), LDA, ZERO, X( I+1, I ), 1 )
21816               CALL ZGEMV( 'Conjugate transpose', N-I+1, I-1, ONE,
21817     $                     Y( I, 1 ), LDY, A( I, I ), LDA, ZERO,
21818     $                     X( 1, I ), 1 )
21819               CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ),
21820     $                     LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
21821               CALL ZGEMV( 'No transpose', I-1, N-I+1, ONE, A( 1, I ),
21822     $                     LDA, A( I, I ), LDA, ZERO, X( 1, I ), 1 )
21823               CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ),
21824     $                     LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
21825               CALL ZSCAL( M-I, TAUP( I ), X( I+1, I ), 1 )
21826               CALL ZLACGV( N-I+1, A( I, I ), LDA )
21827*
21828*              Update A(i+1:m,i)
21829*
21830               CALL ZLACGV( I-1, Y( I, 1 ), LDY )
21831               CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ),
21832     $                     LDA, Y( I, 1 ), LDY, ONE, A( I+1, I ), 1 )
21833               CALL ZLACGV( I-1, Y( I, 1 ), LDY )
21834               CALL ZGEMV( 'No transpose', M-I, I, -ONE, X( I+1, 1 ),
21835     $                     LDX, A( 1, I ), 1, ONE, A( I+1, I ), 1 )
21836*
21837*              Generate reflection Q(i) to annihilate A(i+2:m,i)
21838*
21839               ALPHA = A( I+1, I )
21840               CALL ZLARFG( M-I, ALPHA, A( MIN( I+2, M ), I ), 1,
21841     $                      TAUQ( I ) )
21842               E( I ) = ALPHA
21843               A( I+1, I ) = ONE
21844*
21845*              Compute Y(i+1:n,i)
21846*
21847               CALL ZGEMV( 'Conjugate transpose', M-I, N-I, ONE,
21848     $                     A( I+1, I+1 ), LDA, A( I+1, I ), 1, ZERO,
21849     $                     Y( I+1, I ), 1 )
21850               CALL ZGEMV( 'Conjugate transpose', M-I, I-1, ONE,
21851     $                     A( I+1, 1 ), LDA, A( I+1, I ), 1, ZERO,
21852     $                     Y( 1, I ), 1 )
21853               CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ),
21854     $                     LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
21855               CALL ZGEMV( 'Conjugate transpose', M-I, I, ONE,
21856     $                     X( I+1, 1 ), LDX, A( I+1, I ), 1, ZERO,
21857     $                     Y( 1, I ), 1 )
21858               CALL ZGEMV( 'Conjugate transpose', I, N-I, -ONE,
21859     $                     A( 1, I+1 ), LDA, Y( 1, I ), 1, ONE,
21860     $                     Y( I+1, I ), 1 )
21861               CALL ZSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 )
21862            ELSE
21863               CALL ZLACGV( N-I+1, A( I, I ), LDA )
21864            END IF
21865   20    CONTINUE
21866      END IF
21867      RETURN
21868*
21869*     End of ZLABRD
21870*
21871      END
21872*> \brief \b ZLACGV conjugates a complex vector.
21873*
21874*  =========== DOCUMENTATION ===========
21875*
21876* Online html documentation available at
21877*            http://www.netlib.org/lapack/explore-html/
21878*
21879*> \htmlonly
21880*> Download ZLACGV + dependencies
21881*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlacgv.f">
21882*> [TGZ]</a>
21883*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlacgv.f">
21884*> [ZIP]</a>
21885*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlacgv.f">
21886*> [TXT]</a>
21887*> \endhtmlonly
21888*
21889*  Definition:
21890*  ===========
21891*
21892*       SUBROUTINE ZLACGV( N, X, INCX )
21893*
21894*       .. Scalar Arguments ..
21895*       INTEGER            INCX, N
21896*       ..
21897*       .. Array Arguments ..
21898*       COMPLEX*16         X( * )
21899*       ..
21900*
21901*
21902*> \par Purpose:
21903*  =============
21904*>
21905*> \verbatim
21906*>
21907*> ZLACGV conjugates a complex vector of length N.
21908*> \endverbatim
21909*
21910*  Arguments:
21911*  ==========
21912*
21913*> \param[in] N
21914*> \verbatim
21915*>          N is INTEGER
21916*>          The length of the vector X.  N >= 0.
21917*> \endverbatim
21918*>
21919*> \param[in,out] X
21920*> \verbatim
21921*>          X is COMPLEX*16 array, dimension
21922*>                         (1+(N-1)*abs(INCX))
21923*>          On entry, the vector of length N to be conjugated.
21924*>          On exit, X is overwritten with conjg(X).
21925*> \endverbatim
21926*>
21927*> \param[in] INCX
21928*> \verbatim
21929*>          INCX is INTEGER
21930*>          The spacing between successive elements of X.
21931*> \endverbatim
21932*
21933*  Authors:
21934*  ========
21935*
21936*> \author Univ. of Tennessee
21937*> \author Univ. of California Berkeley
21938*> \author Univ. of Colorado Denver
21939*> \author NAG Ltd.
21940*
21941*> \date December 2016
21942*
21943*> \ingroup complex16OTHERauxiliary
21944*
21945*  =====================================================================
21946      SUBROUTINE ZLACGV( N, X, INCX )
21947*
21948*  -- LAPACK auxiliary routine (version 3.7.0) --
21949*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
21950*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
21951*     December 2016
21952*
21953*     .. Scalar Arguments ..
21954      INTEGER            INCX, N
21955*     ..
21956*     .. Array Arguments ..
21957      COMPLEX*16         X( * )
21958*     ..
21959*
21960* =====================================================================
21961*
21962*     .. Local Scalars ..
21963      INTEGER            I, IOFF
21964*     ..
21965*     .. Intrinsic Functions ..
21966      INTRINSIC          DCONJG
21967*     ..
21968*     .. Executable Statements ..
21969*
21970      IF( INCX.EQ.1 ) THEN
21971         DO 10 I = 1, N
21972            X( I ) = DCONJG( X( I ) )
21973   10    CONTINUE
21974      ELSE
21975         IOFF = 1
21976         IF( INCX.LT.0 )
21977     $      IOFF = 1 - ( N-1 )*INCX
21978         DO 20 I = 1, N
21979            X( IOFF ) = DCONJG( X( IOFF ) )
21980            IOFF = IOFF + INCX
21981   20    CONTINUE
21982      END IF
21983      RETURN
21984*
21985*     End of ZLACGV
21986*
21987      END
21988*> \brief \b ZLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vector products.
21989*
21990*  =========== DOCUMENTATION ===========
21991*
21992* Online html documentation available at
21993*            http://www.netlib.org/lapack/explore-html/
21994*
21995*> \htmlonly
21996*> Download ZLACN2 + dependencies
21997*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlacn2.f">
21998*> [TGZ]</a>
21999*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlacn2.f">
22000*> [ZIP]</a>
22001*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlacn2.f">
22002*> [TXT]</a>
22003*> \endhtmlonly
22004*
22005*  Definition:
22006*  ===========
22007*
22008*       SUBROUTINE ZLACN2( N, V, X, EST, KASE, ISAVE )
22009*
22010*       .. Scalar Arguments ..
22011*       INTEGER            KASE, N
22012*       DOUBLE PRECISION   EST
22013*       ..
22014*       .. Array Arguments ..
22015*       INTEGER            ISAVE( 3 )
22016*       COMPLEX*16         V( * ), X( * )
22017*       ..
22018*
22019*
22020*> \par Purpose:
22021*  =============
22022*>
22023*> \verbatim
22024*>
22025*> ZLACN2 estimates the 1-norm of a square, complex matrix A.
22026*> Reverse communication is used for evaluating matrix-vector products.
22027*> \endverbatim
22028*
22029*  Arguments:
22030*  ==========
22031*
22032*> \param[in] N
22033*> \verbatim
22034*>          N is INTEGER
22035*>         The order of the matrix.  N >= 1.
22036*> \endverbatim
22037*>
22038*> \param[out] V
22039*> \verbatim
22040*>          V is COMPLEX*16 array, dimension (N)
22041*>         On the final return, V = A*W,  where  EST = norm(V)/norm(W)
22042*>         (W is not returned).
22043*> \endverbatim
22044*>
22045*> \param[in,out] X
22046*> \verbatim
22047*>          X is COMPLEX*16 array, dimension (N)
22048*>         On an intermediate return, X should be overwritten by
22049*>               A * X,   if KASE=1,
22050*>               A**H * X,  if KASE=2,
22051*>         where A**H is the conjugate transpose of A, and ZLACN2 must be
22052*>         re-called with all the other parameters unchanged.
22053*> \endverbatim
22054*>
22055*> \param[in,out] EST
22056*> \verbatim
22057*>          EST is DOUBLE PRECISION
22058*>         On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be
22059*>         unchanged from the previous call to ZLACN2.
22060*>         On exit, EST is an estimate (a lower bound) for norm(A).
22061*> \endverbatim
22062*>
22063*> \param[in,out] KASE
22064*> \verbatim
22065*>          KASE is INTEGER
22066*>         On the initial call to ZLACN2, KASE should be 0.
22067*>         On an intermediate return, KASE will be 1 or 2, indicating
22068*>         whether X should be overwritten by A * X  or A**H * X.
22069*>         On the final return from ZLACN2, KASE will again be 0.
22070*> \endverbatim
22071*>
22072*> \param[in,out] ISAVE
22073*> \verbatim
22074*>          ISAVE is INTEGER array, dimension (3)
22075*>         ISAVE is used to save variables between calls to ZLACN2
22076*> \endverbatim
22077*
22078*  Authors:
22079*  ========
22080*
22081*> \author Univ. of Tennessee
22082*> \author Univ. of California Berkeley
22083*> \author Univ. of Colorado Denver
22084*> \author NAG Ltd.
22085*
22086*> \date December 2016
22087*
22088*> \ingroup complex16OTHERauxiliary
22089*
22090*> \par Further Details:
22091*  =====================
22092*>
22093*> \verbatim
22094*>
22095*>  Originally named CONEST, dated March 16, 1988.
22096*>
22097*>  Last modified:  April, 1999
22098*>
22099*>  This is a thread safe version of ZLACON, which uses the array ISAVE
22100*>  in place of a SAVE statement, as follows:
22101*>
22102*>     ZLACON     ZLACN2
22103*>      JUMP     ISAVE(1)
22104*>      J        ISAVE(2)
22105*>      ITER     ISAVE(3)
22106*> \endverbatim
22107*
22108*> \par Contributors:
22109*  ==================
22110*>
22111*>     Nick Higham, University of Manchester
22112*
22113*> \par References:
22114*  ================
22115*>
22116*>  N.J. Higham, "FORTRAN codes for estimating the one-norm of
22117*>  a real or complex matrix, with applications to condition estimation",
22118*>  ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.
22119*>
22120*  =====================================================================
22121      SUBROUTINE ZLACN2( N, V, X, EST, KASE, ISAVE )
22122*
22123*  -- LAPACK auxiliary routine (version 3.7.0) --
22124*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
22125*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
22126*     December 2016
22127*
22128*     .. Scalar Arguments ..
22129      INTEGER            KASE, N
22130      DOUBLE PRECISION   EST
22131*     ..
22132*     .. Array Arguments ..
22133      INTEGER            ISAVE( 3 )
22134      COMPLEX*16         V( * ), X( * )
22135*     ..
22136*
22137*  =====================================================================
22138*
22139*     .. Parameters ..
22140      INTEGER              ITMAX
22141      PARAMETER          ( ITMAX = 5 )
22142      DOUBLE PRECISION     ONE,         TWO
22143      PARAMETER          ( ONE = 1.0D0, TWO = 2.0D0 )
22144      COMPLEX*16           CZERO, CONE
22145      PARAMETER          ( CZERO = ( 0.0D0, 0.0D0 ),
22146     $                            CONE = ( 1.0D0, 0.0D0 ) )
22147*     ..
22148*     .. Local Scalars ..
22149      INTEGER            I, JLAST
22150      DOUBLE PRECISION   ABSXI, ALTSGN, ESTOLD, SAFMIN, TEMP
22151*     ..
22152*     .. External Functions ..
22153      INTEGER            IZMAX1
22154      DOUBLE PRECISION   DLAMCH, DZSUM1
22155      EXTERNAL           IZMAX1, DLAMCH, DZSUM1
22156*     ..
22157*     .. External Subroutines ..
22158      EXTERNAL           ZCOPY
22159*     ..
22160*     .. Intrinsic Functions ..
22161      INTRINSIC          ABS, DBLE, DCMPLX, DIMAG
22162*     ..
22163*     .. Executable Statements ..
22164*
22165      SAFMIN = DLAMCH( 'Safe minimum' )
22166      IF( KASE.EQ.0 ) THEN
22167         DO 10 I = 1, N
22168            X( I ) = DCMPLX( ONE / DBLE( N ) )
22169   10    CONTINUE
22170         KASE = 1
22171         ISAVE( 1 ) = 1
22172         RETURN
22173      END IF
22174*
22175      GO TO ( 20, 40, 70, 90, 120 )ISAVE( 1 )
22176*
22177*     ................ ENTRY   (ISAVE( 1 ) = 1)
22178*     FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY A*X.
22179*
22180   20 CONTINUE
22181      IF( N.EQ.1 ) THEN
22182         V( 1 ) = X( 1 )
22183         EST = ABS( V( 1 ) )
22184*        ... QUIT
22185         GO TO 130
22186      END IF
22187      EST = DZSUM1( N, X, 1 )
22188*
22189      DO 30 I = 1, N
22190         ABSXI = ABS( X( I ) )
22191         IF( ABSXI.GT.SAFMIN ) THEN
22192            X( I ) = DCMPLX( DBLE( X( I ) ) / ABSXI,
22193     $               DIMAG( X( I ) ) / ABSXI )
22194         ELSE
22195            X( I ) = CONE
22196         END IF
22197   30 CONTINUE
22198      KASE = 2
22199      ISAVE( 1 ) = 2
22200      RETURN
22201*
22202*     ................ ENTRY   (ISAVE( 1 ) = 2)
22203*     FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY CTRANS(A)*X.
22204*
22205   40 CONTINUE
22206      ISAVE( 2 ) = IZMAX1( N, X, 1 )
22207      ISAVE( 3 ) = 2
22208*
22209*     MAIN LOOP - ITERATIONS 2,3,...,ITMAX.
22210*
22211   50 CONTINUE
22212      DO 60 I = 1, N
22213         X( I ) = CZERO
22214   60 CONTINUE
22215      X( ISAVE( 2 ) ) = CONE
22216      KASE = 1
22217      ISAVE( 1 ) = 3
22218      RETURN
22219*
22220*     ................ ENTRY   (ISAVE( 1 ) = 3)
22221*     X HAS BEEN OVERWRITTEN BY A*X.
22222*
22223   70 CONTINUE
22224      CALL ZCOPY( N, X, 1, V, 1 )
22225      ESTOLD = EST
22226      EST = DZSUM1( N, V, 1 )
22227*
22228*     TEST FOR CYCLING.
22229      IF( EST.LE.ESTOLD )
22230     $   GO TO 100
22231*
22232      DO 80 I = 1, N
22233         ABSXI = ABS( X( I ) )
22234         IF( ABSXI.GT.SAFMIN ) THEN
22235            X( I ) = DCMPLX( DBLE( X( I ) ) / ABSXI,
22236     $               DIMAG( X( I ) ) / ABSXI )
22237         ELSE
22238            X( I ) = CONE
22239         END IF
22240   80 CONTINUE
22241      KASE = 2
22242      ISAVE( 1 ) = 4
22243      RETURN
22244*
22245*     ................ ENTRY   (ISAVE( 1 ) = 4)
22246*     X HAS BEEN OVERWRITTEN BY CTRANS(A)*X.
22247*
22248   90 CONTINUE
22249      JLAST = ISAVE( 2 )
22250      ISAVE( 2 ) = IZMAX1( N, X, 1 )
22251      IF( ( ABS( X( JLAST ) ).NE.ABS( X( ISAVE( 2 ) ) ) ) .AND.
22252     $    ( ISAVE( 3 ).LT.ITMAX ) ) THEN
22253         ISAVE( 3 ) = ISAVE( 3 ) + 1
22254         GO TO 50
22255      END IF
22256*
22257*     ITERATION COMPLETE.  FINAL STAGE.
22258*
22259  100 CONTINUE
22260      ALTSGN = ONE
22261      DO 110 I = 1, N
22262         X( I ) = DCMPLX( ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) ) )
22263         ALTSGN = -ALTSGN
22264  110 CONTINUE
22265      KASE = 1
22266      ISAVE( 1 ) = 5
22267      RETURN
22268*
22269*     ................ ENTRY   (ISAVE( 1 ) = 5)
22270*     X HAS BEEN OVERWRITTEN BY A*X.
22271*
22272  120 CONTINUE
22273      TEMP = TWO*( DZSUM1( N, X, 1 ) / DBLE( 3*N ) )
22274      IF( TEMP.GT.EST ) THEN
22275         CALL ZCOPY( N, X, 1, V, 1 )
22276         EST = TEMP
22277      END IF
22278*
22279  130 CONTINUE
22280      KASE = 0
22281      RETURN
22282*
22283*     End of ZLACN2
22284*
22285      END
22286*> \brief \b ZLACP2 copies all or part of a real two-dimensional array to a complex array.
22287*
22288*  =========== DOCUMENTATION ===========
22289*
22290* Online html documentation available at
22291*            http://www.netlib.org/lapack/explore-html/
22292*
22293*> \htmlonly
22294*> Download ZLACP2 + dependencies
22295*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlacp2.f">
22296*> [TGZ]</a>
22297*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlacp2.f">
22298*> [ZIP]</a>
22299*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlacp2.f">
22300*> [TXT]</a>
22301*> \endhtmlonly
22302*
22303*  Definition:
22304*  ===========
22305*
22306*       SUBROUTINE ZLACP2( UPLO, M, N, A, LDA, B, LDB )
22307*
22308*       .. Scalar Arguments ..
22309*       CHARACTER          UPLO
22310*       INTEGER            LDA, LDB, M, N
22311*       ..
22312*       .. Array Arguments ..
22313*       DOUBLE PRECISION   A( LDA, * )
22314*       COMPLEX*16         B( LDB, * )
22315*       ..
22316*
22317*
22318*> \par Purpose:
22319*  =============
22320*>
22321*> \verbatim
22322*>
22323*> ZLACP2 copies all or part of a real two-dimensional matrix A to a
22324*> complex matrix B.
22325*> \endverbatim
22326*
22327*  Arguments:
22328*  ==========
22329*
22330*> \param[in] UPLO
22331*> \verbatim
22332*>          UPLO is CHARACTER*1
22333*>          Specifies the part of the matrix A to be copied to B.
22334*>          = 'U':      Upper triangular part
22335*>          = 'L':      Lower triangular part
22336*>          Otherwise:  All of the matrix A
22337*> \endverbatim
22338*>
22339*> \param[in] M
22340*> \verbatim
22341*>          M is INTEGER
22342*>          The number of rows of the matrix A.  M >= 0.
22343*> \endverbatim
22344*>
22345*> \param[in] N
22346*> \verbatim
22347*>          N is INTEGER
22348*>          The number of columns of the matrix A.  N >= 0.
22349*> \endverbatim
22350*>
22351*> \param[in] A
22352*> \verbatim
22353*>          A is DOUBLE PRECISION array, dimension (LDA,N)
22354*>          The m by n matrix A.  If UPLO = 'U', only the upper trapezium
22355*>          is accessed; if UPLO = 'L', only the lower trapezium is
22356*>          accessed.
22357*> \endverbatim
22358*>
22359*> \param[in] LDA
22360*> \verbatim
22361*>          LDA is INTEGER
22362*>          The leading dimension of the array A.  LDA >= max(1,M).
22363*> \endverbatim
22364*>
22365*> \param[out] B
22366*> \verbatim
22367*>          B is COMPLEX*16 array, dimension (LDB,N)
22368*>          On exit, B = A in the locations specified by UPLO.
22369*> \endverbatim
22370*>
22371*> \param[in] LDB
22372*> \verbatim
22373*>          LDB is INTEGER
22374*>          The leading dimension of the array B.  LDB >= max(1,M).
22375*> \endverbatim
22376*
22377*  Authors:
22378*  ========
22379*
22380*> \author Univ. of Tennessee
22381*> \author Univ. of California Berkeley
22382*> \author Univ. of Colorado Denver
22383*> \author NAG Ltd.
22384*
22385*> \date December 2016
22386*
22387*> \ingroup complex16OTHERauxiliary
22388*
22389*  =====================================================================
22390      SUBROUTINE ZLACP2( UPLO, M, N, A, LDA, B, LDB )
22391*
22392*  -- LAPACK auxiliary routine (version 3.7.0) --
22393*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
22394*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
22395*     December 2016
22396*
22397*     .. Scalar Arguments ..
22398      CHARACTER          UPLO
22399      INTEGER            LDA, LDB, M, N
22400*     ..
22401*     .. Array Arguments ..
22402      DOUBLE PRECISION   A( LDA, * )
22403      COMPLEX*16         B( LDB, * )
22404*     ..
22405*
22406*  =====================================================================
22407*
22408*     .. Local Scalars ..
22409      INTEGER            I, J
22410*     ..
22411*     .. External Functions ..
22412      LOGICAL            LSAME
22413      EXTERNAL           LSAME
22414*     ..
22415*     .. Intrinsic Functions ..
22416      INTRINSIC          MIN
22417*     ..
22418*     .. Executable Statements ..
22419*
22420      IF( LSAME( UPLO, 'U' ) ) THEN
22421         DO 20 J = 1, N
22422            DO 10 I = 1, MIN( J, M )
22423               B( I, J ) = A( I, J )
22424   10       CONTINUE
22425   20    CONTINUE
22426*
22427      ELSE IF( LSAME( UPLO, 'L' ) ) THEN
22428         DO 40 J = 1, N
22429            DO 30 I = J, M
22430               B( I, J ) = A( I, J )
22431   30       CONTINUE
22432   40    CONTINUE
22433*
22434      ELSE
22435         DO 60 J = 1, N
22436            DO 50 I = 1, M
22437               B( I, J ) = A( I, J )
22438   50       CONTINUE
22439   60    CONTINUE
22440      END IF
22441*
22442      RETURN
22443*
22444*     End of ZLACP2
22445*
22446      END
22447*> \brief \b ZLACPY copies all or part of one two-dimensional array to another.
22448*
22449*  =========== DOCUMENTATION ===========
22450*
22451* Online html documentation available at
22452*            http://www.netlib.org/lapack/explore-html/
22453*
22454*> \htmlonly
22455*> Download ZLACPY + dependencies
22456*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlacpy.f">
22457*> [TGZ]</a>
22458*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlacpy.f">
22459*> [ZIP]</a>
22460*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlacpy.f">
22461*> [TXT]</a>
22462*> \endhtmlonly
22463*
22464*  Definition:
22465*  ===========
22466*
22467*       SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB )
22468*
22469*       .. Scalar Arguments ..
22470*       CHARACTER          UPLO
22471*       INTEGER            LDA, LDB, M, N
22472*       ..
22473*       .. Array Arguments ..
22474*       COMPLEX*16         A( LDA, * ), B( LDB, * )
22475*       ..
22476*
22477*
22478*> \par Purpose:
22479*  =============
22480*>
22481*> \verbatim
22482*>
22483*> ZLACPY copies all or part of a two-dimensional matrix A to another
22484*> matrix B.
22485*> \endverbatim
22486*
22487*  Arguments:
22488*  ==========
22489*
22490*> \param[in] UPLO
22491*> \verbatim
22492*>          UPLO is CHARACTER*1
22493*>          Specifies the part of the matrix A to be copied to B.
22494*>          = 'U':      Upper triangular part
22495*>          = 'L':      Lower triangular part
22496*>          Otherwise:  All of the matrix A
22497*> \endverbatim
22498*>
22499*> \param[in] M
22500*> \verbatim
22501*>          M is INTEGER
22502*>          The number of rows of the matrix A.  M >= 0.
22503*> \endverbatim
22504*>
22505*> \param[in] N
22506*> \verbatim
22507*>          N is INTEGER
22508*>          The number of columns of the matrix A.  N >= 0.
22509*> \endverbatim
22510*>
22511*> \param[in] A
22512*> \verbatim
22513*>          A is COMPLEX*16 array, dimension (LDA,N)
22514*>          The m by n matrix A.  If UPLO = 'U', only the upper trapezium
22515*>          is accessed; if UPLO = 'L', only the lower trapezium is
22516*>          accessed.
22517*> \endverbatim
22518*>
22519*> \param[in] LDA
22520*> \verbatim
22521*>          LDA is INTEGER
22522*>          The leading dimension of the array A.  LDA >= max(1,M).
22523*> \endverbatim
22524*>
22525*> \param[out] B
22526*> \verbatim
22527*>          B is COMPLEX*16 array, dimension (LDB,N)
22528*>          On exit, B = A in the locations specified by UPLO.
22529*> \endverbatim
22530*>
22531*> \param[in] LDB
22532*> \verbatim
22533*>          LDB is INTEGER
22534*>          The leading dimension of the array B.  LDB >= max(1,M).
22535*> \endverbatim
22536*
22537*  Authors:
22538*  ========
22539*
22540*> \author Univ. of Tennessee
22541*> \author Univ. of California Berkeley
22542*> \author Univ. of Colorado Denver
22543*> \author NAG Ltd.
22544*
22545*> \date December 2016
22546*
22547*> \ingroup complex16OTHERauxiliary
22548*
22549*  =====================================================================
22550      SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB )
22551*
22552*  -- LAPACK auxiliary routine (version 3.7.0) --
22553*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
22554*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
22555*     December 2016
22556*
22557*     .. Scalar Arguments ..
22558      CHARACTER          UPLO
22559      INTEGER            LDA, LDB, M, N
22560*     ..
22561*     .. Array Arguments ..
22562      COMPLEX*16         A( LDA, * ), B( LDB, * )
22563*     ..
22564*
22565*  =====================================================================
22566*
22567*     .. Local Scalars ..
22568      INTEGER            I, J
22569*     ..
22570*     .. External Functions ..
22571      LOGICAL            LSAME
22572      EXTERNAL           LSAME
22573*     ..
22574*     .. Intrinsic Functions ..
22575      INTRINSIC          MIN
22576*     ..
22577*     .. Executable Statements ..
22578*
22579      IF( LSAME( UPLO, 'U' ) ) THEN
22580         DO 20 J = 1, N
22581            DO 10 I = 1, MIN( J, M )
22582               B( I, J ) = A( I, J )
22583   10       CONTINUE
22584   20    CONTINUE
22585*
22586      ELSE IF( LSAME( UPLO, 'L' ) ) THEN
22587         DO 40 J = 1, N
22588            DO 30 I = J, M
22589               B( I, J ) = A( I, J )
22590   30       CONTINUE
22591   40    CONTINUE
22592*
22593      ELSE
22594         DO 60 J = 1, N
22595            DO 50 I = 1, M
22596               B( I, J ) = A( I, J )
22597   50       CONTINUE
22598   60    CONTINUE
22599      END IF
22600*
22601      RETURN
22602*
22603*     End of ZLACPY
22604*
22605      END
22606*> \brief \b ZLACRM multiplies a complex matrix by a square real matrix.
22607*
22608*  =========== DOCUMENTATION ===========
22609*
22610* Online html documentation available at
22611*            http://www.netlib.org/lapack/explore-html/
22612*
22613*> \htmlonly
22614*> Download ZLACRM + dependencies
22615*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlacrm.f">
22616*> [TGZ]</a>
22617*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlacrm.f">
22618*> [ZIP]</a>
22619*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlacrm.f">
22620*> [TXT]</a>
22621*> \endhtmlonly
22622*
22623*  Definition:
22624*  ===========
22625*
22626*       SUBROUTINE ZLACRM( M, N, A, LDA, B, LDB, C, LDC, RWORK )
22627*
22628*       .. Scalar Arguments ..
22629*       INTEGER            LDA, LDB, LDC, M, N
22630*       ..
22631*       .. Array Arguments ..
22632*       DOUBLE PRECISION   B( LDB, * ), RWORK( * )
22633*       COMPLEX*16         A( LDA, * ), C( LDC, * )
22634*       ..
22635*
22636*
22637*> \par Purpose:
22638*  =============
22639*>
22640*> \verbatim
22641*>
22642*> ZLACRM performs a very simple matrix-matrix multiplication:
22643*>          C := A * B,
22644*> where A is M by N and complex; B is N by N and real;
22645*> C is M by N and complex.
22646*> \endverbatim
22647*
22648*  Arguments:
22649*  ==========
22650*
22651*> \param[in] M
22652*> \verbatim
22653*>          M is INTEGER
22654*>          The number of rows of the matrix A and of the matrix C.
22655*>          M >= 0.
22656*> \endverbatim
22657*>
22658*> \param[in] N
22659*> \verbatim
22660*>          N is INTEGER
22661*>          The number of columns and rows of the matrix B and
22662*>          the number of columns of the matrix C.
22663*>          N >= 0.
22664*> \endverbatim
22665*>
22666*> \param[in] A
22667*> \verbatim
22668*>          A is COMPLEX*16 array, dimension (LDA, N)
22669*>          On entry, A contains the M by N matrix A.
22670*> \endverbatim
22671*>
22672*> \param[in] LDA
22673*> \verbatim
22674*>          LDA is INTEGER
22675*>          The leading dimension of the array A. LDA >=max(1,M).
22676*> \endverbatim
22677*>
22678*> \param[in] B
22679*> \verbatim
22680*>          B is DOUBLE PRECISION array, dimension (LDB, N)
22681*>          On entry, B contains the N by N matrix B.
22682*> \endverbatim
22683*>
22684*> \param[in] LDB
22685*> \verbatim
22686*>          LDB is INTEGER
22687*>          The leading dimension of the array B. LDB >=max(1,N).
22688*> \endverbatim
22689*>
22690*> \param[out] C
22691*> \verbatim
22692*>          C is COMPLEX*16 array, dimension (LDC, N)
22693*>          On exit, C contains the M by N matrix C.
22694*> \endverbatim
22695*>
22696*> \param[in] LDC
22697*> \verbatim
22698*>          LDC is INTEGER
22699*>          The leading dimension of the array C. LDC >=max(1,N).
22700*> \endverbatim
22701*>
22702*> \param[out] RWORK
22703*> \verbatim
22704*>          RWORK is DOUBLE PRECISION array, dimension (2*M*N)
22705*> \endverbatim
22706*
22707*  Authors:
22708*  ========
22709*
22710*> \author Univ. of Tennessee
22711*> \author Univ. of California Berkeley
22712*> \author Univ. of Colorado Denver
22713*> \author NAG Ltd.
22714*
22715*> \date December 2016
22716*
22717*> \ingroup complex16OTHERauxiliary
22718*
22719*  =====================================================================
22720      SUBROUTINE ZLACRM( M, N, A, LDA, B, LDB, C, LDC, RWORK )
22721*
22722*  -- LAPACK auxiliary routine (version 3.7.0) --
22723*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
22724*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
22725*     December 2016
22726*
22727*     .. Scalar Arguments ..
22728      INTEGER            LDA, LDB, LDC, M, N
22729*     ..
22730*     .. Array Arguments ..
22731      DOUBLE PRECISION   B( LDB, * ), RWORK( * )
22732      COMPLEX*16         A( LDA, * ), C( LDC, * )
22733*     ..
22734*
22735*  =====================================================================
22736*
22737*     .. Parameters ..
22738      DOUBLE PRECISION   ONE, ZERO
22739      PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0 )
22740*     ..
22741*     .. Local Scalars ..
22742      INTEGER            I, J, L
22743*     ..
22744*     .. Intrinsic Functions ..
22745      INTRINSIC          DBLE, DCMPLX, DIMAG
22746*     ..
22747*     .. External Subroutines ..
22748      EXTERNAL           DGEMM
22749*     ..
22750*     .. Executable Statements ..
22751*
22752*     Quick return if possible.
22753*
22754      IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) )
22755     $   RETURN
22756*
22757      DO 20 J = 1, N
22758         DO 10 I = 1, M
22759            RWORK( ( J-1 )*M+I ) = DBLE( A( I, J ) )
22760   10    CONTINUE
22761   20 CONTINUE
22762*
22763      L = M*N + 1
22764      CALL DGEMM( 'N', 'N', M, N, N, ONE, RWORK, M, B, LDB, ZERO,
22765     $            RWORK( L ), M )
22766      DO 40 J = 1, N
22767         DO 30 I = 1, M
22768            C( I, J ) = RWORK( L+( J-1 )*M+I-1 )
22769   30    CONTINUE
22770   40 CONTINUE
22771*
22772      DO 60 J = 1, N
22773         DO 50 I = 1, M
22774            RWORK( ( J-1 )*M+I ) = DIMAG( A( I, J ) )
22775   50    CONTINUE
22776   60 CONTINUE
22777      CALL DGEMM( 'N', 'N', M, N, N, ONE, RWORK, M, B, LDB, ZERO,
22778     $            RWORK( L ), M )
22779      DO 80 J = 1, N
22780         DO 70 I = 1, M
22781            C( I, J ) = DCMPLX( DBLE( C( I, J ) ),
22782     $                  RWORK( L+( J-1 )*M+I-1 ) )
22783   70    CONTINUE
22784   80 CONTINUE
22785*
22786      RETURN
22787*
22788*     End of ZLACRM
22789*
22790      END
22791*> \brief \b ZLADIV performs complex division in real arithmetic, avoiding unnecessary overflow.
22792*
22793*  =========== DOCUMENTATION ===========
22794*
22795* Online html documentation available at
22796*            http://www.netlib.org/lapack/explore-html/
22797*
22798*> \htmlonly
22799*> Download ZLADIV + dependencies
22800*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zladiv.f">
22801*> [TGZ]</a>
22802*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zladiv.f">
22803*> [ZIP]</a>
22804*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zladiv.f">
22805*> [TXT]</a>
22806*> \endhtmlonly
22807*
22808*  Definition:
22809*  ===========
22810*
22811*       COMPLEX*16     FUNCTION ZLADIV( X, Y )
22812*
22813*       .. Scalar Arguments ..
22814*       COMPLEX*16         X, Y
22815*       ..
22816*
22817*
22818*> \par Purpose:
22819*  =============
22820*>
22821*> \verbatim
22822*>
22823*> ZLADIV := X / Y, where X and Y are complex.  The computation of X / Y
22824*> will not overflow on an intermediary step unless the results
22825*> overflows.
22826*> \endverbatim
22827*
22828*  Arguments:
22829*  ==========
22830*
22831*> \param[in] X
22832*> \verbatim
22833*>          X is COMPLEX*16
22834*> \endverbatim
22835*>
22836*> \param[in] Y
22837*> \verbatim
22838*>          Y is COMPLEX*16
22839*>          The complex scalars X and Y.
22840*> \endverbatim
22841*
22842*  Authors:
22843*  ========
22844*
22845*> \author Univ. of Tennessee
22846*> \author Univ. of California Berkeley
22847*> \author Univ. of Colorado Denver
22848*> \author NAG Ltd.
22849*
22850*> \date December 2016
22851*
22852*> \ingroup complex16OTHERauxiliary
22853*
22854*  =====================================================================
22855      COMPLEX*16     FUNCTION ZLADIV( X, Y )
22856*
22857*  -- LAPACK auxiliary routine (version 3.7.0) --
22858*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
22859*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
22860*     December 2016
22861*
22862*     .. Scalar Arguments ..
22863      COMPLEX*16         X, Y
22864*     ..
22865*
22866*  =====================================================================
22867*
22868*     .. Local Scalars ..
22869      DOUBLE PRECISION   ZI, ZR
22870*     ..
22871*     .. External Subroutines ..
22872      EXTERNAL           DLADIV
22873*     ..
22874*     .. Intrinsic Functions ..
22875      INTRINSIC          DBLE, DCMPLX, DIMAG
22876*     ..
22877*     .. Executable Statements ..
22878*
22879      CALL DLADIV( DBLE( X ), DIMAG( X ), DBLE( Y ), DIMAG( Y ), ZR,
22880     $             ZI )
22881      ZLADIV = DCMPLX( ZR, ZI )
22882*
22883      RETURN
22884*
22885*     End of ZLADIV
22886*
22887      END
22888*> \brief \b ZLAED0 used by sstedc. Computes all eigenvalues and corresponding eigenvectors of an unreduced symmetric tridiagonal matrix using the divide and conquer method.
22889*
22890*  =========== DOCUMENTATION ===========
22891*
22892* Online html documentation available at
22893*            http://www.netlib.org/lapack/explore-html/
22894*
22895*> \htmlonly
22896*> Download ZLAED0 + dependencies
22897*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlaed0.f">
22898*> [TGZ]</a>
22899*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlaed0.f">
22900*> [ZIP]</a>
22901*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlaed0.f">
22902*> [TXT]</a>
22903*> \endhtmlonly
22904*
22905*  Definition:
22906*  ===========
22907*
22908*       SUBROUTINE ZLAED0( QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, RWORK,
22909*                          IWORK, INFO )
22910*
22911*       .. Scalar Arguments ..
22912*       INTEGER            INFO, LDQ, LDQS, N, QSIZ
22913*       ..
22914*       .. Array Arguments ..
22915*       INTEGER            IWORK( * )
22916*       DOUBLE PRECISION   D( * ), E( * ), RWORK( * )
22917*       COMPLEX*16         Q( LDQ, * ), QSTORE( LDQS, * )
22918*       ..
22919*
22920*
22921*> \par Purpose:
22922*  =============
22923*>
22924*> \verbatim
22925*>
22926*> Using the divide and conquer method, ZLAED0 computes all eigenvalues
22927*> of a symmetric tridiagonal matrix which is one diagonal block of
22928*> those from reducing a dense or band Hermitian matrix and
22929*> corresponding eigenvectors of the dense or band matrix.
22930*> \endverbatim
22931*
22932*  Arguments:
22933*  ==========
22934*
22935*> \param[in] QSIZ
22936*> \verbatim
22937*>          QSIZ is INTEGER
22938*>         The dimension of the unitary matrix used to reduce
22939*>         the full matrix to tridiagonal form.  QSIZ >= N if ICOMPQ = 1.
22940*> \endverbatim
22941*>
22942*> \param[in] N
22943*> \verbatim
22944*>          N is INTEGER
22945*>         The dimension of the symmetric tridiagonal matrix.  N >= 0.
22946*> \endverbatim
22947*>
22948*> \param[in,out] D
22949*> \verbatim
22950*>          D is DOUBLE PRECISION array, dimension (N)
22951*>         On entry, the diagonal elements of the tridiagonal matrix.
22952*>         On exit, the eigenvalues in ascending order.
22953*> \endverbatim
22954*>
22955*> \param[in,out] E
22956*> \verbatim
22957*>          E is DOUBLE PRECISION array, dimension (N-1)
22958*>         On entry, the off-diagonal elements of the tridiagonal matrix.
22959*>         On exit, E has been destroyed.
22960*> \endverbatim
22961*>
22962*> \param[in,out] Q
22963*> \verbatim
22964*>          Q is COMPLEX*16 array, dimension (LDQ,N)
22965*>         On entry, Q must contain an QSIZ x N matrix whose columns
22966*>         unitarily orthonormal. It is a part of the unitary matrix
22967*>         that reduces the full dense Hermitian matrix to a
22968*>         (reducible) symmetric tridiagonal matrix.
22969*> \endverbatim
22970*>
22971*> \param[in] LDQ
22972*> \verbatim
22973*>          LDQ is INTEGER
22974*>         The leading dimension of the array Q.  LDQ >= max(1,N).
22975*> \endverbatim
22976*>
22977*> \param[out] IWORK
22978*> \verbatim
22979*>          IWORK is INTEGER array,
22980*>         the dimension of IWORK must be at least
22981*>                      6 + 6*N + 5*N*lg N
22982*>                      ( lg( N ) = smallest integer k
22983*>                                  such that 2^k >= N )
22984*> \endverbatim
22985*>
22986*> \param[out] RWORK
22987*> \verbatim
22988*>          RWORK is DOUBLE PRECISION array,
22989*>                               dimension (1 + 3*N + 2*N*lg N + 3*N**2)
22990*>                        ( lg( N ) = smallest integer k
22991*>                                    such that 2^k >= N )
22992*> \endverbatim
22993*>
22994*> \param[out] QSTORE
22995*> \verbatim
22996*>          QSTORE is COMPLEX*16 array, dimension (LDQS, N)
22997*>         Used to store parts of
22998*>         the eigenvector matrix when the updating matrix multiplies
22999*>         take place.
23000*> \endverbatim
23001*>
23002*> \param[in] LDQS
23003*> \verbatim
23004*>          LDQS is INTEGER
23005*>         The leading dimension of the array QSTORE.
23006*>         LDQS >= max(1,N).
23007*> \endverbatim
23008*>
23009*> \param[out] INFO
23010*> \verbatim
23011*>          INFO is INTEGER
23012*>          = 0:  successful exit.
23013*>          < 0:  if INFO = -i, the i-th argument had an illegal value.
23014*>          > 0:  The algorithm failed to compute an eigenvalue while
23015*>                working on the submatrix lying in rows and columns
23016*>                INFO/(N+1) through mod(INFO,N+1).
23017*> \endverbatim
23018*
23019*  Authors:
23020*  ========
23021*
23022*> \author Univ. of Tennessee
23023*> \author Univ. of California Berkeley
23024*> \author Univ. of Colorado Denver
23025*> \author NAG Ltd.
23026*
23027*> \date December 2016
23028*
23029*> \ingroup complex16OTHERcomputational
23030*
23031*  =====================================================================
23032      SUBROUTINE ZLAED0( QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, RWORK,
23033     $                   IWORK, INFO )
23034*
23035*  -- LAPACK computational routine (version 3.7.0) --
23036*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
23037*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
23038*     December 2016
23039*
23040*     .. Scalar Arguments ..
23041      INTEGER            INFO, LDQ, LDQS, N, QSIZ
23042*     ..
23043*     .. Array Arguments ..
23044      INTEGER            IWORK( * )
23045      DOUBLE PRECISION   D( * ), E( * ), RWORK( * )
23046      COMPLEX*16         Q( LDQ, * ), QSTORE( LDQS, * )
23047*     ..
23048*
23049*  =====================================================================
23050*
23051*  Warning:      N could be as big as QSIZ!
23052*
23053*     .. Parameters ..
23054      DOUBLE PRECISION   TWO
23055      PARAMETER          ( TWO = 2.D+0 )
23056*     ..
23057*     .. Local Scalars ..
23058      INTEGER            CURLVL, CURPRB, CURR, I, IGIVCL, IGIVNM,
23059     $                   IGIVPT, INDXQ, IPERM, IPRMPT, IQ, IQPTR, IWREM,
23060     $                   J, K, LGN, LL, MATSIZ, MSD2, SMLSIZ, SMM1,
23061     $                   SPM1, SPM2, SUBMAT, SUBPBS, TLVLS
23062      DOUBLE PRECISION   TEMP
23063*     ..
23064*     .. External Subroutines ..
23065      EXTERNAL           DCOPY, DSTEQR, XERBLA, ZCOPY, ZLACRM, ZLAED7
23066*     ..
23067*     .. External Functions ..
23068      INTEGER            ILAENV
23069      EXTERNAL           ILAENV
23070*     ..
23071*     .. Intrinsic Functions ..
23072      INTRINSIC          ABS, DBLE, INT, LOG, MAX
23073*     ..
23074*     .. Executable Statements ..
23075*
23076*     Test the input parameters.
23077*
23078      INFO = 0
23079*
23080*     IF( ICOMPQ .LT. 0 .OR. ICOMPQ .GT. 2 ) THEN
23081*        INFO = -1
23082*     ELSE IF( ( ICOMPQ .EQ. 1 ) .AND. ( QSIZ .LT. MAX( 0, N ) ) )
23083*    $        THEN
23084      IF( QSIZ.LT.MAX( 0, N ) ) THEN
23085         INFO = -1
23086      ELSE IF( N.LT.0 ) THEN
23087         INFO = -2
23088      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
23089         INFO = -6
23090      ELSE IF( LDQS.LT.MAX( 1, N ) ) THEN
23091         INFO = -8
23092      END IF
23093      IF( INFO.NE.0 ) THEN
23094         CALL XERBLA( 'ZLAED0', -INFO )
23095         RETURN
23096      END IF
23097*
23098*     Quick return if possible
23099*
23100      IF( N.EQ.0 )
23101     $   RETURN
23102*
23103      SMLSIZ = ILAENV( 9, 'ZLAED0', ' ', 0, 0, 0, 0 )
23104*
23105*     Determine the size and placement of the submatrices, and save in
23106*     the leading elements of IWORK.
23107*
23108      IWORK( 1 ) = N
23109      SUBPBS = 1
23110      TLVLS = 0
23111   10 CONTINUE
23112      IF( IWORK( SUBPBS ).GT.SMLSIZ ) THEN
23113         DO 20 J = SUBPBS, 1, -1
23114            IWORK( 2*J ) = ( IWORK( J )+1 ) / 2
23115            IWORK( 2*J-1 ) = IWORK( J ) / 2
23116   20    CONTINUE
23117         TLVLS = TLVLS + 1
23118         SUBPBS = 2*SUBPBS
23119         GO TO 10
23120      END IF
23121      DO 30 J = 2, SUBPBS
23122         IWORK( J ) = IWORK( J ) + IWORK( J-1 )
23123   30 CONTINUE
23124*
23125*     Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1
23126*     using rank-1 modifications (cuts).
23127*
23128      SPM1 = SUBPBS - 1
23129      DO 40 I = 1, SPM1
23130         SUBMAT = IWORK( I ) + 1
23131         SMM1 = SUBMAT - 1
23132         D( SMM1 ) = D( SMM1 ) - ABS( E( SMM1 ) )
23133         D( SUBMAT ) = D( SUBMAT ) - ABS( E( SMM1 ) )
23134   40 CONTINUE
23135*
23136      INDXQ = 4*N + 3
23137*
23138*     Set up workspaces for eigenvalues only/accumulate new vectors
23139*     routine
23140*
23141      TEMP = LOG( DBLE( N ) ) / LOG( TWO )
23142      LGN = INT( TEMP )
23143      IF( 2**LGN.LT.N )
23144     $   LGN = LGN + 1
23145      IF( 2**LGN.LT.N )
23146     $   LGN = LGN + 1
23147      IPRMPT = INDXQ + N + 1
23148      IPERM = IPRMPT + N*LGN
23149      IQPTR = IPERM + N*LGN
23150      IGIVPT = IQPTR + N + 2
23151      IGIVCL = IGIVPT + N*LGN
23152*
23153      IGIVNM = 1
23154      IQ = IGIVNM + 2*N*LGN
23155      IWREM = IQ + N**2 + 1
23156*     Initialize pointers
23157      DO 50 I = 0, SUBPBS
23158         IWORK( IPRMPT+I ) = 1
23159         IWORK( IGIVPT+I ) = 1
23160   50 CONTINUE
23161      IWORK( IQPTR ) = 1
23162*
23163*     Solve each submatrix eigenproblem at the bottom of the divide and
23164*     conquer tree.
23165*
23166      CURR = 0
23167      DO 70 I = 0, SPM1
23168         IF( I.EQ.0 ) THEN
23169            SUBMAT = 1
23170            MATSIZ = IWORK( 1 )
23171         ELSE
23172            SUBMAT = IWORK( I ) + 1
23173            MATSIZ = IWORK( I+1 ) - IWORK( I )
23174         END IF
23175         LL = IQ - 1 + IWORK( IQPTR+CURR )
23176         CALL DSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ),
23177     $                RWORK( LL ), MATSIZ, RWORK, INFO )
23178         CALL ZLACRM( QSIZ, MATSIZ, Q( 1, SUBMAT ), LDQ, RWORK( LL ),
23179     $                MATSIZ, QSTORE( 1, SUBMAT ), LDQS,
23180     $                RWORK( IWREM ) )
23181         IWORK( IQPTR+CURR+1 ) = IWORK( IQPTR+CURR ) + MATSIZ**2
23182         CURR = CURR + 1
23183         IF( INFO.GT.0 ) THEN
23184            INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1
23185            RETURN
23186         END IF
23187         K = 1
23188         DO 60 J = SUBMAT, IWORK( I+1 )
23189            IWORK( INDXQ+J ) = K
23190            K = K + 1
23191   60    CONTINUE
23192   70 CONTINUE
23193*
23194*     Successively merge eigensystems of adjacent submatrices
23195*     into eigensystem for the corresponding larger matrix.
23196*
23197*     while ( SUBPBS > 1 )
23198*
23199      CURLVL = 1
23200   80 CONTINUE
23201      IF( SUBPBS.GT.1 ) THEN
23202         SPM2 = SUBPBS - 2
23203         DO 90 I = 0, SPM2, 2
23204            IF( I.EQ.0 ) THEN
23205               SUBMAT = 1
23206               MATSIZ = IWORK( 2 )
23207               MSD2 = IWORK( 1 )
23208               CURPRB = 0
23209            ELSE
23210               SUBMAT = IWORK( I ) + 1
23211               MATSIZ = IWORK( I+2 ) - IWORK( I )
23212               MSD2 = MATSIZ / 2
23213               CURPRB = CURPRB + 1
23214            END IF
23215*
23216*     Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2)
23217*     into an eigensystem of size MATSIZ.  ZLAED7 handles the case
23218*     when the eigenvectors of a full or band Hermitian matrix (which
23219*     was reduced to tridiagonal form) are desired.
23220*
23221*     I am free to use Q as a valuable working space until Loop 150.
23222*
23223            CALL ZLAED7( MATSIZ, MSD2, QSIZ, TLVLS, CURLVL, CURPRB,
23224     $                   D( SUBMAT ), QSTORE( 1, SUBMAT ), LDQS,
23225     $                   E( SUBMAT+MSD2-1 ), IWORK( INDXQ+SUBMAT ),
23226     $                   RWORK( IQ ), IWORK( IQPTR ), IWORK( IPRMPT ),
23227     $                   IWORK( IPERM ), IWORK( IGIVPT ),
23228     $                   IWORK( IGIVCL ), RWORK( IGIVNM ),
23229     $                   Q( 1, SUBMAT ), RWORK( IWREM ),
23230     $                   IWORK( SUBPBS+1 ), INFO )
23231            IF( INFO.GT.0 ) THEN
23232               INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1
23233               RETURN
23234            END IF
23235            IWORK( I / 2+1 ) = IWORK( I+2 )
23236   90    CONTINUE
23237         SUBPBS = SUBPBS / 2
23238         CURLVL = CURLVL + 1
23239         GO TO 80
23240      END IF
23241*
23242*     end while
23243*
23244*     Re-merge the eigenvalues/vectors which were deflated at the final
23245*     merge step.
23246*
23247      DO 100 I = 1, N
23248         J = IWORK( INDXQ+I )
23249         RWORK( I ) = D( J )
23250         CALL ZCOPY( QSIZ, QSTORE( 1, J ), 1, Q( 1, I ), 1 )
23251  100 CONTINUE
23252      CALL DCOPY( N, RWORK, 1, D, 1 )
23253*
23254      RETURN
23255*
23256*     End of ZLAED0
23257*
23258      END
23259*> \brief \b ZLAED7 used by sstedc. Computes the updated eigensystem of a diagonal matrix after modification by a rank-one symmetric matrix. Used when the original matrix is dense.
23260*
23261*  =========== DOCUMENTATION ===========
23262*
23263* Online html documentation available at
23264*            http://www.netlib.org/lapack/explore-html/
23265*
23266*> \htmlonly
23267*> Download ZLAED7 + dependencies
23268*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlaed7.f">
23269*> [TGZ]</a>
23270*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlaed7.f">
23271*> [ZIP]</a>
23272*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlaed7.f">
23273*> [TXT]</a>
23274*> \endhtmlonly
23275*
23276*  Definition:
23277*  ===========
23278*
23279*       SUBROUTINE ZLAED7( N, CUTPNT, QSIZ, TLVLS, CURLVL, CURPBM, D, Q,
23280*                          LDQ, RHO, INDXQ, QSTORE, QPTR, PRMPTR, PERM,
23281*                          GIVPTR, GIVCOL, GIVNUM, WORK, RWORK, IWORK,
23282*                          INFO )
23283*
23284*       .. Scalar Arguments ..
23285*       INTEGER            CURLVL, CURPBM, CUTPNT, INFO, LDQ, N, QSIZ,
23286*      $                   TLVLS
23287*       DOUBLE PRECISION   RHO
23288*       ..
23289*       .. Array Arguments ..
23290*       INTEGER            GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ),
23291*      $                   IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * )
23292*       DOUBLE PRECISION   D( * ), GIVNUM( 2, * ), QSTORE( * ), RWORK( * )
23293*       COMPLEX*16         Q( LDQ, * ), WORK( * )
23294*       ..
23295*
23296*
23297*> \par Purpose:
23298*  =============
23299*>
23300*> \verbatim
23301*>
23302*> ZLAED7 computes the updated eigensystem of a diagonal
23303*> matrix after modification by a rank-one symmetric matrix. This
23304*> routine is used only for the eigenproblem which requires all
23305*> eigenvalues and optionally eigenvectors of a dense or banded
23306*> Hermitian matrix that has been reduced to tridiagonal form.
23307*>
23308*>   T = Q(in) ( D(in) + RHO * Z*Z**H ) Q**H(in) = Q(out) * D(out) * Q**H(out)
23309*>
23310*>   where Z = Q**Hu, u is a vector of length N with ones in the
23311*>   CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.
23312*>
23313*>    The eigenvectors of the original matrix are stored in Q, and the
23314*>    eigenvalues are in D.  The algorithm consists of three stages:
23315*>
23316*>       The first stage consists of deflating the size of the problem
23317*>       when there are multiple eigenvalues or if there is a zero in
23318*>       the Z vector.  For each such occurrence the dimension of the
23319*>       secular equation problem is reduced by one.  This stage is
23320*>       performed by the routine DLAED2.
23321*>
23322*>       The second stage consists of calculating the updated
23323*>       eigenvalues. This is done by finding the roots of the secular
23324*>       equation via the routine DLAED4 (as called by SLAED3).
23325*>       This routine also calculates the eigenvectors of the current
23326*>       problem.
23327*>
23328*>       The final stage consists of computing the updated eigenvectors
23329*>       directly using the updated eigenvalues.  The eigenvectors for
23330*>       the current problem are multiplied with the eigenvectors from
23331*>       the overall problem.
23332*> \endverbatim
23333*
23334*  Arguments:
23335*  ==========
23336*
23337*> \param[in] N
23338*> \verbatim
23339*>          N is INTEGER
23340*>         The dimension of the symmetric tridiagonal matrix.  N >= 0.
23341*> \endverbatim
23342*>
23343*> \param[in] CUTPNT
23344*> \verbatim
23345*>          CUTPNT is INTEGER
23346*>         Contains the location of the last eigenvalue in the leading
23347*>         sub-matrix.  min(1,N) <= CUTPNT <= N.
23348*> \endverbatim
23349*>
23350*> \param[in] QSIZ
23351*> \verbatim
23352*>          QSIZ is INTEGER
23353*>         The dimension of the unitary matrix used to reduce
23354*>         the full matrix to tridiagonal form.  QSIZ >= N.
23355*> \endverbatim
23356*>
23357*> \param[in] TLVLS
23358*> \verbatim
23359*>          TLVLS is INTEGER
23360*>         The total number of merging levels in the overall divide and
23361*>         conquer tree.
23362*> \endverbatim
23363*>
23364*> \param[in] CURLVL
23365*> \verbatim
23366*>          CURLVL is INTEGER
23367*>         The current level in the overall merge routine,
23368*>         0 <= curlvl <= tlvls.
23369*> \endverbatim
23370*>
23371*> \param[in] CURPBM
23372*> \verbatim
23373*>          CURPBM is INTEGER
23374*>         The current problem in the current level in the overall
23375*>         merge routine (counting from upper left to lower right).
23376*> \endverbatim
23377*>
23378*> \param[in,out] D
23379*> \verbatim
23380*>          D is DOUBLE PRECISION array, dimension (N)
23381*>         On entry, the eigenvalues of the rank-1-perturbed matrix.
23382*>         On exit, the eigenvalues of the repaired matrix.
23383*> \endverbatim
23384*>
23385*> \param[in,out] Q
23386*> \verbatim
23387*>          Q is COMPLEX*16 array, dimension (LDQ,N)
23388*>         On entry, the eigenvectors of the rank-1-perturbed matrix.
23389*>         On exit, the eigenvectors of the repaired tridiagonal matrix.
23390*> \endverbatim
23391*>
23392*> \param[in] LDQ
23393*> \verbatim
23394*>          LDQ is INTEGER
23395*>         The leading dimension of the array Q.  LDQ >= max(1,N).
23396*> \endverbatim
23397*>
23398*> \param[in] RHO
23399*> \verbatim
23400*>          RHO is DOUBLE PRECISION
23401*>         Contains the subdiagonal element used to create the rank-1
23402*>         modification.
23403*> \endverbatim
23404*>
23405*> \param[out] INDXQ
23406*> \verbatim
23407*>          INDXQ is INTEGER array, dimension (N)
23408*>         This contains the permutation which will reintegrate the
23409*>         subproblem just solved back into sorted order,
23410*>         ie. D( INDXQ( I = 1, N ) ) will be in ascending order.
23411*> \endverbatim
23412*>
23413*> \param[out] IWORK
23414*> \verbatim
23415*>          IWORK is INTEGER array, dimension (4*N)
23416*> \endverbatim
23417*>
23418*> \param[out] RWORK
23419*> \verbatim
23420*>          RWORK is DOUBLE PRECISION array,
23421*>                                 dimension (3*N+2*QSIZ*N)
23422*> \endverbatim
23423*>
23424*> \param[out] WORK
23425*> \verbatim
23426*>          WORK is COMPLEX*16 array, dimension (QSIZ*N)
23427*> \endverbatim
23428*>
23429*> \param[in,out] QSTORE
23430*> \verbatim
23431*>          QSTORE is DOUBLE PRECISION array, dimension (N**2+1)
23432*>         Stores eigenvectors of submatrices encountered during
23433*>         divide and conquer, packed together. QPTR points to
23434*>         beginning of the submatrices.
23435*> \endverbatim
23436*>
23437*> \param[in,out] QPTR
23438*> \verbatim
23439*>          QPTR is INTEGER array, dimension (N+2)
23440*>         List of indices pointing to beginning of submatrices stored
23441*>         in QSTORE. The submatrices are numbered starting at the
23442*>         bottom left of the divide and conquer tree, from left to
23443*>         right and bottom to top.
23444*> \endverbatim
23445*>
23446*> \param[in] PRMPTR
23447*> \verbatim
23448*>          PRMPTR is INTEGER array, dimension (N lg N)
23449*>         Contains a list of pointers which indicate where in PERM a
23450*>         level's permutation is stored.  PRMPTR(i+1) - PRMPTR(i)
23451*>         indicates the size of the permutation and also the size of
23452*>         the full, non-deflated problem.
23453*> \endverbatim
23454*>
23455*> \param[in] PERM
23456*> \verbatim
23457*>          PERM is INTEGER array, dimension (N lg N)
23458*>         Contains the permutations (from deflation and sorting) to be
23459*>         applied to each eigenblock.
23460*> \endverbatim
23461*>
23462*> \param[in] GIVPTR
23463*> \verbatim
23464*>          GIVPTR is INTEGER array, dimension (N lg N)
23465*>         Contains a list of pointers which indicate where in GIVCOL a
23466*>         level's Givens rotations are stored.  GIVPTR(i+1) - GIVPTR(i)
23467*>         indicates the number of Givens rotations.
23468*> \endverbatim
23469*>
23470*> \param[in] GIVCOL
23471*> \verbatim
23472*>          GIVCOL is INTEGER array, dimension (2, N lg N)
23473*>         Each pair of numbers indicates a pair of columns to take place
23474*>         in a Givens rotation.
23475*> \endverbatim
23476*>
23477*> \param[in] GIVNUM
23478*> \verbatim
23479*>          GIVNUM is DOUBLE PRECISION array, dimension (2, N lg N)
23480*>         Each number indicates the S value to be used in the
23481*>         corresponding Givens rotation.
23482*> \endverbatim
23483*>
23484*> \param[out] INFO
23485*> \verbatim
23486*>          INFO is INTEGER
23487*>          = 0:  successful exit.
23488*>          < 0:  if INFO = -i, the i-th argument had an illegal value.
23489*>          > 0:  if INFO = 1, an eigenvalue did not converge
23490*> \endverbatim
23491*
23492*  Authors:
23493*  ========
23494*
23495*> \author Univ. of Tennessee
23496*> \author Univ. of California Berkeley
23497*> \author Univ. of Colorado Denver
23498*> \author NAG Ltd.
23499*
23500*> \date June 2016
23501*
23502*> \ingroup complex16OTHERcomputational
23503*
23504*  =====================================================================
23505      SUBROUTINE ZLAED7( N, CUTPNT, QSIZ, TLVLS, CURLVL, CURPBM, D, Q,
23506     $                   LDQ, RHO, INDXQ, QSTORE, QPTR, PRMPTR, PERM,
23507     $                   GIVPTR, GIVCOL, GIVNUM, WORK, RWORK, IWORK,
23508     $                   INFO )
23509*
23510*  -- LAPACK computational routine (version 3.7.0) --
23511*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
23512*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
23513*     June 2016
23514*
23515*     .. Scalar Arguments ..
23516      INTEGER            CURLVL, CURPBM, CUTPNT, INFO, LDQ, N, QSIZ,
23517     $                   TLVLS
23518      DOUBLE PRECISION   RHO
23519*     ..
23520*     .. Array Arguments ..
23521      INTEGER            GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ),
23522     $                   IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * )
23523      DOUBLE PRECISION   D( * ), GIVNUM( 2, * ), QSTORE( * ), RWORK( * )
23524      COMPLEX*16         Q( LDQ, * ), WORK( * )
23525*     ..
23526*
23527*  =====================================================================
23528*
23529*     .. Local Scalars ..
23530      INTEGER            COLTYP, CURR, I, IDLMDA, INDX,
23531     $                   INDXC, INDXP, IQ, IW, IZ, K, N1, N2, PTR
23532*     ..
23533*     .. External Subroutines ..
23534      EXTERNAL           DLAED9, DLAEDA, DLAMRG, XERBLA, ZLACRM, ZLAED8
23535*     ..
23536*     .. Intrinsic Functions ..
23537      INTRINSIC          MAX, MIN
23538*     ..
23539*     .. Executable Statements ..
23540*
23541*     Test the input parameters.
23542*
23543      INFO = 0
23544*
23545*     IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN
23546*        INFO = -1
23547*     ELSE IF( N.LT.0 ) THEN
23548      IF( N.LT.0 ) THEN
23549         INFO = -1
23550      ELSE IF( MIN( 1, N ).GT.CUTPNT .OR. N.LT.CUTPNT ) THEN
23551         INFO = -2
23552      ELSE IF( QSIZ.LT.N ) THEN
23553         INFO = -3
23554      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
23555         INFO = -9
23556      END IF
23557      IF( INFO.NE.0 ) THEN
23558         CALL XERBLA( 'ZLAED7', -INFO )
23559         RETURN
23560      END IF
23561*
23562*     Quick return if possible
23563*
23564      IF( N.EQ.0 )
23565     $   RETURN
23566*
23567*     The following values are for bookkeeping purposes only.  They are
23568*     integer pointers which indicate the portion of the workspace
23569*     used by a particular array in DLAED2 and SLAED3.
23570*
23571      IZ = 1
23572      IDLMDA = IZ + N
23573      IW = IDLMDA + N
23574      IQ = IW + N
23575*
23576      INDX = 1
23577      INDXC = INDX + N
23578      COLTYP = INDXC + N
23579      INDXP = COLTYP + N
23580*
23581*     Form the z-vector which consists of the last row of Q_1 and the
23582*     first row of Q_2.
23583*
23584      PTR = 1 + 2**TLVLS
23585      DO 10 I = 1, CURLVL - 1
23586         PTR = PTR + 2**( TLVLS-I )
23587   10 CONTINUE
23588      CURR = PTR + CURPBM
23589      CALL DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR,
23590     $             GIVCOL, GIVNUM, QSTORE, QPTR, RWORK( IZ ),
23591     $             RWORK( IZ+N ), INFO )
23592*
23593*     When solving the final problem, we no longer need the stored data,
23594*     so we will overwrite the data from this level onto the previously
23595*     used storage space.
23596*
23597      IF( CURLVL.EQ.TLVLS ) THEN
23598         QPTR( CURR ) = 1
23599         PRMPTR( CURR ) = 1
23600         GIVPTR( CURR ) = 1
23601      END IF
23602*
23603*     Sort and Deflate eigenvalues.
23604*
23605      CALL ZLAED8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, RWORK( IZ ),
23606     $             RWORK( IDLMDA ), WORK, QSIZ, RWORK( IW ),
23607     $             IWORK( INDXP ), IWORK( INDX ), INDXQ,
23608     $             PERM( PRMPTR( CURR ) ), GIVPTR( CURR+1 ),
23609     $             GIVCOL( 1, GIVPTR( CURR ) ),
23610     $             GIVNUM( 1, GIVPTR( CURR ) ), INFO )
23611      PRMPTR( CURR+1 ) = PRMPTR( CURR ) + N
23612      GIVPTR( CURR+1 ) = GIVPTR( CURR+1 ) + GIVPTR( CURR )
23613*
23614*     Solve Secular Equation.
23615*
23616      IF( K.NE.0 ) THEN
23617         CALL DLAED9( K, 1, K, N, D, RWORK( IQ ), K, RHO,
23618     $                RWORK( IDLMDA ), RWORK( IW ),
23619     $                QSTORE( QPTR( CURR ) ), K, INFO )
23620         CALL ZLACRM( QSIZ, K, WORK, QSIZ, QSTORE( QPTR( CURR ) ), K, Q,
23621     $                LDQ, RWORK( IQ ) )
23622         QPTR( CURR+1 ) = QPTR( CURR ) + K**2
23623         IF( INFO.NE.0 ) THEN
23624            RETURN
23625         END IF
23626*
23627*     Prepare the INDXQ sorting premutation.
23628*
23629         N1 = K
23630         N2 = N - K
23631         CALL DLAMRG( N1, N2, D, 1, -1, INDXQ )
23632      ELSE
23633         QPTR( CURR+1 ) = QPTR( CURR )
23634         DO 20 I = 1, N
23635            INDXQ( I ) = I
23636   20    CONTINUE
23637      END IF
23638*
23639      RETURN
23640*
23641*     End of ZLAED7
23642*
23643      END
23644*> \brief \b ZLAED8 used by sstedc. Merges eigenvalues and deflates secular equation. Used when the original matrix is dense.
23645*
23646*  =========== DOCUMENTATION ===========
23647*
23648* Online html documentation available at
23649*            http://www.netlib.org/lapack/explore-html/
23650*
23651*> \htmlonly
23652*> Download ZLAED8 + dependencies
23653*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlaed8.f">
23654*> [TGZ]</a>
23655*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlaed8.f">
23656*> [ZIP]</a>
23657*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlaed8.f">
23658*> [TXT]</a>
23659*> \endhtmlonly
23660*
23661*  Definition:
23662*  ===========
23663*
23664*       SUBROUTINE ZLAED8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, Z, DLAMDA,
23665*                          Q2, LDQ2, W, INDXP, INDX, INDXQ, PERM, GIVPTR,
23666*                          GIVCOL, GIVNUM, INFO )
23667*
23668*       .. Scalar Arguments ..
23669*       INTEGER            CUTPNT, GIVPTR, INFO, K, LDQ, LDQ2, N, QSIZ
23670*       DOUBLE PRECISION   RHO
23671*       ..
23672*       .. Array Arguments ..
23673*       INTEGER            GIVCOL( 2, * ), INDX( * ), INDXP( * ),
23674*      $                   INDXQ( * ), PERM( * )
23675*       DOUBLE PRECISION   D( * ), DLAMDA( * ), GIVNUM( 2, * ), W( * ),
23676*      $                   Z( * )
23677*       COMPLEX*16         Q( LDQ, * ), Q2( LDQ2, * )
23678*       ..
23679*
23680*
23681*> \par Purpose:
23682*  =============
23683*>
23684*> \verbatim
23685*>
23686*> ZLAED8 merges the two sets of eigenvalues together into a single
23687*> sorted set.  Then it tries to deflate the size of the problem.
23688*> There are two ways in which deflation can occur:  when two or more
23689*> eigenvalues are close together or if there is a tiny element in the
23690*> Z vector.  For each such occurrence the order of the related secular
23691*> equation problem is reduced by one.
23692*> \endverbatim
23693*
23694*  Arguments:
23695*  ==========
23696*
23697*> \param[out] K
23698*> \verbatim
23699*>          K is INTEGER
23700*>         Contains the number of non-deflated eigenvalues.
23701*>         This is the order of the related secular equation.
23702*> \endverbatim
23703*>
23704*> \param[in] N
23705*> \verbatim
23706*>          N is INTEGER
23707*>         The dimension of the symmetric tridiagonal matrix.  N >= 0.
23708*> \endverbatim
23709*>
23710*> \param[in] QSIZ
23711*> \verbatim
23712*>          QSIZ is INTEGER
23713*>         The dimension of the unitary matrix used to reduce
23714*>         the dense or band matrix to tridiagonal form.
23715*>         QSIZ >= N if ICOMPQ = 1.
23716*> \endverbatim
23717*>
23718*> \param[in,out] Q
23719*> \verbatim
23720*>          Q is COMPLEX*16 array, dimension (LDQ,N)
23721*>         On entry, Q contains the eigenvectors of the partially solved
23722*>         system which has been previously updated in matrix
23723*>         multiplies with other partially solved eigensystems.
23724*>         On exit, Q contains the trailing (N-K) updated eigenvectors
23725*>         (those which were deflated) in its last N-K columns.
23726*> \endverbatim
23727*>
23728*> \param[in] LDQ
23729*> \verbatim
23730*>          LDQ is INTEGER
23731*>         The leading dimension of the array Q.  LDQ >= max( 1, N ).
23732*> \endverbatim
23733*>
23734*> \param[in,out] D
23735*> \verbatim
23736*>          D is DOUBLE PRECISION array, dimension (N)
23737*>         On entry, D contains the eigenvalues of the two submatrices to
23738*>         be combined.  On exit, D contains the trailing (N-K) updated
23739*>         eigenvalues (those which were deflated) sorted into increasing
23740*>         order.
23741*> \endverbatim
23742*>
23743*> \param[in,out] RHO
23744*> \verbatim
23745*>          RHO is DOUBLE PRECISION
23746*>         Contains the off diagonal element associated with the rank-1
23747*>         cut which originally split the two submatrices which are now
23748*>         being recombined. RHO is modified during the computation to
23749*>         the value required by DLAED3.
23750*> \endverbatim
23751*>
23752*> \param[in] CUTPNT
23753*> \verbatim
23754*>          CUTPNT is INTEGER
23755*>         Contains the location of the last eigenvalue in the leading
23756*>         sub-matrix.  MIN(1,N) <= CUTPNT <= N.
23757*> \endverbatim
23758*>
23759*> \param[in] Z
23760*> \verbatim
23761*>          Z is DOUBLE PRECISION array, dimension (N)
23762*>         On input this vector contains the updating vector (the last
23763*>         row of the first sub-eigenvector matrix and the first row of
23764*>         the second sub-eigenvector matrix).  The contents of Z are
23765*>         destroyed during the updating process.
23766*> \endverbatim
23767*>
23768*> \param[out] DLAMDA
23769*> \verbatim
23770*>          DLAMDA is DOUBLE PRECISION array, dimension (N)
23771*>         Contains a copy of the first K eigenvalues which will be used
23772*>         by DLAED3 to form the secular equation.
23773*> \endverbatim
23774*>
23775*> \param[out] Q2
23776*> \verbatim
23777*>          Q2 is COMPLEX*16 array, dimension (LDQ2,N)
23778*>         If ICOMPQ = 0, Q2 is not referenced.  Otherwise,
23779*>         Contains a copy of the first K eigenvectors which will be used
23780*>         by DLAED7 in a matrix multiply (DGEMM) to update the new
23781*>         eigenvectors.
23782*> \endverbatim
23783*>
23784*> \param[in] LDQ2
23785*> \verbatim
23786*>          LDQ2 is INTEGER
23787*>         The leading dimension of the array Q2.  LDQ2 >= max( 1, N ).
23788*> \endverbatim
23789*>
23790*> \param[out] W
23791*> \verbatim
23792*>          W is DOUBLE PRECISION array, dimension (N)
23793*>         This will hold the first k values of the final
23794*>         deflation-altered z-vector and will be passed to DLAED3.
23795*> \endverbatim
23796*>
23797*> \param[out] INDXP
23798*> \verbatim
23799*>          INDXP is INTEGER array, dimension (N)
23800*>         This will contain the permutation used to place deflated
23801*>         values of D at the end of the array. On output INDXP(1:K)
23802*>         points to the nondeflated D-values and INDXP(K+1:N)
23803*>         points to the deflated eigenvalues.
23804*> \endverbatim
23805*>
23806*> \param[out] INDX
23807*> \verbatim
23808*>          INDX is INTEGER array, dimension (N)
23809*>         This will contain the permutation used to sort the contents of
23810*>         D into ascending order.
23811*> \endverbatim
23812*>
23813*> \param[in] INDXQ
23814*> \verbatim
23815*>          INDXQ is INTEGER array, dimension (N)
23816*>         This contains the permutation which separately sorts the two
23817*>         sub-problems in D into ascending order.  Note that elements in
23818*>         the second half of this permutation must first have CUTPNT
23819*>         added to their values in order to be accurate.
23820*> \endverbatim
23821*>
23822*> \param[out] PERM
23823*> \verbatim
23824*>          PERM is INTEGER array, dimension (N)
23825*>         Contains the permutations (from deflation and sorting) to be
23826*>         applied to each eigenblock.
23827*> \endverbatim
23828*>
23829*> \param[out] GIVPTR
23830*> \verbatim
23831*>          GIVPTR is INTEGER
23832*>         Contains the number of Givens rotations which took place in
23833*>         this subproblem.
23834*> \endverbatim
23835*>
23836*> \param[out] GIVCOL
23837*> \verbatim
23838*>          GIVCOL is INTEGER array, dimension (2, N)
23839*>         Each pair of numbers indicates a pair of columns to take place
23840*>         in a Givens rotation.
23841*> \endverbatim
23842*>
23843*> \param[out] GIVNUM
23844*> \verbatim
23845*>          GIVNUM is DOUBLE PRECISION array, dimension (2, N)
23846*>         Each number indicates the S value to be used in the
23847*>         corresponding Givens rotation.
23848*> \endverbatim
23849*>
23850*> \param[out] INFO
23851*> \verbatim
23852*>          INFO is INTEGER
23853*>          = 0:  successful exit.
23854*>          < 0:  if INFO = -i, the i-th argument had an illegal value.
23855*> \endverbatim
23856*
23857*  Authors:
23858*  ========
23859*
23860*> \author Univ. of Tennessee
23861*> \author Univ. of California Berkeley
23862*> \author Univ. of Colorado Denver
23863*> \author NAG Ltd.
23864*
23865*> \date December 2016
23866*
23867*> \ingroup complex16OTHERcomputational
23868*
23869*  =====================================================================
23870      SUBROUTINE ZLAED8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, Z, DLAMDA,
23871     $                   Q2, LDQ2, W, INDXP, INDX, INDXQ, PERM, GIVPTR,
23872     $                   GIVCOL, GIVNUM, INFO )
23873*
23874*  -- LAPACK computational routine (version 3.7.0) --
23875*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
23876*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
23877*     December 2016
23878*
23879*     .. Scalar Arguments ..
23880      INTEGER            CUTPNT, GIVPTR, INFO, K, LDQ, LDQ2, N, QSIZ
23881      DOUBLE PRECISION   RHO
23882*     ..
23883*     .. Array Arguments ..
23884      INTEGER            GIVCOL( 2, * ), INDX( * ), INDXP( * ),
23885     $                   INDXQ( * ), PERM( * )
23886      DOUBLE PRECISION   D( * ), DLAMDA( * ), GIVNUM( 2, * ), W( * ),
23887     $                   Z( * )
23888      COMPLEX*16         Q( LDQ, * ), Q2( LDQ2, * )
23889*     ..
23890*
23891*  =====================================================================
23892*
23893*     .. Parameters ..
23894      DOUBLE PRECISION   MONE, ZERO, ONE, TWO, EIGHT
23895      PARAMETER          ( MONE = -1.0D0, ZERO = 0.0D0, ONE = 1.0D0,
23896     $                   TWO = 2.0D0, EIGHT = 8.0D0 )
23897*     ..
23898*     .. Local Scalars ..
23899      INTEGER            I, IMAX, J, JLAM, JMAX, JP, K2, N1, N1P1, N2
23900      DOUBLE PRECISION   C, EPS, S, T, TAU, TOL
23901*     ..
23902*     .. External Functions ..
23903      INTEGER            IDAMAX
23904      DOUBLE PRECISION   DLAMCH, DLAPY2
23905      EXTERNAL           IDAMAX, DLAMCH, DLAPY2
23906*     ..
23907*     .. External Subroutines ..
23908      EXTERNAL           DCOPY, DLAMRG, DSCAL, XERBLA, ZCOPY, ZDROT,
23909     $                   ZLACPY
23910*     ..
23911*     .. Intrinsic Functions ..
23912      INTRINSIC          ABS, MAX, MIN, SQRT
23913*     ..
23914*     .. Executable Statements ..
23915*
23916*     Test the input parameters.
23917*
23918      INFO = 0
23919*
23920      IF( N.LT.0 ) THEN
23921         INFO = -2
23922      ELSE IF( QSIZ.LT.N ) THEN
23923         INFO = -3
23924      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
23925         INFO = -5
23926      ELSE IF( CUTPNT.LT.MIN( 1, N ) .OR. CUTPNT.GT.N ) THEN
23927         INFO = -8
23928      ELSE IF( LDQ2.LT.MAX( 1, N ) ) THEN
23929         INFO = -12
23930      END IF
23931      IF( INFO.NE.0 ) THEN
23932         CALL XERBLA( 'ZLAED8', -INFO )
23933         RETURN
23934      END IF
23935*
23936*     Need to initialize GIVPTR to O here in case of quick exit
23937*     to prevent an unspecified code behavior (usually sigfault)
23938*     when IWORK array on entry to *stedc is not zeroed
23939*     (or at least some IWORK entries which used in *laed7 for GIVPTR).
23940*
23941      GIVPTR = 0
23942*
23943*     Quick return if possible
23944*
23945      IF( N.EQ.0 )
23946     $   RETURN
23947*
23948      N1 = CUTPNT
23949      N2 = N - N1
23950      N1P1 = N1 + 1
23951*
23952      IF( RHO.LT.ZERO ) THEN
23953         CALL DSCAL( N2, MONE, Z( N1P1 ), 1 )
23954      END IF
23955*
23956*     Normalize z so that norm(z) = 1
23957*
23958      T = ONE / SQRT( TWO )
23959      DO 10 J = 1, N
23960         INDX( J ) = J
23961   10 CONTINUE
23962      CALL DSCAL( N, T, Z, 1 )
23963      RHO = ABS( TWO*RHO )
23964*
23965*     Sort the eigenvalues into increasing order
23966*
23967      DO 20 I = CUTPNT + 1, N
23968         INDXQ( I ) = INDXQ( I ) + CUTPNT
23969   20 CONTINUE
23970      DO 30 I = 1, N
23971         DLAMDA( I ) = D( INDXQ( I ) )
23972         W( I ) = Z( INDXQ( I ) )
23973   30 CONTINUE
23974      I = 1
23975      J = CUTPNT + 1
23976      CALL DLAMRG( N1, N2, DLAMDA, 1, 1, INDX )
23977      DO 40 I = 1, N
23978         D( I ) = DLAMDA( INDX( I ) )
23979         Z( I ) = W( INDX( I ) )
23980   40 CONTINUE
23981*
23982*     Calculate the allowable deflation tolerance
23983*
23984      IMAX = IDAMAX( N, Z, 1 )
23985      JMAX = IDAMAX( N, D, 1 )
23986      EPS = DLAMCH( 'Epsilon' )
23987      TOL = EIGHT*EPS*ABS( D( JMAX ) )
23988*
23989*     If the rank-1 modifier is small enough, no more needs to be done
23990*     -- except to reorganize Q so that its columns correspond with the
23991*     elements in D.
23992*
23993      IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN
23994         K = 0
23995         DO 50 J = 1, N
23996            PERM( J ) = INDXQ( INDX( J ) )
23997            CALL ZCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )
23998   50    CONTINUE
23999         CALL ZLACPY( 'A', QSIZ, N, Q2( 1, 1 ), LDQ2, Q( 1, 1 ), LDQ )
24000         RETURN
24001      END IF
24002*
24003*     If there are multiple eigenvalues then the problem deflates.  Here
24004*     the number of equal eigenvalues are found.  As each equal
24005*     eigenvalue is found, an elementary reflector is computed to rotate
24006*     the corresponding eigensubspace so that the corresponding
24007*     components of Z are zero in this new basis.
24008*
24009      K = 0
24010      K2 = N + 1
24011      DO 60 J = 1, N
24012         IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN
24013*
24014*           Deflate due to small z component.
24015*
24016            K2 = K2 - 1
24017            INDXP( K2 ) = J
24018            IF( J.EQ.N )
24019     $         GO TO 100
24020         ELSE
24021            JLAM = J
24022            GO TO 70
24023         END IF
24024   60 CONTINUE
24025   70 CONTINUE
24026      J = J + 1
24027      IF( J.GT.N )
24028     $   GO TO 90
24029      IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN
24030*
24031*        Deflate due to small z component.
24032*
24033         K2 = K2 - 1
24034         INDXP( K2 ) = J
24035      ELSE
24036*
24037*        Check if eigenvalues are close enough to allow deflation.
24038*
24039         S = Z( JLAM )
24040         C = Z( J )
24041*
24042*        Find sqrt(a**2+b**2) without overflow or
24043*        destructive underflow.
24044*
24045         TAU = DLAPY2( C, S )
24046         T = D( J ) - D( JLAM )
24047         C = C / TAU
24048         S = -S / TAU
24049         IF( ABS( T*C*S ).LE.TOL ) THEN
24050*
24051*           Deflation is possible.
24052*
24053            Z( J ) = TAU
24054            Z( JLAM ) = ZERO
24055*
24056*           Record the appropriate Givens rotation
24057*
24058            GIVPTR = GIVPTR + 1
24059            GIVCOL( 1, GIVPTR ) = INDXQ( INDX( JLAM ) )
24060            GIVCOL( 2, GIVPTR ) = INDXQ( INDX( J ) )
24061            GIVNUM( 1, GIVPTR ) = C
24062            GIVNUM( 2, GIVPTR ) = S
24063            CALL ZDROT( QSIZ, Q( 1, INDXQ( INDX( JLAM ) ) ), 1,
24064     $                  Q( 1, INDXQ( INDX( J ) ) ), 1, C, S )
24065            T = D( JLAM )*C*C + D( J )*S*S
24066            D( J ) = D( JLAM )*S*S + D( J )*C*C
24067            D( JLAM ) = T
24068            K2 = K2 - 1
24069            I = 1
24070   80       CONTINUE
24071            IF( K2+I.LE.N ) THEN
24072               IF( D( JLAM ).LT.D( INDXP( K2+I ) ) ) THEN
24073                  INDXP( K2+I-1 ) = INDXP( K2+I )
24074                  INDXP( K2+I ) = JLAM
24075                  I = I + 1
24076                  GO TO 80
24077               ELSE
24078                  INDXP( K2+I-1 ) = JLAM
24079               END IF
24080            ELSE
24081               INDXP( K2+I-1 ) = JLAM
24082            END IF
24083            JLAM = J
24084         ELSE
24085            K = K + 1
24086            W( K ) = Z( JLAM )
24087            DLAMDA( K ) = D( JLAM )
24088            INDXP( K ) = JLAM
24089            JLAM = J
24090         END IF
24091      END IF
24092      GO TO 70
24093   90 CONTINUE
24094*
24095*     Record the last eigenvalue.
24096*
24097      K = K + 1
24098      W( K ) = Z( JLAM )
24099      DLAMDA( K ) = D( JLAM )
24100      INDXP( K ) = JLAM
24101*
24102  100 CONTINUE
24103*
24104*     Sort the eigenvalues and corresponding eigenvectors into DLAMDA
24105*     and Q2 respectively.  The eigenvalues/vectors which were not
24106*     deflated go into the first K slots of DLAMDA and Q2 respectively,
24107*     while those which were deflated go into the last N - K slots.
24108*
24109      DO 110 J = 1, N
24110         JP = INDXP( J )
24111         DLAMDA( J ) = D( JP )
24112         PERM( J ) = INDXQ( INDX( JP ) )
24113         CALL ZCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )
24114  110 CONTINUE
24115*
24116*     The deflated eigenvalues and their corresponding vectors go back
24117*     into the last N - K slots of D and Q respectively.
24118*
24119      IF( K.LT.N ) THEN
24120         CALL DCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 )
24121         CALL ZLACPY( 'A', QSIZ, N-K, Q2( 1, K+1 ), LDQ2, Q( 1, K+1 ),
24122     $                LDQ )
24123      END IF
24124*
24125      RETURN
24126*
24127*     End of ZLAED8
24128*
24129      END
24130*> \brief \b ZLAHQR computes the eigenvalues and Schur factorization of an upper Hessenberg matrix, using the double-shift/single-shift QR algorithm.
24131*
24132*  =========== DOCUMENTATION ===========
24133*
24134* Online html documentation available at
24135*            http://www.netlib.org/lapack/explore-html/
24136*
24137*> \htmlonly
24138*> Download ZLAHQR + dependencies
24139*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlahqr.f">
24140*> [TGZ]</a>
24141*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlahqr.f">
24142*> [ZIP]</a>
24143*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlahqr.f">
24144*> [TXT]</a>
24145*> \endhtmlonly
24146*
24147*  Definition:
24148*  ===========
24149*
24150*       SUBROUTINE ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
24151*                          IHIZ, Z, LDZ, INFO )
24152*
24153*       .. Scalar Arguments ..
24154*       INTEGER            IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N
24155*       LOGICAL            WANTT, WANTZ
24156*       ..
24157*       .. Array Arguments ..
24158*       COMPLEX*16         H( LDH, * ), W( * ), Z( LDZ, * )
24159*       ..
24160*
24161*
24162*> \par Purpose:
24163*  =============
24164*>
24165*> \verbatim
24166*>
24167*>    ZLAHQR is an auxiliary routine called by CHSEQR to update the
24168*>    eigenvalues and Schur decomposition already computed by CHSEQR, by
24169*>    dealing with the Hessenberg submatrix in rows and columns ILO to
24170*>    IHI.
24171*> \endverbatim
24172*
24173*  Arguments:
24174*  ==========
24175*
24176*> \param[in] WANTT
24177*> \verbatim
24178*>          WANTT is LOGICAL
24179*>          = .TRUE. : the full Schur form T is required;
24180*>          = .FALSE.: only eigenvalues are required.
24181*> \endverbatim
24182*>
24183*> \param[in] WANTZ
24184*> \verbatim
24185*>          WANTZ is LOGICAL
24186*>          = .TRUE. : the matrix of Schur vectors Z is required;
24187*>          = .FALSE.: Schur vectors are not required.
24188*> \endverbatim
24189*>
24190*> \param[in] N
24191*> \verbatim
24192*>          N is INTEGER
24193*>          The order of the matrix H.  N >= 0.
24194*> \endverbatim
24195*>
24196*> \param[in] ILO
24197*> \verbatim
24198*>          ILO is INTEGER
24199*> \endverbatim
24200*>
24201*> \param[in] IHI
24202*> \verbatim
24203*>          IHI is INTEGER
24204*>          It is assumed that H is already upper triangular in rows and
24205*>          columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1).
24206*>          ZLAHQR works primarily with the Hessenberg submatrix in rows
24207*>          and columns ILO to IHI, but applies transformations to all of
24208*>          H if WANTT is .TRUE..
24209*>          1 <= ILO <= max(1,IHI); IHI <= N.
24210*> \endverbatim
24211*>
24212*> \param[in,out] H
24213*> \verbatim
24214*>          H is COMPLEX*16 array, dimension (LDH,N)
24215*>          On entry, the upper Hessenberg matrix H.
24216*>          On exit, if INFO is zero and if WANTT is .TRUE., then H
24217*>          is upper triangular in rows and columns ILO:IHI.  If INFO
24218*>          is zero and if WANTT is .FALSE., then the contents of H
24219*>          are unspecified on exit.  The output state of H in case
24220*>          INF is positive is below under the description of INFO.
24221*> \endverbatim
24222*>
24223*> \param[in] LDH
24224*> \verbatim
24225*>          LDH is INTEGER
24226*>          The leading dimension of the array H. LDH >= max(1,N).
24227*> \endverbatim
24228*>
24229*> \param[out] W
24230*> \verbatim
24231*>          W is COMPLEX*16 array, dimension (N)
24232*>          The computed eigenvalues ILO to IHI are stored in the
24233*>          corresponding elements of W. If WANTT is .TRUE., the
24234*>          eigenvalues are stored in the same order as on the diagonal
24235*>          of the Schur form returned in H, with W(i) = H(i,i).
24236*> \endverbatim
24237*>
24238*> \param[in] ILOZ
24239*> \verbatim
24240*>          ILOZ is INTEGER
24241*> \endverbatim
24242*>
24243*> \param[in] IHIZ
24244*> \verbatim
24245*>          IHIZ is INTEGER
24246*>          Specify the rows of Z to which transformations must be
24247*>          applied if WANTZ is .TRUE..
24248*>          1 <= ILOZ <= ILO; IHI <= IHIZ <= N.
24249*> \endverbatim
24250*>
24251*> \param[in,out] Z
24252*> \verbatim
24253*>          Z is COMPLEX*16 array, dimension (LDZ,N)
24254*>          If WANTZ is .TRUE., on entry Z must contain the current
24255*>          matrix Z of transformations accumulated by CHSEQR, and on
24256*>          exit Z has been updated; transformations are applied only to
24257*>          the submatrix Z(ILOZ:IHIZ,ILO:IHI).
24258*>          If WANTZ is .FALSE., Z is not referenced.
24259*> \endverbatim
24260*>
24261*> \param[in] LDZ
24262*> \verbatim
24263*>          LDZ is INTEGER
24264*>          The leading dimension of the array Z. LDZ >= max(1,N).
24265*> \endverbatim
24266*>
24267*> \param[out] INFO
24268*> \verbatim
24269*>          INFO is INTEGER
24270*>           = 0:   successful exit
24271*>           > 0:   if INFO = i, ZLAHQR failed to compute all the
24272*>                  eigenvalues ILO to IHI in a total of 30 iterations
24273*>                  per eigenvalue; elements i+1:ihi of W contain
24274*>                  those eigenvalues which have been successfully
24275*>                  computed.
24276*>
24277*>                  If INFO > 0 and WANTT is .FALSE., then on exit,
24278*>                  the remaining unconverged eigenvalues are the
24279*>                  eigenvalues of the upper Hessenberg matrix
24280*>                  rows and columns ILO through INFO of the final,
24281*>                  output value of H.
24282*>
24283*>                  If INFO > 0 and WANTT is .TRUE., then on exit
24284*>          (*)       (initial value of H)*U  = U*(final value of H)
24285*>                  where U is an orthogonal matrix.    The final
24286*>                  value of H is upper Hessenberg and triangular in
24287*>                  rows and columns INFO+1 through IHI.
24288*>
24289*>                  If INFO > 0 and WANTZ is .TRUE., then on exit
24290*>                      (final value of Z)  = (initial value of Z)*U
24291*>                  where U is the orthogonal matrix in (*)
24292*>                  (regardless of the value of WANTT.)
24293*> \endverbatim
24294*
24295*  Authors:
24296*  ========
24297*
24298*> \author Univ. of Tennessee
24299*> \author Univ. of California Berkeley
24300*> \author Univ. of Colorado Denver
24301*> \author NAG Ltd.
24302*
24303*> \date December 2016
24304*
24305*> \ingroup complex16OTHERauxiliary
24306*
24307*> \par Contributors:
24308*  ==================
24309*>
24310*> \verbatim
24311*>
24312*>     02-96 Based on modifications by
24313*>     David Day, Sandia National Laboratory, USA
24314*>
24315*>     12-04 Further modifications by
24316*>     Ralph Byers, University of Kansas, USA
24317*>     This is a modified version of ZLAHQR from LAPACK version 3.0.
24318*>     It is (1) more robust against overflow and underflow and
24319*>     (2) adopts the more conservative Ahues & Tisseur stopping
24320*>     criterion (LAWN 122, 1997).
24321*> \endverbatim
24322*>
24323*  =====================================================================
24324      SUBROUTINE ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
24325     $                   IHIZ, Z, LDZ, INFO )
24326*
24327*  -- LAPACK auxiliary routine (version 3.7.0) --
24328*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
24329*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
24330*     December 2016
24331*
24332*     .. Scalar Arguments ..
24333      INTEGER            IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N
24334      LOGICAL            WANTT, WANTZ
24335*     ..
24336*     .. Array Arguments ..
24337      COMPLEX*16         H( LDH, * ), W( * ), Z( LDZ, * )
24338*     ..
24339*
24340*  =========================================================
24341*
24342*     .. Parameters ..
24343      COMPLEX*16         ZERO, ONE
24344      PARAMETER          ( ZERO = ( 0.0d0, 0.0d0 ),
24345     $                   ONE = ( 1.0d0, 0.0d0 ) )
24346      DOUBLE PRECISION   RZERO, RONE, HALF
24347      PARAMETER          ( RZERO = 0.0d0, RONE = 1.0d0, HALF = 0.5d0 )
24348      DOUBLE PRECISION   DAT1
24349      PARAMETER          ( DAT1 = 3.0d0 / 4.0d0 )
24350*     ..
24351*     .. Local Scalars ..
24352      COMPLEX*16         CDUM, H11, H11S, H22, SC, SUM, T, T1, TEMP, U,
24353     $                   V2, X, Y
24354      DOUBLE PRECISION   AA, AB, BA, BB, H10, H21, RTEMP, S, SAFMAX,
24355     $                   SAFMIN, SMLNUM, SX, T2, TST, ULP
24356      INTEGER            I, I1, I2, ITS, ITMAX, J, JHI, JLO, K, L, M,
24357     $                   NH, NZ
24358*     ..
24359*     .. Local Arrays ..
24360      COMPLEX*16         V( 2 )
24361*     ..
24362*     .. External Functions ..
24363      COMPLEX*16         ZLADIV
24364      DOUBLE PRECISION   DLAMCH
24365      EXTERNAL           ZLADIV, DLAMCH
24366*     ..
24367*     .. External Subroutines ..
24368      EXTERNAL           DLABAD, ZCOPY, ZLARFG, ZSCAL
24369*     ..
24370*     .. Statement Functions ..
24371      DOUBLE PRECISION   CABS1
24372*     ..
24373*     .. Intrinsic Functions ..
24374      INTRINSIC          ABS, DBLE, DCONJG, DIMAG, MAX, MIN, SQRT
24375*     ..
24376*     .. Statement Function definitions ..
24377      CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
24378*     ..
24379*     .. Executable Statements ..
24380*
24381      INFO = 0
24382*
24383*     Quick return if possible
24384*
24385      IF( N.EQ.0 )
24386     $   RETURN
24387      IF( ILO.EQ.IHI ) THEN
24388         W( ILO ) = H( ILO, ILO )
24389         RETURN
24390      END IF
24391*
24392*     ==== clear out the trash ====
24393      DO 10 J = ILO, IHI - 3
24394         H( J+2, J ) = ZERO
24395         H( J+3, J ) = ZERO
24396   10 CONTINUE
24397      IF( ILO.LE.IHI-2 )
24398     $   H( IHI, IHI-2 ) = ZERO
24399*     ==== ensure that subdiagonal entries are real ====
24400      IF( WANTT ) THEN
24401         JLO = 1
24402         JHI = N
24403      ELSE
24404         JLO = ILO
24405         JHI = IHI
24406      END IF
24407      DO 20 I = ILO + 1, IHI
24408         IF( DIMAG( H( I, I-1 ) ).NE.RZERO ) THEN
24409*           ==== The following redundant normalization
24410*           .    avoids problems with both gradual and
24411*           .    sudden underflow in ABS(H(I,I-1)) ====
24412            SC = H( I, I-1 ) / CABS1( H( I, I-1 ) )
24413            SC = DCONJG( SC ) / ABS( SC )
24414            H( I, I-1 ) = ABS( H( I, I-1 ) )
24415            CALL ZSCAL( JHI-I+1, SC, H( I, I ), LDH )
24416            CALL ZSCAL( MIN( JHI, I+1 )-JLO+1, DCONJG( SC ),
24417     $                  H( JLO, I ), 1 )
24418            IF( WANTZ )
24419     $         CALL ZSCAL( IHIZ-ILOZ+1, DCONJG( SC ), Z( ILOZ, I ), 1 )
24420         END IF
24421   20 CONTINUE
24422*
24423      NH = IHI - ILO + 1
24424      NZ = IHIZ - ILOZ + 1
24425*
24426*     Set machine-dependent constants for the stopping criterion.
24427*
24428      SAFMIN = DLAMCH( 'SAFE MINIMUM' )
24429      SAFMAX = RONE / SAFMIN
24430      CALL DLABAD( SAFMIN, SAFMAX )
24431      ULP = DLAMCH( 'PRECISION' )
24432      SMLNUM = SAFMIN*( DBLE( NH ) / ULP )
24433*
24434*     I1 and I2 are the indices of the first row and last column of H
24435*     to which transformations must be applied. If eigenvalues only are
24436*     being computed, I1 and I2 are set inside the main loop.
24437*
24438      IF( WANTT ) THEN
24439         I1 = 1
24440         I2 = N
24441      END IF
24442*
24443*     ITMAX is the total number of QR iterations allowed.
24444*
24445      ITMAX = 30 * MAX( 10, NH )
24446*
24447*     The main loop begins here. I is the loop index and decreases from
24448*     IHI to ILO in steps of 1. Each iteration of the loop works
24449*     with the active submatrix in rows and columns L to I.
24450*     Eigenvalues I+1 to IHI have already converged. Either L = ILO, or
24451*     H(L,L-1) is negligible so that the matrix splits.
24452*
24453      I = IHI
24454   30 CONTINUE
24455      IF( I.LT.ILO )
24456     $   GO TO 150
24457*
24458*     Perform QR iterations on rows and columns ILO to I until a
24459*     submatrix of order 1 splits off at the bottom because a
24460*     subdiagonal element has become negligible.
24461*
24462      L = ILO
24463      DO 130 ITS = 0, ITMAX
24464*
24465*        Look for a single small subdiagonal element.
24466*
24467         DO 40 K = I, L + 1, -1
24468            IF( CABS1( H( K, K-1 ) ).LE.SMLNUM )
24469     $         GO TO 50
24470            TST = CABS1( H( K-1, K-1 ) ) + CABS1( H( K, K ) )
24471            IF( TST.EQ.ZERO ) THEN
24472               IF( K-2.GE.ILO )
24473     $            TST = TST + ABS( DBLE( H( K-1, K-2 ) ) )
24474               IF( K+1.LE.IHI )
24475     $            TST = TST + ABS( DBLE( H( K+1, K ) ) )
24476            END IF
24477*           ==== The following is a conservative small subdiagonal
24478*           .    deflation criterion due to Ahues & Tisseur (LAWN 122,
24479*           .    1997). It has better mathematical foundation and
24480*           .    improves accuracy in some examples.  ====
24481            IF( ABS( DBLE( H( K, K-1 ) ) ).LE.ULP*TST ) THEN
24482               AB = MAX( CABS1( H( K, K-1 ) ), CABS1( H( K-1, K ) ) )
24483               BA = MIN( CABS1( H( K, K-1 ) ), CABS1( H( K-1, K ) ) )
24484               AA = MAX( CABS1( H( K, K ) ),
24485     $              CABS1( H( K-1, K-1 )-H( K, K ) ) )
24486               BB = MIN( CABS1( H( K, K ) ),
24487     $              CABS1( H( K-1, K-1 )-H( K, K ) ) )
24488               S = AA + AB
24489               IF( BA*( AB / S ).LE.MAX( SMLNUM,
24490     $             ULP*( BB*( AA / S ) ) ) )GO TO 50
24491            END IF
24492   40    CONTINUE
24493   50    CONTINUE
24494         L = K
24495         IF( L.GT.ILO ) THEN
24496*
24497*           H(L,L-1) is negligible
24498*
24499            H( L, L-1 ) = ZERO
24500         END IF
24501*
24502*        Exit from loop if a submatrix of order 1 has split off.
24503*
24504         IF( L.GE.I )
24505     $      GO TO 140
24506*
24507*        Now the active submatrix is in rows and columns L to I. If
24508*        eigenvalues only are being computed, only the active submatrix
24509*        need be transformed.
24510*
24511         IF( .NOT.WANTT ) THEN
24512            I1 = L
24513            I2 = I
24514         END IF
24515*
24516         IF( ITS.EQ.10 ) THEN
24517*
24518*           Exceptional shift.
24519*
24520            S = DAT1*ABS( DBLE( H( L+1, L ) ) )
24521            T = S + H( L, L )
24522         ELSE IF( ITS.EQ.20 ) THEN
24523*
24524*           Exceptional shift.
24525*
24526            S = DAT1*ABS( DBLE( H( I, I-1 ) ) )
24527            T = S + H( I, I )
24528         ELSE
24529*
24530*           Wilkinson's shift.
24531*
24532            T = H( I, I )
24533            U = SQRT( H( I-1, I ) )*SQRT( H( I, I-1 ) )
24534            S = CABS1( U )
24535            IF( S.NE.RZERO ) THEN
24536               X = HALF*( H( I-1, I-1 )-T )
24537               SX = CABS1( X )
24538               S = MAX( S, CABS1( X ) )
24539               Y = S*SQRT( ( X / S )**2+( U / S )**2 )
24540               IF( SX.GT.RZERO ) THEN
24541                  IF( DBLE( X / SX )*DBLE( Y )+DIMAG( X / SX )*
24542     $                DIMAG( Y ).LT.RZERO )Y = -Y
24543               END IF
24544               T = T - U*ZLADIV( U, ( X+Y ) )
24545            END IF
24546         END IF
24547*
24548*        Look for two consecutive small subdiagonal elements.
24549*
24550         DO 60 M = I - 1, L + 1, -1
24551*
24552*           Determine the effect of starting the single-shift QR
24553*           iteration at row M, and see if this would make H(M,M-1)
24554*           negligible.
24555*
24556            H11 = H( M, M )
24557            H22 = H( M+1, M+1 )
24558            H11S = H11 - T
24559            H21 = DBLE( H( M+1, M ) )
24560            S = CABS1( H11S ) + ABS( H21 )
24561            H11S = H11S / S
24562            H21 = H21 / S
24563            V( 1 ) = H11S
24564            V( 2 ) = H21
24565            H10 = DBLE( H( M, M-1 ) )
24566            IF( ABS( H10 )*ABS( H21 ).LE.ULP*
24567     $          ( CABS1( H11S )*( CABS1( H11 )+CABS1( H22 ) ) ) )
24568     $          GO TO 70
24569   60    CONTINUE
24570         H11 = H( L, L )
24571         H22 = H( L+1, L+1 )
24572         H11S = H11 - T
24573         H21 = DBLE( H( L+1, L ) )
24574         S = CABS1( H11S ) + ABS( H21 )
24575         H11S = H11S / S
24576         H21 = H21 / S
24577         V( 1 ) = H11S
24578         V( 2 ) = H21
24579   70    CONTINUE
24580*
24581*        Single-shift QR step
24582*
24583         DO 120 K = M, I - 1
24584*
24585*           The first iteration of this loop determines a reflection G
24586*           from the vector V and applies it from left and right to H,
24587*           thus creating a nonzero bulge below the subdiagonal.
24588*
24589*           Each subsequent iteration determines a reflection G to
24590*           restore the Hessenberg form in the (K-1)th column, and thus
24591*           chases the bulge one step toward the bottom of the active
24592*           submatrix.
24593*
24594*           V(2) is always real before the call to ZLARFG, and hence
24595*           after the call T2 ( = T1*V(2) ) is also real.
24596*
24597            IF( K.GT.M )
24598     $         CALL ZCOPY( 2, H( K, K-1 ), 1, V, 1 )
24599            CALL ZLARFG( 2, V( 1 ), V( 2 ), 1, T1 )
24600            IF( K.GT.M ) THEN
24601               H( K, K-1 ) = V( 1 )
24602               H( K+1, K-1 ) = ZERO
24603            END IF
24604            V2 = V( 2 )
24605            T2 = DBLE( T1*V2 )
24606*
24607*           Apply G from the left to transform the rows of the matrix
24608*           in columns K to I2.
24609*
24610            DO 80 J = K, I2
24611               SUM = DCONJG( T1 )*H( K, J ) + T2*H( K+1, J )
24612               H( K, J ) = H( K, J ) - SUM
24613               H( K+1, J ) = H( K+1, J ) - SUM*V2
24614   80       CONTINUE
24615*
24616*           Apply G from the right to transform the columns of the
24617*           matrix in rows I1 to min(K+2,I).
24618*
24619            DO 90 J = I1, MIN( K+2, I )
24620               SUM = T1*H( J, K ) + T2*H( J, K+1 )
24621               H( J, K ) = H( J, K ) - SUM
24622               H( J, K+1 ) = H( J, K+1 ) - SUM*DCONJG( V2 )
24623   90       CONTINUE
24624*
24625            IF( WANTZ ) THEN
24626*
24627*              Accumulate transformations in the matrix Z
24628*
24629               DO 100 J = ILOZ, IHIZ
24630                  SUM = T1*Z( J, K ) + T2*Z( J, K+1 )
24631                  Z( J, K ) = Z( J, K ) - SUM
24632                  Z( J, K+1 ) = Z( J, K+1 ) - SUM*DCONJG( V2 )
24633  100          CONTINUE
24634            END IF
24635*
24636            IF( K.EQ.M .AND. M.GT.L ) THEN
24637*
24638*              If the QR step was started at row M > L because two
24639*              consecutive small subdiagonals were found, then extra
24640*              scaling must be performed to ensure that H(M,M-1) remains
24641*              real.
24642*
24643               TEMP = ONE - T1
24644               TEMP = TEMP / ABS( TEMP )
24645               H( M+1, M ) = H( M+1, M )*DCONJG( TEMP )
24646               IF( M+2.LE.I )
24647     $            H( M+2, M+1 ) = H( M+2, M+1 )*TEMP
24648               DO 110 J = M, I
24649                  IF( J.NE.M+1 ) THEN
24650                     IF( I2.GT.J )
24651     $                  CALL ZSCAL( I2-J, TEMP, H( J, J+1 ), LDH )
24652                     CALL ZSCAL( J-I1, DCONJG( TEMP ), H( I1, J ), 1 )
24653                     IF( WANTZ ) THEN
24654                        CALL ZSCAL( NZ, DCONJG( TEMP ), Z( ILOZ, J ),
24655     $                              1 )
24656                     END IF
24657                  END IF
24658  110          CONTINUE
24659            END IF
24660  120    CONTINUE
24661*
24662*        Ensure that H(I,I-1) is real.
24663*
24664         TEMP = H( I, I-1 )
24665         IF( DIMAG( TEMP ).NE.RZERO ) THEN
24666            RTEMP = ABS( TEMP )
24667            H( I, I-1 ) = RTEMP
24668            TEMP = TEMP / RTEMP
24669            IF( I2.GT.I )
24670     $         CALL ZSCAL( I2-I, DCONJG( TEMP ), H( I, I+1 ), LDH )
24671            CALL ZSCAL( I-I1, TEMP, H( I1, I ), 1 )
24672            IF( WANTZ ) THEN
24673               CALL ZSCAL( NZ, TEMP, Z( ILOZ, I ), 1 )
24674            END IF
24675         END IF
24676*
24677  130 CONTINUE
24678*
24679*     Failure to converge in remaining number of iterations
24680*
24681      INFO = I
24682      RETURN
24683*
24684  140 CONTINUE
24685*
24686*     H(I,I-1) is negligible: one eigenvalue has converged.
24687*
24688      W( I ) = H( I, I )
24689*
24690*     return to start of the main loop with new value of I.
24691*
24692      I = L - 1
24693      GO TO 30
24694*
24695  150 CONTINUE
24696      RETURN
24697*
24698*     End of ZLAHQR
24699*
24700      END
24701*> \brief \b ZLAHR2 reduces the specified number of first columns of a general rectangular matrix A so that elements below the specified subdiagonal are zero, and returns auxiliary matrices which are needed to apply the transformation to the unreduced part of A.
24702*
24703*  =========== DOCUMENTATION ===========
24704*
24705* Online html documentation available at
24706*            http://www.netlib.org/lapack/explore-html/
24707*
24708*> \htmlonly
24709*> Download ZLAHR2 + dependencies
24710*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlahr2.f">
24711*> [TGZ]</a>
24712*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlahr2.f">
24713*> [ZIP]</a>
24714*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlahr2.f">
24715*> [TXT]</a>
24716*> \endhtmlonly
24717*
24718*  Definition:
24719*  ===========
24720*
24721*       SUBROUTINE ZLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )
24722*
24723*       .. Scalar Arguments ..
24724*       INTEGER            K, LDA, LDT, LDY, N, NB
24725*       ..
24726*       .. Array Arguments ..
24727*       COMPLEX*16        A( LDA, * ), T( LDT, NB ), TAU( NB ),
24728*      $                   Y( LDY, NB )
24729*       ..
24730*
24731*
24732*> \par Purpose:
24733*  =============
24734*>
24735*> \verbatim
24736*>
24737*> ZLAHR2 reduces the first NB columns of A complex general n-BY-(n-k+1)
24738*> matrix A so that elements below the k-th subdiagonal are zero. The
24739*> reduction is performed by an unitary similarity transformation
24740*> Q**H * A * Q. The routine returns the matrices V and T which determine
24741*> Q as a block reflector I - V*T*V**H, and also the matrix Y = A * V * T.
24742*>
24743*> This is an auxiliary routine called by ZGEHRD.
24744*> \endverbatim
24745*
24746*  Arguments:
24747*  ==========
24748*
24749*> \param[in] N
24750*> \verbatim
24751*>          N is INTEGER
24752*>          The order of the matrix A.
24753*> \endverbatim
24754*>
24755*> \param[in] K
24756*> \verbatim
24757*>          K is INTEGER
24758*>          The offset for the reduction. Elements below the k-th
24759*>          subdiagonal in the first NB columns are reduced to zero.
24760*>          K < N.
24761*> \endverbatim
24762*>
24763*> \param[in] NB
24764*> \verbatim
24765*>          NB is INTEGER
24766*>          The number of columns to be reduced.
24767*> \endverbatim
24768*>
24769*> \param[in,out] A
24770*> \verbatim
24771*>          A is COMPLEX*16 array, dimension (LDA,N-K+1)
24772*>          On entry, the n-by-(n-k+1) general matrix A.
24773*>          On exit, the elements on and above the k-th subdiagonal in
24774*>          the first NB columns are overwritten with the corresponding
24775*>          elements of the reduced matrix; the elements below the k-th
24776*>          subdiagonal, with the array TAU, represent the matrix Q as a
24777*>          product of elementary reflectors. The other columns of A are
24778*>          unchanged. See Further Details.
24779*> \endverbatim
24780*>
24781*> \param[in] LDA
24782*> \verbatim
24783*>          LDA is INTEGER
24784*>          The leading dimension of the array A.  LDA >= max(1,N).
24785*> \endverbatim
24786*>
24787*> \param[out] TAU
24788*> \verbatim
24789*>          TAU is COMPLEX*16 array, dimension (NB)
24790*>          The scalar factors of the elementary reflectors. See Further
24791*>          Details.
24792*> \endverbatim
24793*>
24794*> \param[out] T
24795*> \verbatim
24796*>          T is COMPLEX*16 array, dimension (LDT,NB)
24797*>          The upper triangular matrix T.
24798*> \endverbatim
24799*>
24800*> \param[in] LDT
24801*> \verbatim
24802*>          LDT is INTEGER
24803*>          The leading dimension of the array T.  LDT >= NB.
24804*> \endverbatim
24805*>
24806*> \param[out] Y
24807*> \verbatim
24808*>          Y is COMPLEX*16 array, dimension (LDY,NB)
24809*>          The n-by-nb matrix Y.
24810*> \endverbatim
24811*>
24812*> \param[in] LDY
24813*> \verbatim
24814*>          LDY is INTEGER
24815*>          The leading dimension of the array Y. LDY >= N.
24816*> \endverbatim
24817*
24818*  Authors:
24819*  ========
24820*
24821*> \author Univ. of Tennessee
24822*> \author Univ. of California Berkeley
24823*> \author Univ. of Colorado Denver
24824*> \author NAG Ltd.
24825*
24826*> \date December 2016
24827*
24828*> \ingroup complex16OTHERauxiliary
24829*
24830*> \par Further Details:
24831*  =====================
24832*>
24833*> \verbatim
24834*>
24835*>  The matrix Q is represented as a product of nb elementary reflectors
24836*>
24837*>     Q = H(1) H(2) . . . H(nb).
24838*>
24839*>  Each H(i) has the form
24840*>
24841*>     H(i) = I - tau * v * v**H
24842*>
24843*>  where tau is a complex scalar, and v is a complex vector with
24844*>  v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in
24845*>  A(i+k+1:n,i), and tau in TAU(i).
24846*>
24847*>  The elements of the vectors v together form the (n-k+1)-by-nb matrix
24848*>  V which is needed, with T and Y, to apply the transformation to the
24849*>  unreduced part of the matrix, using an update of the form:
24850*>  A := (I - V*T*V**H) * (A - Y*V**H).
24851*>
24852*>  The contents of A on exit are illustrated by the following example
24853*>  with n = 7, k = 3 and nb = 2:
24854*>
24855*>     ( a   a   a   a   a )
24856*>     ( a   a   a   a   a )
24857*>     ( a   a   a   a   a )
24858*>     ( h   h   a   a   a )
24859*>     ( v1  h   a   a   a )
24860*>     ( v1  v2  a   a   a )
24861*>     ( v1  v2  a   a   a )
24862*>
24863*>  where a denotes an element of the original matrix A, h denotes a
24864*>  modified element of the upper Hessenberg matrix H, and vi denotes an
24865*>  element of the vector defining H(i).
24866*>
24867*>  This subroutine is a slight modification of LAPACK-3.0's DLAHRD
24868*>  incorporating improvements proposed by Quintana-Orti and Van de
24869*>  Gejin. Note that the entries of A(1:K,2:NB) differ from those
24870*>  returned by the original LAPACK-3.0's DLAHRD routine. (This
24871*>  subroutine is not backward compatible with LAPACK-3.0's DLAHRD.)
24872*> \endverbatim
24873*
24874*> \par References:
24875*  ================
24876*>
24877*>  Gregorio Quintana-Orti and Robert van de Geijn, "Improving the
24878*>  performance of reduction to Hessenberg form," ACM Transactions on
24879*>  Mathematical Software, 32(2):180-194, June 2006.
24880*>
24881*  =====================================================================
24882      SUBROUTINE ZLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )
24883*
24884*  -- LAPACK auxiliary routine (version 3.7.0) --
24885*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
24886*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
24887*     December 2016
24888*
24889*     .. Scalar Arguments ..
24890      INTEGER            K, LDA, LDT, LDY, N, NB
24891*     ..
24892*     .. Array Arguments ..
24893      COMPLEX*16        A( LDA, * ), T( LDT, NB ), TAU( NB ),
24894     $                   Y( LDY, NB )
24895*     ..
24896*
24897*  =====================================================================
24898*
24899*     .. Parameters ..
24900      COMPLEX*16        ZERO, ONE
24901      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ),
24902     $                     ONE = ( 1.0D+0, 0.0D+0 ) )
24903*     ..
24904*     .. Local Scalars ..
24905      INTEGER            I
24906      COMPLEX*16        EI
24907*     ..
24908*     .. External Subroutines ..
24909      EXTERNAL           ZAXPY, ZCOPY, ZGEMM, ZGEMV, ZLACPY,
24910     $                   ZLARFG, ZSCAL, ZTRMM, ZTRMV, ZLACGV
24911*     ..
24912*     .. Intrinsic Functions ..
24913      INTRINSIC          MIN
24914*     ..
24915*     .. Executable Statements ..
24916*
24917*     Quick return if possible
24918*
24919      IF( N.LE.1 )
24920     $   RETURN
24921*
24922      DO 10 I = 1, NB
24923         IF( I.GT.1 ) THEN
24924*
24925*           Update A(K+1:N,I)
24926*
24927*           Update I-th column of A - Y * V**H
24928*
24929            CALL ZLACGV( I-1, A( K+I-1, 1 ), LDA )
24930            CALL ZGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, Y(K+1,1), LDY,
24931     $                  A( K+I-1, 1 ), LDA, ONE, A( K+1, I ), 1 )
24932            CALL ZLACGV( I-1, A( K+I-1, 1 ), LDA )
24933*
24934*           Apply I - V * T**H * V**H to this column (call it b) from the
24935*           left, using the last column of T as workspace
24936*
24937*           Let  V = ( V1 )   and   b = ( b1 )   (first I-1 rows)
24938*                    ( V2 )             ( b2 )
24939*
24940*           where V1 is unit lower triangular
24941*
24942*           w := V1**H * b1
24943*
24944            CALL ZCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 )
24945            CALL ZTRMV( 'Lower', 'Conjugate transpose', 'UNIT',
24946     $                  I-1, A( K+1, 1 ),
24947     $                  LDA, T( 1, NB ), 1 )
24948*
24949*           w := w + V2**H * b2
24950*
24951            CALL ZGEMV( 'Conjugate transpose', N-K-I+1, I-1,
24952     $                  ONE, A( K+I, 1 ),
24953     $                  LDA, A( K+I, I ), 1, ONE, T( 1, NB ), 1 )
24954*
24955*           w := T**H * w
24956*
24957            CALL ZTRMV( 'Upper', 'Conjugate transpose', 'NON-UNIT',
24958     $                  I-1, T, LDT,
24959     $                  T( 1, NB ), 1 )
24960*
24961*           b2 := b2 - V2*w
24962*
24963            CALL ZGEMV( 'NO TRANSPOSE', N-K-I+1, I-1, -ONE,
24964     $                  A( K+I, 1 ),
24965     $                  LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 )
24966*
24967*           b1 := b1 - V1*w
24968*
24969            CALL ZTRMV( 'Lower', 'NO TRANSPOSE',
24970     $                  'UNIT', I-1,
24971     $                  A( K+1, 1 ), LDA, T( 1, NB ), 1 )
24972            CALL ZAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 )
24973*
24974            A( K+I-1, I-1 ) = EI
24975         END IF
24976*
24977*        Generate the elementary reflector H(I) to annihilate
24978*        A(K+I+1:N,I)
24979*
24980         CALL ZLARFG( N-K-I+1, A( K+I, I ), A( MIN( K+I+1, N ), I ), 1,
24981     $                TAU( I ) )
24982         EI = A( K+I, I )
24983         A( K+I, I ) = ONE
24984*
24985*        Compute  Y(K+1:N,I)
24986*
24987         CALL ZGEMV( 'NO TRANSPOSE', N-K, N-K-I+1,
24988     $               ONE, A( K+1, I+1 ),
24989     $               LDA, A( K+I, I ), 1, ZERO, Y( K+1, I ), 1 )
24990         CALL ZGEMV( 'Conjugate transpose', N-K-I+1, I-1,
24991     $               ONE, A( K+I, 1 ), LDA,
24992     $               A( K+I, I ), 1, ZERO, T( 1, I ), 1 )
24993         CALL ZGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE,
24994     $               Y( K+1, 1 ), LDY,
24995     $               T( 1, I ), 1, ONE, Y( K+1, I ), 1 )
24996         CALL ZSCAL( N-K, TAU( I ), Y( K+1, I ), 1 )
24997*
24998*        Compute T(1:I,I)
24999*
25000         CALL ZSCAL( I-1, -TAU( I ), T( 1, I ), 1 )
25001         CALL ZTRMV( 'Upper', 'No Transpose', 'NON-UNIT',
25002     $               I-1, T, LDT,
25003     $               T( 1, I ), 1 )
25004         T( I, I ) = TAU( I )
25005*
25006   10 CONTINUE
25007      A( K+NB, NB ) = EI
25008*
25009*     Compute Y(1:K,1:NB)
25010*
25011      CALL ZLACPY( 'ALL', K, NB, A( 1, 2 ), LDA, Y, LDY )
25012      CALL ZTRMM( 'RIGHT', 'Lower', 'NO TRANSPOSE',
25013     $            'UNIT', K, NB,
25014     $            ONE, A( K+1, 1 ), LDA, Y, LDY )
25015      IF( N.GT.K+NB )
25016     $   CALL ZGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', K,
25017     $               NB, N-K-NB, ONE,
25018     $               A( 1, 2+NB ), LDA, A( K+1+NB, 1 ), LDA, ONE, Y,
25019     $               LDY )
25020      CALL ZTRMM( 'RIGHT', 'Upper', 'NO TRANSPOSE',
25021     $            'NON-UNIT', K, NB,
25022     $            ONE, T, LDT, Y, LDY )
25023*
25024      RETURN
25025*
25026*     End of ZLAHR2
25027*
25028      END
25029*> \brief \b ZLAHRD reduces the first nb columns of a general rectangular matrix A so that elements below the k-th subdiagonal are zero, and returns auxiliary matrices which are needed to apply the transformation to the unreduced part of A.
25030*
25031*  =========== DOCUMENTATION ===========
25032*
25033* Online html documentation available at
25034*            http://www.netlib.org/lapack/explore-html/
25035*
25036*> \htmlonly
25037*> Download ZLAHRD + dependencies
25038*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlahrd.f">
25039*> [TGZ]</a>
25040*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlahrd.f">
25041*> [ZIP]</a>
25042*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlahrd.f">
25043*> [TXT]</a>
25044*> \endhtmlonly
25045*
25046*  Definition:
25047*  ===========
25048*
25049*       SUBROUTINE ZLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )
25050*
25051*       .. Scalar Arguments ..
25052*       INTEGER            K, LDA, LDT, LDY, N, NB
25053*       ..
25054*       .. Array Arguments ..
25055*       COMPLEX*16         A( LDA, * ), T( LDT, NB ), TAU( NB ),
25056*      $                   Y( LDY, NB )
25057*       ..
25058*
25059*
25060*> \par Purpose:
25061*  =============
25062*>
25063*> \verbatim
25064*>
25065*> This routine is deprecated and has been replaced by routine ZLAHR2.
25066*>
25067*> ZLAHRD reduces the first NB columns of a complex general n-by-(n-k+1)
25068*> matrix A so that elements below the k-th subdiagonal are zero. The
25069*> reduction is performed by a unitary similarity transformation
25070*> Q**H * A * Q. The routine returns the matrices V and T which determine
25071*> Q as a block reflector I - V*T*V**H, and also the matrix Y = A * V * T.
25072*> \endverbatim
25073*
25074*  Arguments:
25075*  ==========
25076*
25077*> \param[in] N
25078*> \verbatim
25079*>          N is INTEGER
25080*>          The order of the matrix A.
25081*> \endverbatim
25082*>
25083*> \param[in] K
25084*> \verbatim
25085*>          K is INTEGER
25086*>          The offset for the reduction. Elements below the k-th
25087*>          subdiagonal in the first NB columns are reduced to zero.
25088*> \endverbatim
25089*>
25090*> \param[in] NB
25091*> \verbatim
25092*>          NB is INTEGER
25093*>          The number of columns to be reduced.
25094*> \endverbatim
25095*>
25096*> \param[in,out] A
25097*> \verbatim
25098*>          A is COMPLEX*16 array, dimension (LDA,N-K+1)
25099*>          On entry, the n-by-(n-k+1) general matrix A.
25100*>          On exit, the elements on and above the k-th subdiagonal in
25101*>          the first NB columns are overwritten with the corresponding
25102*>          elements of the reduced matrix; the elements below the k-th
25103*>          subdiagonal, with the array TAU, represent the matrix Q as a
25104*>          product of elementary reflectors. The other columns of A are
25105*>          unchanged. See Further Details.
25106*> \endverbatim
25107*>
25108*> \param[in] LDA
25109*> \verbatim
25110*>          LDA is INTEGER
25111*>          The leading dimension of the array A.  LDA >= max(1,N).
25112*> \endverbatim
25113*>
25114*> \param[out] TAU
25115*> \verbatim
25116*>          TAU is COMPLEX*16 array, dimension (NB)
25117*>          The scalar factors of the elementary reflectors. See Further
25118*>          Details.
25119*> \endverbatim
25120*>
25121*> \param[out] T
25122*> \verbatim
25123*>          T is COMPLEX*16 array, dimension (LDT,NB)
25124*>          The upper triangular matrix T.
25125*> \endverbatim
25126*>
25127*> \param[in] LDT
25128*> \verbatim
25129*>          LDT is INTEGER
25130*>          The leading dimension of the array T.  LDT >= NB.
25131*> \endverbatim
25132*>
25133*> \param[out] Y
25134*> \verbatim
25135*>          Y is COMPLEX*16 array, dimension (LDY,NB)
25136*>          The n-by-nb matrix Y.
25137*> \endverbatim
25138*>
25139*> \param[in] LDY
25140*> \verbatim
25141*>          LDY is INTEGER
25142*>          The leading dimension of the array Y. LDY >= max(1,N).
25143*> \endverbatim
25144*
25145*  Authors:
25146*  ========
25147*
25148*> \author Univ. of Tennessee
25149*> \author Univ. of California Berkeley
25150*> \author Univ. of Colorado Denver
25151*> \author NAG Ltd.
25152*
25153*> \date December 2016
25154*
25155*> \ingroup complex16OTHERauxiliary
25156*
25157*> \par Further Details:
25158*  =====================
25159*>
25160*> \verbatim
25161*>
25162*>  The matrix Q is represented as a product of nb elementary reflectors
25163*>
25164*>     Q = H(1) H(2) . . . H(nb).
25165*>
25166*>  Each H(i) has the form
25167*>
25168*>     H(i) = I - tau * v * v**H
25169*>
25170*>  where tau is a complex scalar, and v is a complex vector with
25171*>  v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in
25172*>  A(i+k+1:n,i), and tau in TAU(i).
25173*>
25174*>  The elements of the vectors v together form the (n-k+1)-by-nb matrix
25175*>  V which is needed, with T and Y, to apply the transformation to the
25176*>  unreduced part of the matrix, using an update of the form:
25177*>  A := (I - V*T*V**H) * (A - Y*V**H).
25178*>
25179*>  The contents of A on exit are illustrated by the following example
25180*>  with n = 7, k = 3 and nb = 2:
25181*>
25182*>     ( a   h   a   a   a )
25183*>     ( a   h   a   a   a )
25184*>     ( a   h   a   a   a )
25185*>     ( h   h   a   a   a )
25186*>     ( v1  h   a   a   a )
25187*>     ( v1  v2  a   a   a )
25188*>     ( v1  v2  a   a   a )
25189*>
25190*>  where a denotes an element of the original matrix A, h denotes a
25191*>  modified element of the upper Hessenberg matrix H, and vi denotes an
25192*>  element of the vector defining H(i).
25193*> \endverbatim
25194*>
25195*  =====================================================================
25196      SUBROUTINE ZLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )
25197*
25198*  -- LAPACK auxiliary routine (version 3.7.0) --
25199*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
25200*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
25201*     December 2016
25202*
25203*     .. Scalar Arguments ..
25204      INTEGER            K, LDA, LDT, LDY, N, NB
25205*     ..
25206*     .. Array Arguments ..
25207      COMPLEX*16         A( LDA, * ), T( LDT, NB ), TAU( NB ),
25208     $                   Y( LDY, NB )
25209*     ..
25210*
25211*  =====================================================================
25212*
25213*     .. Parameters ..
25214      COMPLEX*16         ZERO, ONE
25215      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ),
25216     $                   ONE = ( 1.0D+0, 0.0D+0 ) )
25217*     ..
25218*     .. Local Scalars ..
25219      INTEGER            I
25220      COMPLEX*16         EI
25221*     ..
25222*     .. External Subroutines ..
25223      EXTERNAL           ZAXPY, ZCOPY, ZGEMV, ZLACGV, ZLARFG, ZSCAL,
25224     $                   ZTRMV
25225*     ..
25226*     .. Intrinsic Functions ..
25227      INTRINSIC          MIN
25228*     ..
25229*     .. Executable Statements ..
25230*
25231*     Quick return if possible
25232*
25233      IF( N.LE.1 )
25234     $   RETURN
25235*
25236      DO 10 I = 1, NB
25237         IF( I.GT.1 ) THEN
25238*
25239*           Update A(1:n,i)
25240*
25241*           Compute i-th column of A - Y * V**H
25242*
25243            CALL ZLACGV( I-1, A( K+I-1, 1 ), LDA )
25244            CALL ZGEMV( 'No transpose', N, I-1, -ONE, Y, LDY,
25245     $                  A( K+I-1, 1 ), LDA, ONE, A( 1, I ), 1 )
25246            CALL ZLACGV( I-1, A( K+I-1, 1 ), LDA )
25247*
25248*           Apply I - V * T**H * V**H to this column (call it b) from the
25249*           left, using the last column of T as workspace
25250*
25251*           Let  V = ( V1 )   and   b = ( b1 )   (first I-1 rows)
25252*                    ( V2 )             ( b2 )
25253*
25254*           where V1 is unit lower triangular
25255*
25256*           w := V1**H * b1
25257*
25258            CALL ZCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 )
25259            CALL ZTRMV( 'Lower', 'Conjugate transpose', 'Unit', I-1,
25260     $                  A( K+1, 1 ), LDA, T( 1, NB ), 1 )
25261*
25262*           w := w + V2**H *b2
25263*
25264            CALL ZGEMV( 'Conjugate transpose', N-K-I+1, I-1, ONE,
25265     $                  A( K+I, 1 ), LDA, A( K+I, I ), 1, ONE,
25266     $                  T( 1, NB ), 1 )
25267*
25268*           w := T**H *w
25269*
25270            CALL ZTRMV( 'Upper', 'Conjugate transpose', 'Non-unit', I-1,
25271     $                  T, LDT, T( 1, NB ), 1 )
25272*
25273*           b2 := b2 - V2*w
25274*
25275            CALL ZGEMV( 'No transpose', N-K-I+1, I-1, -ONE, A( K+I, 1 ),
25276     $                  LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 )
25277*
25278*           b1 := b1 - V1*w
25279*
25280            CALL ZTRMV( 'Lower', 'No transpose', 'Unit', I-1,
25281     $                  A( K+1, 1 ), LDA, T( 1, NB ), 1 )
25282            CALL ZAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 )
25283*
25284            A( K+I-1, I-1 ) = EI
25285         END IF
25286*
25287*        Generate the elementary reflector H(i) to annihilate
25288*        A(k+i+1:n,i)
25289*
25290         EI = A( K+I, I )
25291         CALL ZLARFG( N-K-I+1, EI, A( MIN( K+I+1, N ), I ), 1,
25292     $                TAU( I ) )
25293         A( K+I, I ) = ONE
25294*
25295*        Compute  Y(1:n,i)
25296*
25297         CALL ZGEMV( 'No transpose', N, N-K-I+1, ONE, A( 1, I+1 ), LDA,
25298     $               A( K+I, I ), 1, ZERO, Y( 1, I ), 1 )
25299         CALL ZGEMV( 'Conjugate transpose', N-K-I+1, I-1, ONE,
25300     $               A( K+I, 1 ), LDA, A( K+I, I ), 1, ZERO, T( 1, I ),
25301     $               1 )
25302         CALL ZGEMV( 'No transpose', N, I-1, -ONE, Y, LDY, T( 1, I ), 1,
25303     $               ONE, Y( 1, I ), 1 )
25304         CALL ZSCAL( N, TAU( I ), Y( 1, I ), 1 )
25305*
25306*        Compute T(1:i,i)
25307*
25308         CALL ZSCAL( I-1, -TAU( I ), T( 1, I ), 1 )
25309         CALL ZTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, LDT,
25310     $               T( 1, I ), 1 )
25311         T( I, I ) = TAU( I )
25312*
25313   10 CONTINUE
25314      A( K+NB, NB ) = EI
25315*
25316      RETURN
25317*
25318*     End of ZLAHRD
25319*
25320      END
25321*> \brief \b ZLALS0 applies back multiplying factors in solving the least squares problem using divide and conquer SVD approach. Used by sgelsd.
25322*
25323*  =========== DOCUMENTATION ===========
25324*
25325* Online html documentation available at
25326*            http://www.netlib.org/lapack/explore-html/
25327*
25328*> \htmlonly
25329*> Download ZLALS0 + dependencies
25330*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlals0.f">
25331*> [TGZ]</a>
25332*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlals0.f">
25333*> [ZIP]</a>
25334*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlals0.f">
25335*> [TXT]</a>
25336*> \endhtmlonly
25337*
25338*  Definition:
25339*  ===========
25340*
25341*       SUBROUTINE ZLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX,
25342*                          PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM,
25343*                          POLES, DIFL, DIFR, Z, K, C, S, RWORK, INFO )
25344*
25345*       .. Scalar Arguments ..
25346*       INTEGER            GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL,
25347*      $                   LDGNUM, NL, NR, NRHS, SQRE
25348*       DOUBLE PRECISION   C, S
25349*       ..
25350*       .. Array Arguments ..
25351*       INTEGER            GIVCOL( LDGCOL, * ), PERM( * )
25352*       DOUBLE PRECISION   DIFL( * ), DIFR( LDGNUM, * ),
25353*      $                   GIVNUM( LDGNUM, * ), POLES( LDGNUM, * ),
25354*      $                   RWORK( * ), Z( * )
25355*       COMPLEX*16         B( LDB, * ), BX( LDBX, * )
25356*       ..
25357*
25358*
25359*> \par Purpose:
25360*  =============
25361*>
25362*> \verbatim
25363*>
25364*> ZLALS0 applies back the multiplying factors of either the left or the
25365*> right singular vector matrix of a diagonal matrix appended by a row
25366*> to the right hand side matrix B in solving the least squares problem
25367*> using the divide-and-conquer SVD approach.
25368*>
25369*> For the left singular vector matrix, three types of orthogonal
25370*> matrices are involved:
25371*>
25372*> (1L) Givens rotations: the number of such rotations is GIVPTR; the
25373*>      pairs of columns/rows they were applied to are stored in GIVCOL;
25374*>      and the C- and S-values of these rotations are stored in GIVNUM.
25375*>
25376*> (2L) Permutation. The (NL+1)-st row of B is to be moved to the first
25377*>      row, and for J=2:N, PERM(J)-th row of B is to be moved to the
25378*>      J-th row.
25379*>
25380*> (3L) The left singular vector matrix of the remaining matrix.
25381*>
25382*> For the right singular vector matrix, four types of orthogonal
25383*> matrices are involved:
25384*>
25385*> (1R) The right singular vector matrix of the remaining matrix.
25386*>
25387*> (2R) If SQRE = 1, one extra Givens rotation to generate the right
25388*>      null space.
25389*>
25390*> (3R) The inverse transformation of (2L).
25391*>
25392*> (4R) The inverse transformation of (1L).
25393*> \endverbatim
25394*
25395*  Arguments:
25396*  ==========
25397*
25398*> \param[in] ICOMPQ
25399*> \verbatim
25400*>          ICOMPQ is INTEGER
25401*>         Specifies whether singular vectors are to be computed in
25402*>         factored form:
25403*>         = 0: Left singular vector matrix.
25404*>         = 1: Right singular vector matrix.
25405*> \endverbatim
25406*>
25407*> \param[in] NL
25408*> \verbatim
25409*>          NL is INTEGER
25410*>         The row dimension of the upper block. NL >= 1.
25411*> \endverbatim
25412*>
25413*> \param[in] NR
25414*> \verbatim
25415*>          NR is INTEGER
25416*>         The row dimension of the lower block. NR >= 1.
25417*> \endverbatim
25418*>
25419*> \param[in] SQRE
25420*> \verbatim
25421*>          SQRE is INTEGER
25422*>         = 0: the lower block is an NR-by-NR square matrix.
25423*>         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
25424*>
25425*>         The bidiagonal matrix has row dimension N = NL + NR + 1,
25426*>         and column dimension M = N + SQRE.
25427*> \endverbatim
25428*>
25429*> \param[in] NRHS
25430*> \verbatim
25431*>          NRHS is INTEGER
25432*>         The number of columns of B and BX. NRHS must be at least 1.
25433*> \endverbatim
25434*>
25435*> \param[in,out] B
25436*> \verbatim
25437*>          B is COMPLEX*16 array, dimension ( LDB, NRHS )
25438*>         On input, B contains the right hand sides of the least
25439*>         squares problem in rows 1 through M. On output, B contains
25440*>         the solution X in rows 1 through N.
25441*> \endverbatim
25442*>
25443*> \param[in] LDB
25444*> \verbatim
25445*>          LDB is INTEGER
25446*>         The leading dimension of B. LDB must be at least
25447*>         max(1,MAX( M, N ) ).
25448*> \endverbatim
25449*>
25450*> \param[out] BX
25451*> \verbatim
25452*>          BX is COMPLEX*16 array, dimension ( LDBX, NRHS )
25453*> \endverbatim
25454*>
25455*> \param[in] LDBX
25456*> \verbatim
25457*>          LDBX is INTEGER
25458*>         The leading dimension of BX.
25459*> \endverbatim
25460*>
25461*> \param[in] PERM
25462*> \verbatim
25463*>          PERM is INTEGER array, dimension ( N )
25464*>         The permutations (from deflation and sorting) applied
25465*>         to the two blocks.
25466*> \endverbatim
25467*>
25468*> \param[in] GIVPTR
25469*> \verbatim
25470*>          GIVPTR is INTEGER
25471*>         The number of Givens rotations which took place in this
25472*>         subproblem.
25473*> \endverbatim
25474*>
25475*> \param[in] GIVCOL
25476*> \verbatim
25477*>          GIVCOL is INTEGER array, dimension ( LDGCOL, 2 )
25478*>         Each pair of numbers indicates a pair of rows/columns
25479*>         involved in a Givens rotation.
25480*> \endverbatim
25481*>
25482*> \param[in] LDGCOL
25483*> \verbatim
25484*>          LDGCOL is INTEGER
25485*>         The leading dimension of GIVCOL, must be at least N.
25486*> \endverbatim
25487*>
25488*> \param[in] GIVNUM
25489*> \verbatim
25490*>          GIVNUM is DOUBLE PRECISION array, dimension ( LDGNUM, 2 )
25491*>         Each number indicates the C or S value used in the
25492*>         corresponding Givens rotation.
25493*> \endverbatim
25494*>
25495*> \param[in] LDGNUM
25496*> \verbatim
25497*>          LDGNUM is INTEGER
25498*>         The leading dimension of arrays DIFR, POLES and
25499*>         GIVNUM, must be at least K.
25500*> \endverbatim
25501*>
25502*> \param[in] POLES
25503*> \verbatim
25504*>          POLES is DOUBLE PRECISION array, dimension ( LDGNUM, 2 )
25505*>         On entry, POLES(1:K, 1) contains the new singular
25506*>         values obtained from solving the secular equation, and
25507*>         POLES(1:K, 2) is an array containing the poles in the secular
25508*>         equation.
25509*> \endverbatim
25510*>
25511*> \param[in] DIFL
25512*> \verbatim
25513*>          DIFL is DOUBLE PRECISION array, dimension ( K ).
25514*>         On entry, DIFL(I) is the distance between I-th updated
25515*>         (undeflated) singular value and the I-th (undeflated) old
25516*>         singular value.
25517*> \endverbatim
25518*>
25519*> \param[in] DIFR
25520*> \verbatim
25521*>          DIFR is DOUBLE PRECISION array, dimension ( LDGNUM, 2 ).
25522*>         On entry, DIFR(I, 1) contains the distances between I-th
25523*>         updated (undeflated) singular value and the I+1-th
25524*>         (undeflated) old singular value. And DIFR(I, 2) is the
25525*>         normalizing factor for the I-th right singular vector.
25526*> \endverbatim
25527*>
25528*> \param[in] Z
25529*> \verbatim
25530*>          Z is DOUBLE PRECISION array, dimension ( K )
25531*>         Contain the components of the deflation-adjusted updating row
25532*>         vector.
25533*> \endverbatim
25534*>
25535*> \param[in] K
25536*> \verbatim
25537*>          K is INTEGER
25538*>         Contains the dimension of the non-deflated matrix,
25539*>         This is the order of the related secular equation. 1 <= K <=N.
25540*> \endverbatim
25541*>
25542*> \param[in] C
25543*> \verbatim
25544*>          C is DOUBLE PRECISION
25545*>         C contains garbage if SQRE =0 and the C-value of a Givens
25546*>         rotation related to the right null space if SQRE = 1.
25547*> \endverbatim
25548*>
25549*> \param[in] S
25550*> \verbatim
25551*>          S is DOUBLE PRECISION
25552*>         S contains garbage if SQRE =0 and the S-value of a Givens
25553*>         rotation related to the right null space if SQRE = 1.
25554*> \endverbatim
25555*>
25556*> \param[out] RWORK
25557*> \verbatim
25558*>          RWORK is DOUBLE PRECISION array, dimension
25559*>         ( K*(1+NRHS) + 2*NRHS )
25560*> \endverbatim
25561*>
25562*> \param[out] INFO
25563*> \verbatim
25564*>          INFO is INTEGER
25565*>          = 0:  successful exit.
25566*>          < 0:  if INFO = -i, the i-th argument had an illegal value.
25567*> \endverbatim
25568*
25569*  Authors:
25570*  ========
25571*
25572*> \author Univ. of Tennessee
25573*> \author Univ. of California Berkeley
25574*> \author Univ. of Colorado Denver
25575*> \author NAG Ltd.
25576*
25577*> \date December 2016
25578*
25579*> \ingroup complex16OTHERcomputational
25580*
25581*> \par Contributors:
25582*  ==================
25583*>
25584*>     Ming Gu and Ren-Cang Li, Computer Science Division, University of
25585*>       California at Berkeley, USA \n
25586*>     Osni Marques, LBNL/NERSC, USA \n
25587*
25588*  =====================================================================
25589      SUBROUTINE ZLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX,
25590     $                   PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM,
25591     $                   POLES, DIFL, DIFR, Z, K, C, S, RWORK, INFO )
25592*
25593*  -- LAPACK computational routine (version 3.7.0) --
25594*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
25595*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
25596*     December 2016
25597*
25598*     .. Scalar Arguments ..
25599      INTEGER            GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL,
25600     $                   LDGNUM, NL, NR, NRHS, SQRE
25601      DOUBLE PRECISION   C, S
25602*     ..
25603*     .. Array Arguments ..
25604      INTEGER            GIVCOL( LDGCOL, * ), PERM( * )
25605      DOUBLE PRECISION   DIFL( * ), DIFR( LDGNUM, * ),
25606     $                   GIVNUM( LDGNUM, * ), POLES( LDGNUM, * ),
25607     $                   RWORK( * ), Z( * )
25608      COMPLEX*16         B( LDB, * ), BX( LDBX, * )
25609*     ..
25610*
25611*  =====================================================================
25612*
25613*     .. Parameters ..
25614      DOUBLE PRECISION   ONE, ZERO, NEGONE
25615      PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0, NEGONE = -1.0D0 )
25616*     ..
25617*     .. Local Scalars ..
25618      INTEGER            I, J, JCOL, JROW, M, N, NLP1
25619      DOUBLE PRECISION   DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, TEMP
25620*     ..
25621*     .. External Subroutines ..
25622      EXTERNAL           DGEMV, XERBLA, ZCOPY, ZDROT, ZDSCAL, ZLACPY,
25623     $                   ZLASCL
25624*     ..
25625*     .. External Functions ..
25626      DOUBLE PRECISION   DLAMC3, DNRM2
25627      EXTERNAL           DLAMC3, DNRM2
25628*     ..
25629*     .. Intrinsic Functions ..
25630      INTRINSIC          DBLE, DCMPLX, DIMAG, MAX
25631*     ..
25632*     .. Executable Statements ..
25633*
25634*     Test the input parameters.
25635*
25636      INFO = 0
25637      N = NL + NR + 1
25638*
25639      IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
25640         INFO = -1
25641      ELSE IF( NL.LT.1 ) THEN
25642         INFO = -2
25643      ELSE IF( NR.LT.1 ) THEN
25644         INFO = -3
25645      ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
25646         INFO = -4
25647      ELSE IF( NRHS.LT.1 ) THEN
25648         INFO = -5
25649      ELSE IF( LDB.LT.N ) THEN
25650         INFO = -7
25651      ELSE IF( LDBX.LT.N ) THEN
25652         INFO = -9
25653      ELSE IF( GIVPTR.LT.0 ) THEN
25654         INFO = -11
25655      ELSE IF( LDGCOL.LT.N ) THEN
25656         INFO = -13
25657      ELSE IF( LDGNUM.LT.N ) THEN
25658         INFO = -15
25659      ELSE IF( K.LT.1 ) THEN
25660         INFO = -20
25661      END IF
25662      IF( INFO.NE.0 ) THEN
25663         CALL XERBLA( 'ZLALS0', -INFO )
25664         RETURN
25665      END IF
25666*
25667      M = N + SQRE
25668      NLP1 = NL + 1
25669*
25670      IF( ICOMPQ.EQ.0 ) THEN
25671*
25672*        Apply back orthogonal transformations from the left.
25673*
25674*        Step (1L): apply back the Givens rotations performed.
25675*
25676         DO 10 I = 1, GIVPTR
25677            CALL ZDROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB,
25678     $                  B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ),
25679     $                  GIVNUM( I, 1 ) )
25680   10    CONTINUE
25681*
25682*        Step (2L): permute rows of B.
25683*
25684         CALL ZCOPY( NRHS, B( NLP1, 1 ), LDB, BX( 1, 1 ), LDBX )
25685         DO 20 I = 2, N
25686            CALL ZCOPY( NRHS, B( PERM( I ), 1 ), LDB, BX( I, 1 ), LDBX )
25687   20    CONTINUE
25688*
25689*        Step (3L): apply the inverse of the left singular vector
25690*        matrix to BX.
25691*
25692         IF( K.EQ.1 ) THEN
25693            CALL ZCOPY( NRHS, BX, LDBX, B, LDB )
25694            IF( Z( 1 ).LT.ZERO ) THEN
25695               CALL ZDSCAL( NRHS, NEGONE, B, LDB )
25696            END IF
25697         ELSE
25698            DO 100 J = 1, K
25699               DIFLJ = DIFL( J )
25700               DJ = POLES( J, 1 )
25701               DSIGJ = -POLES( J, 2 )
25702               IF( J.LT.K ) THEN
25703                  DIFRJ = -DIFR( J, 1 )
25704                  DSIGJP = -POLES( J+1, 2 )
25705               END IF
25706               IF( ( Z( J ).EQ.ZERO ) .OR. ( POLES( J, 2 ).EQ.ZERO ) )
25707     $              THEN
25708                  RWORK( J ) = ZERO
25709               ELSE
25710                  RWORK( J ) = -POLES( J, 2 )*Z( J ) / DIFLJ /
25711     $                         ( POLES( J, 2 )+DJ )
25712               END IF
25713               DO 30 I = 1, J - 1
25714                  IF( ( Z( I ).EQ.ZERO ) .OR.
25715     $                ( POLES( I, 2 ).EQ.ZERO ) ) THEN
25716                     RWORK( I ) = ZERO
25717                  ELSE
25718                     RWORK( I ) = POLES( I, 2 )*Z( I ) /
25719     $                            ( DLAMC3( POLES( I, 2 ), DSIGJ )-
25720     $                            DIFLJ ) / ( POLES( I, 2 )+DJ )
25721                  END IF
25722   30          CONTINUE
25723               DO 40 I = J + 1, K
25724                  IF( ( Z( I ).EQ.ZERO ) .OR.
25725     $                ( POLES( I, 2 ).EQ.ZERO ) ) THEN
25726                     RWORK( I ) = ZERO
25727                  ELSE
25728                     RWORK( I ) = POLES( I, 2 )*Z( I ) /
25729     $                            ( DLAMC3( POLES( I, 2 ), DSIGJP )+
25730     $                            DIFRJ ) / ( POLES( I, 2 )+DJ )
25731                  END IF
25732   40          CONTINUE
25733               RWORK( 1 ) = NEGONE
25734               TEMP = DNRM2( K, RWORK, 1 )
25735*
25736*              Since B and BX are complex, the following call to DGEMV
25737*              is performed in two steps (real and imaginary parts).
25738*
25739*              CALL DGEMV( 'T', K, NRHS, ONE, BX, LDBX, WORK, 1, ZERO,
25740*    $                     B( J, 1 ), LDB )
25741*
25742               I = K + NRHS*2
25743               DO 60 JCOL = 1, NRHS
25744                  DO 50 JROW = 1, K
25745                     I = I + 1
25746                     RWORK( I ) = DBLE( BX( JROW, JCOL ) )
25747   50             CONTINUE
25748   60          CONTINUE
25749               CALL DGEMV( 'T', K, NRHS, ONE, RWORK( 1+K+NRHS*2 ), K,
25750     $                     RWORK( 1 ), 1, ZERO, RWORK( 1+K ), 1 )
25751               I = K + NRHS*2
25752               DO 80 JCOL = 1, NRHS
25753                  DO 70 JROW = 1, K
25754                     I = I + 1
25755                     RWORK( I ) = DIMAG( BX( JROW, JCOL ) )
25756   70             CONTINUE
25757   80          CONTINUE
25758               CALL DGEMV( 'T', K, NRHS, ONE, RWORK( 1+K+NRHS*2 ), K,
25759     $                     RWORK( 1 ), 1, ZERO, RWORK( 1+K+NRHS ), 1 )
25760               DO 90 JCOL = 1, NRHS
25761                  B( J, JCOL ) = DCMPLX( RWORK( JCOL+K ),
25762     $                           RWORK( JCOL+K+NRHS ) )
25763   90          CONTINUE
25764               CALL ZLASCL( 'G', 0, 0, TEMP, ONE, 1, NRHS, B( J, 1 ),
25765     $                      LDB, INFO )
25766  100       CONTINUE
25767         END IF
25768*
25769*        Move the deflated rows of BX to B also.
25770*
25771         IF( K.LT.MAX( M, N ) )
25772     $      CALL ZLACPY( 'A', N-K, NRHS, BX( K+1, 1 ), LDBX,
25773     $                   B( K+1, 1 ), LDB )
25774      ELSE
25775*
25776*        Apply back the right orthogonal transformations.
25777*
25778*        Step (1R): apply back the new right singular vector matrix
25779*        to B.
25780*
25781         IF( K.EQ.1 ) THEN
25782            CALL ZCOPY( NRHS, B, LDB, BX, LDBX )
25783         ELSE
25784            DO 180 J = 1, K
25785               DSIGJ = POLES( J, 2 )
25786               IF( Z( J ).EQ.ZERO ) THEN
25787                  RWORK( J ) = ZERO
25788               ELSE
25789                  RWORK( J ) = -Z( J ) / DIFL( J ) /
25790     $                         ( DSIGJ+POLES( J, 1 ) ) / DIFR( J, 2 )
25791               END IF
25792               DO 110 I = 1, J - 1
25793                  IF( Z( J ).EQ.ZERO ) THEN
25794                     RWORK( I ) = ZERO
25795                  ELSE
25796                     RWORK( I ) = Z( J ) / ( DLAMC3( DSIGJ, -POLES( I+1,
25797     $                            2 ) )-DIFR( I, 1 ) ) /
25798     $                            ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 )
25799                  END IF
25800  110          CONTINUE
25801               DO 120 I = J + 1, K
25802                  IF( Z( J ).EQ.ZERO ) THEN
25803                     RWORK( I ) = ZERO
25804                  ELSE
25805                     RWORK( I ) = Z( J ) / ( DLAMC3( DSIGJ, -POLES( I,
25806     $                            2 ) )-DIFL( I ) ) /
25807     $                            ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 )
25808                  END IF
25809  120          CONTINUE
25810*
25811*              Since B and BX are complex, the following call to DGEMV
25812*              is performed in two steps (real and imaginary parts).
25813*
25814*              CALL DGEMV( 'T', K, NRHS, ONE, B, LDB, WORK, 1, ZERO,
25815*    $                     BX( J, 1 ), LDBX )
25816*
25817               I = K + NRHS*2
25818               DO 140 JCOL = 1, NRHS
25819                  DO 130 JROW = 1, K
25820                     I = I + 1
25821                     RWORK( I ) = DBLE( B( JROW, JCOL ) )
25822  130             CONTINUE
25823  140          CONTINUE
25824               CALL DGEMV( 'T', K, NRHS, ONE, RWORK( 1+K+NRHS*2 ), K,
25825     $                     RWORK( 1 ), 1, ZERO, RWORK( 1+K ), 1 )
25826               I = K + NRHS*2
25827               DO 160 JCOL = 1, NRHS
25828                  DO 150 JROW = 1, K
25829                     I = I + 1
25830                     RWORK( I ) = DIMAG( B( JROW, JCOL ) )
25831  150             CONTINUE
25832  160          CONTINUE
25833               CALL DGEMV( 'T', K, NRHS, ONE, RWORK( 1+K+NRHS*2 ), K,
25834     $                     RWORK( 1 ), 1, ZERO, RWORK( 1+K+NRHS ), 1 )
25835               DO 170 JCOL = 1, NRHS
25836                  BX( J, JCOL ) = DCMPLX( RWORK( JCOL+K ),
25837     $                            RWORK( JCOL+K+NRHS ) )
25838  170          CONTINUE
25839  180       CONTINUE
25840         END IF
25841*
25842*        Step (2R): if SQRE = 1, apply back the rotation that is
25843*        related to the right null space of the subproblem.
25844*
25845         IF( SQRE.EQ.1 ) THEN
25846            CALL ZCOPY( NRHS, B( M, 1 ), LDB, BX( M, 1 ), LDBX )
25847            CALL ZDROT( NRHS, BX( 1, 1 ), LDBX, BX( M, 1 ), LDBX, C, S )
25848         END IF
25849         IF( K.LT.MAX( M, N ) )
25850     $      CALL ZLACPY( 'A', N-K, NRHS, B( K+1, 1 ), LDB, BX( K+1, 1 ),
25851     $                   LDBX )
25852*
25853*        Step (3R): permute rows of B.
25854*
25855         CALL ZCOPY( NRHS, BX( 1, 1 ), LDBX, B( NLP1, 1 ), LDB )
25856         IF( SQRE.EQ.1 ) THEN
25857            CALL ZCOPY( NRHS, BX( M, 1 ), LDBX, B( M, 1 ), LDB )
25858         END IF
25859         DO 190 I = 2, N
25860            CALL ZCOPY( NRHS, BX( I, 1 ), LDBX, B( PERM( I ), 1 ), LDB )
25861  190    CONTINUE
25862*
25863*        Step (4R): apply back the Givens rotations performed.
25864*
25865         DO 200 I = GIVPTR, 1, -1
25866            CALL ZDROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB,
25867     $                  B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ),
25868     $                  -GIVNUM( I, 1 ) )
25869  200    CONTINUE
25870      END IF
25871*
25872      RETURN
25873*
25874*     End of ZLALS0
25875*
25876      END
25877*> \brief \b ZLALSA computes the SVD of the coefficient matrix in compact form. Used by sgelsd.
25878*
25879*  =========== DOCUMENTATION ===========
25880*
25881* Online html documentation available at
25882*            http://www.netlib.org/lapack/explore-html/
25883*
25884*> \htmlonly
25885*> Download ZLALSA + dependencies
25886*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlalsa.f">
25887*> [TGZ]</a>
25888*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlalsa.f">
25889*> [ZIP]</a>
25890*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlalsa.f">
25891*> [TXT]</a>
25892*> \endhtmlonly
25893*
25894*  Definition:
25895*  ===========
25896*
25897*       SUBROUTINE ZLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U,
25898*                          LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR,
25899*                          GIVCOL, LDGCOL, PERM, GIVNUM, C, S, RWORK,
25900*                          IWORK, INFO )
25901*
25902*       .. Scalar Arguments ..
25903*       INTEGER            ICOMPQ, INFO, LDB, LDBX, LDGCOL, LDU, N, NRHS,
25904*      $                   SMLSIZ
25905*       ..
25906*       .. Array Arguments ..
25907*       INTEGER            GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ),
25908*      $                   K( * ), PERM( LDGCOL, * )
25909*       DOUBLE PRECISION   C( * ), DIFL( LDU, * ), DIFR( LDU, * ),
25910*      $                   GIVNUM( LDU, * ), POLES( LDU, * ), RWORK( * ),
25911*      $                   S( * ), U( LDU, * ), VT( LDU, * ), Z( LDU, * )
25912*       COMPLEX*16         B( LDB, * ), BX( LDBX, * )
25913*       ..
25914*
25915*
25916*> \par Purpose:
25917*  =============
25918*>
25919*> \verbatim
25920*>
25921*> ZLALSA is an itermediate step in solving the least squares problem
25922*> by computing the SVD of the coefficient matrix in compact form (The
25923*> singular vectors are computed as products of simple orthorgonal
25924*> matrices.).
25925*>
25926*> If ICOMPQ = 0, ZLALSA applies the inverse of the left singular vector
25927*> matrix of an upper bidiagonal matrix to the right hand side; and if
25928*> ICOMPQ = 1, ZLALSA applies the right singular vector matrix to the
25929*> right hand side. The singular vector matrices were generated in
25930*> compact form by ZLALSA.
25931*> \endverbatim
25932*
25933*  Arguments:
25934*  ==========
25935*
25936*> \param[in] ICOMPQ
25937*> \verbatim
25938*>          ICOMPQ is INTEGER
25939*>         Specifies whether the left or the right singular vector
25940*>         matrix is involved.
25941*>         = 0: Left singular vector matrix
25942*>         = 1: Right singular vector matrix
25943*> \endverbatim
25944*>
25945*> \param[in] SMLSIZ
25946*> \verbatim
25947*>          SMLSIZ is INTEGER
25948*>         The maximum size of the subproblems at the bottom of the
25949*>         computation tree.
25950*> \endverbatim
25951*>
25952*> \param[in] N
25953*> \verbatim
25954*>          N is INTEGER
25955*>         The row and column dimensions of the upper bidiagonal matrix.
25956*> \endverbatim
25957*>
25958*> \param[in] NRHS
25959*> \verbatim
25960*>          NRHS is INTEGER
25961*>         The number of columns of B and BX. NRHS must be at least 1.
25962*> \endverbatim
25963*>
25964*> \param[in,out] B
25965*> \verbatim
25966*>          B is COMPLEX*16 array, dimension ( LDB, NRHS )
25967*>         On input, B contains the right hand sides of the least
25968*>         squares problem in rows 1 through M.
25969*>         On output, B contains the solution X in rows 1 through N.
25970*> \endverbatim
25971*>
25972*> \param[in] LDB
25973*> \verbatim
25974*>          LDB is INTEGER
25975*>         The leading dimension of B in the calling subprogram.
25976*>         LDB must be at least max(1,MAX( M, N ) ).
25977*> \endverbatim
25978*>
25979*> \param[out] BX
25980*> \verbatim
25981*>          BX is COMPLEX*16 array, dimension ( LDBX, NRHS )
25982*>         On exit, the result of applying the left or right singular
25983*>         vector matrix to B.
25984*> \endverbatim
25985*>
25986*> \param[in] LDBX
25987*> \verbatim
25988*>          LDBX is INTEGER
25989*>         The leading dimension of BX.
25990*> \endverbatim
25991*>
25992*> \param[in] U
25993*> \verbatim
25994*>          U is DOUBLE PRECISION array, dimension ( LDU, SMLSIZ ).
25995*>         On entry, U contains the left singular vector matrices of all
25996*>         subproblems at the bottom level.
25997*> \endverbatim
25998*>
25999*> \param[in] LDU
26000*> \verbatim
26001*>          LDU is INTEGER, LDU = > N.
26002*>         The leading dimension of arrays U, VT, DIFL, DIFR,
26003*>         POLES, GIVNUM, and Z.
26004*> \endverbatim
26005*>
26006*> \param[in] VT
26007*> \verbatim
26008*>          VT is DOUBLE PRECISION array, dimension ( LDU, SMLSIZ+1 ).
26009*>         On entry, VT**H contains the right singular vector matrices of
26010*>         all subproblems at the bottom level.
26011*> \endverbatim
26012*>
26013*> \param[in] K
26014*> \verbatim
26015*>          K is INTEGER array, dimension ( N ).
26016*> \endverbatim
26017*>
26018*> \param[in] DIFL
26019*> \verbatim
26020*>          DIFL is DOUBLE PRECISION array, dimension ( LDU, NLVL ).
26021*>         where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1.
26022*> \endverbatim
26023*>
26024*> \param[in] DIFR
26025*> \verbatim
26026*>          DIFR is DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).
26027*>         On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record
26028*>         distances between singular values on the I-th level and
26029*>         singular values on the (I -1)-th level, and DIFR(*, 2 * I)
26030*>         record the normalizing factors of the right singular vectors
26031*>         matrices of subproblems on I-th level.
26032*> \endverbatim
26033*>
26034*> \param[in] Z
26035*> \verbatim
26036*>          Z is DOUBLE PRECISION array, dimension ( LDU, NLVL ).
26037*>         On entry, Z(1, I) contains the components of the deflation-
26038*>         adjusted updating row vector for subproblems on the I-th
26039*>         level.
26040*> \endverbatim
26041*>
26042*> \param[in] POLES
26043*> \verbatim
26044*>          POLES is DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).
26045*>         On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old
26046*>         singular values involved in the secular equations on the I-th
26047*>         level.
26048*> \endverbatim
26049*>
26050*> \param[in] GIVPTR
26051*> \verbatim
26052*>          GIVPTR is INTEGER array, dimension ( N ).
26053*>         On entry, GIVPTR( I ) records the number of Givens
26054*>         rotations performed on the I-th problem on the computation
26055*>         tree.
26056*> \endverbatim
26057*>
26058*> \param[in] GIVCOL
26059*> \verbatim
26060*>          GIVCOL is INTEGER array, dimension ( LDGCOL, 2 * NLVL ).
26061*>         On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the
26062*>         locations of Givens rotations performed on the I-th level on
26063*>         the computation tree.
26064*> \endverbatim
26065*>
26066*> \param[in] LDGCOL
26067*> \verbatim
26068*>          LDGCOL is INTEGER, LDGCOL = > N.
26069*>         The leading dimension of arrays GIVCOL and PERM.
26070*> \endverbatim
26071*>
26072*> \param[in] PERM
26073*> \verbatim
26074*>          PERM is INTEGER array, dimension ( LDGCOL, NLVL ).
26075*>         On entry, PERM(*, I) records permutations done on the I-th
26076*>         level of the computation tree.
26077*> \endverbatim
26078*>
26079*> \param[in] GIVNUM
26080*> \verbatim
26081*>          GIVNUM is DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).
26082*>         On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S-
26083*>         values of Givens rotations performed on the I-th level on the
26084*>         computation tree.
26085*> \endverbatim
26086*>
26087*> \param[in] C
26088*> \verbatim
26089*>          C is DOUBLE PRECISION array, dimension ( N ).
26090*>         On entry, if the I-th subproblem is not square,
26091*>         C( I ) contains the C-value of a Givens rotation related to
26092*>         the right null space of the I-th subproblem.
26093*> \endverbatim
26094*>
26095*> \param[in] S
26096*> \verbatim
26097*>          S is DOUBLE PRECISION array, dimension ( N ).
26098*>         On entry, if the I-th subproblem is not square,
26099*>         S( I ) contains the S-value of a Givens rotation related to
26100*>         the right null space of the I-th subproblem.
26101*> \endverbatim
26102*>
26103*> \param[out] RWORK
26104*> \verbatim
26105*>          RWORK is DOUBLE PRECISION array, dimension at least
26106*>         MAX( (SMLSZ+1)*NRHS*3, N*(1+NRHS) + 2*NRHS ).
26107*> \endverbatim
26108*>
26109*> \param[out] IWORK
26110*> \verbatim
26111*>          IWORK is INTEGER array, dimension (3*N)
26112*> \endverbatim
26113*>
26114*> \param[out] INFO
26115*> \verbatim
26116*>          INFO is INTEGER
26117*>          = 0:  successful exit.
26118*>          < 0:  if INFO = -i, the i-th argument had an illegal value.
26119*> \endverbatim
26120*
26121*  Authors:
26122*  ========
26123*
26124*> \author Univ. of Tennessee
26125*> \author Univ. of California Berkeley
26126*> \author Univ. of Colorado Denver
26127*> \author NAG Ltd.
26128*
26129*> \date June 2017
26130*
26131*> \ingroup complex16OTHERcomputational
26132*
26133*> \par Contributors:
26134*  ==================
26135*>
26136*>     Ming Gu and Ren-Cang Li, Computer Science Division, University of
26137*>       California at Berkeley, USA \n
26138*>     Osni Marques, LBNL/NERSC, USA \n
26139*
26140*  =====================================================================
26141      SUBROUTINE ZLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U,
26142     $                   LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR,
26143     $                   GIVCOL, LDGCOL, PERM, GIVNUM, C, S, RWORK,
26144     $                   IWORK, INFO )
26145*
26146*  -- LAPACK computational routine (version 3.7.1) --
26147*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
26148*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
26149*     June 2017
26150*
26151*     .. Scalar Arguments ..
26152      INTEGER            ICOMPQ, INFO, LDB, LDBX, LDGCOL, LDU, N, NRHS,
26153     $                   SMLSIZ
26154*     ..
26155*     .. Array Arguments ..
26156      INTEGER            GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ),
26157     $                   K( * ), PERM( LDGCOL, * )
26158      DOUBLE PRECISION   C( * ), DIFL( LDU, * ), DIFR( LDU, * ),
26159     $                   GIVNUM( LDU, * ), POLES( LDU, * ), RWORK( * ),
26160     $                   S( * ), U( LDU, * ), VT( LDU, * ), Z( LDU, * )
26161      COMPLEX*16         B( LDB, * ), BX( LDBX, * )
26162*     ..
26163*
26164*  =====================================================================
26165*
26166*     .. Parameters ..
26167      DOUBLE PRECISION   ZERO, ONE
26168      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
26169*     ..
26170*     .. Local Scalars ..
26171      INTEGER            I, I1, IC, IM1, INODE, J, JCOL, JIMAG, JREAL,
26172     $                   JROW, LF, LL, LVL, LVL2, ND, NDB1, NDIML,
26173     $                   NDIMR, NL, NLF, NLP1, NLVL, NR, NRF, NRP1, SQRE
26174*     ..
26175*     .. External Subroutines ..
26176      EXTERNAL           DGEMM, DLASDT, XERBLA, ZCOPY, ZLALS0
26177*     ..
26178*     .. Intrinsic Functions ..
26179      INTRINSIC          DBLE, DCMPLX, DIMAG
26180*     ..
26181*     .. Executable Statements ..
26182*
26183*     Test the input parameters.
26184*
26185      INFO = 0
26186*
26187      IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
26188         INFO = -1
26189      ELSE IF( SMLSIZ.LT.3 ) THEN
26190         INFO = -2
26191      ELSE IF( N.LT.SMLSIZ ) THEN
26192         INFO = -3
26193      ELSE IF( NRHS.LT.1 ) THEN
26194         INFO = -4
26195      ELSE IF( LDB.LT.N ) THEN
26196         INFO = -6
26197      ELSE IF( LDBX.LT.N ) THEN
26198         INFO = -8
26199      ELSE IF( LDU.LT.N ) THEN
26200         INFO = -10
26201      ELSE IF( LDGCOL.LT.N ) THEN
26202         INFO = -19
26203      END IF
26204      IF( INFO.NE.0 ) THEN
26205         CALL XERBLA( 'ZLALSA', -INFO )
26206         RETURN
26207      END IF
26208*
26209*     Book-keeping and  setting up the computation tree.
26210*
26211      INODE = 1
26212      NDIML = INODE + N
26213      NDIMR = NDIML + N
26214*
26215      CALL DLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ),
26216     $             IWORK( NDIMR ), SMLSIZ )
26217*
26218*     The following code applies back the left singular vector factors.
26219*     For applying back the right singular vector factors, go to 170.
26220*
26221      IF( ICOMPQ.EQ.1 ) THEN
26222         GO TO 170
26223      END IF
26224*
26225*     The nodes on the bottom level of the tree were solved
26226*     by DLASDQ. The corresponding left and right singular vector
26227*     matrices are in explicit form. First apply back the left
26228*     singular vector matrices.
26229*
26230      NDB1 = ( ND+1 ) / 2
26231      DO 130 I = NDB1, ND
26232*
26233*        IC : center row of each node
26234*        NL : number of rows of left  subproblem
26235*        NR : number of rows of right subproblem
26236*        NLF: starting row of the left   subproblem
26237*        NRF: starting row of the right  subproblem
26238*
26239         I1 = I - 1
26240         IC = IWORK( INODE+I1 )
26241         NL = IWORK( NDIML+I1 )
26242         NR = IWORK( NDIMR+I1 )
26243         NLF = IC - NL
26244         NRF = IC + 1
26245*
26246*        Since B and BX are complex, the following call to DGEMM
26247*        is performed in two steps (real and imaginary parts).
26248*
26249*        CALL DGEMM( 'T', 'N', NL, NRHS, NL, ONE, U( NLF, 1 ), LDU,
26250*     $               B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX )
26251*
26252         J = NL*NRHS*2
26253         DO 20 JCOL = 1, NRHS
26254            DO 10 JROW = NLF, NLF + NL - 1
26255               J = J + 1
26256               RWORK( J ) = DBLE( B( JROW, JCOL ) )
26257   10       CONTINUE
26258   20    CONTINUE
26259         CALL DGEMM( 'T', 'N', NL, NRHS, NL, ONE, U( NLF, 1 ), LDU,
26260     $               RWORK( 1+NL*NRHS*2 ), NL, ZERO, RWORK( 1 ), NL )
26261         J = NL*NRHS*2
26262         DO 40 JCOL = 1, NRHS
26263            DO 30 JROW = NLF, NLF + NL - 1
26264               J = J + 1
26265               RWORK( J ) = DIMAG( B( JROW, JCOL ) )
26266   30       CONTINUE
26267   40    CONTINUE
26268         CALL DGEMM( 'T', 'N', NL, NRHS, NL, ONE, U( NLF, 1 ), LDU,
26269     $               RWORK( 1+NL*NRHS*2 ), NL, ZERO, RWORK( 1+NL*NRHS ),
26270     $               NL )
26271         JREAL = 0
26272         JIMAG = NL*NRHS
26273         DO 60 JCOL = 1, NRHS
26274            DO 50 JROW = NLF, NLF + NL - 1
26275               JREAL = JREAL + 1
26276               JIMAG = JIMAG + 1
26277               BX( JROW, JCOL ) = DCMPLX( RWORK( JREAL ),
26278     $                            RWORK( JIMAG ) )
26279   50       CONTINUE
26280   60    CONTINUE
26281*
26282*        Since B and BX are complex, the following call to DGEMM
26283*        is performed in two steps (real and imaginary parts).
26284*
26285*        CALL DGEMM( 'T', 'N', NR, NRHS, NR, ONE, U( NRF, 1 ), LDU,
26286*    $               B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX )
26287*
26288         J = NR*NRHS*2
26289         DO 80 JCOL = 1, NRHS
26290            DO 70 JROW = NRF, NRF + NR - 1
26291               J = J + 1
26292               RWORK( J ) = DBLE( B( JROW, JCOL ) )
26293   70       CONTINUE
26294   80    CONTINUE
26295         CALL DGEMM( 'T', 'N', NR, NRHS, NR, ONE, U( NRF, 1 ), LDU,
26296     $               RWORK( 1+NR*NRHS*2 ), NR, ZERO, RWORK( 1 ), NR )
26297         J = NR*NRHS*2
26298         DO 100 JCOL = 1, NRHS
26299            DO 90 JROW = NRF, NRF + NR - 1
26300               J = J + 1
26301               RWORK( J ) = DIMAG( B( JROW, JCOL ) )
26302   90       CONTINUE
26303  100    CONTINUE
26304         CALL DGEMM( 'T', 'N', NR, NRHS, NR, ONE, U( NRF, 1 ), LDU,
26305     $               RWORK( 1+NR*NRHS*2 ), NR, ZERO, RWORK( 1+NR*NRHS ),
26306     $               NR )
26307         JREAL = 0
26308         JIMAG = NR*NRHS
26309         DO 120 JCOL = 1, NRHS
26310            DO 110 JROW = NRF, NRF + NR - 1
26311               JREAL = JREAL + 1
26312               JIMAG = JIMAG + 1
26313               BX( JROW, JCOL ) = DCMPLX( RWORK( JREAL ),
26314     $                            RWORK( JIMAG ) )
26315  110       CONTINUE
26316  120    CONTINUE
26317*
26318  130 CONTINUE
26319*
26320*     Next copy the rows of B that correspond to unchanged rows
26321*     in the bidiagonal matrix to BX.
26322*
26323      DO 140 I = 1, ND
26324         IC = IWORK( INODE+I-1 )
26325         CALL ZCOPY( NRHS, B( IC, 1 ), LDB, BX( IC, 1 ), LDBX )
26326  140 CONTINUE
26327*
26328*     Finally go through the left singular vector matrices of all
26329*     the other subproblems bottom-up on the tree.
26330*
26331      J = 2**NLVL
26332      SQRE = 0
26333*
26334      DO 160 LVL = NLVL, 1, -1
26335         LVL2 = 2*LVL - 1
26336*
26337*        find the first node LF and last node LL on
26338*        the current level LVL
26339*
26340         IF( LVL.EQ.1 ) THEN
26341            LF = 1
26342            LL = 1
26343         ELSE
26344            LF = 2**( LVL-1 )
26345            LL = 2*LF - 1
26346         END IF
26347         DO 150 I = LF, LL
26348            IM1 = I - 1
26349            IC = IWORK( INODE+IM1 )
26350            NL = IWORK( NDIML+IM1 )
26351            NR = IWORK( NDIMR+IM1 )
26352            NLF = IC - NL
26353            NRF = IC + 1
26354            J = J - 1
26355            CALL ZLALS0( ICOMPQ, NL, NR, SQRE, NRHS, BX( NLF, 1 ), LDBX,
26356     $                   B( NLF, 1 ), LDB, PERM( NLF, LVL ),
26357     $                   GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL,
26358     $                   GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ),
26359     $                   DIFL( NLF, LVL ), DIFR( NLF, LVL2 ),
26360     $                   Z( NLF, LVL ), K( J ), C( J ), S( J ), RWORK,
26361     $                   INFO )
26362  150    CONTINUE
26363  160 CONTINUE
26364      GO TO 330
26365*
26366*     ICOMPQ = 1: applying back the right singular vector factors.
26367*
26368  170 CONTINUE
26369*
26370*     First now go through the right singular vector matrices of all
26371*     the tree nodes top-down.
26372*
26373      J = 0
26374      DO 190 LVL = 1, NLVL
26375         LVL2 = 2*LVL - 1
26376*
26377*        Find the first node LF and last node LL on
26378*        the current level LVL.
26379*
26380         IF( LVL.EQ.1 ) THEN
26381            LF = 1
26382            LL = 1
26383         ELSE
26384            LF = 2**( LVL-1 )
26385            LL = 2*LF - 1
26386         END IF
26387         DO 180 I = LL, LF, -1
26388            IM1 = I - 1
26389            IC = IWORK( INODE+IM1 )
26390            NL = IWORK( NDIML+IM1 )
26391            NR = IWORK( NDIMR+IM1 )
26392            NLF = IC - NL
26393            NRF = IC + 1
26394            IF( I.EQ.LL ) THEN
26395               SQRE = 0
26396            ELSE
26397               SQRE = 1
26398            END IF
26399            J = J + 1
26400            CALL ZLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B( NLF, 1 ), LDB,
26401     $                   BX( NLF, 1 ), LDBX, PERM( NLF, LVL ),
26402     $                   GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL,
26403     $                   GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ),
26404     $                   DIFL( NLF, LVL ), DIFR( NLF, LVL2 ),
26405     $                   Z( NLF, LVL ), K( J ), C( J ), S( J ), RWORK,
26406     $                   INFO )
26407  180    CONTINUE
26408  190 CONTINUE
26409*
26410*     The nodes on the bottom level of the tree were solved
26411*     by DLASDQ. The corresponding right singular vector
26412*     matrices are in explicit form. Apply them back.
26413*
26414      NDB1 = ( ND+1 ) / 2
26415      DO 320 I = NDB1, ND
26416         I1 = I - 1
26417         IC = IWORK( INODE+I1 )
26418         NL = IWORK( NDIML+I1 )
26419         NR = IWORK( NDIMR+I1 )
26420         NLP1 = NL + 1
26421         IF( I.EQ.ND ) THEN
26422            NRP1 = NR
26423         ELSE
26424            NRP1 = NR + 1
26425         END IF
26426         NLF = IC - NL
26427         NRF = IC + 1
26428*
26429*        Since B and BX are complex, the following call to DGEMM is
26430*        performed in two steps (real and imaginary parts).
26431*
26432*        CALL DGEMM( 'T', 'N', NLP1, NRHS, NLP1, ONE, VT( NLF, 1 ), LDU,
26433*    $               B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX )
26434*
26435         J = NLP1*NRHS*2
26436         DO 210 JCOL = 1, NRHS
26437            DO 200 JROW = NLF, NLF + NLP1 - 1
26438               J = J + 1
26439               RWORK( J ) = DBLE( B( JROW, JCOL ) )
26440  200       CONTINUE
26441  210    CONTINUE
26442         CALL DGEMM( 'T', 'N', NLP1, NRHS, NLP1, ONE, VT( NLF, 1 ), LDU,
26443     $               RWORK( 1+NLP1*NRHS*2 ), NLP1, ZERO, RWORK( 1 ),
26444     $               NLP1 )
26445         J = NLP1*NRHS*2
26446         DO 230 JCOL = 1, NRHS
26447            DO 220 JROW = NLF, NLF + NLP1 - 1
26448               J = J + 1
26449               RWORK( J ) = DIMAG( B( JROW, JCOL ) )
26450  220       CONTINUE
26451  230    CONTINUE
26452         CALL DGEMM( 'T', 'N', NLP1, NRHS, NLP1, ONE, VT( NLF, 1 ), LDU,
26453     $               RWORK( 1+NLP1*NRHS*2 ), NLP1, ZERO,
26454     $               RWORK( 1+NLP1*NRHS ), NLP1 )
26455         JREAL = 0
26456         JIMAG = NLP1*NRHS
26457         DO 250 JCOL = 1, NRHS
26458            DO 240 JROW = NLF, NLF + NLP1 - 1
26459               JREAL = JREAL + 1
26460               JIMAG = JIMAG + 1
26461               BX( JROW, JCOL ) = DCMPLX( RWORK( JREAL ),
26462     $                            RWORK( JIMAG ) )
26463  240       CONTINUE
26464  250    CONTINUE
26465*
26466*        Since B and BX are complex, the following call to DGEMM is
26467*        performed in two steps (real and imaginary parts).
26468*
26469*        CALL DGEMM( 'T', 'N', NRP1, NRHS, NRP1, ONE, VT( NRF, 1 ), LDU,
26470*    $               B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX )
26471*
26472         J = NRP1*NRHS*2
26473         DO 270 JCOL = 1, NRHS
26474            DO 260 JROW = NRF, NRF + NRP1 - 1
26475               J = J + 1
26476               RWORK( J ) = DBLE( B( JROW, JCOL ) )
26477  260       CONTINUE
26478  270    CONTINUE
26479         CALL DGEMM( 'T', 'N', NRP1, NRHS, NRP1, ONE, VT( NRF, 1 ), LDU,
26480     $               RWORK( 1+NRP1*NRHS*2 ), NRP1, ZERO, RWORK( 1 ),
26481     $               NRP1 )
26482         J = NRP1*NRHS*2
26483         DO 290 JCOL = 1, NRHS
26484            DO 280 JROW = NRF, NRF + NRP1 - 1
26485               J = J + 1
26486               RWORK( J ) = DIMAG( B( JROW, JCOL ) )
26487  280       CONTINUE
26488  290    CONTINUE
26489         CALL DGEMM( 'T', 'N', NRP1, NRHS, NRP1, ONE, VT( NRF, 1 ), LDU,
26490     $               RWORK( 1+NRP1*NRHS*2 ), NRP1, ZERO,
26491     $               RWORK( 1+NRP1*NRHS ), NRP1 )
26492         JREAL = 0
26493         JIMAG = NRP1*NRHS
26494         DO 310 JCOL = 1, NRHS
26495            DO 300 JROW = NRF, NRF + NRP1 - 1
26496               JREAL = JREAL + 1
26497               JIMAG = JIMAG + 1
26498               BX( JROW, JCOL ) = DCMPLX( RWORK( JREAL ),
26499     $                            RWORK( JIMAG ) )
26500  300       CONTINUE
26501  310    CONTINUE
26502*
26503  320 CONTINUE
26504*
26505  330 CONTINUE
26506*
26507      RETURN
26508*
26509*     End of ZLALSA
26510*
26511      END
26512*> \brief \b ZLALSD uses the singular value decomposition of A to solve the least squares problem.
26513*
26514*  =========== DOCUMENTATION ===========
26515*
26516* Online html documentation available at
26517*            http://www.netlib.org/lapack/explore-html/
26518*
26519*> \htmlonly
26520*> Download ZLALSD + dependencies
26521*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlalsd.f">
26522*> [TGZ]</a>
26523*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlalsd.f">
26524*> [ZIP]</a>
26525*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlalsd.f">
26526*> [TXT]</a>
26527*> \endhtmlonly
26528*
26529*  Definition:
26530*  ===========
26531*
26532*       SUBROUTINE ZLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND,
26533*                          RANK, WORK, RWORK, IWORK, INFO )
26534*
26535*       .. Scalar Arguments ..
26536*       CHARACTER          UPLO
26537*       INTEGER            INFO, LDB, N, NRHS, RANK, SMLSIZ
26538*       DOUBLE PRECISION   RCOND
26539*       ..
26540*       .. Array Arguments ..
26541*       INTEGER            IWORK( * )
26542*       DOUBLE PRECISION   D( * ), E( * ), RWORK( * )
26543*       COMPLEX*16         B( LDB, * ), WORK( * )
26544*       ..
26545*
26546*
26547*> \par Purpose:
26548*  =============
26549*>
26550*> \verbatim
26551*>
26552*> ZLALSD uses the singular value decomposition of A to solve the least
26553*> squares problem of finding X to minimize the Euclidean norm of each
26554*> column of A*X-B, where A is N-by-N upper bidiagonal, and X and B
26555*> are N-by-NRHS. The solution X overwrites B.
26556*>
26557*> The singular values of A smaller than RCOND times the largest
26558*> singular value are treated as zero in solving the least squares
26559*> problem; in this case a minimum norm solution is returned.
26560*> The actual singular values are returned in D in ascending order.
26561*>
26562*> This code makes very mild assumptions about floating point
26563*> arithmetic. It will work on machines with a guard digit in
26564*> add/subtract, or on those binary machines without guard digits
26565*> which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.
26566*> It could conceivably fail on hexadecimal or decimal machines
26567*> without guard digits, but we know of none.
26568*> \endverbatim
26569*
26570*  Arguments:
26571*  ==========
26572*
26573*> \param[in] UPLO
26574*> \verbatim
26575*>          UPLO is CHARACTER*1
26576*>         = 'U': D and E define an upper bidiagonal matrix.
26577*>         = 'L': D and E define a  lower bidiagonal matrix.
26578*> \endverbatim
26579*>
26580*> \param[in] SMLSIZ
26581*> \verbatim
26582*>          SMLSIZ is INTEGER
26583*>         The maximum size of the subproblems at the bottom of the
26584*>         computation tree.
26585*> \endverbatim
26586*>
26587*> \param[in] N
26588*> \verbatim
26589*>          N is INTEGER
26590*>         The dimension of the  bidiagonal matrix.  N >= 0.
26591*> \endverbatim
26592*>
26593*> \param[in] NRHS
26594*> \verbatim
26595*>          NRHS is INTEGER
26596*>         The number of columns of B. NRHS must be at least 1.
26597*> \endverbatim
26598*>
26599*> \param[in,out] D
26600*> \verbatim
26601*>          D is DOUBLE PRECISION array, dimension (N)
26602*>         On entry D contains the main diagonal of the bidiagonal
26603*>         matrix. On exit, if INFO = 0, D contains its singular values.
26604*> \endverbatim
26605*>
26606*> \param[in,out] E
26607*> \verbatim
26608*>          E is DOUBLE PRECISION array, dimension (N-1)
26609*>         Contains the super-diagonal entries of the bidiagonal matrix.
26610*>         On exit, E has been destroyed.
26611*> \endverbatim
26612*>
26613*> \param[in,out] B
26614*> \verbatim
26615*>          B is COMPLEX*16 array, dimension (LDB,NRHS)
26616*>         On input, B contains the right hand sides of the least
26617*>         squares problem. On output, B contains the solution X.
26618*> \endverbatim
26619*>
26620*> \param[in] LDB
26621*> \verbatim
26622*>          LDB is INTEGER
26623*>         The leading dimension of B in the calling subprogram.
26624*>         LDB must be at least max(1,N).
26625*> \endverbatim
26626*>
26627*> \param[in] RCOND
26628*> \verbatim
26629*>          RCOND is DOUBLE PRECISION
26630*>         The singular values of A less than or equal to RCOND times
26631*>         the largest singular value are treated as zero in solving
26632*>         the least squares problem. If RCOND is negative,
26633*>         machine precision is used instead.
26634*>         For example, if diag(S)*X=B were the least squares problem,
26635*>         where diag(S) is a diagonal matrix of singular values, the
26636*>         solution would be X(i) = B(i) / S(i) if S(i) is greater than
26637*>         RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to
26638*>         RCOND*max(S).
26639*> \endverbatim
26640*>
26641*> \param[out] RANK
26642*> \verbatim
26643*>          RANK is INTEGER
26644*>         The number of singular values of A greater than RCOND times
26645*>         the largest singular value.
26646*> \endverbatim
26647*>
26648*> \param[out] WORK
26649*> \verbatim
26650*>          WORK is COMPLEX*16 array, dimension (N * NRHS)
26651*> \endverbatim
26652*>
26653*> \param[out] RWORK
26654*> \verbatim
26655*>          RWORK is DOUBLE PRECISION array, dimension at least
26656*>         (9*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS +
26657*>         MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS ),
26658*>         where
26659*>         NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )
26660*> \endverbatim
26661*>
26662*> \param[out] IWORK
26663*> \verbatim
26664*>          IWORK is INTEGER array, dimension at least
26665*>         (3*N*NLVL + 11*N).
26666*> \endverbatim
26667*>
26668*> \param[out] INFO
26669*> \verbatim
26670*>          INFO is INTEGER
26671*>         = 0:  successful exit.
26672*>         < 0:  if INFO = -i, the i-th argument had an illegal value.
26673*>         > 0:  The algorithm failed to compute a singular value while
26674*>               working on the submatrix lying in rows and columns
26675*>               INFO/(N+1) through MOD(INFO,N+1).
26676*> \endverbatim
26677*
26678*  Authors:
26679*  ========
26680*
26681*> \author Univ. of Tennessee
26682*> \author Univ. of California Berkeley
26683*> \author Univ. of Colorado Denver
26684*> \author NAG Ltd.
26685*
26686*> \date June 2017
26687*
26688*> \ingroup complex16OTHERcomputational
26689*
26690*> \par Contributors:
26691*  ==================
26692*>
26693*>     Ming Gu and Ren-Cang Li, Computer Science Division, University of
26694*>       California at Berkeley, USA \n
26695*>     Osni Marques, LBNL/NERSC, USA \n
26696*
26697*  =====================================================================
26698      SUBROUTINE ZLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND,
26699     $                   RANK, WORK, RWORK, IWORK, INFO )
26700*
26701*  -- LAPACK computational routine (version 3.7.1) --
26702*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
26703*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
26704*     June 2017
26705*
26706*     .. Scalar Arguments ..
26707      CHARACTER          UPLO
26708      INTEGER            INFO, LDB, N, NRHS, RANK, SMLSIZ
26709      DOUBLE PRECISION   RCOND
26710*     ..
26711*     .. Array Arguments ..
26712      INTEGER            IWORK( * )
26713      DOUBLE PRECISION   D( * ), E( * ), RWORK( * )
26714      COMPLEX*16         B( LDB, * ), WORK( * )
26715*     ..
26716*
26717*  =====================================================================
26718*
26719*     .. Parameters ..
26720      DOUBLE PRECISION   ZERO, ONE, TWO
26721      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
26722      COMPLEX*16         CZERO
26723      PARAMETER          ( CZERO = ( 0.0D0, 0.0D0 ) )
26724*     ..
26725*     .. Local Scalars ..
26726      INTEGER            BX, BXST, C, DIFL, DIFR, GIVCOL, GIVNUM,
26727     $                   GIVPTR, I, ICMPQ1, ICMPQ2, IRWB, IRWIB, IRWRB,
26728     $                   IRWU, IRWVT, IRWWRK, IWK, J, JCOL, JIMAG,
26729     $                   JREAL, JROW, K, NLVL, NM1, NRWORK, NSIZE, NSUB,
26730     $                   PERM, POLES, S, SIZEI, SMLSZP, SQRE, ST, ST1,
26731     $                   U, VT, Z
26732      DOUBLE PRECISION   CS, EPS, ORGNRM, RCND, R, SN, TOL
26733*     ..
26734*     .. External Functions ..
26735      INTEGER            IDAMAX
26736      DOUBLE PRECISION   DLAMCH, DLANST
26737      EXTERNAL           IDAMAX, DLAMCH, DLANST
26738*     ..
26739*     .. External Subroutines ..
26740      EXTERNAL           DGEMM, DLARTG, DLASCL, DLASDA, DLASDQ, DLASET,
26741     $                   DLASRT, XERBLA, ZCOPY, ZDROT, ZLACPY, ZLALSA,
26742     $                   ZLASCL, ZLASET
26743*     ..
26744*     .. Intrinsic Functions ..
26745      INTRINSIC          ABS, DBLE, DCMPLX, DIMAG, INT, LOG, SIGN
26746*     ..
26747*     .. Executable Statements ..
26748*
26749*     Test the input parameters.
26750*
26751      INFO = 0
26752*
26753      IF( N.LT.0 ) THEN
26754         INFO = -3
26755      ELSE IF( NRHS.LT.1 ) THEN
26756         INFO = -4
26757      ELSE IF( ( LDB.LT.1 ) .OR. ( LDB.LT.N ) ) THEN
26758         INFO = -8
26759      END IF
26760      IF( INFO.NE.0 ) THEN
26761         CALL XERBLA( 'ZLALSD', -INFO )
26762         RETURN
26763      END IF
26764*
26765      EPS = DLAMCH( 'Epsilon' )
26766*
26767*     Set up the tolerance.
26768*
26769      IF( ( RCOND.LE.ZERO ) .OR. ( RCOND.GE.ONE ) ) THEN
26770         RCND = EPS
26771      ELSE
26772         RCND = RCOND
26773      END IF
26774*
26775      RANK = 0
26776*
26777*     Quick return if possible.
26778*
26779      IF( N.EQ.0 ) THEN
26780         RETURN
26781      ELSE IF( N.EQ.1 ) THEN
26782         IF( D( 1 ).EQ.ZERO ) THEN
26783            CALL ZLASET( 'A', 1, NRHS, CZERO, CZERO, B, LDB )
26784         ELSE
26785            RANK = 1
26786            CALL ZLASCL( 'G', 0, 0, D( 1 ), ONE, 1, NRHS, B, LDB, INFO )
26787            D( 1 ) = ABS( D( 1 ) )
26788         END IF
26789         RETURN
26790      END IF
26791*
26792*     Rotate the matrix if it is lower bidiagonal.
26793*
26794      IF( UPLO.EQ.'L' ) THEN
26795         DO 10 I = 1, N - 1
26796            CALL DLARTG( D( I ), E( I ), CS, SN, R )
26797            D( I ) = R
26798            E( I ) = SN*D( I+1 )
26799            D( I+1 ) = CS*D( I+1 )
26800            IF( NRHS.EQ.1 ) THEN
26801               CALL ZDROT( 1, B( I, 1 ), 1, B( I+1, 1 ), 1, CS, SN )
26802            ELSE
26803               RWORK( I*2-1 ) = CS
26804               RWORK( I*2 ) = SN
26805            END IF
26806   10    CONTINUE
26807         IF( NRHS.GT.1 ) THEN
26808            DO 30 I = 1, NRHS
26809               DO 20 J = 1, N - 1
26810                  CS = RWORK( J*2-1 )
26811                  SN = RWORK( J*2 )
26812                  CALL ZDROT( 1, B( J, I ), 1, B( J+1, I ), 1, CS, SN )
26813   20          CONTINUE
26814   30       CONTINUE
26815         END IF
26816      END IF
26817*
26818*     Scale.
26819*
26820      NM1 = N - 1
26821      ORGNRM = DLANST( 'M', N, D, E )
26822      IF( ORGNRM.EQ.ZERO ) THEN
26823         CALL ZLASET( 'A', N, NRHS, CZERO, CZERO, B, LDB )
26824         RETURN
26825      END IF
26826*
26827      CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO )
26828      CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, NM1, 1, E, NM1, INFO )
26829*
26830*     If N is smaller than the minimum divide size SMLSIZ, then solve
26831*     the problem with another solver.
26832*
26833      IF( N.LE.SMLSIZ ) THEN
26834         IRWU = 1
26835         IRWVT = IRWU + N*N
26836         IRWWRK = IRWVT + N*N
26837         IRWRB = IRWWRK
26838         IRWIB = IRWRB + N*NRHS
26839         IRWB = IRWIB + N*NRHS
26840         CALL DLASET( 'A', N, N, ZERO, ONE, RWORK( IRWU ), N )
26841         CALL DLASET( 'A', N, N, ZERO, ONE, RWORK( IRWVT ), N )
26842         CALL DLASDQ( 'U', 0, N, N, N, 0, D, E, RWORK( IRWVT ), N,
26843     $                RWORK( IRWU ), N, RWORK( IRWWRK ), 1,
26844     $                RWORK( IRWWRK ), INFO )
26845         IF( INFO.NE.0 ) THEN
26846            RETURN
26847         END IF
26848*
26849*        In the real version, B is passed to DLASDQ and multiplied
26850*        internally by Q**H. Here B is complex and that product is
26851*        computed below in two steps (real and imaginary parts).
26852*
26853         J = IRWB - 1
26854         DO 50 JCOL = 1, NRHS
26855            DO 40 JROW = 1, N
26856               J = J + 1
26857               RWORK( J ) = DBLE( B( JROW, JCOL ) )
26858   40       CONTINUE
26859   50    CONTINUE
26860         CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, RWORK( IRWU ), N,
26861     $               RWORK( IRWB ), N, ZERO, RWORK( IRWRB ), N )
26862         J = IRWB - 1
26863         DO 70 JCOL = 1, NRHS
26864            DO 60 JROW = 1, N
26865               J = J + 1
26866               RWORK( J ) = DIMAG( B( JROW, JCOL ) )
26867   60       CONTINUE
26868   70    CONTINUE
26869         CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, RWORK( IRWU ), N,
26870     $               RWORK( IRWB ), N, ZERO, RWORK( IRWIB ), N )
26871         JREAL = IRWRB - 1
26872         JIMAG = IRWIB - 1
26873         DO 90 JCOL = 1, NRHS
26874            DO 80 JROW = 1, N
26875               JREAL = JREAL + 1
26876               JIMAG = JIMAG + 1
26877               B( JROW, JCOL ) = DCMPLX( RWORK( JREAL ),
26878     $                           RWORK( JIMAG ) )
26879   80       CONTINUE
26880   90    CONTINUE
26881*
26882         TOL = RCND*ABS( D( IDAMAX( N, D, 1 ) ) )
26883         DO 100 I = 1, N
26884            IF( D( I ).LE.TOL ) THEN
26885               CALL ZLASET( 'A', 1, NRHS, CZERO, CZERO, B( I, 1 ), LDB )
26886            ELSE
26887               CALL ZLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS, B( I, 1 ),
26888     $                      LDB, INFO )
26889               RANK = RANK + 1
26890            END IF
26891  100    CONTINUE
26892*
26893*        Since B is complex, the following call to DGEMM is performed
26894*        in two steps (real and imaginary parts). That is for V * B
26895*        (in the real version of the code V**H is stored in WORK).
26896*
26897*        CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, WORK, N, B, LDB, ZERO,
26898*    $               WORK( NWORK ), N )
26899*
26900         J = IRWB - 1
26901         DO 120 JCOL = 1, NRHS
26902            DO 110 JROW = 1, N
26903               J = J + 1
26904               RWORK( J ) = DBLE( B( JROW, JCOL ) )
26905  110       CONTINUE
26906  120    CONTINUE
26907         CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, RWORK( IRWVT ), N,
26908     $               RWORK( IRWB ), N, ZERO, RWORK( IRWRB ), N )
26909         J = IRWB - 1
26910         DO 140 JCOL = 1, NRHS
26911            DO 130 JROW = 1, N
26912               J = J + 1
26913               RWORK( J ) = DIMAG( B( JROW, JCOL ) )
26914  130       CONTINUE
26915  140    CONTINUE
26916         CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, RWORK( IRWVT ), N,
26917     $               RWORK( IRWB ), N, ZERO, RWORK( IRWIB ), N )
26918         JREAL = IRWRB - 1
26919         JIMAG = IRWIB - 1
26920         DO 160 JCOL = 1, NRHS
26921            DO 150 JROW = 1, N
26922               JREAL = JREAL + 1
26923               JIMAG = JIMAG + 1
26924               B( JROW, JCOL ) = DCMPLX( RWORK( JREAL ),
26925     $                           RWORK( JIMAG ) )
26926  150       CONTINUE
26927  160    CONTINUE
26928*
26929*        Unscale.
26930*
26931         CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
26932         CALL DLASRT( 'D', N, D, INFO )
26933         CALL ZLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO )
26934*
26935         RETURN
26936      END IF
26937*
26938*     Book-keeping and setting up some constants.
26939*
26940      NLVL = INT( LOG( DBLE( N ) / DBLE( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1
26941*
26942      SMLSZP = SMLSIZ + 1
26943*
26944      U = 1
26945      VT = 1 + SMLSIZ*N
26946      DIFL = VT + SMLSZP*N
26947      DIFR = DIFL + NLVL*N
26948      Z = DIFR + NLVL*N*2
26949      C = Z + NLVL*N
26950      S = C + N
26951      POLES = S + N
26952      GIVNUM = POLES + 2*NLVL*N
26953      NRWORK = GIVNUM + 2*NLVL*N
26954      BX = 1
26955*
26956      IRWRB = NRWORK
26957      IRWIB = IRWRB + SMLSIZ*NRHS
26958      IRWB = IRWIB + SMLSIZ*NRHS
26959*
26960      SIZEI = 1 + N
26961      K = SIZEI + N
26962      GIVPTR = K + N
26963      PERM = GIVPTR + N
26964      GIVCOL = PERM + NLVL*N
26965      IWK = GIVCOL + NLVL*N*2
26966*
26967      ST = 1
26968      SQRE = 0
26969      ICMPQ1 = 1
26970      ICMPQ2 = 0
26971      NSUB = 0
26972*
26973      DO 170 I = 1, N
26974         IF( ABS( D( I ) ).LT.EPS ) THEN
26975            D( I ) = SIGN( EPS, D( I ) )
26976         END IF
26977  170 CONTINUE
26978*
26979      DO 240 I = 1, NM1
26980         IF( ( ABS( E( I ) ).LT.EPS ) .OR. ( I.EQ.NM1 ) ) THEN
26981            NSUB = NSUB + 1
26982            IWORK( NSUB ) = ST
26983*
26984*           Subproblem found. First determine its size and then
26985*           apply divide and conquer on it.
26986*
26987            IF( I.LT.NM1 ) THEN
26988*
26989*              A subproblem with E(I) small for I < NM1.
26990*
26991               NSIZE = I - ST + 1
26992               IWORK( SIZEI+NSUB-1 ) = NSIZE
26993            ELSE IF( ABS( E( I ) ).GE.EPS ) THEN
26994*
26995*              A subproblem with E(NM1) not too small but I = NM1.
26996*
26997               NSIZE = N - ST + 1
26998               IWORK( SIZEI+NSUB-1 ) = NSIZE
26999            ELSE
27000*
27001*              A subproblem with E(NM1) small. This implies an
27002*              1-by-1 subproblem at D(N), which is not solved
27003*              explicitly.
27004*
27005               NSIZE = I - ST + 1
27006               IWORK( SIZEI+NSUB-1 ) = NSIZE
27007               NSUB = NSUB + 1
27008               IWORK( NSUB ) = N
27009               IWORK( SIZEI+NSUB-1 ) = 1
27010               CALL ZCOPY( NRHS, B( N, 1 ), LDB, WORK( BX+NM1 ), N )
27011            END IF
27012            ST1 = ST - 1
27013            IF( NSIZE.EQ.1 ) THEN
27014*
27015*              This is a 1-by-1 subproblem and is not solved
27016*              explicitly.
27017*
27018               CALL ZCOPY( NRHS, B( ST, 1 ), LDB, WORK( BX+ST1 ), N )
27019            ELSE IF( NSIZE.LE.SMLSIZ ) THEN
27020*
27021*              This is a small subproblem and is solved by DLASDQ.
27022*
27023               CALL DLASET( 'A', NSIZE, NSIZE, ZERO, ONE,
27024     $                      RWORK( VT+ST1 ), N )
27025               CALL DLASET( 'A', NSIZE, NSIZE, ZERO, ONE,
27026     $                      RWORK( U+ST1 ), N )
27027               CALL DLASDQ( 'U', 0, NSIZE, NSIZE, NSIZE, 0, D( ST ),
27028     $                      E( ST ), RWORK( VT+ST1 ), N, RWORK( U+ST1 ),
27029     $                      N, RWORK( NRWORK ), 1, RWORK( NRWORK ),
27030     $                      INFO )
27031               IF( INFO.NE.0 ) THEN
27032                  RETURN
27033               END IF
27034*
27035*              In the real version, B is passed to DLASDQ and multiplied
27036*              internally by Q**H. Here B is complex and that product is
27037*              computed below in two steps (real and imaginary parts).
27038*
27039               J = IRWB - 1
27040               DO 190 JCOL = 1, NRHS
27041                  DO 180 JROW = ST, ST + NSIZE - 1
27042                     J = J + 1
27043                     RWORK( J ) = DBLE( B( JROW, JCOL ) )
27044  180             CONTINUE
27045  190          CONTINUE
27046               CALL DGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE,
27047     $                     RWORK( U+ST1 ), N, RWORK( IRWB ), NSIZE,
27048     $                     ZERO, RWORK( IRWRB ), NSIZE )
27049               J = IRWB - 1
27050               DO 210 JCOL = 1, NRHS
27051                  DO 200 JROW = ST, ST + NSIZE - 1
27052                     J = J + 1
27053                     RWORK( J ) = DIMAG( B( JROW, JCOL ) )
27054  200             CONTINUE
27055  210          CONTINUE
27056               CALL DGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE,
27057     $                     RWORK( U+ST1 ), N, RWORK( IRWB ), NSIZE,
27058     $                     ZERO, RWORK( IRWIB ), NSIZE )
27059               JREAL = IRWRB - 1
27060               JIMAG = IRWIB - 1
27061               DO 230 JCOL = 1, NRHS
27062                  DO 220 JROW = ST, ST + NSIZE - 1
27063                     JREAL = JREAL + 1
27064                     JIMAG = JIMAG + 1
27065                     B( JROW, JCOL ) = DCMPLX( RWORK( JREAL ),
27066     $                                 RWORK( JIMAG ) )
27067  220             CONTINUE
27068  230          CONTINUE
27069*
27070               CALL ZLACPY( 'A', NSIZE, NRHS, B( ST, 1 ), LDB,
27071     $                      WORK( BX+ST1 ), N )
27072            ELSE
27073*
27074*              A large problem. Solve it using divide and conquer.
27075*
27076               CALL DLASDA( ICMPQ1, SMLSIZ, NSIZE, SQRE, D( ST ),
27077     $                      E( ST ), RWORK( U+ST1 ), N, RWORK( VT+ST1 ),
27078     $                      IWORK( K+ST1 ), RWORK( DIFL+ST1 ),
27079     $                      RWORK( DIFR+ST1 ), RWORK( Z+ST1 ),
27080     $                      RWORK( POLES+ST1 ), IWORK( GIVPTR+ST1 ),
27081     $                      IWORK( GIVCOL+ST1 ), N, IWORK( PERM+ST1 ),
27082     $                      RWORK( GIVNUM+ST1 ), RWORK( C+ST1 ),
27083     $                      RWORK( S+ST1 ), RWORK( NRWORK ),
27084     $                      IWORK( IWK ), INFO )
27085               IF( INFO.NE.0 ) THEN
27086                  RETURN
27087               END IF
27088               BXST = BX + ST1
27089               CALL ZLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, B( ST, 1 ),
27090     $                      LDB, WORK( BXST ), N, RWORK( U+ST1 ), N,
27091     $                      RWORK( VT+ST1 ), IWORK( K+ST1 ),
27092     $                      RWORK( DIFL+ST1 ), RWORK( DIFR+ST1 ),
27093     $                      RWORK( Z+ST1 ), RWORK( POLES+ST1 ),
27094     $                      IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N,
27095     $                      IWORK( PERM+ST1 ), RWORK( GIVNUM+ST1 ),
27096     $                      RWORK( C+ST1 ), RWORK( S+ST1 ),
27097     $                      RWORK( NRWORK ), IWORK( IWK ), INFO )
27098               IF( INFO.NE.0 ) THEN
27099                  RETURN
27100               END IF
27101            END IF
27102            ST = I + 1
27103         END IF
27104  240 CONTINUE
27105*
27106*     Apply the singular values and treat the tiny ones as zero.
27107*
27108      TOL = RCND*ABS( D( IDAMAX( N, D, 1 ) ) )
27109*
27110      DO 250 I = 1, N
27111*
27112*        Some of the elements in D can be negative because 1-by-1
27113*        subproblems were not solved explicitly.
27114*
27115         IF( ABS( D( I ) ).LE.TOL ) THEN
27116            CALL ZLASET( 'A', 1, NRHS, CZERO, CZERO, WORK( BX+I-1 ), N )
27117         ELSE
27118            RANK = RANK + 1
27119            CALL ZLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS,
27120     $                   WORK( BX+I-1 ), N, INFO )
27121         END IF
27122         D( I ) = ABS( D( I ) )
27123  250 CONTINUE
27124*
27125*     Now apply back the right singular vectors.
27126*
27127      ICMPQ2 = 1
27128      DO 320 I = 1, NSUB
27129         ST = IWORK( I )
27130         ST1 = ST - 1
27131         NSIZE = IWORK( SIZEI+I-1 )
27132         BXST = BX + ST1
27133         IF( NSIZE.EQ.1 ) THEN
27134            CALL ZCOPY( NRHS, WORK( BXST ), N, B( ST, 1 ), LDB )
27135         ELSE IF( NSIZE.LE.SMLSIZ ) THEN
27136*
27137*           Since B and BX are complex, the following call to DGEMM
27138*           is performed in two steps (real and imaginary parts).
27139*
27140*           CALL DGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE,
27141*    $                  RWORK( VT+ST1 ), N, RWORK( BXST ), N, ZERO,
27142*    $                  B( ST, 1 ), LDB )
27143*
27144            J = BXST - N - 1
27145            JREAL = IRWB - 1
27146            DO 270 JCOL = 1, NRHS
27147               J = J + N
27148               DO 260 JROW = 1, NSIZE
27149                  JREAL = JREAL + 1
27150                  RWORK( JREAL ) = DBLE( WORK( J+JROW ) )
27151  260          CONTINUE
27152  270       CONTINUE
27153            CALL DGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE,
27154     $                  RWORK( VT+ST1 ), N, RWORK( IRWB ), NSIZE, ZERO,
27155     $                  RWORK( IRWRB ), NSIZE )
27156            J = BXST - N - 1
27157            JIMAG = IRWB - 1
27158            DO 290 JCOL = 1, NRHS
27159               J = J + N
27160               DO 280 JROW = 1, NSIZE
27161                  JIMAG = JIMAG + 1
27162                  RWORK( JIMAG ) = DIMAG( WORK( J+JROW ) )
27163  280          CONTINUE
27164  290       CONTINUE
27165            CALL DGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE,
27166     $                  RWORK( VT+ST1 ), N, RWORK( IRWB ), NSIZE, ZERO,
27167     $                  RWORK( IRWIB ), NSIZE )
27168            JREAL = IRWRB - 1
27169            JIMAG = IRWIB - 1
27170            DO 310 JCOL = 1, NRHS
27171               DO 300 JROW = ST, ST + NSIZE - 1
27172                  JREAL = JREAL + 1
27173                  JIMAG = JIMAG + 1
27174                  B( JROW, JCOL ) = DCMPLX( RWORK( JREAL ),
27175     $                              RWORK( JIMAG ) )
27176  300          CONTINUE
27177  310       CONTINUE
27178         ELSE
27179            CALL ZLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, WORK( BXST ), N,
27180     $                   B( ST, 1 ), LDB, RWORK( U+ST1 ), N,
27181     $                   RWORK( VT+ST1 ), IWORK( K+ST1 ),
27182     $                   RWORK( DIFL+ST1 ), RWORK( DIFR+ST1 ),
27183     $                   RWORK( Z+ST1 ), RWORK( POLES+ST1 ),
27184     $                   IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N,
27185     $                   IWORK( PERM+ST1 ), RWORK( GIVNUM+ST1 ),
27186     $                   RWORK( C+ST1 ), RWORK( S+ST1 ),
27187     $                   RWORK( NRWORK ), IWORK( IWK ), INFO )
27188            IF( INFO.NE.0 ) THEN
27189               RETURN
27190            END IF
27191         END IF
27192  320 CONTINUE
27193*
27194*     Unscale and sort the singular values.
27195*
27196      CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
27197      CALL DLASRT( 'D', N, D, INFO )
27198      CALL ZLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO )
27199*
27200      RETURN
27201*
27202*     End of ZLALSD
27203*
27204      END
27205*> \brief \b ZLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value of any element of a general rectangular matrix.
27206*
27207*  =========== DOCUMENTATION ===========
27208*
27209* Online html documentation available at
27210*            http://www.netlib.org/lapack/explore-html/
27211*
27212*> \htmlonly
27213*> Download ZLANGE + dependencies
27214*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlange.f">
27215*> [TGZ]</a>
27216*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlange.f">
27217*> [ZIP]</a>
27218*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlange.f">
27219*> [TXT]</a>
27220*> \endhtmlonly
27221*
27222*  Definition:
27223*  ===========
27224*
27225*       DOUBLE PRECISION FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK )
27226*
27227*       .. Scalar Arguments ..
27228*       CHARACTER          NORM
27229*       INTEGER            LDA, M, N
27230*       ..
27231*       .. Array Arguments ..
27232*       DOUBLE PRECISION   WORK( * )
27233*       COMPLEX*16         A( LDA, * )
27234*       ..
27235*
27236*
27237*> \par Purpose:
27238*  =============
27239*>
27240*> \verbatim
27241*>
27242*> ZLANGE  returns the value of the one norm,  or the Frobenius norm, or
27243*> the  infinity norm,  or the  element of  largest absolute value  of a
27244*> complex matrix A.
27245*> \endverbatim
27246*>
27247*> \return ZLANGE
27248*> \verbatim
27249*>
27250*>    ZLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm'
27251*>             (
27252*>             ( norm1(A),         NORM = '1', 'O' or 'o'
27253*>             (
27254*>             ( normI(A),         NORM = 'I' or 'i'
27255*>             (
27256*>             ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
27257*>
27258*> where  norm1  denotes the  one norm of a matrix (maximum column sum),
27259*> normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
27260*> normF  denotes the  Frobenius norm of a matrix (square root of sum of
27261*> squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.
27262*> \endverbatim
27263*
27264*  Arguments:
27265*  ==========
27266*
27267*> \param[in] NORM
27268*> \verbatim
27269*>          NORM is CHARACTER*1
27270*>          Specifies the value to be returned in ZLANGE as described
27271*>          above.
27272*> \endverbatim
27273*>
27274*> \param[in] M
27275*> \verbatim
27276*>          M is INTEGER
27277*>          The number of rows of the matrix A.  M >= 0.  When M = 0,
27278*>          ZLANGE is set to zero.
27279*> \endverbatim
27280*>
27281*> \param[in] N
27282*> \verbatim
27283*>          N is INTEGER
27284*>          The number of columns of the matrix A.  N >= 0.  When N = 0,
27285*>          ZLANGE is set to zero.
27286*> \endverbatim
27287*>
27288*> \param[in] A
27289*> \verbatim
27290*>          A is COMPLEX*16 array, dimension (LDA,N)
27291*>          The m by n matrix A.
27292*> \endverbatim
27293*>
27294*> \param[in] LDA
27295*> \verbatim
27296*>          LDA is INTEGER
27297*>          The leading dimension of the array A.  LDA >= max(M,1).
27298*> \endverbatim
27299*>
27300*> \param[out] WORK
27301*> \verbatim
27302*>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
27303*>          where LWORK >= M when NORM = 'I'; otherwise, WORK is not
27304*>          referenced.
27305*> \endverbatim
27306*
27307*  Authors:
27308*  ========
27309*
27310*> \author Univ. of Tennessee
27311*> \author Univ. of California Berkeley
27312*> \author Univ. of Colorado Denver
27313*> \author NAG Ltd.
27314*
27315*> \date December 2016
27316*
27317*> \ingroup complex16GEauxiliary
27318*
27319*  =====================================================================
27320      DOUBLE PRECISION FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK )
27321*
27322*  -- LAPACK auxiliary routine (version 3.7.0) --
27323*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
27324*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
27325*     December 2016
27326*
27327      IMPLICIT NONE
27328*     .. Scalar Arguments ..
27329      CHARACTER          NORM
27330      INTEGER            LDA, M, N
27331*     ..
27332*     .. Array Arguments ..
27333      DOUBLE PRECISION   WORK( * )
27334      COMPLEX*16         A( LDA, * )
27335*     ..
27336*
27337* =====================================================================
27338*
27339*     .. Parameters ..
27340      DOUBLE PRECISION   ONE, ZERO
27341      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
27342*     ..
27343*     .. Local Scalars ..
27344      INTEGER            I, J
27345      DOUBLE PRECISION   SUM, VALUE, TEMP
27346*     ..
27347*     .. Local Arrays ..
27348      DOUBLE PRECISION   SSQ( 2 ), COLSSQ( 2 )
27349*     ..
27350*     .. External Functions ..
27351      LOGICAL            LSAME, DISNAN
27352      EXTERNAL           LSAME, DISNAN
27353*     ..
27354*     .. External Subroutines ..
27355      EXTERNAL           ZLASSQ, DCOMBSSQ
27356*     ..
27357*     .. Intrinsic Functions ..
27358      INTRINSIC          ABS, MIN, SQRT
27359*     ..
27360*     .. Executable Statements ..
27361*
27362      IF( MIN( M, N ).EQ.0 ) THEN
27363         VALUE = ZERO
27364      ELSE IF( LSAME( NORM, 'M' ) ) THEN
27365*
27366*        Find max(abs(A(i,j))).
27367*
27368         VALUE = ZERO
27369         DO 20 J = 1, N
27370            DO 10 I = 1, M
27371               TEMP = ABS( A( I, J ) )
27372               IF( VALUE.LT.TEMP .OR. DISNAN( TEMP ) ) VALUE = TEMP
27373   10       CONTINUE
27374   20    CONTINUE
27375      ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
27376*
27377*        Find norm1(A).
27378*
27379         VALUE = ZERO
27380         DO 40 J = 1, N
27381            SUM = ZERO
27382            DO 30 I = 1, M
27383               SUM = SUM + ABS( A( I, J ) )
27384   30       CONTINUE
27385            IF( VALUE.LT.SUM .OR. DISNAN( SUM ) ) VALUE = SUM
27386   40    CONTINUE
27387      ELSE IF( LSAME( NORM, 'I' ) ) THEN
27388*
27389*        Find normI(A).
27390*
27391         DO 50 I = 1, M
27392            WORK( I ) = ZERO
27393   50    CONTINUE
27394         DO 70 J = 1, N
27395            DO 60 I = 1, M
27396               WORK( I ) = WORK( I ) + ABS( A( I, J ) )
27397   60       CONTINUE
27398   70    CONTINUE
27399         VALUE = ZERO
27400         DO 80 I = 1, M
27401            TEMP = WORK( I )
27402            IF( VALUE.LT.TEMP .OR. DISNAN( TEMP ) ) VALUE = TEMP
27403   80    CONTINUE
27404      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
27405*
27406*        Find normF(A).
27407*        SSQ(1) is scale
27408*        SSQ(2) is sum-of-squares
27409*        For better accuracy, sum each column separately.
27410*
27411         SSQ( 1 ) = ZERO
27412         SSQ( 2 ) = ONE
27413         DO 90 J = 1, N
27414            COLSSQ( 1 ) = ZERO
27415            COLSSQ( 2 ) = ONE
27416            CALL ZLASSQ( M, A( 1, J ), 1, COLSSQ( 1 ), COLSSQ( 2 ) )
27417            CALL DCOMBSSQ( SSQ, COLSSQ )
27418   90    CONTINUE
27419         VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) )
27420      END IF
27421*
27422      ZLANGE = VALUE
27423      RETURN
27424*
27425*     End of ZLANGE
27426*
27427      END
27428*> \brief \b ZLANHE returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a complex Hermitian matrix.
27429*
27430*  =========== DOCUMENTATION ===========
27431*
27432* Online html documentation available at
27433*            http://www.netlib.org/lapack/explore-html/
27434*
27435*> \htmlonly
27436*> Download ZLANHE + dependencies
27437*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlanhe.f">
27438*> [TGZ]</a>
27439*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlanhe.f">
27440*> [ZIP]</a>
27441*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlanhe.f">
27442*> [TXT]</a>
27443*> \endhtmlonly
27444*
27445*  Definition:
27446*  ===========
27447*
27448*       DOUBLE PRECISION FUNCTION ZLANHE( NORM, UPLO, N, A, LDA, WORK )
27449*
27450*       .. Scalar Arguments ..
27451*       CHARACTER          NORM, UPLO
27452*       INTEGER            LDA, N
27453*       ..
27454*       .. Array Arguments ..
27455*       DOUBLE PRECISION   WORK( * )
27456*       COMPLEX*16         A( LDA, * )
27457*       ..
27458*
27459*
27460*> \par Purpose:
27461*  =============
27462*>
27463*> \verbatim
27464*>
27465*> ZLANHE  returns the value of the one norm,  or the Frobenius norm, or
27466*> the  infinity norm,  or the  element of  largest absolute value  of a
27467*> complex hermitian matrix A.
27468*> \endverbatim
27469*>
27470*> \return ZLANHE
27471*> \verbatim
27472*>
27473*>    ZLANHE = ( max(abs(A(i,j))), NORM = 'M' or 'm'
27474*>             (
27475*>             ( norm1(A),         NORM = '1', 'O' or 'o'
27476*>             (
27477*>             ( normI(A),         NORM = 'I' or 'i'
27478*>             (
27479*>             ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
27480*>
27481*> where  norm1  denotes the  one norm of a matrix (maximum column sum),
27482*> normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
27483*> normF  denotes the  Frobenius norm of a matrix (square root of sum of
27484*> squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.
27485*> \endverbatim
27486*
27487*  Arguments:
27488*  ==========
27489*
27490*> \param[in] NORM
27491*> \verbatim
27492*>          NORM is CHARACTER*1
27493*>          Specifies the value to be returned in ZLANHE as described
27494*>          above.
27495*> \endverbatim
27496*>
27497*> \param[in] UPLO
27498*> \verbatim
27499*>          UPLO is CHARACTER*1
27500*>          Specifies whether the upper or lower triangular part of the
27501*>          hermitian matrix A is to be referenced.
27502*>          = 'U':  Upper triangular part of A is referenced
27503*>          = 'L':  Lower triangular part of A is referenced
27504*> \endverbatim
27505*>
27506*> \param[in] N
27507*> \verbatim
27508*>          N is INTEGER
27509*>          The order of the matrix A.  N >= 0.  When N = 0, ZLANHE is
27510*>          set to zero.
27511*> \endverbatim
27512*>
27513*> \param[in] A
27514*> \verbatim
27515*>          A is COMPLEX*16 array, dimension (LDA,N)
27516*>          The hermitian matrix A.  If UPLO = 'U', the leading n by n
27517*>          upper triangular part of A contains the upper triangular part
27518*>          of the matrix A, and the strictly lower triangular part of A
27519*>          is not referenced.  If UPLO = 'L', the leading n by n lower
27520*>          triangular part of A contains the lower triangular part of
27521*>          the matrix A, and the strictly upper triangular part of A is
27522*>          not referenced. Note that the imaginary parts of the diagonal
27523*>          elements need not be set and are assumed to be zero.
27524*> \endverbatim
27525*>
27526*> \param[in] LDA
27527*> \verbatim
27528*>          LDA is INTEGER
27529*>          The leading dimension of the array A.  LDA >= max(N,1).
27530*> \endverbatim
27531*>
27532*> \param[out] WORK
27533*> \verbatim
27534*>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
27535*>          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
27536*>          WORK is not referenced.
27537*> \endverbatim
27538*
27539*  Authors:
27540*  ========
27541*
27542*> \author Univ. of Tennessee
27543*> \author Univ. of California Berkeley
27544*> \author Univ. of Colorado Denver
27545*> \author NAG Ltd.
27546*
27547*> \date December 2016
27548*
27549*> \ingroup complex16HEauxiliary
27550*
27551*  =====================================================================
27552      DOUBLE PRECISION FUNCTION ZLANHE( NORM, UPLO, N, A, LDA, WORK )
27553*
27554*  -- LAPACK auxiliary routine (version 3.7.0) --
27555*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
27556*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
27557*     December 2016
27558*
27559      IMPLICIT NONE
27560*     .. Scalar Arguments ..
27561      CHARACTER          NORM, UPLO
27562      INTEGER            LDA, N
27563*     ..
27564*     .. Array Arguments ..
27565      DOUBLE PRECISION   WORK( * )
27566      COMPLEX*16         A( LDA, * )
27567*     ..
27568*
27569* =====================================================================
27570*
27571*     .. Parameters ..
27572      DOUBLE PRECISION   ONE, ZERO
27573      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
27574*     ..
27575*     .. Local Scalars ..
27576      INTEGER            I, J
27577      DOUBLE PRECISION   ABSA, SUM, VALUE
27578*     ..
27579*     .. Local Arrays ..
27580      DOUBLE PRECISION   SSQ( 2 ), COLSSQ( 2 )
27581*     ..
27582*     .. External Functions ..
27583      LOGICAL            LSAME, DISNAN
27584      EXTERNAL           LSAME, DISNAN
27585*     ..
27586*     .. External Subroutines ..
27587      EXTERNAL           ZLASSQ, DCOMBSSQ
27588*     ..
27589*     .. Intrinsic Functions ..
27590      INTRINSIC          ABS, DBLE, SQRT
27591*     ..
27592*     .. Executable Statements ..
27593*
27594      IF( N.EQ.0 ) THEN
27595         VALUE = ZERO
27596      ELSE IF( LSAME( NORM, 'M' ) ) THEN
27597*
27598*        Find max(abs(A(i,j))).
27599*
27600         VALUE = ZERO
27601         IF( LSAME( UPLO, 'U' ) ) THEN
27602            DO 20 J = 1, N
27603               DO 10 I = 1, J - 1
27604                  SUM = ABS( A( I, J ) )
27605                  IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
27606   10          CONTINUE
27607               SUM = ABS( DBLE( A( J, J ) ) )
27608               IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
27609   20       CONTINUE
27610         ELSE
27611            DO 40 J = 1, N
27612               SUM = ABS( DBLE( A( J, J ) ) )
27613               IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
27614               DO 30 I = J + 1, N
27615                  SUM = ABS( A( I, J ) )
27616                  IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
27617   30          CONTINUE
27618   40       CONTINUE
27619         END IF
27620      ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR.
27621     $         ( NORM.EQ.'1' ) ) THEN
27622*
27623*        Find normI(A) ( = norm1(A), since A is hermitian).
27624*
27625         VALUE = ZERO
27626         IF( LSAME( UPLO, 'U' ) ) THEN
27627            DO 60 J = 1, N
27628               SUM = ZERO
27629               DO 50 I = 1, J - 1
27630                  ABSA = ABS( A( I, J ) )
27631                  SUM = SUM + ABSA
27632                  WORK( I ) = WORK( I ) + ABSA
27633   50          CONTINUE
27634               WORK( J ) = SUM + ABS( DBLE( A( J, J ) ) )
27635   60       CONTINUE
27636            DO 70 I = 1, N
27637               SUM = WORK( I )
27638               IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
27639   70       CONTINUE
27640         ELSE
27641            DO 80 I = 1, N
27642               WORK( I ) = ZERO
27643   80       CONTINUE
27644            DO 100 J = 1, N
27645               SUM = WORK( J ) + ABS( DBLE( A( J, J ) ) )
27646               DO 90 I = J + 1, N
27647                  ABSA = ABS( A( I, J ) )
27648                  SUM = SUM + ABSA
27649                  WORK( I ) = WORK( I ) + ABSA
27650   90          CONTINUE
27651               IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
27652  100       CONTINUE
27653         END IF
27654      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
27655*
27656*        Find normF(A).
27657*        SSQ(1) is scale
27658*        SSQ(2) is sum-of-squares
27659*        For better accuracy, sum each column separately.
27660*
27661         SSQ( 1 ) = ZERO
27662         SSQ( 2 ) = ONE
27663*
27664*        Sum off-diagonals
27665*
27666         IF( LSAME( UPLO, 'U' ) ) THEN
27667            DO 110 J = 2, N
27668               COLSSQ( 1 ) = ZERO
27669               COLSSQ( 2 ) = ONE
27670               CALL ZLASSQ( J-1, A( 1, J ), 1,
27671     $                      COLSSQ( 1 ), COLSSQ( 2 ) )
27672               CALL DCOMBSSQ( SSQ, COLSSQ )
27673  110       CONTINUE
27674         ELSE
27675            DO 120 J = 1, N - 1
27676               COLSSQ( 1 ) = ZERO
27677               COLSSQ( 2 ) = ONE
27678               CALL ZLASSQ( N-J, A( J+1, J ), 1,
27679     $                      COLSSQ( 1 ), COLSSQ( 2 ) )
27680               CALL DCOMBSSQ( SSQ, COLSSQ )
27681  120       CONTINUE
27682         END IF
27683         SSQ( 2 ) = 2*SSQ( 2 )
27684*
27685*        Sum diagonal
27686*
27687         DO 130 I = 1, N
27688            IF( DBLE( A( I, I ) ).NE.ZERO ) THEN
27689               ABSA = ABS( DBLE( A( I, I ) ) )
27690               IF( SSQ( 1 ).LT.ABSA ) THEN
27691                  SSQ( 2 ) = ONE + SSQ( 2 )*( SSQ( 1 ) / ABSA )**2
27692                  SSQ( 1 ) = ABSA
27693               ELSE
27694                  SSQ( 2 ) = SSQ( 2 ) + ( ABSA / SSQ( 1 ) )**2
27695               END IF
27696            END IF
27697  130    CONTINUE
27698         VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) )
27699      END IF
27700*
27701      ZLANHE = VALUE
27702      RETURN
27703*
27704*     End of ZLANHE
27705*
27706      END
27707*> \brief \b ZLANHS returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value of any element of an upper Hessenberg matrix.
27708*
27709*  =========== DOCUMENTATION ===========
27710*
27711* Online html documentation available at
27712*            http://www.netlib.org/lapack/explore-html/
27713*
27714*> \htmlonly
27715*> Download ZLANHS + dependencies
27716*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlanhs.f">
27717*> [TGZ]</a>
27718*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlanhs.f">
27719*> [ZIP]</a>
27720*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlanhs.f">
27721*> [TXT]</a>
27722*> \endhtmlonly
27723*
27724*  Definition:
27725*  ===========
27726*
27727*       DOUBLE PRECISION FUNCTION ZLANHS( NORM, N, A, LDA, WORK )
27728*
27729*       .. Scalar Arguments ..
27730*       CHARACTER          NORM
27731*       INTEGER            LDA, N
27732*       ..
27733*       .. Array Arguments ..
27734*       DOUBLE PRECISION   WORK( * )
27735*       COMPLEX*16         A( LDA, * )
27736*       ..
27737*
27738*
27739*> \par Purpose:
27740*  =============
27741*>
27742*> \verbatim
27743*>
27744*> ZLANHS  returns the value of the one norm,  or the Frobenius norm, or
27745*> the  infinity norm,  or the  element of  largest absolute value  of a
27746*> Hessenberg matrix A.
27747*> \endverbatim
27748*>
27749*> \return ZLANHS
27750*> \verbatim
27751*>
27752*>    ZLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm'
27753*>             (
27754*>             ( norm1(A),         NORM = '1', 'O' or 'o'
27755*>             (
27756*>             ( normI(A),         NORM = 'I' or 'i'
27757*>             (
27758*>             ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
27759*>
27760*> where  norm1  denotes the  one norm of a matrix (maximum column sum),
27761*> normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
27762*> normF  denotes the  Frobenius norm of a matrix (square root of sum of
27763*> squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.
27764*> \endverbatim
27765*
27766*  Arguments:
27767*  ==========
27768*
27769*> \param[in] NORM
27770*> \verbatim
27771*>          NORM is CHARACTER*1
27772*>          Specifies the value to be returned in ZLANHS as described
27773*>          above.
27774*> \endverbatim
27775*>
27776*> \param[in] N
27777*> \verbatim
27778*>          N is INTEGER
27779*>          The order of the matrix A.  N >= 0.  When N = 0, ZLANHS is
27780*>          set to zero.
27781*> \endverbatim
27782*>
27783*> \param[in] A
27784*> \verbatim
27785*>          A is COMPLEX*16 array, dimension (LDA,N)
27786*>          The n by n upper Hessenberg matrix A; the part of A below the
27787*>          first sub-diagonal is not referenced.
27788*> \endverbatim
27789*>
27790*> \param[in] LDA
27791*> \verbatim
27792*>          LDA is INTEGER
27793*>          The leading dimension of the array A.  LDA >= max(N,1).
27794*> \endverbatim
27795*>
27796*> \param[out] WORK
27797*> \verbatim
27798*>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
27799*>          where LWORK >= N when NORM = 'I'; otherwise, WORK is not
27800*>          referenced.
27801*> \endverbatim
27802*
27803*  Authors:
27804*  ========
27805*
27806*> \author Univ. of Tennessee
27807*> \author Univ. of California Berkeley
27808*> \author Univ. of Colorado Denver
27809*> \author NAG Ltd.
27810*
27811*> \date December 2016
27812*
27813*> \ingroup complex16OTHERauxiliary
27814*
27815*  =====================================================================
27816      DOUBLE PRECISION FUNCTION ZLANHS( NORM, N, A, LDA, WORK )
27817*
27818*  -- LAPACK auxiliary routine (version 3.7.0) --
27819*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
27820*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
27821*     December 2016
27822*
27823      IMPLICIT NONE
27824*     .. Scalar Arguments ..
27825      CHARACTER          NORM
27826      INTEGER            LDA, N
27827*     ..
27828*     .. Array Arguments ..
27829      DOUBLE PRECISION   WORK( * )
27830      COMPLEX*16         A( LDA, * )
27831*     ..
27832*
27833* =====================================================================
27834*
27835*     .. Parameters ..
27836      DOUBLE PRECISION   ONE, ZERO
27837      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
27838*     ..
27839*     .. Local Scalars ..
27840      INTEGER            I, J
27841      DOUBLE PRECISION   SUM, VALUE
27842*     ..
27843*     .. Local Arrays ..
27844      DOUBLE PRECISION   SSQ( 2 ), COLSSQ( 2 )
27845*     ..
27846*     .. External Functions ..
27847      LOGICAL            LSAME, DISNAN
27848      EXTERNAL           LSAME, DISNAN
27849*     ..
27850*     .. External Subroutines ..
27851      EXTERNAL           ZLASSQ, DCOMBSSQ
27852*     ..
27853*     .. Intrinsic Functions ..
27854      INTRINSIC          ABS, MIN, SQRT
27855*     ..
27856*     .. Executable Statements ..
27857*
27858      IF( N.EQ.0 ) THEN
27859         VALUE = ZERO
27860      ELSE IF( LSAME( NORM, 'M' ) ) THEN
27861*
27862*        Find max(abs(A(i,j))).
27863*
27864         VALUE = ZERO
27865         DO 20 J = 1, N
27866            DO 10 I = 1, MIN( N, J+1 )
27867               SUM = ABS( A( I, J ) )
27868               IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
27869   10       CONTINUE
27870   20    CONTINUE
27871      ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
27872*
27873*        Find norm1(A).
27874*
27875         VALUE = ZERO
27876         DO 40 J = 1, N
27877            SUM = ZERO
27878            DO 30 I = 1, MIN( N, J+1 )
27879               SUM = SUM + ABS( A( I, J ) )
27880   30       CONTINUE
27881            IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
27882   40    CONTINUE
27883      ELSE IF( LSAME( NORM, 'I' ) ) THEN
27884*
27885*        Find normI(A).
27886*
27887         DO 50 I = 1, N
27888            WORK( I ) = ZERO
27889   50    CONTINUE
27890         DO 70 J = 1, N
27891            DO 60 I = 1, MIN( N, J+1 )
27892               WORK( I ) = WORK( I ) + ABS( A( I, J ) )
27893   60       CONTINUE
27894   70    CONTINUE
27895         VALUE = ZERO
27896         DO 80 I = 1, N
27897            SUM = WORK( I )
27898            IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
27899   80    CONTINUE
27900      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
27901*
27902*        Find normF(A).
27903*        SSQ(1) is scale
27904*        SSQ(2) is sum-of-squares
27905*        For better accuracy, sum each column separately.
27906*
27907         SSQ( 1 ) = ZERO
27908         SSQ( 2 ) = ONE
27909         DO 90 J = 1, N
27910            COLSSQ( 1 ) = ZERO
27911            COLSSQ( 2 ) = ONE
27912            CALL ZLASSQ( MIN( N, J+1 ), A( 1, J ), 1,
27913     $                   COLSSQ( 1 ), COLSSQ( 2 ) )
27914            CALL DCOMBSSQ( SSQ, COLSSQ )
27915   90    CONTINUE
27916         VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) )
27917      END IF
27918*
27919      ZLANHS = VALUE
27920      RETURN
27921*
27922*     End of ZLANHS
27923*
27924      END
27925*> \brief \b ZLANTR returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a trapezoidal or triangular matrix.
27926*
27927*  =========== DOCUMENTATION ===========
27928*
27929* Online html documentation available at
27930*            http://www.netlib.org/lapack/explore-html/
27931*
27932*> \htmlonly
27933*> Download ZLANTR + dependencies
27934*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlantr.f">
27935*> [TGZ]</a>
27936*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlantr.f">
27937*> [ZIP]</a>
27938*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlantr.f">
27939*> [TXT]</a>
27940*> \endhtmlonly
27941*
27942*  Definition:
27943*  ===========
27944*
27945*       DOUBLE PRECISION FUNCTION ZLANTR( NORM, UPLO, DIAG, M, N, A, LDA,
27946*                        WORK )
27947*
27948*       .. Scalar Arguments ..
27949*       CHARACTER          DIAG, NORM, UPLO
27950*       INTEGER            LDA, M, N
27951*       ..
27952*       .. Array Arguments ..
27953*       DOUBLE PRECISION   WORK( * )
27954*       COMPLEX*16         A( LDA, * )
27955*       ..
27956*
27957*
27958*> \par Purpose:
27959*  =============
27960*>
27961*> \verbatim
27962*>
27963*> ZLANTR  returns the value of the one norm,  or the Frobenius norm, or
27964*> the  infinity norm,  or the  element of  largest absolute value  of a
27965*> trapezoidal or triangular matrix A.
27966*> \endverbatim
27967*>
27968*> \return ZLANTR
27969*> \verbatim
27970*>
27971*>    ZLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm'
27972*>             (
27973*>             ( norm1(A),         NORM = '1', 'O' or 'o'
27974*>             (
27975*>             ( normI(A),         NORM = 'I' or 'i'
27976*>             (
27977*>             ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
27978*>
27979*> where  norm1  denotes the  one norm of a matrix (maximum column sum),
27980*> normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
27981*> normF  denotes the  Frobenius norm of a matrix (square root of sum of
27982*> squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.
27983*> \endverbatim
27984*
27985*  Arguments:
27986*  ==========
27987*
27988*> \param[in] NORM
27989*> \verbatim
27990*>          NORM is CHARACTER*1
27991*>          Specifies the value to be returned in ZLANTR as described
27992*>          above.
27993*> \endverbatim
27994*>
27995*> \param[in] UPLO
27996*> \verbatim
27997*>          UPLO is CHARACTER*1
27998*>          Specifies whether the matrix A is upper or lower trapezoidal.
27999*>          = 'U':  Upper trapezoidal
28000*>          = 'L':  Lower trapezoidal
28001*>          Note that A is triangular instead of trapezoidal if M = N.
28002*> \endverbatim
28003*>
28004*> \param[in] DIAG
28005*> \verbatim
28006*>          DIAG is CHARACTER*1
28007*>          Specifies whether or not the matrix A has unit diagonal.
28008*>          = 'N':  Non-unit diagonal
28009*>          = 'U':  Unit diagonal
28010*> \endverbatim
28011*>
28012*> \param[in] M
28013*> \verbatim
28014*>          M is INTEGER
28015*>          The number of rows of the matrix A.  M >= 0, and if
28016*>          UPLO = 'U', M <= N.  When M = 0, ZLANTR is set to zero.
28017*> \endverbatim
28018*>
28019*> \param[in] N
28020*> \verbatim
28021*>          N is INTEGER
28022*>          The number of columns of the matrix A.  N >= 0, and if
28023*>          UPLO = 'L', N <= M.  When N = 0, ZLANTR is set to zero.
28024*> \endverbatim
28025*>
28026*> \param[in] A
28027*> \verbatim
28028*>          A is COMPLEX*16 array, dimension (LDA,N)
28029*>          The trapezoidal matrix A (A is triangular if M = N).
28030*>          If UPLO = 'U', the leading m by n upper trapezoidal part of
28031*>          the array A contains the upper trapezoidal matrix, and the
28032*>          strictly lower triangular part of A is not referenced.
28033*>          If UPLO = 'L', the leading m by n lower trapezoidal part of
28034*>          the array A contains the lower trapezoidal matrix, and the
28035*>          strictly upper triangular part of A is not referenced.  Note
28036*>          that when DIAG = 'U', the diagonal elements of A are not
28037*>          referenced and are assumed to be one.
28038*> \endverbatim
28039*>
28040*> \param[in] LDA
28041*> \verbatim
28042*>          LDA is INTEGER
28043*>          The leading dimension of the array A.  LDA >= max(M,1).
28044*> \endverbatim
28045*>
28046*> \param[out] WORK
28047*> \verbatim
28048*>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
28049*>          where LWORK >= M when NORM = 'I'; otherwise, WORK is not
28050*>          referenced.
28051*> \endverbatim
28052*
28053*  Authors:
28054*  ========
28055*
28056*> \author Univ. of Tennessee
28057*> \author Univ. of California Berkeley
28058*> \author Univ. of Colorado Denver
28059*> \author NAG Ltd.
28060*
28061*> \date December 2016
28062*
28063*> \ingroup complex16OTHERauxiliary
28064*
28065*  =====================================================================
28066      DOUBLE PRECISION FUNCTION ZLANTR( NORM, UPLO, DIAG, M, N, A, LDA,
28067     $                 WORK )
28068*
28069*  -- LAPACK auxiliary routine (version 3.7.0) --
28070*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
28071*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
28072*     December 2016
28073*
28074      IMPLICIT NONE
28075*     .. Scalar Arguments ..
28076      CHARACTER          DIAG, NORM, UPLO
28077      INTEGER            LDA, M, N
28078*     ..
28079*     .. Array Arguments ..
28080      DOUBLE PRECISION   WORK( * )
28081      COMPLEX*16         A( LDA, * )
28082*     ..
28083*
28084* =====================================================================
28085*
28086*     .. Parameters ..
28087      DOUBLE PRECISION   ONE, ZERO
28088      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
28089*     ..
28090*     .. Local Scalars ..
28091      LOGICAL            UDIAG
28092      INTEGER            I, J
28093      DOUBLE PRECISION   SUM, VALUE
28094*     ..
28095*     .. Local Arrays ..
28096      DOUBLE PRECISION   SSQ( 2 ), COLSSQ( 2 )
28097*     ..
28098*     .. External Functions ..
28099      LOGICAL            LSAME, DISNAN
28100      EXTERNAL           LSAME, DISNAN
28101*     ..
28102*     .. External Subroutines ..
28103      EXTERNAL           ZLASSQ, DCOMBSSQ
28104*     ..
28105*     .. Intrinsic Functions ..
28106      INTRINSIC          ABS, MIN, SQRT
28107*     ..
28108*     .. Executable Statements ..
28109*
28110      IF( MIN( M, N ).EQ.0 ) THEN
28111         VALUE = ZERO
28112      ELSE IF( LSAME( NORM, 'M' ) ) THEN
28113*
28114*        Find max(abs(A(i,j))).
28115*
28116         IF( LSAME( DIAG, 'U' ) ) THEN
28117            VALUE = ONE
28118            IF( LSAME( UPLO, 'U' ) ) THEN
28119               DO 20 J = 1, N
28120                  DO 10 I = 1, MIN( M, J-1 )
28121                     SUM = ABS( A( I, J ) )
28122                     IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
28123   10             CONTINUE
28124   20          CONTINUE
28125            ELSE
28126               DO 40 J = 1, N
28127                  DO 30 I = J + 1, M
28128                     SUM = ABS( A( I, J ) )
28129                     IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
28130   30             CONTINUE
28131   40          CONTINUE
28132            END IF
28133         ELSE
28134            VALUE = ZERO
28135            IF( LSAME( UPLO, 'U' ) ) THEN
28136               DO 60 J = 1, N
28137                  DO 50 I = 1, MIN( M, J )
28138                     SUM = ABS( A( I, J ) )
28139                     IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
28140   50             CONTINUE
28141   60          CONTINUE
28142            ELSE
28143               DO 80 J = 1, N
28144                  DO 70 I = J, M
28145                     SUM = ABS( A( I, J ) )
28146                     IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
28147   70             CONTINUE
28148   80          CONTINUE
28149            END IF
28150         END IF
28151      ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
28152*
28153*        Find norm1(A).
28154*
28155         VALUE = ZERO
28156         UDIAG = LSAME( DIAG, 'U' )
28157         IF( LSAME( UPLO, 'U' ) ) THEN
28158            DO 110 J = 1, N
28159               IF( ( UDIAG ) .AND. ( J.LE.M ) ) THEN
28160                  SUM = ONE
28161                  DO 90 I = 1, J - 1
28162                     SUM = SUM + ABS( A( I, J ) )
28163   90             CONTINUE
28164               ELSE
28165                  SUM = ZERO
28166                  DO 100 I = 1, MIN( M, J )
28167                     SUM = SUM + ABS( A( I, J ) )
28168  100             CONTINUE
28169               END IF
28170               IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
28171  110       CONTINUE
28172         ELSE
28173            DO 140 J = 1, N
28174               IF( UDIAG ) THEN
28175                  SUM = ONE
28176                  DO 120 I = J + 1, M
28177                     SUM = SUM + ABS( A( I, J ) )
28178  120             CONTINUE
28179               ELSE
28180                  SUM = ZERO
28181                  DO 130 I = J, M
28182                     SUM = SUM + ABS( A( I, J ) )
28183  130             CONTINUE
28184               END IF
28185               IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
28186  140       CONTINUE
28187         END IF
28188      ELSE IF( LSAME( NORM, 'I' ) ) THEN
28189*
28190*        Find normI(A).
28191*
28192         IF( LSAME( UPLO, 'U' ) ) THEN
28193            IF( LSAME( DIAG, 'U' ) ) THEN
28194               DO 150 I = 1, M
28195                  WORK( I ) = ONE
28196  150          CONTINUE
28197               DO 170 J = 1, N
28198                  DO 160 I = 1, MIN( M, J-1 )
28199                     WORK( I ) = WORK( I ) + ABS( A( I, J ) )
28200  160             CONTINUE
28201  170          CONTINUE
28202            ELSE
28203               DO 180 I = 1, M
28204                  WORK( I ) = ZERO
28205  180          CONTINUE
28206               DO 200 J = 1, N
28207                  DO 190 I = 1, MIN( M, J )
28208                     WORK( I ) = WORK( I ) + ABS( A( I, J ) )
28209  190             CONTINUE
28210  200          CONTINUE
28211            END IF
28212         ELSE
28213            IF( LSAME( DIAG, 'U' ) ) THEN
28214               DO 210 I = 1, N
28215                  WORK( I ) = ONE
28216  210          CONTINUE
28217               DO 220 I = N + 1, M
28218                  WORK( I ) = ZERO
28219  220          CONTINUE
28220               DO 240 J = 1, N
28221                  DO 230 I = J + 1, M
28222                     WORK( I ) = WORK( I ) + ABS( A( I, J ) )
28223  230             CONTINUE
28224  240          CONTINUE
28225            ELSE
28226               DO 250 I = 1, M
28227                  WORK( I ) = ZERO
28228  250          CONTINUE
28229               DO 270 J = 1, N
28230                  DO 260 I = J, M
28231                     WORK( I ) = WORK( I ) + ABS( A( I, J ) )
28232  260             CONTINUE
28233  270          CONTINUE
28234            END IF
28235         END IF
28236         VALUE = ZERO
28237         DO 280 I = 1, M
28238            SUM = WORK( I )
28239            IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
28240  280    CONTINUE
28241      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
28242*
28243*        Find normF(A).
28244*        SSQ(1) is scale
28245*        SSQ(2) is sum-of-squares
28246*        For better accuracy, sum each column separately.
28247*
28248         IF( LSAME( UPLO, 'U' ) ) THEN
28249            IF( LSAME( DIAG, 'U' ) ) THEN
28250               SSQ( 1 ) = ONE
28251               SSQ( 2 ) = MIN( M, N )
28252               DO 290 J = 2, N
28253                  COLSSQ( 1 ) = ZERO
28254                  COLSSQ( 2 ) = ONE
28255                  CALL ZLASSQ( MIN( M, J-1 ), A( 1, J ), 1,
28256     $                         COLSSQ( 1 ), COLSSQ( 2 ) )
28257                  CALL DCOMBSSQ( SSQ, COLSSQ )
28258  290          CONTINUE
28259            ELSE
28260               SSQ( 1 ) = ZERO
28261               SSQ( 2 ) = ONE
28262               DO 300 J = 1, N
28263                  COLSSQ( 1 ) = ZERO
28264                  COLSSQ( 2 ) = ONE
28265                  CALL ZLASSQ( MIN( M, J ), A( 1, J ), 1,
28266     $                         COLSSQ( 1 ), COLSSQ( 2 ) )
28267                  CALL DCOMBSSQ( SSQ, COLSSQ )
28268  300          CONTINUE
28269            END IF
28270         ELSE
28271            IF( LSAME( DIAG, 'U' ) ) THEN
28272               SSQ( 1 ) = ONE
28273               SSQ( 2 ) = MIN( M, N )
28274               DO 310 J = 1, N
28275                  COLSSQ( 1 ) = ZERO
28276                  COLSSQ( 2 ) = ONE
28277                  CALL ZLASSQ( M-J, A( MIN( M, J+1 ), J ), 1,
28278     $                         COLSSQ( 1 ), COLSSQ( 2 ) )
28279                  CALL DCOMBSSQ( SSQ, COLSSQ )
28280  310          CONTINUE
28281            ELSE
28282               SSQ( 1 ) = ZERO
28283               SSQ( 2 ) = ONE
28284               DO 320 J = 1, N
28285                  COLSSQ( 1 ) = ZERO
28286                  COLSSQ( 2 ) = ONE
28287                  CALL ZLASSQ( M-J+1, A( J, J ), 1,
28288     $                         COLSSQ( 1 ), COLSSQ( 2 ) )
28289                  CALL DCOMBSSQ( SSQ, COLSSQ )
28290  320          CONTINUE
28291            END IF
28292         END IF
28293         VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) )
28294      END IF
28295*
28296      ZLANTR = VALUE
28297      RETURN
28298*
28299*     End of ZLANTR
28300*
28301      END
28302*> \brief \b ZLAQGE scales a general rectangular matrix, using row and column scaling factors computed by sgeequ.
28303*
28304*  =========== DOCUMENTATION ===========
28305*
28306* Online html documentation available at
28307*            http://www.netlib.org/lapack/explore-html/
28308*
28309*> \htmlonly
28310*> Download ZLAQGE + dependencies
28311*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlaqge.f">
28312*> [TGZ]</a>
28313*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlaqge.f">
28314*> [ZIP]</a>
28315*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlaqge.f">
28316*> [TXT]</a>
28317*> \endhtmlonly
28318*
28319*  Definition:
28320*  ===========
28321*
28322*       SUBROUTINE ZLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX,
28323*                          EQUED )
28324*
28325*       .. Scalar Arguments ..
28326*       CHARACTER          EQUED
28327*       INTEGER            LDA, M, N
28328*       DOUBLE PRECISION   AMAX, COLCND, ROWCND
28329*       ..
28330*       .. Array Arguments ..
28331*       DOUBLE PRECISION   C( * ), R( * )
28332*       COMPLEX*16         A( LDA, * )
28333*       ..
28334*
28335*
28336*> \par Purpose:
28337*  =============
28338*>
28339*> \verbatim
28340*>
28341*> ZLAQGE equilibrates a general M by N matrix A using the row and
28342*> column scaling factors in the vectors R and C.
28343*> \endverbatim
28344*
28345*  Arguments:
28346*  ==========
28347*
28348*> \param[in] M
28349*> \verbatim
28350*>          M is INTEGER
28351*>          The number of rows of the matrix A.  M >= 0.
28352*> \endverbatim
28353*>
28354*> \param[in] N
28355*> \verbatim
28356*>          N is INTEGER
28357*>          The number of columns of the matrix A.  N >= 0.
28358*> \endverbatim
28359*>
28360*> \param[in,out] A
28361*> \verbatim
28362*>          A is COMPLEX*16 array, dimension (LDA,N)
28363*>          On entry, the M by N matrix A.
28364*>          On exit, the equilibrated matrix.  See EQUED for the form of
28365*>          the equilibrated matrix.
28366*> \endverbatim
28367*>
28368*> \param[in] LDA
28369*> \verbatim
28370*>          LDA is INTEGER
28371*>          The leading dimension of the array A.  LDA >= max(M,1).
28372*> \endverbatim
28373*>
28374*> \param[in] R
28375*> \verbatim
28376*>          R is DOUBLE PRECISION array, dimension (M)
28377*>          The row scale factors for A.
28378*> \endverbatim
28379*>
28380*> \param[in] C
28381*> \verbatim
28382*>          C is DOUBLE PRECISION array, dimension (N)
28383*>          The column scale factors for A.
28384*> \endverbatim
28385*>
28386*> \param[in] ROWCND
28387*> \verbatim
28388*>          ROWCND is DOUBLE PRECISION
28389*>          Ratio of the smallest R(i) to the largest R(i).
28390*> \endverbatim
28391*>
28392*> \param[in] COLCND
28393*> \verbatim
28394*>          COLCND is DOUBLE PRECISION
28395*>          Ratio of the smallest C(i) to the largest C(i).
28396*> \endverbatim
28397*>
28398*> \param[in] AMAX
28399*> \verbatim
28400*>          AMAX is DOUBLE PRECISION
28401*>          Absolute value of largest matrix entry.
28402*> \endverbatim
28403*>
28404*> \param[out] EQUED
28405*> \verbatim
28406*>          EQUED is CHARACTER*1
28407*>          Specifies the form of equilibration that was done.
28408*>          = 'N':  No equilibration
28409*>          = 'R':  Row equilibration, i.e., A has been premultiplied by
28410*>                  diag(R).
28411*>          = 'C':  Column equilibration, i.e., A has been postmultiplied
28412*>                  by diag(C).
28413*>          = 'B':  Both row and column equilibration, i.e., A has been
28414*>                  replaced by diag(R) * A * diag(C).
28415*> \endverbatim
28416*
28417*> \par Internal Parameters:
28418*  =========================
28419*>
28420*> \verbatim
28421*>  THRESH is a threshold value used to decide if row or column scaling
28422*>  should be done based on the ratio of the row or column scaling
28423*>  factors.  If ROWCND < THRESH, row scaling is done, and if
28424*>  COLCND < THRESH, column scaling is done.
28425*>
28426*>  LARGE and SMALL are threshold values used to decide if row scaling
28427*>  should be done based on the absolute size of the largest matrix
28428*>  element.  If AMAX > LARGE or AMAX < SMALL, row scaling is done.
28429*> \endverbatim
28430*
28431*  Authors:
28432*  ========
28433*
28434*> \author Univ. of Tennessee
28435*> \author Univ. of California Berkeley
28436*> \author Univ. of Colorado Denver
28437*> \author NAG Ltd.
28438*
28439*> \date December 2016
28440*
28441*> \ingroup complex16GEauxiliary
28442*
28443*  =====================================================================
28444      SUBROUTINE ZLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX,
28445     $                   EQUED )
28446*
28447*  -- LAPACK auxiliary routine (version 3.7.0) --
28448*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
28449*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
28450*     December 2016
28451*
28452*     .. Scalar Arguments ..
28453      CHARACTER          EQUED
28454      INTEGER            LDA, M, N
28455      DOUBLE PRECISION   AMAX, COLCND, ROWCND
28456*     ..
28457*     .. Array Arguments ..
28458      DOUBLE PRECISION   C( * ), R( * )
28459      COMPLEX*16         A( LDA, * )
28460*     ..
28461*
28462*  =====================================================================
28463*
28464*     .. Parameters ..
28465      DOUBLE PRECISION   ONE, THRESH
28466      PARAMETER          ( ONE = 1.0D+0, THRESH = 0.1D+0 )
28467*     ..
28468*     .. Local Scalars ..
28469      INTEGER            I, J
28470      DOUBLE PRECISION   CJ, LARGE, SMALL
28471*     ..
28472*     .. External Functions ..
28473      DOUBLE PRECISION   DLAMCH
28474      EXTERNAL           DLAMCH
28475*     ..
28476*     .. Executable Statements ..
28477*
28478*     Quick return if possible
28479*
28480      IF( M.LE.0 .OR. N.LE.0 ) THEN
28481         EQUED = 'N'
28482         RETURN
28483      END IF
28484*
28485*     Initialize LARGE and SMALL.
28486*
28487      SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
28488      LARGE = ONE / SMALL
28489*
28490      IF( ROWCND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE )
28491     $     THEN
28492*
28493*        No row scaling
28494*
28495         IF( COLCND.GE.THRESH ) THEN
28496*
28497*           No column scaling
28498*
28499            EQUED = 'N'
28500         ELSE
28501*
28502*           Column scaling
28503*
28504            DO 20 J = 1, N
28505               CJ = C( J )
28506               DO 10 I = 1, M
28507                  A( I, J ) = CJ*A( I, J )
28508   10          CONTINUE
28509   20       CONTINUE
28510            EQUED = 'C'
28511         END IF
28512      ELSE IF( COLCND.GE.THRESH ) THEN
28513*
28514*        Row scaling, no column scaling
28515*
28516         DO 40 J = 1, N
28517            DO 30 I = 1, M
28518               A( I, J ) = R( I )*A( I, J )
28519   30       CONTINUE
28520   40    CONTINUE
28521         EQUED = 'R'
28522      ELSE
28523*
28524*        Row and column scaling
28525*
28526         DO 60 J = 1, N
28527            CJ = C( J )
28528            DO 50 I = 1, M
28529               A( I, J ) = CJ*R( I )*A( I, J )
28530   50       CONTINUE
28531   60    CONTINUE
28532         EQUED = 'B'
28533      END IF
28534*
28535      RETURN
28536*
28537*     End of ZLAQGE
28538*
28539      END
28540*> \brief \b ZLAQP2 computes a QR factorization with column pivoting of the matrix block.
28541*
28542*  =========== DOCUMENTATION ===========
28543*
28544* Online html documentation available at
28545*            http://www.netlib.org/lapack/explore-html/
28546*
28547*> \htmlonly
28548*> Download ZLAQP2 + dependencies
28549*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlaqp2.f">
28550*> [TGZ]</a>
28551*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlaqp2.f">
28552*> [ZIP]</a>
28553*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlaqp2.f">
28554*> [TXT]</a>
28555*> \endhtmlonly
28556*
28557*  Definition:
28558*  ===========
28559*
28560*       SUBROUTINE ZLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2,
28561*                          WORK )
28562*
28563*       .. Scalar Arguments ..
28564*       INTEGER            LDA, M, N, OFFSET
28565*       ..
28566*       .. Array Arguments ..
28567*       INTEGER            JPVT( * )
28568*       DOUBLE PRECISION   VN1( * ), VN2( * )
28569*       COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
28570*       ..
28571*
28572*
28573*> \par Purpose:
28574*  =============
28575*>
28576*> \verbatim
28577*>
28578*> ZLAQP2 computes a QR factorization with column pivoting of
28579*> the block A(OFFSET+1:M,1:N).
28580*> The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.
28581*> \endverbatim
28582*
28583*  Arguments:
28584*  ==========
28585*
28586*> \param[in] M
28587*> \verbatim
28588*>          M is INTEGER
28589*>          The number of rows of the matrix A. M >= 0.
28590*> \endverbatim
28591*>
28592*> \param[in] N
28593*> \verbatim
28594*>          N is INTEGER
28595*>          The number of columns of the matrix A. N >= 0.
28596*> \endverbatim
28597*>
28598*> \param[in] OFFSET
28599*> \verbatim
28600*>          OFFSET is INTEGER
28601*>          The number of rows of the matrix A that must be pivoted
28602*>          but no factorized. OFFSET >= 0.
28603*> \endverbatim
28604*>
28605*> \param[in,out] A
28606*> \verbatim
28607*>          A is COMPLEX*16 array, dimension (LDA,N)
28608*>          On entry, the M-by-N matrix A.
28609*>          On exit, the upper triangle of block A(OFFSET+1:M,1:N) is
28610*>          the triangular factor obtained; the elements in block
28611*>          A(OFFSET+1:M,1:N) below the diagonal, together with the
28612*>          array TAU, represent the orthogonal matrix Q as a product of
28613*>          elementary reflectors. Block A(1:OFFSET,1:N) has been
28614*>          accordingly pivoted, but no factorized.
28615*> \endverbatim
28616*>
28617*> \param[in] LDA
28618*> \verbatim
28619*>          LDA is INTEGER
28620*>          The leading dimension of the array A. LDA >= max(1,M).
28621*> \endverbatim
28622*>
28623*> \param[in,out] JPVT
28624*> \verbatim
28625*>          JPVT is INTEGER array, dimension (N)
28626*>          On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
28627*>          to the front of A*P (a leading column); if JPVT(i) = 0,
28628*>          the i-th column of A is a free column.
28629*>          On exit, if JPVT(i) = k, then the i-th column of A*P
28630*>          was the k-th column of A.
28631*> \endverbatim
28632*>
28633*> \param[out] TAU
28634*> \verbatim
28635*>          TAU is COMPLEX*16 array, dimension (min(M,N))
28636*>          The scalar factors of the elementary reflectors.
28637*> \endverbatim
28638*>
28639*> \param[in,out] VN1
28640*> \verbatim
28641*>          VN1 is DOUBLE PRECISION array, dimension (N)
28642*>          The vector with the partial column norms.
28643*> \endverbatim
28644*>
28645*> \param[in,out] VN2
28646*> \verbatim
28647*>          VN2 is DOUBLE PRECISION array, dimension (N)
28648*>          The vector with the exact column norms.
28649*> \endverbatim
28650*>
28651*> \param[out] WORK
28652*> \verbatim
28653*>          WORK is COMPLEX*16 array, dimension (N)
28654*> \endverbatim
28655*
28656*  Authors:
28657*  ========
28658*
28659*> \author Univ. of Tennessee
28660*> \author Univ. of California Berkeley
28661*> \author Univ. of Colorado Denver
28662*> \author NAG Ltd.
28663*
28664*> \date December 2016
28665*
28666*> \ingroup complex16OTHERauxiliary
28667*
28668*> \par Contributors:
28669*  ==================
28670*>
28671*>    G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
28672*>    X. Sun, Computer Science Dept., Duke University, USA
28673*> \n
28674*>  Partial column norm updating strategy modified on April 2011
28675*>    Z. Drmac and Z. Bujanovic, Dept. of Mathematics,
28676*>    University of Zagreb, Croatia.
28677*
28678*> \par References:
28679*  ================
28680*>
28681*> LAPACK Working Note 176
28682*
28683*> \htmlonly
28684*> <a href="http://www.netlib.org/lapack/lawnspdf/lawn176.pdf">[PDF]</a>
28685*> \endhtmlonly
28686*
28687*  =====================================================================
28688      SUBROUTINE ZLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2,
28689     $                   WORK )
28690*
28691*  -- LAPACK auxiliary routine (version 3.7.0) --
28692*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
28693*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
28694*     December 2016
28695*
28696*     .. Scalar Arguments ..
28697      INTEGER            LDA, M, N, OFFSET
28698*     ..
28699*     .. Array Arguments ..
28700      INTEGER            JPVT( * )
28701      DOUBLE PRECISION   VN1( * ), VN2( * )
28702      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
28703*     ..
28704*
28705*  =====================================================================
28706*
28707*     .. Parameters ..
28708      DOUBLE PRECISION   ZERO, ONE
28709      COMPLEX*16         CONE
28710      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0,
28711     $                   CONE = ( 1.0D+0, 0.0D+0 ) )
28712*     ..
28713*     .. Local Scalars ..
28714      INTEGER            I, ITEMP, J, MN, OFFPI, PVT
28715      DOUBLE PRECISION   TEMP, TEMP2, TOL3Z
28716      COMPLEX*16         AII
28717*     ..
28718*     .. External Subroutines ..
28719      EXTERNAL           ZLARF, ZLARFG, ZSWAP
28720*     ..
28721*     .. Intrinsic Functions ..
28722      INTRINSIC          ABS, DCONJG, MAX, MIN, SQRT
28723*     ..
28724*     .. External Functions ..
28725      INTEGER            IDAMAX
28726      DOUBLE PRECISION   DLAMCH, DZNRM2
28727      EXTERNAL           IDAMAX, DLAMCH, DZNRM2
28728*     ..
28729*     .. Executable Statements ..
28730*
28731      MN = MIN( M-OFFSET, N )
28732      TOL3Z = SQRT(DLAMCH('Epsilon'))
28733*
28734*     Compute factorization.
28735*
28736      DO 20 I = 1, MN
28737*
28738         OFFPI = OFFSET + I
28739*
28740*        Determine ith pivot column and swap if necessary.
28741*
28742         PVT = ( I-1 ) + IDAMAX( N-I+1, VN1( I ), 1 )
28743*
28744         IF( PVT.NE.I ) THEN
28745            CALL ZSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 )
28746            ITEMP = JPVT( PVT )
28747            JPVT( PVT ) = JPVT( I )
28748            JPVT( I ) = ITEMP
28749            VN1( PVT ) = VN1( I )
28750            VN2( PVT ) = VN2( I )
28751         END IF
28752*
28753*        Generate elementary reflector H(i).
28754*
28755         IF( OFFPI.LT.M ) THEN
28756            CALL ZLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ), 1,
28757     $                   TAU( I ) )
28758         ELSE
28759            CALL ZLARFG( 1, A( M, I ), A( M, I ), 1, TAU( I ) )
28760         END IF
28761*
28762         IF( I.LT.N ) THEN
28763*
28764*           Apply H(i)**H to A(offset+i:m,i+1:n) from the left.
28765*
28766            AII = A( OFFPI, I )
28767            A( OFFPI, I ) = CONE
28768            CALL ZLARF( 'Left', M-OFFPI+1, N-I, A( OFFPI, I ), 1,
28769     $                  DCONJG( TAU( I ) ), A( OFFPI, I+1 ), LDA,
28770     $                  WORK( 1 ) )
28771            A( OFFPI, I ) = AII
28772         END IF
28773*
28774*        Update partial column norms.
28775*
28776         DO 10 J = I + 1, N
28777            IF( VN1( J ).NE.ZERO ) THEN
28778*
28779*              NOTE: The following 4 lines follow from the analysis in
28780*              Lapack Working Note 176.
28781*
28782               TEMP = ONE - ( ABS( A( OFFPI, J ) ) / VN1( J ) )**2
28783               TEMP = MAX( TEMP, ZERO )
28784               TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2
28785               IF( TEMP2 .LE. TOL3Z ) THEN
28786                  IF( OFFPI.LT.M ) THEN
28787                     VN1( J ) = DZNRM2( M-OFFPI, A( OFFPI+1, J ), 1 )
28788                     VN2( J ) = VN1( J )
28789                  ELSE
28790                     VN1( J ) = ZERO
28791                     VN2( J ) = ZERO
28792                  END IF
28793               ELSE
28794                  VN1( J ) = VN1( J )*SQRT( TEMP )
28795               END IF
28796            END IF
28797   10    CONTINUE
28798*
28799   20 CONTINUE
28800*
28801      RETURN
28802*
28803*     End of ZLAQP2
28804*
28805      END
28806*> \brief \b ZLAQPS computes a step of QR factorization with column pivoting of a real m-by-n matrix A by using BLAS level 3.
28807*
28808*  =========== DOCUMENTATION ===========
28809*
28810* Online html documentation available at
28811*            http://www.netlib.org/lapack/explore-html/
28812*
28813*> \htmlonly
28814*> Download ZLAQPS + dependencies
28815*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlaqps.f">
28816*> [TGZ]</a>
28817*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlaqps.f">
28818*> [ZIP]</a>
28819*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlaqps.f">
28820*> [TXT]</a>
28821*> \endhtmlonly
28822*
28823*  Definition:
28824*  ===========
28825*
28826*       SUBROUTINE ZLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1,
28827*                          VN2, AUXV, F, LDF )
28828*
28829*       .. Scalar Arguments ..
28830*       INTEGER            KB, LDA, LDF, M, N, NB, OFFSET
28831*       ..
28832*       .. Array Arguments ..
28833*       INTEGER            JPVT( * )
28834*       DOUBLE PRECISION   VN1( * ), VN2( * )
28835*       COMPLEX*16         A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * )
28836*       ..
28837*
28838*
28839*> \par Purpose:
28840*  =============
28841*>
28842*> \verbatim
28843*>
28844*> ZLAQPS computes a step of QR factorization with column pivoting
28845*> of a complex M-by-N matrix A by using Blas-3.  It tries to factorize
28846*> NB columns from A starting from the row OFFSET+1, and updates all
28847*> of the matrix with Blas-3 xGEMM.
28848*>
28849*> In some cases, due to catastrophic cancellations, it cannot
28850*> factorize NB columns.  Hence, the actual number of factorized
28851*> columns is returned in KB.
28852*>
28853*> Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.
28854*> \endverbatim
28855*
28856*  Arguments:
28857*  ==========
28858*
28859*> \param[in] M
28860*> \verbatim
28861*>          M is INTEGER
28862*>          The number of rows of the matrix A. M >= 0.
28863*> \endverbatim
28864*>
28865*> \param[in] N
28866*> \verbatim
28867*>          N is INTEGER
28868*>          The number of columns of the matrix A. N >= 0
28869*> \endverbatim
28870*>
28871*> \param[in] OFFSET
28872*> \verbatim
28873*>          OFFSET is INTEGER
28874*>          The number of rows of A that have been factorized in
28875*>          previous steps.
28876*> \endverbatim
28877*>
28878*> \param[in] NB
28879*> \verbatim
28880*>          NB is INTEGER
28881*>          The number of columns to factorize.
28882*> \endverbatim
28883*>
28884*> \param[out] KB
28885*> \verbatim
28886*>          KB is INTEGER
28887*>          The number of columns actually factorized.
28888*> \endverbatim
28889*>
28890*> \param[in,out] A
28891*> \verbatim
28892*>          A is COMPLEX*16 array, dimension (LDA,N)
28893*>          On entry, the M-by-N matrix A.
28894*>          On exit, block A(OFFSET+1:M,1:KB) is the triangular
28895*>          factor obtained and block A(1:OFFSET,1:N) has been
28896*>          accordingly pivoted, but no factorized.
28897*>          The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has
28898*>          been updated.
28899*> \endverbatim
28900*>
28901*> \param[in] LDA
28902*> \verbatim
28903*>          LDA is INTEGER
28904*>          The leading dimension of the array A. LDA >= max(1,M).
28905*> \endverbatim
28906*>
28907*> \param[in,out] JPVT
28908*> \verbatim
28909*>          JPVT is INTEGER array, dimension (N)
28910*>          JPVT(I) = K <==> Column K of the full matrix A has been
28911*>          permuted into position I in AP.
28912*> \endverbatim
28913*>
28914*> \param[out] TAU
28915*> \verbatim
28916*>          TAU is COMPLEX*16 array, dimension (KB)
28917*>          The scalar factors of the elementary reflectors.
28918*> \endverbatim
28919*>
28920*> \param[in,out] VN1
28921*> \verbatim
28922*>          VN1 is DOUBLE PRECISION array, dimension (N)
28923*>          The vector with the partial column norms.
28924*> \endverbatim
28925*>
28926*> \param[in,out] VN2
28927*> \verbatim
28928*>          VN2 is DOUBLE PRECISION array, dimension (N)
28929*>          The vector with the exact column norms.
28930*> \endverbatim
28931*>
28932*> \param[in,out] AUXV
28933*> \verbatim
28934*>          AUXV is COMPLEX*16 array, dimension (NB)
28935*>          Auxiliary vector.
28936*> \endverbatim
28937*>
28938*> \param[in,out] F
28939*> \verbatim
28940*>          F is COMPLEX*16 array, dimension (LDF,NB)
28941*>          Matrix F**H = L * Y**H * A.
28942*> \endverbatim
28943*>
28944*> \param[in] LDF
28945*> \verbatim
28946*>          LDF is INTEGER
28947*>          The leading dimension of the array F. LDF >= max(1,N).
28948*> \endverbatim
28949*
28950*  Authors:
28951*  ========
28952*
28953*> \author Univ. of Tennessee
28954*> \author Univ. of California Berkeley
28955*> \author Univ. of Colorado Denver
28956*> \author NAG Ltd.
28957*
28958*> \date December 2016
28959*
28960*> \ingroup complex16OTHERauxiliary
28961*
28962*> \par Contributors:
28963*  ==================
28964*>
28965*>    G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
28966*>    X. Sun, Computer Science Dept., Duke University, USA
28967*> \n
28968*>  Partial column norm updating strategy modified on April 2011
28969*>    Z. Drmac and Z. Bujanovic, Dept. of Mathematics,
28970*>    University of Zagreb, Croatia.
28971*
28972*> \par References:
28973*  ================
28974*>
28975*> LAPACK Working Note 176
28976*
28977*> \htmlonly
28978*> <a href="http://www.netlib.org/lapack/lawnspdf/lawn176.pdf">[PDF]</a>
28979*> \endhtmlonly
28980*
28981*  =====================================================================
28982      SUBROUTINE ZLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1,
28983     $                   VN2, AUXV, F, LDF )
28984*
28985*  -- LAPACK auxiliary routine (version 3.7.0) --
28986*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
28987*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
28988*     December 2016
28989*
28990*     .. Scalar Arguments ..
28991      INTEGER            KB, LDA, LDF, M, N, NB, OFFSET
28992*     ..
28993*     .. Array Arguments ..
28994      INTEGER            JPVT( * )
28995      DOUBLE PRECISION   VN1( * ), VN2( * )
28996      COMPLEX*16         A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * )
28997*     ..
28998*
28999*  =====================================================================
29000*
29001*     .. Parameters ..
29002      DOUBLE PRECISION   ZERO, ONE
29003      COMPLEX*16         CZERO, CONE
29004      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0,
29005     $                   CZERO = ( 0.0D+0, 0.0D+0 ),
29006     $                   CONE = ( 1.0D+0, 0.0D+0 ) )
29007*     ..
29008*     .. Local Scalars ..
29009      INTEGER            ITEMP, J, K, LASTRK, LSTICC, PVT, RK
29010      DOUBLE PRECISION   TEMP, TEMP2, TOL3Z
29011      COMPLEX*16         AKK
29012*     ..
29013*     .. External Subroutines ..
29014      EXTERNAL           ZGEMM, ZGEMV, ZLARFG, ZSWAP
29015*     ..
29016*     .. Intrinsic Functions ..
29017      INTRINSIC          ABS, DBLE, DCONJG, MAX, MIN, NINT, SQRT
29018*     ..
29019*     .. External Functions ..
29020      INTEGER            IDAMAX
29021      DOUBLE PRECISION   DLAMCH, DZNRM2
29022      EXTERNAL           IDAMAX, DLAMCH, DZNRM2
29023*     ..
29024*     .. Executable Statements ..
29025*
29026      LASTRK = MIN( M, N+OFFSET )
29027      LSTICC = 0
29028      K = 0
29029      TOL3Z = SQRT(DLAMCH('Epsilon'))
29030*
29031*     Beginning of while loop.
29032*
29033   10 CONTINUE
29034      IF( ( K.LT.NB ) .AND. ( LSTICC.EQ.0 ) ) THEN
29035         K = K + 1
29036         RK = OFFSET + K
29037*
29038*        Determine ith pivot column and swap if necessary
29039*
29040         PVT = ( K-1 ) + IDAMAX( N-K+1, VN1( K ), 1 )
29041         IF( PVT.NE.K ) THEN
29042            CALL ZSWAP( M, A( 1, PVT ), 1, A( 1, K ), 1 )
29043            CALL ZSWAP( K-1, F( PVT, 1 ), LDF, F( K, 1 ), LDF )
29044            ITEMP = JPVT( PVT )
29045            JPVT( PVT ) = JPVT( K )
29046            JPVT( K ) = ITEMP
29047            VN1( PVT ) = VN1( K )
29048            VN2( PVT ) = VN2( K )
29049         END IF
29050*
29051*        Apply previous Householder reflectors to column K:
29052*        A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)**H.
29053*
29054         IF( K.GT.1 ) THEN
29055            DO 20 J = 1, K - 1
29056               F( K, J ) = DCONJG( F( K, J ) )
29057   20       CONTINUE
29058            CALL ZGEMV( 'No transpose', M-RK+1, K-1, -CONE, A( RK, 1 ),
29059     $                  LDA, F( K, 1 ), LDF, CONE, A( RK, K ), 1 )
29060            DO 30 J = 1, K - 1
29061               F( K, J ) = DCONJG( F( K, J ) )
29062   30       CONTINUE
29063         END IF
29064*
29065*        Generate elementary reflector H(k).
29066*
29067         IF( RK.LT.M ) THEN
29068            CALL ZLARFG( M-RK+1, A( RK, K ), A( RK+1, K ), 1, TAU( K ) )
29069         ELSE
29070            CALL ZLARFG( 1, A( RK, K ), A( RK, K ), 1, TAU( K ) )
29071         END IF
29072*
29073         AKK = A( RK, K )
29074         A( RK, K ) = CONE
29075*
29076*        Compute Kth column of F:
29077*
29078*        Compute  F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)**H*A(RK:M,K).
29079*
29080         IF( K.LT.N ) THEN
29081            CALL ZGEMV( 'Conjugate transpose', M-RK+1, N-K, TAU( K ),
29082     $                  A( RK, K+1 ), LDA, A( RK, K ), 1, CZERO,
29083     $                  F( K+1, K ), 1 )
29084         END IF
29085*
29086*        Padding F(1:K,K) with zeros.
29087*
29088         DO 40 J = 1, K
29089            F( J, K ) = CZERO
29090   40    CONTINUE
29091*
29092*        Incremental updating of F:
29093*        F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)**H
29094*                    *A(RK:M,K).
29095*
29096         IF( K.GT.1 ) THEN
29097            CALL ZGEMV( 'Conjugate transpose', M-RK+1, K-1, -TAU( K ),
29098     $                  A( RK, 1 ), LDA, A( RK, K ), 1, CZERO,
29099     $                  AUXV( 1 ), 1 )
29100*
29101            CALL ZGEMV( 'No transpose', N, K-1, CONE, F( 1, 1 ), LDF,
29102     $                  AUXV( 1 ), 1, CONE, F( 1, K ), 1 )
29103         END IF
29104*
29105*        Update the current row of A:
29106*        A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)**H.
29107*
29108         IF( K.LT.N ) THEN
29109            CALL ZGEMM( 'No transpose', 'Conjugate transpose', 1, N-K,
29110     $                  K, -CONE, A( RK, 1 ), LDA, F( K+1, 1 ), LDF,
29111     $                  CONE, A( RK, K+1 ), LDA )
29112         END IF
29113*
29114*        Update partial column norms.
29115*
29116         IF( RK.LT.LASTRK ) THEN
29117            DO 50 J = K + 1, N
29118               IF( VN1( J ).NE.ZERO ) THEN
29119*
29120*                 NOTE: The following 4 lines follow from the analysis in
29121*                 Lapack Working Note 176.
29122*
29123                  TEMP = ABS( A( RK, J ) ) / VN1( J )
29124                  TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) )
29125                  TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2
29126                  IF( TEMP2 .LE. TOL3Z ) THEN
29127                     VN2( J ) = DBLE( LSTICC )
29128                     LSTICC = J
29129                  ELSE
29130                     VN1( J ) = VN1( J )*SQRT( TEMP )
29131                  END IF
29132               END IF
29133   50       CONTINUE
29134         END IF
29135*
29136         A( RK, K ) = AKK
29137*
29138*        End of while loop.
29139*
29140         GO TO 10
29141      END IF
29142      KB = K
29143      RK = OFFSET + KB
29144*
29145*     Apply the block reflector to the rest of the matrix:
29146*     A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) -
29147*                         A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)**H.
29148*
29149      IF( KB.LT.MIN( N, M-OFFSET ) ) THEN
29150         CALL ZGEMM( 'No transpose', 'Conjugate transpose', M-RK, N-KB,
29151     $               KB, -CONE, A( RK+1, 1 ), LDA, F( KB+1, 1 ), LDF,
29152     $               CONE, A( RK+1, KB+1 ), LDA )
29153      END IF
29154*
29155*     Recomputation of difficult columns.
29156*
29157   60 CONTINUE
29158      IF( LSTICC.GT.0 ) THEN
29159         ITEMP = NINT( VN2( LSTICC ) )
29160         VN1( LSTICC ) = DZNRM2( M-RK, A( RK+1, LSTICC ), 1 )
29161*
29162*        NOTE: The computation of VN1( LSTICC ) relies on the fact that
29163*        SNRM2 does not fail on vectors with norm below the value of
29164*        SQRT(DLAMCH('S'))
29165*
29166         VN2( LSTICC ) = VN1( LSTICC )
29167         LSTICC = ITEMP
29168         GO TO 60
29169      END IF
29170*
29171      RETURN
29172*
29173*     End of ZLAQPS
29174*
29175      END
29176*> \brief \b ZLAQR0 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Schur decomposition.
29177*
29178*  =========== DOCUMENTATION ===========
29179*
29180* Online html documentation available at
29181*            http://www.netlib.org/lapack/explore-html/
29182*
29183*> \htmlonly
29184*> Download ZLAQR0 + dependencies
29185*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlaqr0.f">
29186*> [TGZ]</a>
29187*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlaqr0.f">
29188*> [ZIP]</a>
29189*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlaqr0.f">
29190*> [TXT]</a>
29191*> \endhtmlonly
29192*
29193*  Definition:
29194*  ===========
29195*
29196*       SUBROUTINE ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
29197*                          IHIZ, Z, LDZ, WORK, LWORK, INFO )
29198*
29199*       .. Scalar Arguments ..
29200*       INTEGER            IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N
29201*       LOGICAL            WANTT, WANTZ
29202*       ..
29203*       .. Array Arguments ..
29204*       COMPLEX*16         H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * )
29205*       ..
29206*
29207*
29208*> \par Purpose:
29209*  =============
29210*>
29211*> \verbatim
29212*>
29213*>    ZLAQR0 computes the eigenvalues of a Hessenberg matrix H
29214*>    and, optionally, the matrices T and Z from the Schur decomposition
29215*>    H = Z T Z**H, where T is an upper triangular matrix (the
29216*>    Schur form), and Z is the unitary matrix of Schur vectors.
29217*>
29218*>    Optionally Z may be postmultiplied into an input unitary
29219*>    matrix Q so that this routine can give the Schur factorization
29220*>    of a matrix A which has been reduced to the Hessenberg form H
29221*>    by the unitary matrix Q:  A = Q*H*Q**H = (QZ)*H*(QZ)**H.
29222*> \endverbatim
29223*
29224*  Arguments:
29225*  ==========
29226*
29227*> \param[in] WANTT
29228*> \verbatim
29229*>          WANTT is LOGICAL
29230*>          = .TRUE. : the full Schur form T is required;
29231*>          = .FALSE.: only eigenvalues are required.
29232*> \endverbatim
29233*>
29234*> \param[in] WANTZ
29235*> \verbatim
29236*>          WANTZ is LOGICAL
29237*>          = .TRUE. : the matrix of Schur vectors Z is required;
29238*>          = .FALSE.: Schur vectors are not required.
29239*> \endverbatim
29240*>
29241*> \param[in] N
29242*> \verbatim
29243*>          N is INTEGER
29244*>           The order of the matrix H.  N >= 0.
29245*> \endverbatim
29246*>
29247*> \param[in] ILO
29248*> \verbatim
29249*>          ILO is INTEGER
29250*> \endverbatim
29251*>
29252*> \param[in] IHI
29253*> \verbatim
29254*>          IHI is INTEGER
29255*>
29256*>           It is assumed that H is already upper triangular in rows
29257*>           and columns 1:ILO-1 and IHI+1:N and, if ILO > 1,
29258*>           H(ILO,ILO-1) is zero. ILO and IHI are normally set by a
29259*>           previous call to ZGEBAL, and then passed to ZGEHRD when the
29260*>           matrix output by ZGEBAL is reduced to Hessenberg form.
29261*>           Otherwise, ILO and IHI should be set to 1 and N,
29262*>           respectively.  If N > 0, then 1 <= ILO <= IHI <= N.
29263*>           If N = 0, then ILO = 1 and IHI = 0.
29264*> \endverbatim
29265*>
29266*> \param[in,out] H
29267*> \verbatim
29268*>          H is COMPLEX*16 array, dimension (LDH,N)
29269*>           On entry, the upper Hessenberg matrix H.
29270*>           On exit, if INFO = 0 and WANTT is .TRUE., then H
29271*>           contains the upper triangular matrix T from the Schur
29272*>           decomposition (the Schur form). If INFO = 0 and WANT is
29273*>           .FALSE., then the contents of H are unspecified on exit.
29274*>           (The output value of H when INFO > 0 is given under the
29275*>           description of INFO below.)
29276*>
29277*>           This subroutine may explicitly set H(i,j) = 0 for i > j and
29278*>           j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.
29279*> \endverbatim
29280*>
29281*> \param[in] LDH
29282*> \verbatim
29283*>          LDH is INTEGER
29284*>           The leading dimension of the array H. LDH >= max(1,N).
29285*> \endverbatim
29286*>
29287*> \param[out] W
29288*> \verbatim
29289*>          W is COMPLEX*16 array, dimension (N)
29290*>           The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored
29291*>           in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are
29292*>           stored in the same order as on the diagonal of the Schur
29293*>           form returned in H, with W(i) = H(i,i).
29294*> \endverbatim
29295*>
29296*> \param[in] ILOZ
29297*> \verbatim
29298*>          ILOZ is INTEGER
29299*> \endverbatim
29300*>
29301*> \param[in] IHIZ
29302*> \verbatim
29303*>          IHIZ is INTEGER
29304*>           Specify the rows of Z to which transformations must be
29305*>           applied if WANTZ is .TRUE..
29306*>           1 <= ILOZ <= ILO; IHI <= IHIZ <= N.
29307*> \endverbatim
29308*>
29309*> \param[in,out] Z
29310*> \verbatim
29311*>          Z is COMPLEX*16 array, dimension (LDZ,IHI)
29312*>           If WANTZ is .FALSE., then Z is not referenced.
29313*>           If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is
29314*>           replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the
29315*>           orthogonal Schur factor of H(ILO:IHI,ILO:IHI).
29316*>           (The output value of Z when INFO > 0 is given under
29317*>           the description of INFO below.)
29318*> \endverbatim
29319*>
29320*> \param[in] LDZ
29321*> \verbatim
29322*>          LDZ is INTEGER
29323*>           The leading dimension of the array Z.  if WANTZ is .TRUE.
29324*>           then LDZ >= MAX(1,IHIZ).  Otherwise, LDZ >= 1.
29325*> \endverbatim
29326*>
29327*> \param[out] WORK
29328*> \verbatim
29329*>          WORK is COMPLEX*16 array, dimension LWORK
29330*>           On exit, if LWORK = -1, WORK(1) returns an estimate of
29331*>           the optimal value for LWORK.
29332*> \endverbatim
29333*>
29334*> \param[in] LWORK
29335*> \verbatim
29336*>          LWORK is INTEGER
29337*>           The dimension of the array WORK.  LWORK >= max(1,N)
29338*>           is sufficient, but LWORK typically as large as 6*N may
29339*>           be required for optimal performance.  A workspace query
29340*>           to determine the optimal workspace size is recommended.
29341*>
29342*>           If LWORK = -1, then ZLAQR0 does a workspace query.
29343*>           In this case, ZLAQR0 checks the input parameters and
29344*>           estimates the optimal workspace size for the given
29345*>           values of N, ILO and IHI.  The estimate is returned
29346*>           in WORK(1).  No error message related to LWORK is
29347*>           issued by XERBLA.  Neither H nor Z are accessed.
29348*> \endverbatim
29349*>
29350*> \param[out] INFO
29351*> \verbatim
29352*>          INFO is INTEGER
29353*>             = 0:  successful exit
29354*>             > 0:  if INFO = i, ZLAQR0 failed to compute all of
29355*>                the eigenvalues.  Elements 1:ilo-1 and i+1:n of WR
29356*>                and WI contain those eigenvalues which have been
29357*>                successfully computed.  (Failures are rare.)
29358*>
29359*>                If INFO > 0 and WANT is .FALSE., then on exit,
29360*>                the remaining unconverged eigenvalues are the eigen-
29361*>                values of the upper Hessenberg matrix rows and
29362*>                columns ILO through INFO of the final, output
29363*>                value of H.
29364*>
29365*>                If INFO > 0 and WANTT is .TRUE., then on exit
29366*>
29367*>           (*)  (initial value of H)*U  = U*(final value of H)
29368*>
29369*>                where U is a unitary matrix.  The final
29370*>                value of  H is upper Hessenberg and triangular in
29371*>                rows and columns INFO+1 through IHI.
29372*>
29373*>                If INFO > 0 and WANTZ is .TRUE., then on exit
29374*>
29375*>                  (final value of Z(ILO:IHI,ILOZ:IHIZ)
29376*>                   =  (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U
29377*>
29378*>                where U is the unitary matrix in (*) (regard-
29379*>                less of the value of WANTT.)
29380*>
29381*>                If INFO > 0 and WANTZ is .FALSE., then Z is not
29382*>                accessed.
29383*> \endverbatim
29384*
29385*  Authors:
29386*  ========
29387*
29388*> \author Univ. of Tennessee
29389*> \author Univ. of California Berkeley
29390*> \author Univ. of Colorado Denver
29391*> \author NAG Ltd.
29392*
29393*> \date December 2016
29394*
29395*> \ingroup complex16OTHERauxiliary
29396*
29397*> \par Contributors:
29398*  ==================
29399*>
29400*>       Karen Braman and Ralph Byers, Department of Mathematics,
29401*>       University of Kansas, USA
29402*
29403*> \par References:
29404*  ================
29405*>
29406*>       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
29407*>       Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
29408*>       Performance, SIAM Journal of Matrix Analysis, volume 23, pages
29409*>       929--947, 2002.
29410*> \n
29411*>       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
29412*>       Algorithm Part II: Aggressive Early Deflation, SIAM Journal
29413*>       of Matrix Analysis, volume 23, pages 948--973, 2002.
29414*>
29415*  =====================================================================
29416      SUBROUTINE ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
29417     $                   IHIZ, Z, LDZ, WORK, LWORK, INFO )
29418*
29419*  -- LAPACK auxiliary routine (version 3.7.0) --
29420*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
29421*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
29422*     December 2016
29423*
29424*     .. Scalar Arguments ..
29425      INTEGER            IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N
29426      LOGICAL            WANTT, WANTZ
29427*     ..
29428*     .. Array Arguments ..
29429      COMPLEX*16         H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * )
29430*     ..
29431*
29432*  ================================================================
29433*
29434*     .. Parameters ..
29435*
29436*     ==== Matrices of order NTINY or smaller must be processed by
29437*     .    ZLAHQR because of insufficient subdiagonal scratch space.
29438*     .    (This is a hard limit.) ====
29439      INTEGER            NTINY
29440      PARAMETER          ( NTINY = 11 )
29441*
29442*     ==== Exceptional deflation windows:  try to cure rare
29443*     .    slow convergence by varying the size of the
29444*     .    deflation window after KEXNW iterations. ====
29445      INTEGER            KEXNW
29446      PARAMETER          ( KEXNW = 5 )
29447*
29448*     ==== Exceptional shifts: try to cure rare slow convergence
29449*     .    with ad-hoc exceptional shifts every KEXSH iterations.
29450*     .    ====
29451      INTEGER            KEXSH
29452      PARAMETER          ( KEXSH = 6 )
29453*
29454*     ==== The constant WILK1 is used to form the exceptional
29455*     .    shifts. ====
29456      DOUBLE PRECISION   WILK1
29457      PARAMETER          ( WILK1 = 0.75d0 )
29458      COMPLEX*16         ZERO, ONE
29459      PARAMETER          ( ZERO = ( 0.0d0, 0.0d0 ),
29460     $                   ONE = ( 1.0d0, 0.0d0 ) )
29461      DOUBLE PRECISION   TWO
29462      PARAMETER          ( TWO = 2.0d0 )
29463*     ..
29464*     .. Local Scalars ..
29465      COMPLEX*16         AA, BB, CC, CDUM, DD, DET, RTDISC, SWAP, TR2
29466      DOUBLE PRECISION   S
29467      INTEGER            I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS,
29468     $                   KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS,
29469     $                   LWKOPT, NDEC, NDFL, NH, NHO, NIBBLE, NMIN, NS,
29470     $                   NSMAX, NSR, NVE, NW, NWMAX, NWR, NWUPBD
29471      LOGICAL            SORTED
29472      CHARACTER          JBCMPZ*2
29473*     ..
29474*     .. External Functions ..
29475      INTEGER            ILAENV
29476      EXTERNAL           ILAENV
29477*     ..
29478*     .. Local Arrays ..
29479      COMPLEX*16         ZDUM( 1, 1 )
29480*     ..
29481*     .. External Subroutines ..
29482      EXTERNAL           ZLACPY, ZLAHQR, ZLAQR3, ZLAQR4, ZLAQR5
29483*     ..
29484*     .. Intrinsic Functions ..
29485      INTRINSIC          ABS, DBLE, DCMPLX, DIMAG, INT, MAX, MIN, MOD,
29486     $                   SQRT
29487*     ..
29488*     .. Statement Functions ..
29489      DOUBLE PRECISION   CABS1
29490*     ..
29491*     .. Statement Function definitions ..
29492      CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
29493*     ..
29494*     .. Executable Statements ..
29495      INFO = 0
29496*
29497*     ==== Quick return for N = 0: nothing to do. ====
29498*
29499      IF( N.EQ.0 ) THEN
29500         WORK( 1 ) = ONE
29501         RETURN
29502      END IF
29503*
29504      IF( N.LE.NTINY ) THEN
29505*
29506*        ==== Tiny matrices must use ZLAHQR. ====
29507*
29508         LWKOPT = 1
29509         IF( LWORK.NE.-1 )
29510     $      CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
29511     $                   IHIZ, Z, LDZ, INFO )
29512      ELSE
29513*
29514*        ==== Use small bulge multi-shift QR with aggressive early
29515*        .    deflation on larger-than-tiny matrices. ====
29516*
29517*        ==== Hope for the best. ====
29518*
29519         INFO = 0
29520*
29521*        ==== Set up job flags for ILAENV. ====
29522*
29523         IF( WANTT ) THEN
29524            JBCMPZ( 1: 1 ) = 'S'
29525         ELSE
29526            JBCMPZ( 1: 1 ) = 'E'
29527         END IF
29528         IF( WANTZ ) THEN
29529            JBCMPZ( 2: 2 ) = 'V'
29530         ELSE
29531            JBCMPZ( 2: 2 ) = 'N'
29532         END IF
29533*
29534*        ==== NWR = recommended deflation window size.  At this
29535*        .    point,  N .GT. NTINY = 11, so there is enough
29536*        .    subdiagonal workspace for NWR.GE.2 as required.
29537*        .    (In fact, there is enough subdiagonal space for
29538*        .    NWR.GE.3.) ====
29539*
29540         NWR = ILAENV( 13, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
29541         NWR = MAX( 2, NWR )
29542         NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR )
29543*
29544*        ==== NSR = recommended number of simultaneous shifts.
29545*        .    At this point N .GT. NTINY = 11, so there is at
29546*        .    enough subdiagonal workspace for NSR to be even
29547*        .    and greater than or equal to two as required. ====
29548*
29549         NSR = ILAENV( 15, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
29550         NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO )
29551         NSR = MAX( 2, NSR-MOD( NSR, 2 ) )
29552*
29553*        ==== Estimate optimal workspace ====
29554*
29555*        ==== Workspace query call to ZLAQR3 ====
29556*
29557         CALL ZLAQR3( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ,
29558     $                IHIZ, Z, LDZ, LS, LD, W, H, LDH, N, H, LDH, N, H,
29559     $                LDH, WORK, -1 )
29560*
29561*        ==== Optimal workspace = MAX(ZLAQR5, ZLAQR3) ====
29562*
29563         LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) )
29564*
29565*        ==== Quick return in case of workspace query. ====
29566*
29567         IF( LWORK.EQ.-1 ) THEN
29568            WORK( 1 ) = DCMPLX( LWKOPT, 0 )
29569            RETURN
29570         END IF
29571*
29572*        ==== ZLAHQR/ZLAQR0 crossover point ====
29573*
29574         NMIN = ILAENV( 12, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
29575         NMIN = MAX( NTINY, NMIN )
29576*
29577*        ==== Nibble crossover point ====
29578*
29579         NIBBLE = ILAENV( 14, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
29580         NIBBLE = MAX( 0, NIBBLE )
29581*
29582*        ==== Accumulate reflections during ttswp?  Use block
29583*        .    2-by-2 structure during matrix-matrix multiply? ====
29584*
29585         KACC22 = ILAENV( 16, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
29586         KACC22 = MAX( 0, KACC22 )
29587         KACC22 = MIN( 2, KACC22 )
29588*
29589*        ==== NWMAX = the largest possible deflation window for
29590*        .    which there is sufficient workspace. ====
29591*
29592         NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 )
29593         NW = NWMAX
29594*
29595*        ==== NSMAX = the Largest number of simultaneous shifts
29596*        .    for which there is sufficient workspace. ====
29597*
29598         NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 )
29599         NSMAX = NSMAX - MOD( NSMAX, 2 )
29600*
29601*        ==== NDFL: an iteration count restarted at deflation. ====
29602*
29603         NDFL = 1
29604*
29605*        ==== ITMAX = iteration limit ====
29606*
29607         ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) )
29608*
29609*        ==== Last row and column in the active block ====
29610*
29611         KBOT = IHI
29612*
29613*        ==== Main Loop ====
29614*
29615         DO 70 IT = 1, ITMAX
29616*
29617*           ==== Done when KBOT falls below ILO ====
29618*
29619            IF( KBOT.LT.ILO )
29620     $         GO TO 80
29621*
29622*           ==== Locate active block ====
29623*
29624            DO 10 K = KBOT, ILO + 1, -1
29625               IF( H( K, K-1 ).EQ.ZERO )
29626     $            GO TO 20
29627   10       CONTINUE
29628            K = ILO
29629   20       CONTINUE
29630            KTOP = K
29631*
29632*           ==== Select deflation window size:
29633*           .    Typical Case:
29634*           .      If possible and advisable, nibble the entire
29635*           .      active block.  If not, use size MIN(NWR,NWMAX)
29636*           .      or MIN(NWR+1,NWMAX) depending upon which has
29637*           .      the smaller corresponding subdiagonal entry
29638*           .      (a heuristic).
29639*           .
29640*           .    Exceptional Case:
29641*           .      If there have been no deflations in KEXNW or
29642*           .      more iterations, then vary the deflation window
29643*           .      size.   At first, because, larger windows are,
29644*           .      in general, more powerful than smaller ones,
29645*           .      rapidly increase the window to the maximum possible.
29646*           .      Then, gradually reduce the window size. ====
29647*
29648            NH = KBOT - KTOP + 1
29649            NWUPBD = MIN( NH, NWMAX )
29650            IF( NDFL.LT.KEXNW ) THEN
29651               NW = MIN( NWUPBD, NWR )
29652            ELSE
29653               NW = MIN( NWUPBD, 2*NW )
29654            END IF
29655            IF( NW.LT.NWMAX ) THEN
29656               IF( NW.GE.NH-1 ) THEN
29657                  NW = NH
29658               ELSE
29659                  KWTOP = KBOT - NW + 1
29660                  IF( CABS1( H( KWTOP, KWTOP-1 ) ).GT.
29661     $                CABS1( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1
29662               END IF
29663            END IF
29664            IF( NDFL.LT.KEXNW ) THEN
29665               NDEC = -1
29666            ELSE IF( NDEC.GE.0 .OR. NW.GE.NWUPBD ) THEN
29667               NDEC = NDEC + 1
29668               IF( NW-NDEC.LT.2 )
29669     $            NDEC = 0
29670               NW = NW - NDEC
29671            END IF
29672*
29673*           ==== Aggressive early deflation:
29674*           .    split workspace under the subdiagonal into
29675*           .      - an nw-by-nw work array V in the lower
29676*           .        left-hand-corner,
29677*           .      - an NW-by-at-least-NW-but-more-is-better
29678*           .        (NW-by-NHO) horizontal work array along
29679*           .        the bottom edge,
29680*           .      - an at-least-NW-but-more-is-better (NHV-by-NW)
29681*           .        vertical work array along the left-hand-edge.
29682*           .        ====
29683*
29684            KV = N - NW + 1
29685            KT = NW + 1
29686            NHO = ( N-NW-1 ) - KT + 1
29687            KWV = NW + 2
29688            NVE = ( N-NW ) - KWV + 1
29689*
29690*           ==== Aggressive early deflation ====
29691*
29692            CALL ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
29693     $                   IHIZ, Z, LDZ, LS, LD, W, H( KV, 1 ), LDH, NHO,
29694     $                   H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, WORK,
29695     $                   LWORK )
29696*
29697*           ==== Adjust KBOT accounting for new deflations. ====
29698*
29699            KBOT = KBOT - LD
29700*
29701*           ==== KS points to the shifts. ====
29702*
29703            KS = KBOT - LS + 1
29704*
29705*           ==== Skip an expensive QR sweep if there is a (partly
29706*           .    heuristic) reason to expect that many eigenvalues
29707*           .    will deflate without it.  Here, the QR sweep is
29708*           .    skipped if many eigenvalues have just been deflated
29709*           .    or if the remaining active block is small.
29710*
29711            IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT-
29712     $          KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN
29713*
29714*              ==== NS = nominal number of simultaneous shifts.
29715*              .    This may be lowered (slightly) if ZLAQR3
29716*              .    did not provide that many shifts. ====
29717*
29718               NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) )
29719               NS = NS - MOD( NS, 2 )
29720*
29721*              ==== If there have been no deflations
29722*              .    in a multiple of KEXSH iterations,
29723*              .    then try exceptional shifts.
29724*              .    Otherwise use shifts provided by
29725*              .    ZLAQR3 above or from the eigenvalues
29726*              .    of a trailing principal submatrix. ====
29727*
29728               IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN
29729                  KS = KBOT - NS + 1
29730                  DO 30 I = KBOT, KS + 1, -2
29731                     W( I ) = H( I, I ) + WILK1*CABS1( H( I, I-1 ) )
29732                     W( I-1 ) = W( I )
29733   30             CONTINUE
29734               ELSE
29735*
29736*                 ==== Got NS/2 or fewer shifts? Use ZLAQR4 or
29737*                 .    ZLAHQR on a trailing principal submatrix to
29738*                 .    get more. (Since NS.LE.NSMAX.LE.(N+6)/9,
29739*                 .    there is enough space below the subdiagonal
29740*                 .    to fit an NS-by-NS scratch array.) ====
29741*
29742                  IF( KBOT-KS+1.LE.NS / 2 ) THEN
29743                     KS = KBOT - NS + 1
29744                     KT = N - NS + 1
29745                     CALL ZLACPY( 'A', NS, NS, H( KS, KS ), LDH,
29746     $                            H( KT, 1 ), LDH )
29747                     IF( NS.GT.NMIN ) THEN
29748                        CALL ZLAQR4( .false., .false., NS, 1, NS,
29749     $                               H( KT, 1 ), LDH, W( KS ), 1, 1,
29750     $                               ZDUM, 1, WORK, LWORK, INF )
29751                     ELSE
29752                        CALL ZLAHQR( .false., .false., NS, 1, NS,
29753     $                               H( KT, 1 ), LDH, W( KS ), 1, 1,
29754     $                               ZDUM, 1, INF )
29755                     END IF
29756                     KS = KS + INF
29757*
29758*                    ==== In case of a rare QR failure use
29759*                    .    eigenvalues of the trailing 2-by-2
29760*                    .    principal submatrix.  Scale to avoid
29761*                    .    overflows, underflows and subnormals.
29762*                    .    (The scale factor S can not be zero,
29763*                    .    because H(KBOT,KBOT-1) is nonzero.) ====
29764*
29765                     IF( KS.GE.KBOT ) THEN
29766                        S = CABS1( H( KBOT-1, KBOT-1 ) ) +
29767     $                      CABS1( H( KBOT, KBOT-1 ) ) +
29768     $                      CABS1( H( KBOT-1, KBOT ) ) +
29769     $                      CABS1( H( KBOT, KBOT ) )
29770                        AA = H( KBOT-1, KBOT-1 ) / S
29771                        CC = H( KBOT, KBOT-1 ) / S
29772                        BB = H( KBOT-1, KBOT ) / S
29773                        DD = H( KBOT, KBOT ) / S
29774                        TR2 = ( AA+DD ) / TWO
29775                        DET = ( AA-TR2 )*( DD-TR2 ) - BB*CC
29776                        RTDISC = SQRT( -DET )
29777                        W( KBOT-1 ) = ( TR2+RTDISC )*S
29778                        W( KBOT ) = ( TR2-RTDISC )*S
29779*
29780                        KS = KBOT - 1
29781                     END IF
29782                  END IF
29783*
29784                  IF( KBOT-KS+1.GT.NS ) THEN
29785*
29786*                    ==== Sort the shifts (Helps a little) ====
29787*
29788                     SORTED = .false.
29789                     DO 50 K = KBOT, KS + 1, -1
29790                        IF( SORTED )
29791     $                     GO TO 60
29792                        SORTED = .true.
29793                        DO 40 I = KS, K - 1
29794                           IF( CABS1( W( I ) ).LT.CABS1( W( I+1 ) ) )
29795     $                          THEN
29796                              SORTED = .false.
29797                              SWAP = W( I )
29798                              W( I ) = W( I+1 )
29799                              W( I+1 ) = SWAP
29800                           END IF
29801   40                   CONTINUE
29802   50                CONTINUE
29803   60                CONTINUE
29804                  END IF
29805               END IF
29806*
29807*              ==== If there are only two shifts, then use
29808*              .    only one.  ====
29809*
29810               IF( KBOT-KS+1.EQ.2 ) THEN
29811                  IF( CABS1( W( KBOT )-H( KBOT, KBOT ) ).LT.
29812     $                CABS1( W( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN
29813                     W( KBOT-1 ) = W( KBOT )
29814                  ELSE
29815                     W( KBOT ) = W( KBOT-1 )
29816                  END IF
29817               END IF
29818*
29819*              ==== Use up to NS of the the smallest magnitude
29820*              .    shifts.  If there aren't NS shifts available,
29821*              .    then use them all, possibly dropping one to
29822*              .    make the number of shifts even. ====
29823*
29824               NS = MIN( NS, KBOT-KS+1 )
29825               NS = NS - MOD( NS, 2 )
29826               KS = KBOT - NS + 1
29827*
29828*              ==== Small-bulge multi-shift QR sweep:
29829*              .    split workspace under the subdiagonal into
29830*              .    - a KDU-by-KDU work array U in the lower
29831*              .      left-hand-corner,
29832*              .    - a KDU-by-at-least-KDU-but-more-is-better
29833*              .      (KDU-by-NHo) horizontal work array WH along
29834*              .      the bottom edge,
29835*              .    - and an at-least-KDU-but-more-is-better-by-KDU
29836*              .      (NVE-by-KDU) vertical work WV arrow along
29837*              .      the left-hand-edge. ====
29838*
29839               KDU = 3*NS - 3
29840               KU = N - KDU + 1
29841               KWH = KDU + 1
29842               NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1
29843               KWV = KDU + 4
29844               NVE = N - KDU - KWV + 1
29845*
29846*              ==== Small-bulge multi-shift QR sweep ====
29847*
29848               CALL ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS,
29849     $                      W( KS ), H, LDH, ILOZ, IHIZ, Z, LDZ, WORK,
29850     $                      3, H( KU, 1 ), LDH, NVE, H( KWV, 1 ), LDH,
29851     $                      NHO, H( KU, KWH ), LDH )
29852            END IF
29853*
29854*           ==== Note progress (or the lack of it). ====
29855*
29856            IF( LD.GT.0 ) THEN
29857               NDFL = 1
29858            ELSE
29859               NDFL = NDFL + 1
29860            END IF
29861*
29862*           ==== End of main loop ====
29863   70    CONTINUE
29864*
29865*        ==== Iteration limit exceeded.  Set INFO to show where
29866*        .    the problem occurred and exit. ====
29867*
29868         INFO = KBOT
29869   80    CONTINUE
29870      END IF
29871*
29872*     ==== Return the optimal value of LWORK. ====
29873*
29874      WORK( 1 ) = DCMPLX( LWKOPT, 0 )
29875*
29876*     ==== End of ZLAQR0 ====
29877*
29878      END
29879*> \brief \b ZLAQR1 sets a scalar multiple of the first column of the product of 2-by-2 or 3-by-3 matrix H and specified shifts.
29880*
29881*  =========== DOCUMENTATION ===========
29882*
29883* Online html documentation available at
29884*            http://www.netlib.org/lapack/explore-html/
29885*
29886*> \htmlonly
29887*> Download ZLAQR1 + dependencies
29888*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlaqr1.f">
29889*> [TGZ]</a>
29890*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlaqr1.f">
29891*> [ZIP]</a>
29892*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlaqr1.f">
29893*> [TXT]</a>
29894*> \endhtmlonly
29895*
29896*  Definition:
29897*  ===========
29898*
29899*       SUBROUTINE ZLAQR1( N, H, LDH, S1, S2, V )
29900*
29901*       .. Scalar Arguments ..
29902*       COMPLEX*16         S1, S2
29903*       INTEGER            LDH, N
29904*       ..
29905*       .. Array Arguments ..
29906*       COMPLEX*16         H( LDH, * ), V( * )
29907*       ..
29908*
29909*
29910*> \par Purpose:
29911*  =============
29912*>
29913*> \verbatim
29914*>
29915*>      Given a 2-by-2 or 3-by-3 matrix H, ZLAQR1 sets v to a
29916*>      scalar multiple of the first column of the product
29917*>
29918*>      (*)  K = (H - s1*I)*(H - s2*I)
29919*>
29920*>      scaling to avoid overflows and most underflows.
29921*>
29922*>      This is useful for starting double implicit shift bulges
29923*>      in the QR algorithm.
29924*> \endverbatim
29925*
29926*  Arguments:
29927*  ==========
29928*
29929*> \param[in] N
29930*> \verbatim
29931*>          N is INTEGER
29932*>              Order of the matrix H. N must be either 2 or 3.
29933*> \endverbatim
29934*>
29935*> \param[in] H
29936*> \verbatim
29937*>          H is COMPLEX*16 array, dimension (LDH,N)
29938*>              The 2-by-2 or 3-by-3 matrix H in (*).
29939*> \endverbatim
29940*>
29941*> \param[in] LDH
29942*> \verbatim
29943*>          LDH is INTEGER
29944*>              The leading dimension of H as declared in
29945*>              the calling procedure.  LDH >= N
29946*> \endverbatim
29947*>
29948*> \param[in] S1
29949*> \verbatim
29950*>          S1 is COMPLEX*16
29951*> \endverbatim
29952*>
29953*> \param[in] S2
29954*> \verbatim
29955*>          S2 is COMPLEX*16
29956*>
29957*>          S1 and S2 are the shifts defining K in (*) above.
29958*> \endverbatim
29959*>
29960*> \param[out] V
29961*> \verbatim
29962*>          V is COMPLEX*16 array, dimension (N)
29963*>              A scalar multiple of the first column of the
29964*>              matrix K in (*).
29965*> \endverbatim
29966*
29967*  Authors:
29968*  ========
29969*
29970*> \author Univ. of Tennessee
29971*> \author Univ. of California Berkeley
29972*> \author Univ. of Colorado Denver
29973*> \author NAG Ltd.
29974*
29975*> \date June 2017
29976*
29977*> \ingroup complex16OTHERauxiliary
29978*
29979*> \par Contributors:
29980*  ==================
29981*>
29982*>       Karen Braman and Ralph Byers, Department of Mathematics,
29983*>       University of Kansas, USA
29984*>
29985*  =====================================================================
29986      SUBROUTINE ZLAQR1( N, H, LDH, S1, S2, V )
29987*
29988*  -- LAPACK auxiliary routine (version 3.7.1) --
29989*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
29990*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
29991*     June 2017
29992*
29993*     .. Scalar Arguments ..
29994      COMPLEX*16         S1, S2
29995      INTEGER            LDH, N
29996*     ..
29997*     .. Array Arguments ..
29998      COMPLEX*16         H( LDH, * ), V( * )
29999*     ..
30000*
30001*  ================================================================
30002*
30003*     .. Parameters ..
30004      COMPLEX*16         ZERO
30005      PARAMETER          ( ZERO = ( 0.0d0, 0.0d0 ) )
30006      DOUBLE PRECISION   RZERO
30007      PARAMETER          ( RZERO = 0.0d0 )
30008*     ..
30009*     .. Local Scalars ..
30010      COMPLEX*16         CDUM, H21S, H31S
30011      DOUBLE PRECISION   S
30012*     ..
30013*     .. Intrinsic Functions ..
30014      INTRINSIC          ABS, DBLE, DIMAG
30015*     ..
30016*     .. Statement Functions ..
30017      DOUBLE PRECISION   CABS1
30018*     ..
30019*     .. Statement Function definitions ..
30020      CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
30021*     ..
30022*     .. Executable Statements ..
30023*
30024*     Quick return if possible
30025*
30026      IF( N.NE.2 .AND. N.NE.3 ) THEN
30027         RETURN
30028      END IF
30029*
30030      IF( N.EQ.2 ) THEN
30031         S = CABS1( H( 1, 1 )-S2 ) + CABS1( H( 2, 1 ) )
30032         IF( S.EQ.RZERO ) THEN
30033            V( 1 ) = ZERO
30034            V( 2 ) = ZERO
30035         ELSE
30036            H21S = H( 2, 1 ) / S
30037            V( 1 ) = H21S*H( 1, 2 ) + ( H( 1, 1 )-S1 )*
30038     $               ( ( H( 1, 1 )-S2 ) / S )
30039            V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-S1-S2 )
30040         END IF
30041      ELSE
30042         S = CABS1( H( 1, 1 )-S2 ) + CABS1( H( 2, 1 ) ) +
30043     $       CABS1( H( 3, 1 ) )
30044         IF( S.EQ.ZERO ) THEN
30045            V( 1 ) = ZERO
30046            V( 2 ) = ZERO
30047            V( 3 ) = ZERO
30048         ELSE
30049            H21S = H( 2, 1 ) / S
30050            H31S = H( 3, 1 ) / S
30051            V( 1 ) = ( H( 1, 1 )-S1 )*( ( H( 1, 1 )-S2 ) / S ) +
30052     $               H( 1, 2 )*H21S + H( 1, 3 )*H31S
30053            V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-S1-S2 ) + H( 2, 3 )*H31S
30054            V( 3 ) = H31S*( H( 1, 1 )+H( 3, 3 )-S1-S2 ) + H21S*H( 3, 2 )
30055         END IF
30056      END IF
30057      END
30058*> \brief \b ZLAQR2 performs the unitary similarity transformation of a Hessenberg matrix to detect and deflate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation).
30059*
30060*  =========== DOCUMENTATION ===========
30061*
30062* Online html documentation available at
30063*            http://www.netlib.org/lapack/explore-html/
30064*
30065*> \htmlonly
30066*> Download ZLAQR2 + dependencies
30067*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlaqr2.f">
30068*> [TGZ]</a>
30069*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlaqr2.f">
30070*> [ZIP]</a>
30071*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlaqr2.f">
30072*> [TXT]</a>
30073*> \endhtmlonly
30074*
30075*  Definition:
30076*  ===========
30077*
30078*       SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
30079*                          IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT,
30080*                          NV, WV, LDWV, WORK, LWORK )
30081*
30082*       .. Scalar Arguments ..
30083*       INTEGER            IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV,
30084*      $                   LDZ, LWORK, N, ND, NH, NS, NV, NW
30085*       LOGICAL            WANTT, WANTZ
30086*       ..
30087*       .. Array Arguments ..
30088*       COMPLEX*16         H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ),
30089*      $                   WORK( * ), WV( LDWV, * ), Z( LDZ, * )
30090*       ..
30091*
30092*
30093*> \par Purpose:
30094*  =============
30095*>
30096*> \verbatim
30097*>
30098*>    ZLAQR2 is identical to ZLAQR3 except that it avoids
30099*>    recursion by calling ZLAHQR instead of ZLAQR4.
30100*>
30101*>    Aggressive early deflation:
30102*>
30103*>    ZLAQR2 accepts as input an upper Hessenberg matrix
30104*>    H and performs an unitary similarity transformation
30105*>    designed to detect and deflate fully converged eigenvalues from
30106*>    a trailing principal submatrix.  On output H has been over-
30107*>    written by a new Hessenberg matrix that is a perturbation of
30108*>    an unitary similarity transformation of H.  It is to be
30109*>    hoped that the final version of H has many zero subdiagonal
30110*>    entries.
30111*>
30112*> \endverbatim
30113*
30114*  Arguments:
30115*  ==========
30116*
30117*> \param[in] WANTT
30118*> \verbatim
30119*>          WANTT is LOGICAL
30120*>          If .TRUE., then the Hessenberg matrix H is fully updated
30121*>          so that the triangular Schur factor may be
30122*>          computed (in cooperation with the calling subroutine).
30123*>          If .FALSE., then only enough of H is updated to preserve
30124*>          the eigenvalues.
30125*> \endverbatim
30126*>
30127*> \param[in] WANTZ
30128*> \verbatim
30129*>          WANTZ is LOGICAL
30130*>          If .TRUE., then the unitary matrix Z is updated so
30131*>          so that the unitary Schur factor may be computed
30132*>          (in cooperation with the calling subroutine).
30133*>          If .FALSE., then Z is not referenced.
30134*> \endverbatim
30135*>
30136*> \param[in] N
30137*> \verbatim
30138*>          N is INTEGER
30139*>          The order of the matrix H and (if WANTZ is .TRUE.) the
30140*>          order of the unitary matrix Z.
30141*> \endverbatim
30142*>
30143*> \param[in] KTOP
30144*> \verbatim
30145*>          KTOP is INTEGER
30146*>          It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.
30147*>          KBOT and KTOP together determine an isolated block
30148*>          along the diagonal of the Hessenberg matrix.
30149*> \endverbatim
30150*>
30151*> \param[in] KBOT
30152*> \verbatim
30153*>          KBOT is INTEGER
30154*>          It is assumed without a check that either
30155*>          KBOT = N or H(KBOT+1,KBOT)=0.  KBOT and KTOP together
30156*>          determine an isolated block along the diagonal of the
30157*>          Hessenberg matrix.
30158*> \endverbatim
30159*>
30160*> \param[in] NW
30161*> \verbatim
30162*>          NW is INTEGER
30163*>          Deflation window size.  1 <= NW <= (KBOT-KTOP+1).
30164*> \endverbatim
30165*>
30166*> \param[in,out] H
30167*> \verbatim
30168*>          H is COMPLEX*16 array, dimension (LDH,N)
30169*>          On input the initial N-by-N section of H stores the
30170*>          Hessenberg matrix undergoing aggressive early deflation.
30171*>          On output H has been transformed by a unitary
30172*>          similarity transformation, perturbed, and the returned
30173*>          to Hessenberg form that (it is to be hoped) has some
30174*>          zero subdiagonal entries.
30175*> \endverbatim
30176*>
30177*> \param[in] LDH
30178*> \verbatim
30179*>          LDH is INTEGER
30180*>          Leading dimension of H just as declared in the calling
30181*>          subroutine.  N <= LDH
30182*> \endverbatim
30183*>
30184*> \param[in] ILOZ
30185*> \verbatim
30186*>          ILOZ is INTEGER
30187*> \endverbatim
30188*>
30189*> \param[in] IHIZ
30190*> \verbatim
30191*>          IHIZ is INTEGER
30192*>          Specify the rows of Z to which transformations must be
30193*>          applied if WANTZ is .TRUE.. 1 <= ILOZ <= IHIZ <= N.
30194*> \endverbatim
30195*>
30196*> \param[in,out] Z
30197*> \verbatim
30198*>          Z is COMPLEX*16 array, dimension (LDZ,N)
30199*>          IF WANTZ is .TRUE., then on output, the unitary
30200*>          similarity transformation mentioned above has been
30201*>          accumulated into Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right.
30202*>          If WANTZ is .FALSE., then Z is unreferenced.
30203*> \endverbatim
30204*>
30205*> \param[in] LDZ
30206*> \verbatim
30207*>          LDZ is INTEGER
30208*>          The leading dimension of Z just as declared in the
30209*>          calling subroutine.  1 <= LDZ.
30210*> \endverbatim
30211*>
30212*> \param[out] NS
30213*> \verbatim
30214*>          NS is INTEGER
30215*>          The number of unconverged (ie approximate) eigenvalues
30216*>          returned in SR and SI that may be used as shifts by the
30217*>          calling subroutine.
30218*> \endverbatim
30219*>
30220*> \param[out] ND
30221*> \verbatim
30222*>          ND is INTEGER
30223*>          The number of converged eigenvalues uncovered by this
30224*>          subroutine.
30225*> \endverbatim
30226*>
30227*> \param[out] SH
30228*> \verbatim
30229*>          SH is COMPLEX*16 array, dimension (KBOT)
30230*>          On output, approximate eigenvalues that may
30231*>          be used for shifts are stored in SH(KBOT-ND-NS+1)
30232*>          through SR(KBOT-ND).  Converged eigenvalues are
30233*>          stored in SH(KBOT-ND+1) through SH(KBOT).
30234*> \endverbatim
30235*>
30236*> \param[out] V
30237*> \verbatim
30238*>          V is COMPLEX*16 array, dimension (LDV,NW)
30239*>          An NW-by-NW work array.
30240*> \endverbatim
30241*>
30242*> \param[in] LDV
30243*> \verbatim
30244*>          LDV is INTEGER
30245*>          The leading dimension of V just as declared in the
30246*>          calling subroutine.  NW <= LDV
30247*> \endverbatim
30248*>
30249*> \param[in] NH
30250*> \verbatim
30251*>          NH is INTEGER
30252*>          The number of columns of T.  NH >= NW.
30253*> \endverbatim
30254*>
30255*> \param[out] T
30256*> \verbatim
30257*>          T is COMPLEX*16 array, dimension (LDT,NW)
30258*> \endverbatim
30259*>
30260*> \param[in] LDT
30261*> \verbatim
30262*>          LDT is INTEGER
30263*>          The leading dimension of T just as declared in the
30264*>          calling subroutine.  NW <= LDT
30265*> \endverbatim
30266*>
30267*> \param[in] NV
30268*> \verbatim
30269*>          NV is INTEGER
30270*>          The number of rows of work array WV available for
30271*>          workspace.  NV >= NW.
30272*> \endverbatim
30273*>
30274*> \param[out] WV
30275*> \verbatim
30276*>          WV is COMPLEX*16 array, dimension (LDWV,NW)
30277*> \endverbatim
30278*>
30279*> \param[in] LDWV
30280*> \verbatim
30281*>          LDWV is INTEGER
30282*>          The leading dimension of W just as declared in the
30283*>          calling subroutine.  NW <= LDV
30284*> \endverbatim
30285*>
30286*> \param[out] WORK
30287*> \verbatim
30288*>          WORK is COMPLEX*16 array, dimension (LWORK)
30289*>          On exit, WORK(1) is set to an estimate of the optimal value
30290*>          of LWORK for the given values of N, NW, KTOP and KBOT.
30291*> \endverbatim
30292*>
30293*> \param[in] LWORK
30294*> \verbatim
30295*>          LWORK is INTEGER
30296*>          The dimension of the work array WORK.  LWORK = 2*NW
30297*>          suffices, but greater efficiency may result from larger
30298*>          values of LWORK.
30299*>
30300*>          If LWORK = -1, then a workspace query is assumed; ZLAQR2
30301*>          only estimates the optimal workspace size for the given
30302*>          values of N, NW, KTOP and KBOT.  The estimate is returned
30303*>          in WORK(1).  No error message related to LWORK is issued
30304*>          by XERBLA.  Neither H nor Z are accessed.
30305*> \endverbatim
30306*
30307*  Authors:
30308*  ========
30309*
30310*> \author Univ. of Tennessee
30311*> \author Univ. of California Berkeley
30312*> \author Univ. of Colorado Denver
30313*> \author NAG Ltd.
30314*
30315*> \date June 2017
30316*
30317*> \ingroup complex16OTHERauxiliary
30318*
30319*> \par Contributors:
30320*  ==================
30321*>
30322*>       Karen Braman and Ralph Byers, Department of Mathematics,
30323*>       University of Kansas, USA
30324*>
30325*  =====================================================================
30326      SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
30327     $                   IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT,
30328     $                   NV, WV, LDWV, WORK, LWORK )
30329*
30330*  -- LAPACK auxiliary routine (version 3.7.1) --
30331*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
30332*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
30333*     June 2017
30334*
30335*     .. Scalar Arguments ..
30336      INTEGER            IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV,
30337     $                   LDZ, LWORK, N, ND, NH, NS, NV, NW
30338      LOGICAL            WANTT, WANTZ
30339*     ..
30340*     .. Array Arguments ..
30341      COMPLEX*16         H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ),
30342     $                   WORK( * ), WV( LDWV, * ), Z( LDZ, * )
30343*     ..
30344*
30345*  ================================================================
30346*
30347*     .. Parameters ..
30348      COMPLEX*16         ZERO, ONE
30349      PARAMETER          ( ZERO = ( 0.0d0, 0.0d0 ),
30350     $                   ONE = ( 1.0d0, 0.0d0 ) )
30351      DOUBLE PRECISION   RZERO, RONE
30352      PARAMETER          ( RZERO = 0.0d0, RONE = 1.0d0 )
30353*     ..
30354*     .. Local Scalars ..
30355      COMPLEX*16         BETA, CDUM, S, TAU
30356      DOUBLE PRECISION   FOO, SAFMAX, SAFMIN, SMLNUM, ULP
30357      INTEGER            I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN,
30358     $                   KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWKOPT
30359*     ..
30360*     .. External Functions ..
30361      DOUBLE PRECISION   DLAMCH
30362      EXTERNAL           DLAMCH
30363*     ..
30364*     .. External Subroutines ..
30365      EXTERNAL           DLABAD, ZCOPY, ZGEHRD, ZGEMM, ZLACPY, ZLAHQR,
30366     $                   ZLARF, ZLARFG, ZLASET, ZTREXC, ZUNMHR
30367*     ..
30368*     .. Intrinsic Functions ..
30369      INTRINSIC          ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, MAX, MIN
30370*     ..
30371*     .. Statement Functions ..
30372      DOUBLE PRECISION   CABS1
30373*     ..
30374*     .. Statement Function definitions ..
30375      CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
30376*     ..
30377*     .. Executable Statements ..
30378*
30379*     ==== Estimate optimal workspace. ====
30380*
30381      JW = MIN( NW, KBOT-KTOP+1 )
30382      IF( JW.LE.2 ) THEN
30383         LWKOPT = 1
30384      ELSE
30385*
30386*        ==== Workspace query call to ZGEHRD ====
30387*
30388         CALL ZGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
30389         LWK1 = INT( WORK( 1 ) )
30390*
30391*        ==== Workspace query call to ZUNMHR ====
30392*
30393         CALL ZUNMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV,
30394     $                WORK, -1, INFO )
30395         LWK2 = INT( WORK( 1 ) )
30396*
30397*        ==== Optimal workspace ====
30398*
30399         LWKOPT = JW + MAX( LWK1, LWK2 )
30400      END IF
30401*
30402*     ==== Quick return in case of workspace query. ====
30403*
30404      IF( LWORK.EQ.-1 ) THEN
30405         WORK( 1 ) = DCMPLX( LWKOPT, 0 )
30406         RETURN
30407      END IF
30408*
30409*     ==== Nothing to do ...
30410*     ... for an empty active block ... ====
30411      NS = 0
30412      ND = 0
30413      WORK( 1 ) = ONE
30414      IF( KTOP.GT.KBOT )
30415     $   RETURN
30416*     ... nor for an empty deflation window. ====
30417      IF( NW.LT.1 )
30418     $   RETURN
30419*
30420*     ==== Machine constants ====
30421*
30422      SAFMIN = DLAMCH( 'SAFE MINIMUM' )
30423      SAFMAX = RONE / SAFMIN
30424      CALL DLABAD( SAFMIN, SAFMAX )
30425      ULP = DLAMCH( 'PRECISION' )
30426      SMLNUM = SAFMIN*( DBLE( N ) / ULP )
30427*
30428*     ==== Setup deflation window ====
30429*
30430      JW = MIN( NW, KBOT-KTOP+1 )
30431      KWTOP = KBOT - JW + 1
30432      IF( KWTOP.EQ.KTOP ) THEN
30433         S = ZERO
30434      ELSE
30435         S = H( KWTOP, KWTOP-1 )
30436      END IF
30437*
30438      IF( KBOT.EQ.KWTOP ) THEN
30439*
30440*        ==== 1-by-1 deflation window: not much to do ====
30441*
30442         SH( KWTOP ) = H( KWTOP, KWTOP )
30443         NS = 1
30444         ND = 0
30445         IF( CABS1( S ).LE.MAX( SMLNUM, ULP*CABS1( H( KWTOP,
30446     $       KWTOP ) ) ) ) THEN
30447            NS = 0
30448            ND = 1
30449            IF( KWTOP.GT.KTOP )
30450     $         H( KWTOP, KWTOP-1 ) = ZERO
30451         END IF
30452         WORK( 1 ) = ONE
30453         RETURN
30454      END IF
30455*
30456*     ==== Convert to spike-triangular form.  (In case of a
30457*     .    rare QR failure, this routine continues to do
30458*     .    aggressive early deflation using that part of
30459*     .    the deflation window that converged using INFQR
30460*     .    here and there to keep track.) ====
30461*
30462      CALL ZLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT )
30463      CALL ZCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 )
30464*
30465      CALL ZLASET( 'A', JW, JW, ZERO, ONE, V, LDV )
30466      CALL ZLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1,
30467     $             JW, V, LDV, INFQR )
30468*
30469*     ==== Deflation detection loop ====
30470*
30471      NS = JW
30472      ILST = INFQR + 1
30473      DO 10 KNT = INFQR + 1, JW
30474*
30475*        ==== Small spike tip deflation test ====
30476*
30477         FOO = CABS1( T( NS, NS ) )
30478         IF( FOO.EQ.RZERO )
30479     $      FOO = CABS1( S )
30480         IF( CABS1( S )*CABS1( V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) )
30481     $        THEN
30482*
30483*           ==== One more converged eigenvalue ====
30484*
30485            NS = NS - 1
30486         ELSE
30487*
30488*           ==== One undeflatable eigenvalue.  Move it up out of the
30489*           .    way.   (ZTREXC can not fail in this case.) ====
30490*
30491            IFST = NS
30492            CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO )
30493            ILST = ILST + 1
30494         END IF
30495   10 CONTINUE
30496*
30497*        ==== Return to Hessenberg form ====
30498*
30499      IF( NS.EQ.0 )
30500     $   S = ZERO
30501*
30502      IF( NS.LT.JW ) THEN
30503*
30504*        ==== sorting the diagonal of T improves accuracy for
30505*        .    graded matrices.  ====
30506*
30507         DO 30 I = INFQR + 1, NS
30508            IFST = I
30509            DO 20 J = I + 1, NS
30510               IF( CABS1( T( J, J ) ).GT.CABS1( T( IFST, IFST ) ) )
30511     $            IFST = J
30512   20       CONTINUE
30513            ILST = I
30514            IF( IFST.NE.ILST )
30515     $         CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO )
30516   30    CONTINUE
30517      END IF
30518*
30519*     ==== Restore shift/eigenvalue array from T ====
30520*
30521      DO 40 I = INFQR + 1, JW
30522         SH( KWTOP+I-1 ) = T( I, I )
30523   40 CONTINUE
30524*
30525*
30526      IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN
30527         IF( NS.GT.1 .AND. S.NE.ZERO ) THEN
30528*
30529*           ==== Reflect spike back into lower triangle ====
30530*
30531            CALL ZCOPY( NS, V, LDV, WORK, 1 )
30532            DO 50 I = 1, NS
30533               WORK( I ) = DCONJG( WORK( I ) )
30534   50       CONTINUE
30535            BETA = WORK( 1 )
30536            CALL ZLARFG( NS, BETA, WORK( 2 ), 1, TAU )
30537            WORK( 1 ) = ONE
30538*
30539            CALL ZLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT )
30540*
30541            CALL ZLARF( 'L', NS, JW, WORK, 1, DCONJG( TAU ), T, LDT,
30542     $                  WORK( JW+1 ) )
30543            CALL ZLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT,
30544     $                  WORK( JW+1 ) )
30545            CALL ZLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV,
30546     $                  WORK( JW+1 ) )
30547*
30548            CALL ZGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
30549     $                   LWORK-JW, INFO )
30550         END IF
30551*
30552*        ==== Copy updated reduced window into place ====
30553*
30554         IF( KWTOP.GT.1 )
30555     $      H( KWTOP, KWTOP-1 ) = S*DCONJG( V( 1, 1 ) )
30556         CALL ZLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH )
30557         CALL ZCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ),
30558     $               LDH+1 )
30559*
30560*        ==== Accumulate orthogonal matrix in order update
30561*        .    H and Z, if requested.  ====
30562*
30563         IF( NS.GT.1 .AND. S.NE.ZERO )
30564     $      CALL ZUNMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV,
30565     $                   WORK( JW+1 ), LWORK-JW, INFO )
30566*
30567*        ==== Update vertical slab in H ====
30568*
30569         IF( WANTT ) THEN
30570            LTOP = 1
30571         ELSE
30572            LTOP = KTOP
30573         END IF
30574         DO 60 KROW = LTOP, KWTOP - 1, NV
30575            KLN = MIN( NV, KWTOP-KROW )
30576            CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ),
30577     $                  LDH, V, LDV, ZERO, WV, LDWV )
30578            CALL ZLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH )
30579   60    CONTINUE
30580*
30581*        ==== Update horizontal slab in H ====
30582*
30583         IF( WANTT ) THEN
30584            DO 70 KCOL = KBOT + 1, N, NH
30585               KLN = MIN( NH, N-KCOL+1 )
30586               CALL ZGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV,
30587     $                     H( KWTOP, KCOL ), LDH, ZERO, T, LDT )
30588               CALL ZLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ),
30589     $                      LDH )
30590   70       CONTINUE
30591         END IF
30592*
30593*        ==== Update vertical slab in Z ====
30594*
30595         IF( WANTZ ) THEN
30596            DO 80 KROW = ILOZ, IHIZ, NV
30597               KLN = MIN( NV, IHIZ-KROW+1 )
30598               CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ),
30599     $                     LDZ, V, LDV, ZERO, WV, LDWV )
30600               CALL ZLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ),
30601     $                      LDZ )
30602   80       CONTINUE
30603         END IF
30604      END IF
30605*
30606*     ==== Return the number of deflations ... ====
30607*
30608      ND = JW - NS
30609*
30610*     ==== ... and the number of shifts. (Subtracting
30611*     .    INFQR from the spike length takes care
30612*     .    of the case of a rare QR failure while
30613*     .    calculating eigenvalues of the deflation
30614*     .    window.)  ====
30615*
30616      NS = NS - INFQR
30617*
30618*      ==== Return optimal workspace. ====
30619*
30620      WORK( 1 ) = DCMPLX( LWKOPT, 0 )
30621*
30622*     ==== End of ZLAQR2 ====
30623*
30624      END
30625*> \brief \b ZLAQR3 performs the unitary similarity transformation of a Hessenberg matrix to detect and deflate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation).
30626*
30627*  =========== DOCUMENTATION ===========
30628*
30629* Online html documentation available at
30630*            http://www.netlib.org/lapack/explore-html/
30631*
30632*> \htmlonly
30633*> Download ZLAQR3 + dependencies
30634*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlaqr3.f">
30635*> [TGZ]</a>
30636*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlaqr3.f">
30637*> [ZIP]</a>
30638*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlaqr3.f">
30639*> [TXT]</a>
30640*> \endhtmlonly
30641*
30642*  Definition:
30643*  ===========
30644*
30645*       SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
30646*                          IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT,
30647*                          NV, WV, LDWV, WORK, LWORK )
30648*
30649*       .. Scalar Arguments ..
30650*       INTEGER            IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV,
30651*      $                   LDZ, LWORK, N, ND, NH, NS, NV, NW
30652*       LOGICAL            WANTT, WANTZ
30653*       ..
30654*       .. Array Arguments ..
30655*       COMPLEX*16         H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ),
30656*      $                   WORK( * ), WV( LDWV, * ), Z( LDZ, * )
30657*       ..
30658*
30659*
30660*> \par Purpose:
30661*  =============
30662*>
30663*> \verbatim
30664*>
30665*>    Aggressive early deflation:
30666*>
30667*>    ZLAQR3 accepts as input an upper Hessenberg matrix
30668*>    H and performs an unitary similarity transformation
30669*>    designed to detect and deflate fully converged eigenvalues from
30670*>    a trailing principal submatrix.  On output H has been over-
30671*>    written by a new Hessenberg matrix that is a perturbation of
30672*>    an unitary similarity transformation of H.  It is to be
30673*>    hoped that the final version of H has many zero subdiagonal
30674*>    entries.
30675*>
30676*> \endverbatim
30677*
30678*  Arguments:
30679*  ==========
30680*
30681*> \param[in] WANTT
30682*> \verbatim
30683*>          WANTT is LOGICAL
30684*>          If .TRUE., then the Hessenberg matrix H is fully updated
30685*>          so that the triangular Schur factor may be
30686*>          computed (in cooperation with the calling subroutine).
30687*>          If .FALSE., then only enough of H is updated to preserve
30688*>          the eigenvalues.
30689*> \endverbatim
30690*>
30691*> \param[in] WANTZ
30692*> \verbatim
30693*>          WANTZ is LOGICAL
30694*>          If .TRUE., then the unitary matrix Z is updated so
30695*>          so that the unitary Schur factor may be computed
30696*>          (in cooperation with the calling subroutine).
30697*>          If .FALSE., then Z is not referenced.
30698*> \endverbatim
30699*>
30700*> \param[in] N
30701*> \verbatim
30702*>          N is INTEGER
30703*>          The order of the matrix H and (if WANTZ is .TRUE.) the
30704*>          order of the unitary matrix Z.
30705*> \endverbatim
30706*>
30707*> \param[in] KTOP
30708*> \verbatim
30709*>          KTOP is INTEGER
30710*>          It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.
30711*>          KBOT and KTOP together determine an isolated block
30712*>          along the diagonal of the Hessenberg matrix.
30713*> \endverbatim
30714*>
30715*> \param[in] KBOT
30716*> \verbatim
30717*>          KBOT is INTEGER
30718*>          It is assumed without a check that either
30719*>          KBOT = N or H(KBOT+1,KBOT)=0.  KBOT and KTOP together
30720*>          determine an isolated block along the diagonal of the
30721*>          Hessenberg matrix.
30722*> \endverbatim
30723*>
30724*> \param[in] NW
30725*> \verbatim
30726*>          NW is INTEGER
30727*>          Deflation window size.  1 <= NW <= (KBOT-KTOP+1).
30728*> \endverbatim
30729*>
30730*> \param[in,out] H
30731*> \verbatim
30732*>          H is COMPLEX*16 array, dimension (LDH,N)
30733*>          On input the initial N-by-N section of H stores the
30734*>          Hessenberg matrix undergoing aggressive early deflation.
30735*>          On output H has been transformed by a unitary
30736*>          similarity transformation, perturbed, and the returned
30737*>          to Hessenberg form that (it is to be hoped) has some
30738*>          zero subdiagonal entries.
30739*> \endverbatim
30740*>
30741*> \param[in] LDH
30742*> \verbatim
30743*>          LDH is INTEGER
30744*>          Leading dimension of H just as declared in the calling
30745*>          subroutine.  N <= LDH
30746*> \endverbatim
30747*>
30748*> \param[in] ILOZ
30749*> \verbatim
30750*>          ILOZ is INTEGER
30751*> \endverbatim
30752*>
30753*> \param[in] IHIZ
30754*> \verbatim
30755*>          IHIZ is INTEGER
30756*>          Specify the rows of Z to which transformations must be
30757*>          applied if WANTZ is .TRUE.. 1 <= ILOZ <= IHIZ <= N.
30758*> \endverbatim
30759*>
30760*> \param[in,out] Z
30761*> \verbatim
30762*>          Z is COMPLEX*16 array, dimension (LDZ,N)
30763*>          IF WANTZ is .TRUE., then on output, the unitary
30764*>          similarity transformation mentioned above has been
30765*>          accumulated into Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right.
30766*>          If WANTZ is .FALSE., then Z is unreferenced.
30767*> \endverbatim
30768*>
30769*> \param[in] LDZ
30770*> \verbatim
30771*>          LDZ is INTEGER
30772*>          The leading dimension of Z just as declared in the
30773*>          calling subroutine.  1 <= LDZ.
30774*> \endverbatim
30775*>
30776*> \param[out] NS
30777*> \verbatim
30778*>          NS is INTEGER
30779*>          The number of unconverged (ie approximate) eigenvalues
30780*>          returned in SR and SI that may be used as shifts by the
30781*>          calling subroutine.
30782*> \endverbatim
30783*>
30784*> \param[out] ND
30785*> \verbatim
30786*>          ND is INTEGER
30787*>          The number of converged eigenvalues uncovered by this
30788*>          subroutine.
30789*> \endverbatim
30790*>
30791*> \param[out] SH
30792*> \verbatim
30793*>          SH is COMPLEX*16 array, dimension (KBOT)
30794*>          On output, approximate eigenvalues that may
30795*>          be used for shifts are stored in SH(KBOT-ND-NS+1)
30796*>          through SR(KBOT-ND).  Converged eigenvalues are
30797*>          stored in SH(KBOT-ND+1) through SH(KBOT).
30798*> \endverbatim
30799*>
30800*> \param[out] V
30801*> \verbatim
30802*>          V is COMPLEX*16 array, dimension (LDV,NW)
30803*>          An NW-by-NW work array.
30804*> \endverbatim
30805*>
30806*> \param[in] LDV
30807*> \verbatim
30808*>          LDV is INTEGER
30809*>          The leading dimension of V just as declared in the
30810*>          calling subroutine.  NW <= LDV
30811*> \endverbatim
30812*>
30813*> \param[in] NH
30814*> \verbatim
30815*>          NH is INTEGER
30816*>          The number of columns of T.  NH >= NW.
30817*> \endverbatim
30818*>
30819*> \param[out] T
30820*> \verbatim
30821*>          T is COMPLEX*16 array, dimension (LDT,NW)
30822*> \endverbatim
30823*>
30824*> \param[in] LDT
30825*> \verbatim
30826*>          LDT is INTEGER
30827*>          The leading dimension of T just as declared in the
30828*>          calling subroutine.  NW <= LDT
30829*> \endverbatim
30830*>
30831*> \param[in] NV
30832*> \verbatim
30833*>          NV is INTEGER
30834*>          The number of rows of work array WV available for
30835*>          workspace.  NV >= NW.
30836*> \endverbatim
30837*>
30838*> \param[out] WV
30839*> \verbatim
30840*>          WV is COMPLEX*16 array, dimension (LDWV,NW)
30841*> \endverbatim
30842*>
30843*> \param[in] LDWV
30844*> \verbatim
30845*>          LDWV is INTEGER
30846*>          The leading dimension of W just as declared in the
30847*>          calling subroutine.  NW <= LDV
30848*> \endverbatim
30849*>
30850*> \param[out] WORK
30851*> \verbatim
30852*>          WORK is COMPLEX*16 array, dimension (LWORK)
30853*>          On exit, WORK(1) is set to an estimate of the optimal value
30854*>          of LWORK for the given values of N, NW, KTOP and KBOT.
30855*> \endverbatim
30856*>
30857*> \param[in] LWORK
30858*> \verbatim
30859*>          LWORK is INTEGER
30860*>          The dimension of the work array WORK.  LWORK = 2*NW
30861*>          suffices, but greater efficiency may result from larger
30862*>          values of LWORK.
30863*>
30864*>          If LWORK = -1, then a workspace query is assumed; ZLAQR3
30865*>          only estimates the optimal workspace size for the given
30866*>          values of N, NW, KTOP and KBOT.  The estimate is returned
30867*>          in WORK(1).  No error message related to LWORK is issued
30868*>          by XERBLA.  Neither H nor Z are accessed.
30869*> \endverbatim
30870*
30871*  Authors:
30872*  ========
30873*
30874*> \author Univ. of Tennessee
30875*> \author Univ. of California Berkeley
30876*> \author Univ. of Colorado Denver
30877*> \author NAG Ltd.
30878*
30879*> \date June 2016
30880*
30881*> \ingroup complex16OTHERauxiliary
30882*
30883*> \par Contributors:
30884*  ==================
30885*>
30886*>       Karen Braman and Ralph Byers, Department of Mathematics,
30887*>       University of Kansas, USA
30888*>
30889*  =====================================================================
30890      SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
30891     $                   IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT,
30892     $                   NV, WV, LDWV, WORK, LWORK )
30893*
30894*  -- LAPACK auxiliary routine (version 3.7.1) --
30895*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
30896*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
30897*     June 2016
30898*
30899*     .. Scalar Arguments ..
30900      INTEGER            IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV,
30901     $                   LDZ, LWORK, N, ND, NH, NS, NV, NW
30902      LOGICAL            WANTT, WANTZ
30903*     ..
30904*     .. Array Arguments ..
30905      COMPLEX*16         H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ),
30906     $                   WORK( * ), WV( LDWV, * ), Z( LDZ, * )
30907*     ..
30908*
30909*  ================================================================
30910*
30911*     .. Parameters ..
30912      COMPLEX*16         ZERO, ONE
30913      PARAMETER          ( ZERO = ( 0.0d0, 0.0d0 ),
30914     $                   ONE = ( 1.0d0, 0.0d0 ) )
30915      DOUBLE PRECISION   RZERO, RONE
30916      PARAMETER          ( RZERO = 0.0d0, RONE = 1.0d0 )
30917*     ..
30918*     .. Local Scalars ..
30919      COMPLEX*16         BETA, CDUM, S, TAU
30920      DOUBLE PRECISION   FOO, SAFMAX, SAFMIN, SMLNUM, ULP
30921      INTEGER            I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN,
30922     $                   KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3,
30923     $                   LWKOPT, NMIN
30924*     ..
30925*     .. External Functions ..
30926      DOUBLE PRECISION   DLAMCH
30927      INTEGER            ILAENV
30928      EXTERNAL           DLAMCH, ILAENV
30929*     ..
30930*     .. External Subroutines ..
30931      EXTERNAL           DLABAD, ZCOPY, ZGEHRD, ZGEMM, ZLACPY, ZLAHQR,
30932     $                   ZLAQR4, ZLARF, ZLARFG, ZLASET, ZTREXC, ZUNMHR
30933*     ..
30934*     .. Intrinsic Functions ..
30935      INTRINSIC          ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, MAX, MIN
30936*     ..
30937*     .. Statement Functions ..
30938      DOUBLE PRECISION   CABS1
30939*     ..
30940*     .. Statement Function definitions ..
30941      CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
30942*     ..
30943*     .. Executable Statements ..
30944*
30945*     ==== Estimate optimal workspace. ====
30946*
30947      JW = MIN( NW, KBOT-KTOP+1 )
30948      IF( JW.LE.2 ) THEN
30949         LWKOPT = 1
30950      ELSE
30951*
30952*        ==== Workspace query call to ZGEHRD ====
30953*
30954         CALL ZGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
30955         LWK1 = INT( WORK( 1 ) )
30956*
30957*        ==== Workspace query call to ZUNMHR ====
30958*
30959         CALL ZUNMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV,
30960     $                WORK, -1, INFO )
30961         LWK2 = INT( WORK( 1 ) )
30962*
30963*        ==== Workspace query call to ZLAQR4 ====
30964*
30965         CALL ZLAQR4( .true., .true., JW, 1, JW, T, LDT, SH, 1, JW, V,
30966     $                LDV, WORK, -1, INFQR )
30967         LWK3 = INT( WORK( 1 ) )
30968*
30969*        ==== Optimal workspace ====
30970*
30971         LWKOPT = MAX( JW+MAX( LWK1, LWK2 ), LWK3 )
30972      END IF
30973*
30974*     ==== Quick return in case of workspace query. ====
30975*
30976      IF( LWORK.EQ.-1 ) THEN
30977         WORK( 1 ) = DCMPLX( LWKOPT, 0 )
30978         RETURN
30979      END IF
30980*
30981*     ==== Nothing to do ...
30982*     ... for an empty active block ... ====
30983      NS = 0
30984      ND = 0
30985      WORK( 1 ) = ONE
30986      IF( KTOP.GT.KBOT )
30987     $   RETURN
30988*     ... nor for an empty deflation window. ====
30989      IF( NW.LT.1 )
30990     $   RETURN
30991*
30992*     ==== Machine constants ====
30993*
30994      SAFMIN = DLAMCH( 'SAFE MINIMUM' )
30995      SAFMAX = RONE / SAFMIN
30996      CALL DLABAD( SAFMIN, SAFMAX )
30997      ULP = DLAMCH( 'PRECISION' )
30998      SMLNUM = SAFMIN*( DBLE( N ) / ULP )
30999*
31000*     ==== Setup deflation window ====
31001*
31002      JW = MIN( NW, KBOT-KTOP+1 )
31003      KWTOP = KBOT - JW + 1
31004      IF( KWTOP.EQ.KTOP ) THEN
31005         S = ZERO
31006      ELSE
31007         S = H( KWTOP, KWTOP-1 )
31008      END IF
31009*
31010      IF( KBOT.EQ.KWTOP ) THEN
31011*
31012*        ==== 1-by-1 deflation window: not much to do ====
31013*
31014         SH( KWTOP ) = H( KWTOP, KWTOP )
31015         NS = 1
31016         ND = 0
31017         IF( CABS1( S ).LE.MAX( SMLNUM, ULP*CABS1( H( KWTOP,
31018     $       KWTOP ) ) ) ) THEN
31019            NS = 0
31020            ND = 1
31021            IF( KWTOP.GT.KTOP )
31022     $         H( KWTOP, KWTOP-1 ) = ZERO
31023         END IF
31024         WORK( 1 ) = ONE
31025         RETURN
31026      END IF
31027*
31028*     ==== Convert to spike-triangular form.  (In case of a
31029*     .    rare QR failure, this routine continues to do
31030*     .    aggressive early deflation using that part of
31031*     .    the deflation window that converged using INFQR
31032*     .    here and there to keep track.) ====
31033*
31034      CALL ZLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT )
31035      CALL ZCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 )
31036*
31037      CALL ZLASET( 'A', JW, JW, ZERO, ONE, V, LDV )
31038      NMIN = ILAENV( 12, 'ZLAQR3', 'SV', JW, 1, JW, LWORK )
31039      IF( JW.GT.NMIN ) THEN
31040         CALL ZLAQR4( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1,
31041     $                JW, V, LDV, WORK, LWORK, INFQR )
31042      ELSE
31043         CALL ZLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1,
31044     $                JW, V, LDV, INFQR )
31045      END IF
31046*
31047*     ==== Deflation detection loop ====
31048*
31049      NS = JW
31050      ILST = INFQR + 1
31051      DO 10 KNT = INFQR + 1, JW
31052*
31053*        ==== Small spike tip deflation test ====
31054*
31055         FOO = CABS1( T( NS, NS ) )
31056         IF( FOO.EQ.RZERO )
31057     $      FOO = CABS1( S )
31058         IF( CABS1( S )*CABS1( V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) )
31059     $        THEN
31060*
31061*           ==== One more converged eigenvalue ====
31062*
31063            NS = NS - 1
31064         ELSE
31065*
31066*           ==== One undeflatable eigenvalue.  Move it up out of the
31067*           .    way.   (ZTREXC can not fail in this case.) ====
31068*
31069            IFST = NS
31070            CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO )
31071            ILST = ILST + 1
31072         END IF
31073   10 CONTINUE
31074*
31075*        ==== Return to Hessenberg form ====
31076*
31077      IF( NS.EQ.0 )
31078     $   S = ZERO
31079*
31080      IF( NS.LT.JW ) THEN
31081*
31082*        ==== sorting the diagonal of T improves accuracy for
31083*        .    graded matrices.  ====
31084*
31085         DO 30 I = INFQR + 1, NS
31086            IFST = I
31087            DO 20 J = I + 1, NS
31088               IF( CABS1( T( J, J ) ).GT.CABS1( T( IFST, IFST ) ) )
31089     $            IFST = J
31090   20       CONTINUE
31091            ILST = I
31092            IF( IFST.NE.ILST )
31093     $         CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO )
31094   30    CONTINUE
31095      END IF
31096*
31097*     ==== Restore shift/eigenvalue array from T ====
31098*
31099      DO 40 I = INFQR + 1, JW
31100         SH( KWTOP+I-1 ) = T( I, I )
31101   40 CONTINUE
31102*
31103*
31104      IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN
31105         IF( NS.GT.1 .AND. S.NE.ZERO ) THEN
31106*
31107*           ==== Reflect spike back into lower triangle ====
31108*
31109            CALL ZCOPY( NS, V, LDV, WORK, 1 )
31110            DO 50 I = 1, NS
31111               WORK( I ) = DCONJG( WORK( I ) )
31112   50       CONTINUE
31113            BETA = WORK( 1 )
31114            CALL ZLARFG( NS, BETA, WORK( 2 ), 1, TAU )
31115            WORK( 1 ) = ONE
31116*
31117            CALL ZLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT )
31118*
31119            CALL ZLARF( 'L', NS, JW, WORK, 1, DCONJG( TAU ), T, LDT,
31120     $                  WORK( JW+1 ) )
31121            CALL ZLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT,
31122     $                  WORK( JW+1 ) )
31123            CALL ZLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV,
31124     $                  WORK( JW+1 ) )
31125*
31126            CALL ZGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
31127     $                   LWORK-JW, INFO )
31128         END IF
31129*
31130*        ==== Copy updated reduced window into place ====
31131*
31132         IF( KWTOP.GT.1 )
31133     $      H( KWTOP, KWTOP-1 ) = S*DCONJG( V( 1, 1 ) )
31134         CALL ZLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH )
31135         CALL ZCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ),
31136     $               LDH+1 )
31137*
31138*        ==== Accumulate orthogonal matrix in order update
31139*        .    H and Z, if requested.  ====
31140*
31141         IF( NS.GT.1 .AND. S.NE.ZERO )
31142     $      CALL ZUNMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV,
31143     $                   WORK( JW+1 ), LWORK-JW, INFO )
31144*
31145*        ==== Update vertical slab in H ====
31146*
31147         IF( WANTT ) THEN
31148            LTOP = 1
31149         ELSE
31150            LTOP = KTOP
31151         END IF
31152         DO 60 KROW = LTOP, KWTOP - 1, NV
31153            KLN = MIN( NV, KWTOP-KROW )
31154            CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ),
31155     $                  LDH, V, LDV, ZERO, WV, LDWV )
31156            CALL ZLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH )
31157   60    CONTINUE
31158*
31159*        ==== Update horizontal slab in H ====
31160*
31161         IF( WANTT ) THEN
31162            DO 70 KCOL = KBOT + 1, N, NH
31163               KLN = MIN( NH, N-KCOL+1 )
31164               CALL ZGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV,
31165     $                     H( KWTOP, KCOL ), LDH, ZERO, T, LDT )
31166               CALL ZLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ),
31167     $                      LDH )
31168   70       CONTINUE
31169         END IF
31170*
31171*        ==== Update vertical slab in Z ====
31172*
31173         IF( WANTZ ) THEN
31174            DO 80 KROW = ILOZ, IHIZ, NV
31175               KLN = MIN( NV, IHIZ-KROW+1 )
31176               CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ),
31177     $                     LDZ, V, LDV, ZERO, WV, LDWV )
31178               CALL ZLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ),
31179     $                      LDZ )
31180   80       CONTINUE
31181         END IF
31182      END IF
31183*
31184*     ==== Return the number of deflations ... ====
31185*
31186      ND = JW - NS
31187*
31188*     ==== ... and the number of shifts. (Subtracting
31189*     .    INFQR from the spike length takes care
31190*     .    of the case of a rare QR failure while
31191*     .    calculating eigenvalues of the deflation
31192*     .    window.)  ====
31193*
31194      NS = NS - INFQR
31195*
31196*      ==== Return optimal workspace. ====
31197*
31198      WORK( 1 ) = DCMPLX( LWKOPT, 0 )
31199*
31200*     ==== End of ZLAQR3 ====
31201*
31202      END
31203*> \brief \b ZLAQR4 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Schur decomposition.
31204*
31205*  =========== DOCUMENTATION ===========
31206*
31207* Online html documentation available at
31208*            http://www.netlib.org/lapack/explore-html/
31209*
31210*> \htmlonly
31211*> Download ZLAQR4 + dependencies
31212*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlaqr4.f">
31213*> [TGZ]</a>
31214*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlaqr4.f">
31215*> [ZIP]</a>
31216*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlaqr4.f">
31217*> [TXT]</a>
31218*> \endhtmlonly
31219*
31220*  Definition:
31221*  ===========
31222*
31223*       SUBROUTINE ZLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
31224*                          IHIZ, Z, LDZ, WORK, LWORK, INFO )
31225*
31226*       .. Scalar Arguments ..
31227*       INTEGER            IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N
31228*       LOGICAL            WANTT, WANTZ
31229*       ..
31230*       .. Array Arguments ..
31231*       COMPLEX*16         H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * )
31232*       ..
31233*
31234*
31235*> \par Purpose:
31236*  =============
31237*>
31238*> \verbatim
31239*>
31240*>    ZLAQR4 implements one level of recursion for ZLAQR0.
31241*>    It is a complete implementation of the small bulge multi-shift
31242*>    QR algorithm.  It may be called by ZLAQR0 and, for large enough
31243*>    deflation window size, it may be called by ZLAQR3.  This
31244*>    subroutine is identical to ZLAQR0 except that it calls ZLAQR2
31245*>    instead of ZLAQR3.
31246*>
31247*>    ZLAQR4 computes the eigenvalues of a Hessenberg matrix H
31248*>    and, optionally, the matrices T and Z from the Schur decomposition
31249*>    H = Z T Z**H, where T is an upper triangular matrix (the
31250*>    Schur form), and Z is the unitary matrix of Schur vectors.
31251*>
31252*>    Optionally Z may be postmultiplied into an input unitary
31253*>    matrix Q so that this routine can give the Schur factorization
31254*>    of a matrix A which has been reduced to the Hessenberg form H
31255*>    by the unitary matrix Q:  A = Q*H*Q**H = (QZ)*H*(QZ)**H.
31256*> \endverbatim
31257*
31258*  Arguments:
31259*  ==========
31260*
31261*> \param[in] WANTT
31262*> \verbatim
31263*>          WANTT is LOGICAL
31264*>          = .TRUE. : the full Schur form T is required;
31265*>          = .FALSE.: only eigenvalues are required.
31266*> \endverbatim
31267*>
31268*> \param[in] WANTZ
31269*> \verbatim
31270*>          WANTZ is LOGICAL
31271*>          = .TRUE. : the matrix of Schur vectors Z is required;
31272*>          = .FALSE.: Schur vectors are not required.
31273*> \endverbatim
31274*>
31275*> \param[in] N
31276*> \verbatim
31277*>          N is INTEGER
31278*>           The order of the matrix H.  N >= 0.
31279*> \endverbatim
31280*>
31281*> \param[in] ILO
31282*> \verbatim
31283*>          ILO is INTEGER
31284*> \endverbatim
31285*>
31286*> \param[in] IHI
31287*> \verbatim
31288*>          IHI is INTEGER
31289*>           It is assumed that H is already upper triangular in rows
31290*>           and columns 1:ILO-1 and IHI+1:N and, if ILO > 1,
31291*>           H(ILO,ILO-1) is zero. ILO and IHI are normally set by a
31292*>           previous call to ZGEBAL, and then passed to ZGEHRD when the
31293*>           matrix output by ZGEBAL is reduced to Hessenberg form.
31294*>           Otherwise, ILO and IHI should be set to 1 and N,
31295*>           respectively.  If N > 0, then 1 <= ILO <= IHI <= N.
31296*>           If N = 0, then ILO = 1 and IHI = 0.
31297*> \endverbatim
31298*>
31299*> \param[in,out] H
31300*> \verbatim
31301*>          H is COMPLEX*16 array, dimension (LDH,N)
31302*>           On entry, the upper Hessenberg matrix H.
31303*>           On exit, if INFO = 0 and WANTT is .TRUE., then H
31304*>           contains the upper triangular matrix T from the Schur
31305*>           decomposition (the Schur form). If INFO = 0 and WANT is
31306*>           .FALSE., then the contents of H are unspecified on exit.
31307*>           (The output value of H when INFO > 0 is given under the
31308*>           description of INFO below.)
31309*>
31310*>           This subroutine may explicitly set H(i,j) = 0 for i > j and
31311*>           j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.
31312*> \endverbatim
31313*>
31314*> \param[in] LDH
31315*> \verbatim
31316*>          LDH is INTEGER
31317*>           The leading dimension of the array H. LDH >= max(1,N).
31318*> \endverbatim
31319*>
31320*> \param[out] W
31321*> \verbatim
31322*>          W is COMPLEX*16 array, dimension (N)
31323*>           The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored
31324*>           in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are
31325*>           stored in the same order as on the diagonal of the Schur
31326*>           form returned in H, with W(i) = H(i,i).
31327*> \endverbatim
31328*>
31329*> \param[in] ILOZ
31330*> \verbatim
31331*>          ILOZ is INTEGER
31332*> \endverbatim
31333*>
31334*> \param[in] IHIZ
31335*> \verbatim
31336*>          IHIZ is INTEGER
31337*>           Specify the rows of Z to which transformations must be
31338*>           applied if WANTZ is .TRUE..
31339*>           1 <= ILOZ <= ILO; IHI <= IHIZ <= N.
31340*> \endverbatim
31341*>
31342*> \param[in,out] Z
31343*> \verbatim
31344*>          Z is COMPLEX*16 array, dimension (LDZ,IHI)
31345*>           If WANTZ is .FALSE., then Z is not referenced.
31346*>           If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is
31347*>           replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the
31348*>           orthogonal Schur factor of H(ILO:IHI,ILO:IHI).
31349*>           (The output value of Z when INFO > 0 is given under
31350*>           the description of INFO below.)
31351*> \endverbatim
31352*>
31353*> \param[in] LDZ
31354*> \verbatim
31355*>          LDZ is INTEGER
31356*>           The leading dimension of the array Z.  if WANTZ is .TRUE.
31357*>           then LDZ >= MAX(1,IHIZ).  Otherwise, LDZ >= 1.
31358*> \endverbatim
31359*>
31360*> \param[out] WORK
31361*> \verbatim
31362*>          WORK is COMPLEX*16 array, dimension LWORK
31363*>           On exit, if LWORK = -1, WORK(1) returns an estimate of
31364*>           the optimal value for LWORK.
31365*> \endverbatim
31366*>
31367*> \param[in] LWORK
31368*> \verbatim
31369*>          LWORK is INTEGER
31370*>           The dimension of the array WORK.  LWORK >= max(1,N)
31371*>           is sufficient, but LWORK typically as large as 6*N may
31372*>           be required for optimal performance.  A workspace query
31373*>           to determine the optimal workspace size is recommended.
31374*>
31375*>           If LWORK = -1, then ZLAQR4 does a workspace query.
31376*>           In this case, ZLAQR4 checks the input parameters and
31377*>           estimates the optimal workspace size for the given
31378*>           values of N, ILO and IHI.  The estimate is returned
31379*>           in WORK(1).  No error message related to LWORK is
31380*>           issued by XERBLA.  Neither H nor Z are accessed.
31381*> \endverbatim
31382*>
31383*> \param[out] INFO
31384*> \verbatim
31385*>          INFO is INTEGER
31386*>             =  0:  successful exit
31387*>             > 0:  if INFO = i, ZLAQR4 failed to compute all of
31388*>                the eigenvalues.  Elements 1:ilo-1 and i+1:n of WR
31389*>                and WI contain those eigenvalues which have been
31390*>                successfully computed.  (Failures are rare.)
31391*>
31392*>                If INFO > 0 and WANT is .FALSE., then on exit,
31393*>                the remaining unconverged eigenvalues are the eigen-
31394*>                values of the upper Hessenberg matrix rows and
31395*>                columns ILO through INFO of the final, output
31396*>                value of H.
31397*>
31398*>                If INFO > 0 and WANTT is .TRUE., then on exit
31399*>
31400*>           (*)  (initial value of H)*U  = U*(final value of H)
31401*>
31402*>                where U is a unitary matrix.  The final
31403*>                value of  H is upper Hessenberg and triangular in
31404*>                rows and columns INFO+1 through IHI.
31405*>
31406*>                If INFO > 0 and WANTZ is .TRUE., then on exit
31407*>
31408*>                  (final value of Z(ILO:IHI,ILOZ:IHIZ)
31409*>                   =  (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U
31410*>
31411*>                where U is the unitary matrix in (*) (regard-
31412*>                less of the value of WANTT.)
31413*>
31414*>                If INFO > 0 and WANTZ is .FALSE., then Z is not
31415*>                accessed.
31416*> \endverbatim
31417*
31418*  Authors:
31419*  ========
31420*
31421*> \author Univ. of Tennessee
31422*> \author Univ. of California Berkeley
31423*> \author Univ. of Colorado Denver
31424*> \author NAG Ltd.
31425*
31426*> \date December 2016
31427*
31428*> \ingroup complex16OTHERauxiliary
31429*
31430*> \par Contributors:
31431*  ==================
31432*>
31433*>       Karen Braman and Ralph Byers, Department of Mathematics,
31434*>       University of Kansas, USA
31435*
31436*> \par References:
31437*  ================
31438*>
31439*>       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
31440*>       Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
31441*>       Performance, SIAM Journal of Matrix Analysis, volume 23, pages
31442*>       929--947, 2002.
31443*> \n
31444*>       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
31445*>       Algorithm Part II: Aggressive Early Deflation, SIAM Journal
31446*>       of Matrix Analysis, volume 23, pages 948--973, 2002.
31447*>
31448*  =====================================================================
31449      SUBROUTINE ZLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
31450     $                   IHIZ, Z, LDZ, WORK, LWORK, INFO )
31451*
31452*  -- LAPACK auxiliary routine (version 3.7.0) --
31453*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
31454*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
31455*     December 2016
31456*
31457*     .. Scalar Arguments ..
31458      INTEGER            IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N
31459      LOGICAL            WANTT, WANTZ
31460*     ..
31461*     .. Array Arguments ..
31462      COMPLEX*16         H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * )
31463*     ..
31464*
31465*  ================================================================
31466*
31467*     .. Parameters ..
31468*
31469*     ==== Matrices of order NTINY or smaller must be processed by
31470*     .    ZLAHQR because of insufficient subdiagonal scratch space.
31471*     .    (This is a hard limit.) ====
31472      INTEGER            NTINY
31473      PARAMETER          ( NTINY = 11 )
31474*
31475*     ==== Exceptional deflation windows:  try to cure rare
31476*     .    slow convergence by varying the size of the
31477*     .    deflation window after KEXNW iterations. ====
31478      INTEGER            KEXNW
31479      PARAMETER          ( KEXNW = 5 )
31480*
31481*     ==== Exceptional shifts: try to cure rare slow convergence
31482*     .    with ad-hoc exceptional shifts every KEXSH iterations.
31483*     .    ====
31484      INTEGER            KEXSH
31485      PARAMETER          ( KEXSH = 6 )
31486*
31487*     ==== The constant WILK1 is used to form the exceptional
31488*     .    shifts. ====
31489      DOUBLE PRECISION   WILK1
31490      PARAMETER          ( WILK1 = 0.75d0 )
31491      COMPLEX*16         ZERO, ONE
31492      PARAMETER          ( ZERO = ( 0.0d0, 0.0d0 ),
31493     $                   ONE = ( 1.0d0, 0.0d0 ) )
31494      DOUBLE PRECISION   TWO
31495      PARAMETER          ( TWO = 2.0d0 )
31496*     ..
31497*     .. Local Scalars ..
31498      COMPLEX*16         AA, BB, CC, CDUM, DD, DET, RTDISC, SWAP, TR2
31499      DOUBLE PRECISION   S
31500      INTEGER            I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS,
31501     $                   KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS,
31502     $                   LWKOPT, NDEC, NDFL, NH, NHO, NIBBLE, NMIN, NS,
31503     $                   NSMAX, NSR, NVE, NW, NWMAX, NWR, NWUPBD
31504      LOGICAL            SORTED
31505      CHARACTER          JBCMPZ*2
31506*     ..
31507*     .. External Functions ..
31508      INTEGER            ILAENV
31509      EXTERNAL           ILAENV
31510*     ..
31511*     .. Local Arrays ..
31512      COMPLEX*16         ZDUM( 1, 1 )
31513*     ..
31514*     .. External Subroutines ..
31515      EXTERNAL           ZLACPY, ZLAHQR, ZLAQR2, ZLAQR5
31516*     ..
31517*     .. Intrinsic Functions ..
31518      INTRINSIC          ABS, DBLE, DCMPLX, DIMAG, INT, MAX, MIN, MOD,
31519     $                   SQRT
31520*     ..
31521*     .. Statement Functions ..
31522      DOUBLE PRECISION   CABS1
31523*     ..
31524*     .. Statement Function definitions ..
31525      CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
31526*     ..
31527*     .. Executable Statements ..
31528      INFO = 0
31529*
31530*     ==== Quick return for N = 0: nothing to do. ====
31531*
31532      IF( N.EQ.0 ) THEN
31533         WORK( 1 ) = ONE
31534         RETURN
31535      END IF
31536*
31537      IF( N.LE.NTINY ) THEN
31538*
31539*        ==== Tiny matrices must use ZLAHQR. ====
31540*
31541         LWKOPT = 1
31542         IF( LWORK.NE.-1 )
31543     $      CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
31544     $                   IHIZ, Z, LDZ, INFO )
31545      ELSE
31546*
31547*        ==== Use small bulge multi-shift QR with aggressive early
31548*        .    deflation on larger-than-tiny matrices. ====
31549*
31550*        ==== Hope for the best. ====
31551*
31552         INFO = 0
31553*
31554*        ==== Set up job flags for ILAENV. ====
31555*
31556         IF( WANTT ) THEN
31557            JBCMPZ( 1: 1 ) = 'S'
31558         ELSE
31559            JBCMPZ( 1: 1 ) = 'E'
31560         END IF
31561         IF( WANTZ ) THEN
31562            JBCMPZ( 2: 2 ) = 'V'
31563         ELSE
31564            JBCMPZ( 2: 2 ) = 'N'
31565         END IF
31566*
31567*        ==== NWR = recommended deflation window size.  At this
31568*        .    point,  N .GT. NTINY = 11, so there is enough
31569*        .    subdiagonal workspace for NWR.GE.2 as required.
31570*        .    (In fact, there is enough subdiagonal space for
31571*        .    NWR.GE.3.) ====
31572*
31573         NWR = ILAENV( 13, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
31574         NWR = MAX( 2, NWR )
31575         NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR )
31576*
31577*        ==== NSR = recommended number of simultaneous shifts.
31578*        .    At this point N .GT. NTINY = 11, so there is at
31579*        .    enough subdiagonal workspace for NSR to be even
31580*        .    and greater than or equal to two as required. ====
31581*
31582         NSR = ILAENV( 15, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
31583         NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO )
31584         NSR = MAX( 2, NSR-MOD( NSR, 2 ) )
31585*
31586*        ==== Estimate optimal workspace ====
31587*
31588*        ==== Workspace query call to ZLAQR2 ====
31589*
31590         CALL ZLAQR2( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ,
31591     $                IHIZ, Z, LDZ, LS, LD, W, H, LDH, N, H, LDH, N, H,
31592     $                LDH, WORK, -1 )
31593*
31594*        ==== Optimal workspace = MAX(ZLAQR5, ZLAQR2) ====
31595*
31596         LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) )
31597*
31598*        ==== Quick return in case of workspace query. ====
31599*
31600         IF( LWORK.EQ.-1 ) THEN
31601            WORK( 1 ) = DCMPLX( LWKOPT, 0 )
31602            RETURN
31603         END IF
31604*
31605*        ==== ZLAHQR/ZLAQR0 crossover point ====
31606*
31607         NMIN = ILAENV( 12, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
31608         NMIN = MAX( NTINY, NMIN )
31609*
31610*        ==== Nibble crossover point ====
31611*
31612         NIBBLE = ILAENV( 14, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
31613         NIBBLE = MAX( 0, NIBBLE )
31614*
31615*        ==== Accumulate reflections during ttswp?  Use block
31616*        .    2-by-2 structure during matrix-matrix multiply? ====
31617*
31618         KACC22 = ILAENV( 16, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
31619         KACC22 = MAX( 0, KACC22 )
31620         KACC22 = MIN( 2, KACC22 )
31621*
31622*        ==== NWMAX = the largest possible deflation window for
31623*        .    which there is sufficient workspace. ====
31624*
31625         NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 )
31626         NW = NWMAX
31627*
31628*        ==== NSMAX = the Largest number of simultaneous shifts
31629*        .    for which there is sufficient workspace. ====
31630*
31631         NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 )
31632         NSMAX = NSMAX - MOD( NSMAX, 2 )
31633*
31634*        ==== NDFL: an iteration count restarted at deflation. ====
31635*
31636         NDFL = 1
31637*
31638*        ==== ITMAX = iteration limit ====
31639*
31640         ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) )
31641*
31642*        ==== Last row and column in the active block ====
31643*
31644         KBOT = IHI
31645*
31646*        ==== Main Loop ====
31647*
31648         DO 70 IT = 1, ITMAX
31649*
31650*           ==== Done when KBOT falls below ILO ====
31651*
31652            IF( KBOT.LT.ILO )
31653     $         GO TO 80
31654*
31655*           ==== Locate active block ====
31656*
31657            DO 10 K = KBOT, ILO + 1, -1
31658               IF( H( K, K-1 ).EQ.ZERO )
31659     $            GO TO 20
31660   10       CONTINUE
31661            K = ILO
31662   20       CONTINUE
31663            KTOP = K
31664*
31665*           ==== Select deflation window size:
31666*           .    Typical Case:
31667*           .      If possible and advisable, nibble the entire
31668*           .      active block.  If not, use size MIN(NWR,NWMAX)
31669*           .      or MIN(NWR+1,NWMAX) depending upon which has
31670*           .      the smaller corresponding subdiagonal entry
31671*           .      (a heuristic).
31672*           .
31673*           .    Exceptional Case:
31674*           .      If there have been no deflations in KEXNW or
31675*           .      more iterations, then vary the deflation window
31676*           .      size.   At first, because, larger windows are,
31677*           .      in general, more powerful than smaller ones,
31678*           .      rapidly increase the window to the maximum possible.
31679*           .      Then, gradually reduce the window size. ====
31680*
31681            NH = KBOT - KTOP + 1
31682            NWUPBD = MIN( NH, NWMAX )
31683            IF( NDFL.LT.KEXNW ) THEN
31684               NW = MIN( NWUPBD, NWR )
31685            ELSE
31686               NW = MIN( NWUPBD, 2*NW )
31687            END IF
31688            IF( NW.LT.NWMAX ) THEN
31689               IF( NW.GE.NH-1 ) THEN
31690                  NW = NH
31691               ELSE
31692                  KWTOP = KBOT - NW + 1
31693                  IF( CABS1( H( KWTOP, KWTOP-1 ) ).GT.
31694     $                CABS1( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1
31695               END IF
31696            END IF
31697            IF( NDFL.LT.KEXNW ) THEN
31698               NDEC = -1
31699            ELSE IF( NDEC.GE.0 .OR. NW.GE.NWUPBD ) THEN
31700               NDEC = NDEC + 1
31701               IF( NW-NDEC.LT.2 )
31702     $            NDEC = 0
31703               NW = NW - NDEC
31704            END IF
31705*
31706*           ==== Aggressive early deflation:
31707*           .    split workspace under the subdiagonal into
31708*           .      - an nw-by-nw work array V in the lower
31709*           .        left-hand-corner,
31710*           .      - an NW-by-at-least-NW-but-more-is-better
31711*           .        (NW-by-NHO) horizontal work array along
31712*           .        the bottom edge,
31713*           .      - an at-least-NW-but-more-is-better (NHV-by-NW)
31714*           .        vertical work array along the left-hand-edge.
31715*           .        ====
31716*
31717            KV = N - NW + 1
31718            KT = NW + 1
31719            NHO = ( N-NW-1 ) - KT + 1
31720            KWV = NW + 2
31721            NVE = ( N-NW ) - KWV + 1
31722*
31723*           ==== Aggressive early deflation ====
31724*
31725            CALL ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
31726     $                   IHIZ, Z, LDZ, LS, LD, W, H( KV, 1 ), LDH, NHO,
31727     $                   H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, WORK,
31728     $                   LWORK )
31729*
31730*           ==== Adjust KBOT accounting for new deflations. ====
31731*
31732            KBOT = KBOT - LD
31733*
31734*           ==== KS points to the shifts. ====
31735*
31736            KS = KBOT - LS + 1
31737*
31738*           ==== Skip an expensive QR sweep if there is a (partly
31739*           .    heuristic) reason to expect that many eigenvalues
31740*           .    will deflate without it.  Here, the QR sweep is
31741*           .    skipped if many eigenvalues have just been deflated
31742*           .    or if the remaining active block is small.
31743*
31744            IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT-
31745     $          KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN
31746*
31747*              ==== NS = nominal number of simultaneous shifts.
31748*              .    This may be lowered (slightly) if ZLAQR2
31749*              .    did not provide that many shifts. ====
31750*
31751               NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) )
31752               NS = NS - MOD( NS, 2 )
31753*
31754*              ==== If there have been no deflations
31755*              .    in a multiple of KEXSH iterations,
31756*              .    then try exceptional shifts.
31757*              .    Otherwise use shifts provided by
31758*              .    ZLAQR2 above or from the eigenvalues
31759*              .    of a trailing principal submatrix. ====
31760*
31761               IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN
31762                  KS = KBOT - NS + 1
31763                  DO 30 I = KBOT, KS + 1, -2
31764                     W( I ) = H( I, I ) + WILK1*CABS1( H( I, I-1 ) )
31765                     W( I-1 ) = W( I )
31766   30             CONTINUE
31767               ELSE
31768*
31769*                 ==== Got NS/2 or fewer shifts? Use ZLAHQR
31770*                 .    on a trailing principal submatrix to
31771*                 .    get more. (Since NS.LE.NSMAX.LE.(N+6)/9,
31772*                 .    there is enough space below the subdiagonal
31773*                 .    to fit an NS-by-NS scratch array.) ====
31774*
31775                  IF( KBOT-KS+1.LE.NS / 2 ) THEN
31776                     KS = KBOT - NS + 1
31777                     KT = N - NS + 1
31778                     CALL ZLACPY( 'A', NS, NS, H( KS, KS ), LDH,
31779     $                            H( KT, 1 ), LDH )
31780                     CALL ZLAHQR( .false., .false., NS, 1, NS,
31781     $                            H( KT, 1 ), LDH, W( KS ), 1, 1, ZDUM,
31782     $                            1, INF )
31783                     KS = KS + INF
31784*
31785*                    ==== In case of a rare QR failure use
31786*                    .    eigenvalues of the trailing 2-by-2
31787*                    .    principal submatrix.  Scale to avoid
31788*                    .    overflows, underflows and subnormals.
31789*                    .    (The scale factor S can not be zero,
31790*                    .    because H(KBOT,KBOT-1) is nonzero.) ====
31791*
31792                     IF( KS.GE.KBOT ) THEN
31793                        S = CABS1( H( KBOT-1, KBOT-1 ) ) +
31794     $                      CABS1( H( KBOT, KBOT-1 ) ) +
31795     $                      CABS1( H( KBOT-1, KBOT ) ) +
31796     $                      CABS1( H( KBOT, KBOT ) )
31797                        AA = H( KBOT-1, KBOT-1 ) / S
31798                        CC = H( KBOT, KBOT-1 ) / S
31799                        BB = H( KBOT-1, KBOT ) / S
31800                        DD = H( KBOT, KBOT ) / S
31801                        TR2 = ( AA+DD ) / TWO
31802                        DET = ( AA-TR2 )*( DD-TR2 ) - BB*CC
31803                        RTDISC = SQRT( -DET )
31804                        W( KBOT-1 ) = ( TR2+RTDISC )*S
31805                        W( KBOT ) = ( TR2-RTDISC )*S
31806*
31807                        KS = KBOT - 1
31808                     END IF
31809                  END IF
31810*
31811                  IF( KBOT-KS+1.GT.NS ) THEN
31812*
31813*                    ==== Sort the shifts (Helps a little) ====
31814*
31815                     SORTED = .false.
31816                     DO 50 K = KBOT, KS + 1, -1
31817                        IF( SORTED )
31818     $                     GO TO 60
31819                        SORTED = .true.
31820                        DO 40 I = KS, K - 1
31821                           IF( CABS1( W( I ) ).LT.CABS1( W( I+1 ) ) )
31822     $                          THEN
31823                              SORTED = .false.
31824                              SWAP = W( I )
31825                              W( I ) = W( I+1 )
31826                              W( I+1 ) = SWAP
31827                           END IF
31828   40                   CONTINUE
31829   50                CONTINUE
31830   60                CONTINUE
31831                  END IF
31832               END IF
31833*
31834*              ==== If there are only two shifts, then use
31835*              .    only one.  ====
31836*
31837               IF( KBOT-KS+1.EQ.2 ) THEN
31838                  IF( CABS1( W( KBOT )-H( KBOT, KBOT ) ).LT.
31839     $                CABS1( W( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN
31840                     W( KBOT-1 ) = W( KBOT )
31841                  ELSE
31842                     W( KBOT ) = W( KBOT-1 )
31843                  END IF
31844               END IF
31845*
31846*              ==== Use up to NS of the the smallest magnitude
31847*              .    shifts.  If there aren't NS shifts available,
31848*              .    then use them all, possibly dropping one to
31849*              .    make the number of shifts even. ====
31850*
31851               NS = MIN( NS, KBOT-KS+1 )
31852               NS = NS - MOD( NS, 2 )
31853               KS = KBOT - NS + 1
31854*
31855*              ==== Small-bulge multi-shift QR sweep:
31856*              .    split workspace under the subdiagonal into
31857*              .    - a KDU-by-KDU work array U in the lower
31858*              .      left-hand-corner,
31859*              .    - a KDU-by-at-least-KDU-but-more-is-better
31860*              .      (KDU-by-NHo) horizontal work array WH along
31861*              .      the bottom edge,
31862*              .    - and an at-least-KDU-but-more-is-better-by-KDU
31863*              .      (NVE-by-KDU) vertical work WV arrow along
31864*              .      the left-hand-edge. ====
31865*
31866               KDU = 3*NS - 3
31867               KU = N - KDU + 1
31868               KWH = KDU + 1
31869               NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1
31870               KWV = KDU + 4
31871               NVE = N - KDU - KWV + 1
31872*
31873*              ==== Small-bulge multi-shift QR sweep ====
31874*
31875               CALL ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS,
31876     $                      W( KS ), H, LDH, ILOZ, IHIZ, Z, LDZ, WORK,
31877     $                      3, H( KU, 1 ), LDH, NVE, H( KWV, 1 ), LDH,
31878     $                      NHO, H( KU, KWH ), LDH )
31879            END IF
31880*
31881*           ==== Note progress (or the lack of it). ====
31882*
31883            IF( LD.GT.0 ) THEN
31884               NDFL = 1
31885            ELSE
31886               NDFL = NDFL + 1
31887            END IF
31888*
31889*           ==== End of main loop ====
31890   70    CONTINUE
31891*
31892*        ==== Iteration limit exceeded.  Set INFO to show where
31893*        .    the problem occurred and exit. ====
31894*
31895         INFO = KBOT
31896   80    CONTINUE
31897      END IF
31898*
31899*     ==== Return the optimal value of LWORK. ====
31900*
31901      WORK( 1 ) = DCMPLX( LWKOPT, 0 )
31902*
31903*     ==== End of ZLAQR4 ====
31904*
31905      END
31906*> \brief \b ZLAQR5 performs a single small-bulge multi-shift QR sweep.
31907*
31908*  =========== DOCUMENTATION ===========
31909*
31910* Online html documentation available at
31911*            http://www.netlib.org/lapack/explore-html/
31912*
31913*> \htmlonly
31914*> Download ZLAQR5 + dependencies
31915*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlaqr5.f">
31916*> [TGZ]</a>
31917*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlaqr5.f">
31918*> [ZIP]</a>
31919*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlaqr5.f">
31920*> [TXT]</a>
31921*> \endhtmlonly
31922*
31923*  Definition:
31924*  ===========
31925*
31926*       SUBROUTINE ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S,
31927*                          H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV,
31928*                          WV, LDWV, NH, WH, LDWH )
31929*
31930*       .. Scalar Arguments ..
31931*       INTEGER            IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV,
31932*      $                   LDWH, LDWV, LDZ, N, NH, NSHFTS, NV
31933*       LOGICAL            WANTT, WANTZ
31934*       ..
31935*       .. Array Arguments ..
31936*       COMPLEX*16         H( LDH, * ), S( * ), U( LDU, * ), V( LDV, * ),
31937*      $                   WH( LDWH, * ), WV( LDWV, * ), Z( LDZ, * )
31938*       ..
31939*
31940*
31941*> \par Purpose:
31942*  =============
31943*>
31944*> \verbatim
31945*>
31946*>    ZLAQR5, called by ZLAQR0, performs a
31947*>    single small-bulge multi-shift QR sweep.
31948*> \endverbatim
31949*
31950*  Arguments:
31951*  ==========
31952*
31953*> \param[in] WANTT
31954*> \verbatim
31955*>          WANTT is LOGICAL
31956*>             WANTT = .true. if the triangular Schur factor
31957*>             is being computed.  WANTT is set to .false. otherwise.
31958*> \endverbatim
31959*>
31960*> \param[in] WANTZ
31961*> \verbatim
31962*>          WANTZ is LOGICAL
31963*>             WANTZ = .true. if the unitary Schur factor is being
31964*>             computed.  WANTZ is set to .false. otherwise.
31965*> \endverbatim
31966*>
31967*> \param[in] KACC22
31968*> \verbatim
31969*>          KACC22 is INTEGER with value 0, 1, or 2.
31970*>             Specifies the computation mode of far-from-diagonal
31971*>             orthogonal updates.
31972*>        = 0: ZLAQR5 does not accumulate reflections and does not
31973*>             use matrix-matrix multiply to update far-from-diagonal
31974*>             matrix entries.
31975*>        = 1: ZLAQR5 accumulates reflections and uses matrix-matrix
31976*>             multiply to update the far-from-diagonal matrix entries.
31977*>        = 2: ZLAQR5 accumulates reflections, uses matrix-matrix
31978*>             multiply to update the far-from-diagonal matrix entries,
31979*>             and takes advantage of 2-by-2 block structure during
31980*>             matrix multiplies.
31981*> \endverbatim
31982*>
31983*> \param[in] N
31984*> \verbatim
31985*>          N is INTEGER
31986*>             N is the order of the Hessenberg matrix H upon which this
31987*>             subroutine operates.
31988*> \endverbatim
31989*>
31990*> \param[in] KTOP
31991*> \verbatim
31992*>          KTOP is INTEGER
31993*> \endverbatim
31994*>
31995*> \param[in] KBOT
31996*> \verbatim
31997*>          KBOT is INTEGER
31998*>             These are the first and last rows and columns of an
31999*>             isolated diagonal block upon which the QR sweep is to be
32000*>             applied. It is assumed without a check that
32001*>                       either KTOP = 1  or   H(KTOP,KTOP-1) = 0
32002*>             and
32003*>                       either KBOT = N  or   H(KBOT+1,KBOT) = 0.
32004*> \endverbatim
32005*>
32006*> \param[in] NSHFTS
32007*> \verbatim
32008*>          NSHFTS is INTEGER
32009*>             NSHFTS gives the number of simultaneous shifts.  NSHFTS
32010*>             must be positive and even.
32011*> \endverbatim
32012*>
32013*> \param[in,out] S
32014*> \verbatim
32015*>          S is COMPLEX*16 array, dimension (NSHFTS)
32016*>             S contains the shifts of origin that define the multi-
32017*>             shift QR sweep.  On output S may be reordered.
32018*> \endverbatim
32019*>
32020*> \param[in,out] H
32021*> \verbatim
32022*>          H is COMPLEX*16 array, dimension (LDH,N)
32023*>             On input H contains a Hessenberg matrix.  On output a
32024*>             multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied
32025*>             to the isolated diagonal block in rows and columns KTOP
32026*>             through KBOT.
32027*> \endverbatim
32028*>
32029*> \param[in] LDH
32030*> \verbatim
32031*>          LDH is INTEGER
32032*>             LDH is the leading dimension of H just as declared in the
32033*>             calling procedure.  LDH >= MAX(1,N).
32034*> \endverbatim
32035*>
32036*> \param[in] ILOZ
32037*> \verbatim
32038*>          ILOZ is INTEGER
32039*> \endverbatim
32040*>
32041*> \param[in] IHIZ
32042*> \verbatim
32043*>          IHIZ is INTEGER
32044*>             Specify the rows of Z to which transformations must be
32045*>             applied if WANTZ is .TRUE.. 1 <= ILOZ <= IHIZ <= N
32046*> \endverbatim
32047*>
32048*> \param[in,out] Z
32049*> \verbatim
32050*>          Z is COMPLEX*16 array, dimension (LDZ,IHIZ)
32051*>             If WANTZ = .TRUE., then the QR Sweep unitary
32052*>             similarity transformation is accumulated into
32053*>             Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right.
32054*>             If WANTZ = .FALSE., then Z is unreferenced.
32055*> \endverbatim
32056*>
32057*> \param[in] LDZ
32058*> \verbatim
32059*>          LDZ is INTEGER
32060*>             LDA is the leading dimension of Z just as declared in
32061*>             the calling procedure. LDZ >= N.
32062*> \endverbatim
32063*>
32064*> \param[out] V
32065*> \verbatim
32066*>          V is COMPLEX*16 array, dimension (LDV,NSHFTS/2)
32067*> \endverbatim
32068*>
32069*> \param[in] LDV
32070*> \verbatim
32071*>          LDV is INTEGER
32072*>             LDV is the leading dimension of V as declared in the
32073*>             calling procedure.  LDV >= 3.
32074*> \endverbatim
32075*>
32076*> \param[out] U
32077*> \verbatim
32078*>          U is COMPLEX*16 array, dimension (LDU,3*NSHFTS-3)
32079*> \endverbatim
32080*>
32081*> \param[in] LDU
32082*> \verbatim
32083*>          LDU is INTEGER
32084*>             LDU is the leading dimension of U just as declared in the
32085*>             in the calling subroutine.  LDU >= 3*NSHFTS-3.
32086*> \endverbatim
32087*>
32088*> \param[in] NV
32089*> \verbatim
32090*>          NV is INTEGER
32091*>             NV is the number of rows in WV agailable for workspace.
32092*>             NV >= 1.
32093*> \endverbatim
32094*>
32095*> \param[out] WV
32096*> \verbatim
32097*>          WV is COMPLEX*16 array, dimension (LDWV,3*NSHFTS-3)
32098*> \endverbatim
32099*>
32100*> \param[in] LDWV
32101*> \verbatim
32102*>          LDWV is INTEGER
32103*>             LDWV is the leading dimension of WV as declared in the
32104*>             in the calling subroutine.  LDWV >= NV.
32105*> \endverbatim
32106*
32107*> \param[in] NH
32108*> \verbatim
32109*>          NH is INTEGER
32110*>             NH is the number of columns in array WH available for
32111*>             workspace. NH >= 1.
32112*> \endverbatim
32113*>
32114*> \param[out] WH
32115*> \verbatim
32116*>          WH is COMPLEX*16 array, dimension (LDWH,NH)
32117*> \endverbatim
32118*>
32119*> \param[in] LDWH
32120*> \verbatim
32121*>          LDWH is INTEGER
32122*>             Leading dimension of WH just as declared in the
32123*>             calling procedure.  LDWH >= 3*NSHFTS-3.
32124*> \endverbatim
32125*>
32126*  Authors:
32127*  ========
32128*
32129*> \author Univ. of Tennessee
32130*> \author Univ. of California Berkeley
32131*> \author Univ. of Colorado Denver
32132*> \author NAG Ltd.
32133*
32134*> \date June 2016
32135*
32136*> \ingroup complex16OTHERauxiliary
32137*
32138*> \par Contributors:
32139*  ==================
32140*>
32141*>       Karen Braman and Ralph Byers, Department of Mathematics,
32142*>       University of Kansas, USA
32143*
32144*> \par References:
32145*  ================
32146*>
32147*>       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
32148*>       Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
32149*>       Performance, SIAM Journal of Matrix Analysis, volume 23, pages
32150*>       929--947, 2002.
32151*>
32152*  =====================================================================
32153      SUBROUTINE ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S,
32154     $                   H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV,
32155     $                   WV, LDWV, NH, WH, LDWH )
32156*
32157*  -- LAPACK auxiliary routine (version 3.7.1) --
32158*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
32159*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
32160*     June 2016
32161*
32162*     .. Scalar Arguments ..
32163      INTEGER            IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV,
32164     $                   LDWH, LDWV, LDZ, N, NH, NSHFTS, NV
32165      LOGICAL            WANTT, WANTZ
32166*     ..
32167*     .. Array Arguments ..
32168      COMPLEX*16         H( LDH, * ), S( * ), U( LDU, * ), V( LDV, * ),
32169     $                   WH( LDWH, * ), WV( LDWV, * ), Z( LDZ, * )
32170*     ..
32171*
32172*  ================================================================
32173*     .. Parameters ..
32174      COMPLEX*16         ZERO, ONE
32175      PARAMETER          ( ZERO = ( 0.0d0, 0.0d0 ),
32176     $                   ONE = ( 1.0d0, 0.0d0 ) )
32177      DOUBLE PRECISION   RZERO, RONE
32178      PARAMETER          ( RZERO = 0.0d0, RONE = 1.0d0 )
32179*     ..
32180*     .. Local Scalars ..
32181      COMPLEX*16         ALPHA, BETA, CDUM, REFSUM
32182      DOUBLE PRECISION   H11, H12, H21, H22, SAFMAX, SAFMIN, SCL,
32183     $                   SMLNUM, TST1, TST2, ULP
32184      INTEGER            I2, I4, INCOL, J, J2, J4, JBOT, JCOL, JLEN,
32185     $                   JROW, JTOP, K, K1, KDU, KMS, KNZ, KRCOL, KZS,
32186     $                   M, M22, MBOT, MEND, MSTART, MTOP, NBMPS, NDCOL,
32187     $                   NS, NU
32188      LOGICAL            ACCUM, BLK22, BMP22
32189*     ..
32190*     .. External Functions ..
32191      DOUBLE PRECISION   DLAMCH
32192      EXTERNAL           DLAMCH
32193*     ..
32194*     .. Intrinsic Functions ..
32195*
32196      INTRINSIC          ABS, DBLE, DCONJG, DIMAG, MAX, MIN, MOD
32197*     ..
32198*     .. Local Arrays ..
32199      COMPLEX*16         VT( 3 )
32200*     ..
32201*     .. External Subroutines ..
32202      EXTERNAL           DLABAD, ZGEMM, ZLACPY, ZLAQR1, ZLARFG, ZLASET,
32203     $                   ZTRMM
32204*     ..
32205*     .. Statement Functions ..
32206      DOUBLE PRECISION   CABS1
32207*     ..
32208*     .. Statement Function definitions ..
32209      CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
32210*     ..
32211*     .. Executable Statements ..
32212*
32213*     ==== If there are no shifts, then there is nothing to do. ====
32214*
32215      IF( NSHFTS.LT.2 )
32216     $   RETURN
32217*
32218*     ==== If the active block is empty or 1-by-1, then there
32219*     .    is nothing to do. ====
32220*
32221      IF( KTOP.GE.KBOT )
32222     $   RETURN
32223*
32224*     ==== NSHFTS is supposed to be even, but if it is odd,
32225*     .    then simply reduce it by one.  ====
32226*
32227      NS = NSHFTS - MOD( NSHFTS, 2 )
32228*
32229*     ==== Machine constants for deflation ====
32230*
32231      SAFMIN = DLAMCH( 'SAFE MINIMUM' )
32232      SAFMAX = RONE / SAFMIN
32233      CALL DLABAD( SAFMIN, SAFMAX )
32234      ULP = DLAMCH( 'PRECISION' )
32235      SMLNUM = SAFMIN*( DBLE( N ) / ULP )
32236*
32237*     ==== Use accumulated reflections to update far-from-diagonal
32238*     .    entries ? ====
32239*
32240      ACCUM = ( KACC22.EQ.1 ) .OR. ( KACC22.EQ.2 )
32241*
32242*     ==== If so, exploit the 2-by-2 block structure? ====
32243*
32244      BLK22 = ( NS.GT.2 ) .AND. ( KACC22.EQ.2 )
32245*
32246*     ==== clear trash ====
32247*
32248      IF( KTOP+2.LE.KBOT )
32249     $   H( KTOP+2, KTOP ) = ZERO
32250*
32251*     ==== NBMPS = number of 2-shift bulges in the chain ====
32252*
32253      NBMPS = NS / 2
32254*
32255*     ==== KDU = width of slab ====
32256*
32257      KDU = 6*NBMPS - 3
32258*
32259*     ==== Create and chase chains of NBMPS bulges ====
32260*
32261      DO 210 INCOL = 3*( 1-NBMPS ) + KTOP - 1, KBOT - 2, 3*NBMPS - 2
32262         NDCOL = INCOL + KDU
32263         IF( ACCUM )
32264     $      CALL ZLASET( 'ALL', KDU, KDU, ZERO, ONE, U, LDU )
32265*
32266*        ==== Near-the-diagonal bulge chase.  The following loop
32267*        .    performs the near-the-diagonal part of a small bulge
32268*        .    multi-shift QR sweep.  Each 6*NBMPS-2 column diagonal
32269*        .    chunk extends from column INCOL to column NDCOL
32270*        .    (including both column INCOL and column NDCOL). The
32271*        .    following loop chases a 3*NBMPS column long chain of
32272*        .    NBMPS bulges 3*NBMPS-2 columns to the right.  (INCOL
32273*        .    may be less than KTOP and and NDCOL may be greater than
32274*        .    KBOT indicating phantom columns from which to chase
32275*        .    bulges before they are actually introduced or to which
32276*        .    to chase bulges beyond column KBOT.)  ====
32277*
32278         DO 140 KRCOL = INCOL, MIN( INCOL+3*NBMPS-3, KBOT-2 )
32279*
32280*           ==== Bulges number MTOP to MBOT are active double implicit
32281*           .    shift bulges.  There may or may not also be small
32282*           .    2-by-2 bulge, if there is room.  The inactive bulges
32283*           .    (if any) must wait until the active bulges have moved
32284*           .    down the diagonal to make room.  The phantom matrix
32285*           .    paradigm described above helps keep track.  ====
32286*
32287            MTOP = MAX( 1, ( ( KTOP-1 )-KRCOL+2 ) / 3+1 )
32288            MBOT = MIN( NBMPS, ( KBOT-KRCOL ) / 3 )
32289            M22 = MBOT + 1
32290            BMP22 = ( MBOT.LT.NBMPS ) .AND. ( KRCOL+3*( M22-1 ) ).EQ.
32291     $              ( KBOT-2 )
32292*
32293*           ==== Generate reflections to chase the chain right
32294*           .    one column.  (The minimum value of K is KTOP-1.) ====
32295*
32296            DO 10 M = MTOP, MBOT
32297               K = KRCOL + 3*( M-1 )
32298               IF( K.EQ.KTOP-1 ) THEN
32299                  CALL ZLAQR1( 3, H( KTOP, KTOP ), LDH, S( 2*M-1 ),
32300     $                         S( 2*M ), V( 1, M ) )
32301                  ALPHA = V( 1, M )
32302                  CALL ZLARFG( 3, ALPHA, V( 2, M ), 1, V( 1, M ) )
32303               ELSE
32304                  BETA = H( K+1, K )
32305                  V( 2, M ) = H( K+2, K )
32306                  V( 3, M ) = H( K+3, K )
32307                  CALL ZLARFG( 3, BETA, V( 2, M ), 1, V( 1, M ) )
32308*
32309*                 ==== A Bulge may collapse because of vigilant
32310*                 .    deflation or destructive underflow.  In the
32311*                 .    underflow case, try the two-small-subdiagonals
32312*                 .    trick to try to reinflate the bulge.  ====
32313*
32314                  IF( H( K+3, K ).NE.ZERO .OR. H( K+3, K+1 ).NE.
32315     $                ZERO .OR. H( K+3, K+2 ).EQ.ZERO ) THEN
32316*
32317*                    ==== Typical case: not collapsed (yet). ====
32318*
32319                     H( K+1, K ) = BETA
32320                     H( K+2, K ) = ZERO
32321                     H( K+3, K ) = ZERO
32322                  ELSE
32323*
32324*                    ==== Atypical case: collapsed.  Attempt to
32325*                    .    reintroduce ignoring H(K+1,K) and H(K+2,K).
32326*                    .    If the fill resulting from the new
32327*                    .    reflector is too large, then abandon it.
32328*                    .    Otherwise, use the new one. ====
32329*
32330                     CALL ZLAQR1( 3, H( K+1, K+1 ), LDH, S( 2*M-1 ),
32331     $                            S( 2*M ), VT )
32332                     ALPHA = VT( 1 )
32333                     CALL ZLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) )
32334                     REFSUM = DCONJG( VT( 1 ) )*
32335     $                        ( H( K+1, K )+DCONJG( VT( 2 ) )*
32336     $                        H( K+2, K ) )
32337*
32338                     IF( CABS1( H( K+2, K )-REFSUM*VT( 2 ) )+
32339     $                   CABS1( REFSUM*VT( 3 ) ).GT.ULP*
32340     $                   ( CABS1( H( K, K ) )+CABS1( H( K+1,
32341     $                   K+1 ) )+CABS1( H( K+2, K+2 ) ) ) ) THEN
32342*
32343*                       ==== Starting a new bulge here would
32344*                       .    create non-negligible fill.  Use
32345*                       .    the old one with trepidation. ====
32346*
32347                        H( K+1, K ) = BETA
32348                        H( K+2, K ) = ZERO
32349                        H( K+3, K ) = ZERO
32350                     ELSE
32351*
32352*                       ==== Stating a new bulge here would
32353*                       .    create only negligible fill.
32354*                       .    Replace the old reflector with
32355*                       .    the new one. ====
32356*
32357                        H( K+1, K ) = H( K+1, K ) - REFSUM
32358                        H( K+2, K ) = ZERO
32359                        H( K+3, K ) = ZERO
32360                        V( 1, M ) = VT( 1 )
32361                        V( 2, M ) = VT( 2 )
32362                        V( 3, M ) = VT( 3 )
32363                     END IF
32364                  END IF
32365               END IF
32366   10       CONTINUE
32367*
32368*           ==== Generate a 2-by-2 reflection, if needed. ====
32369*
32370            K = KRCOL + 3*( M22-1 )
32371            IF( BMP22 ) THEN
32372               IF( K.EQ.KTOP-1 ) THEN
32373                  CALL ZLAQR1( 2, H( K+1, K+1 ), LDH, S( 2*M22-1 ),
32374     $                         S( 2*M22 ), V( 1, M22 ) )
32375                  BETA = V( 1, M22 )
32376                  CALL ZLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) )
32377               ELSE
32378                  BETA = H( K+1, K )
32379                  V( 2, M22 ) = H( K+2, K )
32380                  CALL ZLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) )
32381                  H( K+1, K ) = BETA
32382                  H( K+2, K ) = ZERO
32383               END IF
32384            END IF
32385*
32386*           ==== Multiply H by reflections from the left ====
32387*
32388            IF( ACCUM ) THEN
32389               JBOT = MIN( NDCOL, KBOT )
32390            ELSE IF( WANTT ) THEN
32391               JBOT = N
32392            ELSE
32393               JBOT = KBOT
32394            END IF
32395            DO 30 J = MAX( KTOP, KRCOL ), JBOT
32396               MEND = MIN( MBOT, ( J-KRCOL+2 ) / 3 )
32397               DO 20 M = MTOP, MEND
32398                  K = KRCOL + 3*( M-1 )
32399                  REFSUM = DCONJG( V( 1, M ) )*
32400     $                     ( H( K+1, J )+DCONJG( V( 2, M ) )*
32401     $                     H( K+2, J )+DCONJG( V( 3, M ) )*H( K+3, J ) )
32402                  H( K+1, J ) = H( K+1, J ) - REFSUM
32403                  H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M )
32404                  H( K+3, J ) = H( K+3, J ) - REFSUM*V( 3, M )
32405   20          CONTINUE
32406   30       CONTINUE
32407            IF( BMP22 ) THEN
32408               K = KRCOL + 3*( M22-1 )
32409               DO 40 J = MAX( K+1, KTOP ), JBOT
32410                  REFSUM = DCONJG( V( 1, M22 ) )*
32411     $                     ( H( K+1, J )+DCONJG( V( 2, M22 ) )*
32412     $                     H( K+2, J ) )
32413                  H( K+1, J ) = H( K+1, J ) - REFSUM
32414                  H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M22 )
32415   40          CONTINUE
32416            END IF
32417*
32418*           ==== Multiply H by reflections from the right.
32419*           .    Delay filling in the last row until the
32420*           .    vigilant deflation check is complete. ====
32421*
32422            IF( ACCUM ) THEN
32423               JTOP = MAX( KTOP, INCOL )
32424            ELSE IF( WANTT ) THEN
32425               JTOP = 1
32426            ELSE
32427               JTOP = KTOP
32428            END IF
32429            DO 80 M = MTOP, MBOT
32430               IF( V( 1, M ).NE.ZERO ) THEN
32431                  K = KRCOL + 3*( M-1 )
32432                  DO 50 J = JTOP, MIN( KBOT, K+3 )
32433                     REFSUM = V( 1, M )*( H( J, K+1 )+V( 2, M )*
32434     $                        H( J, K+2 )+V( 3, M )*H( J, K+3 ) )
32435                     H( J, K+1 ) = H( J, K+1 ) - REFSUM
32436                     H( J, K+2 ) = H( J, K+2 ) -
32437     $                             REFSUM*DCONJG( V( 2, M ) )
32438                     H( J, K+3 ) = H( J, K+3 ) -
32439     $                             REFSUM*DCONJG( V( 3, M ) )
32440   50             CONTINUE
32441*
32442                  IF( ACCUM ) THEN
32443*
32444*                    ==== Accumulate U. (If necessary, update Z later
32445*                    .    with with an efficient matrix-matrix
32446*                    .    multiply.) ====
32447*
32448                     KMS = K - INCOL
32449                     DO 60 J = MAX( 1, KTOP-INCOL ), KDU
32450                        REFSUM = V( 1, M )*( U( J, KMS+1 )+V( 2, M )*
32451     $                           U( J, KMS+2 )+V( 3, M )*U( J, KMS+3 ) )
32452                        U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM
32453                        U( J, KMS+2 ) = U( J, KMS+2 ) -
32454     $                                  REFSUM*DCONJG( V( 2, M ) )
32455                        U( J, KMS+3 ) = U( J, KMS+3 ) -
32456     $                                  REFSUM*DCONJG( V( 3, M ) )
32457   60                CONTINUE
32458                  ELSE IF( WANTZ ) THEN
32459*
32460*                    ==== U is not accumulated, so update Z
32461*                    .    now by multiplying by reflections
32462*                    .    from the right. ====
32463*
32464                     DO 70 J = ILOZ, IHIZ
32465                        REFSUM = V( 1, M )*( Z( J, K+1 )+V( 2, M )*
32466     $                           Z( J, K+2 )+V( 3, M )*Z( J, K+3 ) )
32467                        Z( J, K+1 ) = Z( J, K+1 ) - REFSUM
32468                        Z( J, K+2 ) = Z( J, K+2 ) -
32469     $                                REFSUM*DCONJG( V( 2, M ) )
32470                        Z( J, K+3 ) = Z( J, K+3 ) -
32471     $                                REFSUM*DCONJG( V( 3, M ) )
32472   70                CONTINUE
32473                  END IF
32474               END IF
32475   80       CONTINUE
32476*
32477*           ==== Special case: 2-by-2 reflection (if needed) ====
32478*
32479            K = KRCOL + 3*( M22-1 )
32480            IF( BMP22 ) THEN
32481               IF ( V( 1, M22 ).NE.ZERO ) THEN
32482                  DO 90 J = JTOP, MIN( KBOT, K+3 )
32483                     REFSUM = V( 1, M22 )*( H( J, K+1 )+V( 2, M22 )*
32484     $                        H( J, K+2 ) )
32485                     H( J, K+1 ) = H( J, K+1 ) - REFSUM
32486                     H( J, K+2 ) = H( J, K+2 ) -
32487     $                             REFSUM*DCONJG( V( 2, M22 ) )
32488   90             CONTINUE
32489*
32490                  IF( ACCUM ) THEN
32491                     KMS = K - INCOL
32492                     DO 100 J = MAX( 1, KTOP-INCOL ), KDU
32493                        REFSUM = V( 1, M22 )*( U( J, KMS+1 )+
32494     $                           V( 2, M22 )*U( J, KMS+2 ) )
32495                        U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM
32496                        U( J, KMS+2 ) = U( J, KMS+2 ) -
32497     $                                  REFSUM*DCONJG( V( 2, M22 ) )
32498  100                CONTINUE
32499                  ELSE IF( WANTZ ) THEN
32500                     DO 110 J = ILOZ, IHIZ
32501                        REFSUM = V( 1, M22 )*( Z( J, K+1 )+V( 2, M22 )*
32502     $                           Z( J, K+2 ) )
32503                        Z( J, K+1 ) = Z( J, K+1 ) - REFSUM
32504                        Z( J, K+2 ) = Z( J, K+2 ) -
32505     $                                REFSUM*DCONJG( V( 2, M22 ) )
32506  110                CONTINUE
32507                  END IF
32508               END IF
32509            END IF
32510*
32511*           ==== Vigilant deflation check ====
32512*
32513            MSTART = MTOP
32514            IF( KRCOL+3*( MSTART-1 ).LT.KTOP )
32515     $         MSTART = MSTART + 1
32516            MEND = MBOT
32517            IF( BMP22 )
32518     $         MEND = MEND + 1
32519            IF( KRCOL.EQ.KBOT-2 )
32520     $         MEND = MEND + 1
32521            DO 120 M = MSTART, MEND
32522               K = MIN( KBOT-1, KRCOL+3*( M-1 ) )
32523*
32524*              ==== The following convergence test requires that
32525*              .    the tradition small-compared-to-nearby-diagonals
32526*              .    criterion and the Ahues & Tisseur (LAWN 122, 1997)
32527*              .    criteria both be satisfied.  The latter improves
32528*              .    accuracy in some examples. Falling back on an
32529*              .    alternate convergence criterion when TST1 or TST2
32530*              .    is zero (as done here) is traditional but probably
32531*              .    unnecessary. ====
32532*
32533               IF( H( K+1, K ).NE.ZERO ) THEN
32534                  TST1 = CABS1( H( K, K ) ) + CABS1( H( K+1, K+1 ) )
32535                  IF( TST1.EQ.RZERO ) THEN
32536                     IF( K.GE.KTOP+1 )
32537     $                  TST1 = TST1 + CABS1( H( K, K-1 ) )
32538                     IF( K.GE.KTOP+2 )
32539     $                  TST1 = TST1 + CABS1( H( K, K-2 ) )
32540                     IF( K.GE.KTOP+3 )
32541     $                  TST1 = TST1 + CABS1( H( K, K-3 ) )
32542                     IF( K.LE.KBOT-2 )
32543     $                  TST1 = TST1 + CABS1( H( K+2, K+1 ) )
32544                     IF( K.LE.KBOT-3 )
32545     $                  TST1 = TST1 + CABS1( H( K+3, K+1 ) )
32546                     IF( K.LE.KBOT-4 )
32547     $                  TST1 = TST1 + CABS1( H( K+4, K+1 ) )
32548                  END IF
32549                  IF( CABS1( H( K+1, K ) ).LE.MAX( SMLNUM, ULP*TST1 ) )
32550     $                 THEN
32551                     H12 = MAX( CABS1( H( K+1, K ) ),
32552     $                     CABS1( H( K, K+1 ) ) )
32553                     H21 = MIN( CABS1( H( K+1, K ) ),
32554     $                     CABS1( H( K, K+1 ) ) )
32555                     H11 = MAX( CABS1( H( K+1, K+1 ) ),
32556     $                     CABS1( H( K, K )-H( K+1, K+1 ) ) )
32557                     H22 = MIN( CABS1( H( K+1, K+1 ) ),
32558     $                     CABS1( H( K, K )-H( K+1, K+1 ) ) )
32559                     SCL = H11 + H12
32560                     TST2 = H22*( H11 / SCL )
32561*
32562                     IF( TST2.EQ.RZERO .OR. H21*( H12 / SCL ).LE.
32563     $                   MAX( SMLNUM, ULP*TST2 ) )H( K+1, K ) = ZERO
32564                  END IF
32565               END IF
32566  120       CONTINUE
32567*
32568*           ==== Fill in the last row of each bulge. ====
32569*
32570            MEND = MIN( NBMPS, ( KBOT-KRCOL-1 ) / 3 )
32571            DO 130 M = MTOP, MEND
32572               K = KRCOL + 3*( M-1 )
32573               REFSUM = V( 1, M )*V( 3, M )*H( K+4, K+3 )
32574               H( K+4, K+1 ) = -REFSUM
32575               H( K+4, K+2 ) = -REFSUM*DCONJG( V( 2, M ) )
32576               H( K+4, K+3 ) = H( K+4, K+3 ) -
32577     $                         REFSUM*DCONJG( V( 3, M ) )
32578  130       CONTINUE
32579*
32580*           ==== End of near-the-diagonal bulge chase. ====
32581*
32582  140    CONTINUE
32583*
32584*        ==== Use U (if accumulated) to update far-from-diagonal
32585*        .    entries in H.  If required, use U to update Z as
32586*        .    well. ====
32587*
32588         IF( ACCUM ) THEN
32589            IF( WANTT ) THEN
32590               JTOP = 1
32591               JBOT = N
32592            ELSE
32593               JTOP = KTOP
32594               JBOT = KBOT
32595            END IF
32596            IF( ( .NOT.BLK22 ) .OR. ( INCOL.LT.KTOP ) .OR.
32597     $          ( NDCOL.GT.KBOT ) .OR. ( NS.LE.2 ) ) THEN
32598*
32599*              ==== Updates not exploiting the 2-by-2 block
32600*              .    structure of U.  K1 and NU keep track of
32601*              .    the location and size of U in the special
32602*              .    cases of introducing bulges and chasing
32603*              .    bulges off the bottom.  In these special
32604*              .    cases and in case the number of shifts
32605*              .    is NS = 2, there is no 2-by-2 block
32606*              .    structure to exploit.  ====
32607*
32608               K1 = MAX( 1, KTOP-INCOL )
32609               NU = ( KDU-MAX( 0, NDCOL-KBOT ) ) - K1 + 1
32610*
32611*              ==== Horizontal Multiply ====
32612*
32613               DO 150 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH
32614                  JLEN = MIN( NH, JBOT-JCOL+1 )
32615                  CALL ZGEMM( 'C', 'N', NU, JLEN, NU, ONE, U( K1, K1 ),
32616     $                        LDU, H( INCOL+K1, JCOL ), LDH, ZERO, WH,
32617     $                        LDWH )
32618                  CALL ZLACPY( 'ALL', NU, JLEN, WH, LDWH,
32619     $                         H( INCOL+K1, JCOL ), LDH )
32620  150          CONTINUE
32621*
32622*              ==== Vertical multiply ====
32623*
32624               DO 160 JROW = JTOP, MAX( KTOP, INCOL ) - 1, NV
32625                  JLEN = MIN( NV, MAX( KTOP, INCOL )-JROW )
32626                  CALL ZGEMM( 'N', 'N', JLEN, NU, NU, ONE,
32627     $                        H( JROW, INCOL+K1 ), LDH, U( K1, K1 ),
32628     $                        LDU, ZERO, WV, LDWV )
32629                  CALL ZLACPY( 'ALL', JLEN, NU, WV, LDWV,
32630     $                         H( JROW, INCOL+K1 ), LDH )
32631  160          CONTINUE
32632*
32633*              ==== Z multiply (also vertical) ====
32634*
32635               IF( WANTZ ) THEN
32636                  DO 170 JROW = ILOZ, IHIZ, NV
32637                     JLEN = MIN( NV, IHIZ-JROW+1 )
32638                     CALL ZGEMM( 'N', 'N', JLEN, NU, NU, ONE,
32639     $                           Z( JROW, INCOL+K1 ), LDZ, U( K1, K1 ),
32640     $                           LDU, ZERO, WV, LDWV )
32641                     CALL ZLACPY( 'ALL', JLEN, NU, WV, LDWV,
32642     $                            Z( JROW, INCOL+K1 ), LDZ )
32643  170             CONTINUE
32644               END IF
32645            ELSE
32646*
32647*              ==== Updates exploiting U's 2-by-2 block structure.
32648*              .    (I2, I4, J2, J4 are the last rows and columns
32649*              .    of the blocks.) ====
32650*
32651               I2 = ( KDU+1 ) / 2
32652               I4 = KDU
32653               J2 = I4 - I2
32654               J4 = KDU
32655*
32656*              ==== KZS and KNZ deal with the band of zeros
32657*              .    along the diagonal of one of the triangular
32658*              .    blocks. ====
32659*
32660               KZS = ( J4-J2 ) - ( NS+1 )
32661               KNZ = NS + 1
32662*
32663*              ==== Horizontal multiply ====
32664*
32665               DO 180 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH
32666                  JLEN = MIN( NH, JBOT-JCOL+1 )
32667*
32668*                 ==== Copy bottom of H to top+KZS of scratch ====
32669*                  (The first KZS rows get multiplied by zero.) ====
32670*
32671                  CALL ZLACPY( 'ALL', KNZ, JLEN, H( INCOL+1+J2, JCOL ),
32672     $                         LDH, WH( KZS+1, 1 ), LDWH )
32673*
32674*                 ==== Multiply by U21**H ====
32675*
32676                  CALL ZLASET( 'ALL', KZS, JLEN, ZERO, ZERO, WH, LDWH )
32677                  CALL ZTRMM( 'L', 'U', 'C', 'N', KNZ, JLEN, ONE,
32678     $                        U( J2+1, 1+KZS ), LDU, WH( KZS+1, 1 ),
32679     $                        LDWH )
32680*
32681*                 ==== Multiply top of H by U11**H ====
32682*
32683                  CALL ZGEMM( 'C', 'N', I2, JLEN, J2, ONE, U, LDU,
32684     $                        H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH )
32685*
32686*                 ==== Copy top of H to bottom of WH ====
32687*
32688                  CALL ZLACPY( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH,
32689     $                         WH( I2+1, 1 ), LDWH )
32690*
32691*                 ==== Multiply by U21**H ====
32692*
32693                  CALL ZTRMM( 'L', 'L', 'C', 'N', J2, JLEN, ONE,
32694     $                        U( 1, I2+1 ), LDU, WH( I2+1, 1 ), LDWH )
32695*
32696*                 ==== Multiply by U22 ====
32697*
32698                  CALL ZGEMM( 'C', 'N', I4-I2, JLEN, J4-J2, ONE,
32699     $                        U( J2+1, I2+1 ), LDU,
32700     $                        H( INCOL+1+J2, JCOL ), LDH, ONE,
32701     $                        WH( I2+1, 1 ), LDWH )
32702*
32703*                 ==== Copy it back ====
32704*
32705                  CALL ZLACPY( 'ALL', KDU, JLEN, WH, LDWH,
32706     $                         H( INCOL+1, JCOL ), LDH )
32707  180          CONTINUE
32708*
32709*              ==== Vertical multiply ====
32710*
32711               DO 190 JROW = JTOP, MAX( INCOL, KTOP ) - 1, NV
32712                  JLEN = MIN( NV, MAX( INCOL, KTOP )-JROW )
32713*
32714*                 ==== Copy right of H to scratch (the first KZS
32715*                 .    columns get multiplied by zero) ====
32716*
32717                  CALL ZLACPY( 'ALL', JLEN, KNZ, H( JROW, INCOL+1+J2 ),
32718     $                         LDH, WV( 1, 1+KZS ), LDWV )
32719*
32720*                 ==== Multiply by U21 ====
32721*
32722                  CALL ZLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, LDWV )
32723                  CALL ZTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE,
32724     $                        U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ),
32725     $                        LDWV )
32726*
32727*                 ==== Multiply by U11 ====
32728*
32729                  CALL ZGEMM( 'N', 'N', JLEN, I2, J2, ONE,
32730     $                        H( JROW, INCOL+1 ), LDH, U, LDU, ONE, WV,
32731     $                        LDWV )
32732*
32733*                 ==== Copy left of H to right of scratch ====
32734*
32735                  CALL ZLACPY( 'ALL', JLEN, J2, H( JROW, INCOL+1 ), LDH,
32736     $                         WV( 1, 1+I2 ), LDWV )
32737*
32738*                 ==== Multiply by U21 ====
32739*
32740                  CALL ZTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE,
32741     $                        U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), LDWV )
32742*
32743*                 ==== Multiply by U22 ====
32744*
32745                  CALL ZGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE,
32746     $                        H( JROW, INCOL+1+J2 ), LDH,
32747     $                        U( J2+1, I2+1 ), LDU, ONE, WV( 1, 1+I2 ),
32748     $                        LDWV )
32749*
32750*                 ==== Copy it back ====
32751*
32752                  CALL ZLACPY( 'ALL', JLEN, KDU, WV, LDWV,
32753     $                         H( JROW, INCOL+1 ), LDH )
32754  190          CONTINUE
32755*
32756*              ==== Multiply Z (also vertical) ====
32757*
32758               IF( WANTZ ) THEN
32759                  DO 200 JROW = ILOZ, IHIZ, NV
32760                     JLEN = MIN( NV, IHIZ-JROW+1 )
32761*
32762*                    ==== Copy right of Z to left of scratch (first
32763*                    .     KZS columns get multiplied by zero) ====
32764*
32765                     CALL ZLACPY( 'ALL', JLEN, KNZ,
32766     $                            Z( JROW, INCOL+1+J2 ), LDZ,
32767     $                            WV( 1, 1+KZS ), LDWV )
32768*
32769*                    ==== Multiply by U12 ====
32770*
32771                     CALL ZLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV,
32772     $                            LDWV )
32773                     CALL ZTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE,
32774     $                           U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ),
32775     $                           LDWV )
32776*
32777*                    ==== Multiply by U11 ====
32778*
32779                     CALL ZGEMM( 'N', 'N', JLEN, I2, J2, ONE,
32780     $                           Z( JROW, INCOL+1 ), LDZ, U, LDU, ONE,
32781     $                           WV, LDWV )
32782*
32783*                    ==== Copy left of Z to right of scratch ====
32784*
32785                     CALL ZLACPY( 'ALL', JLEN, J2, Z( JROW, INCOL+1 ),
32786     $                            LDZ, WV( 1, 1+I2 ), LDWV )
32787*
32788*                    ==== Multiply by U21 ====
32789*
32790                     CALL ZTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE,
32791     $                           U( 1, I2+1 ), LDU, WV( 1, 1+I2 ),
32792     $                           LDWV )
32793*
32794*                    ==== Multiply by U22 ====
32795*
32796                     CALL ZGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE,
32797     $                           Z( JROW, INCOL+1+J2 ), LDZ,
32798     $                           U( J2+1, I2+1 ), LDU, ONE,
32799     $                           WV( 1, 1+I2 ), LDWV )
32800*
32801*                    ==== Copy the result back to Z ====
32802*
32803                     CALL ZLACPY( 'ALL', JLEN, KDU, WV, LDWV,
32804     $                            Z( JROW, INCOL+1 ), LDZ )
32805  200             CONTINUE
32806               END IF
32807            END IF
32808         END IF
32809  210 CONTINUE
32810*
32811*     ==== End of ZLAQR5 ====
32812*
32813      END
32814*> \brief \b ZLARCM copies all or part of a real two-dimensional array to a complex array.
32815*
32816*  =========== DOCUMENTATION ===========
32817*
32818* Online html documentation available at
32819*            http://www.netlib.org/lapack/explore-html/
32820*
32821*> \htmlonly
32822*> Download ZLARCM + dependencies
32823*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlarcm.f">
32824*> [TGZ]</a>
32825*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlarcm.f">
32826*> [ZIP]</a>
32827*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlarcm.f">
32828*> [TXT]</a>
32829*> \endhtmlonly
32830*
32831*  Definition:
32832*  ===========
32833*
32834*       SUBROUTINE ZLARCM( M, N, A, LDA, B, LDB, C, LDC, RWORK )
32835*
32836*       .. Scalar Arguments ..
32837*       INTEGER            LDA, LDB, LDC, M, N
32838*       ..
32839*       .. Array Arguments ..
32840*       DOUBLE PRECISION   A( LDA, * ), RWORK( * )
32841*       COMPLEX*16         B( LDB, * ), C( LDC, * )
32842*       ..
32843*
32844*
32845*> \par Purpose:
32846*  =============
32847*>
32848*> \verbatim
32849*>
32850*> ZLARCM performs a very simple matrix-matrix multiplication:
32851*>          C := A * B,
32852*> where A is M by M and real; B is M by N and complex;
32853*> C is M by N and complex.
32854*> \endverbatim
32855*
32856*  Arguments:
32857*  ==========
32858*
32859*> \param[in] M
32860*> \verbatim
32861*>          M is INTEGER
32862*>          The number of rows of the matrix A and of the matrix C.
32863*>          M >= 0.
32864*> \endverbatim
32865*>
32866*> \param[in] N
32867*> \verbatim
32868*>          N is INTEGER
32869*>          The number of columns and rows of the matrix B and
32870*>          the number of columns of the matrix C.
32871*>          N >= 0.
32872*> \endverbatim
32873*>
32874*> \param[in] A
32875*> \verbatim
32876*>          A is DOUBLE PRECISION array, dimension (LDA, M)
32877*>          On entry, A contains the M by M matrix A.
32878*> \endverbatim
32879*>
32880*> \param[in] LDA
32881*> \verbatim
32882*>          LDA is INTEGER
32883*>          The leading dimension of the array A. LDA >=max(1,M).
32884*> \endverbatim
32885*>
32886*> \param[in] B
32887*> \verbatim
32888*>          B is COMPLEX*16 array, dimension (LDB, N)
32889*>          On entry, B contains the M by N matrix B.
32890*> \endverbatim
32891*>
32892*> \param[in] LDB
32893*> \verbatim
32894*>          LDB is INTEGER
32895*>          The leading dimension of the array B. LDB >=max(1,M).
32896*> \endverbatim
32897*>
32898*> \param[out] C
32899*> \verbatim
32900*>          C is COMPLEX*16 array, dimension (LDC, N)
32901*>          On exit, C contains the M by N matrix C.
32902*> \endverbatim
32903*>
32904*> \param[in] LDC
32905*> \verbatim
32906*>          LDC is INTEGER
32907*>          The leading dimension of the array C. LDC >=max(1,M).
32908*> \endverbatim
32909*>
32910*> \param[out] RWORK
32911*> \verbatim
32912*>          RWORK is DOUBLE PRECISION array, dimension (2*M*N)
32913*> \endverbatim
32914*
32915*  Authors:
32916*  ========
32917*
32918*> \author Univ. of Tennessee
32919*> \author Univ. of California Berkeley
32920*> \author Univ. of Colorado Denver
32921*> \author NAG Ltd.
32922*
32923*> \date June 2016
32924*
32925*> \ingroup complex16OTHERauxiliary
32926*
32927*  =====================================================================
32928      SUBROUTINE ZLARCM( M, N, A, LDA, B, LDB, C, LDC, RWORK )
32929*
32930*  -- LAPACK auxiliary routine (version 3.7.0) --
32931*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
32932*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
32933*     June 2016
32934*
32935*     .. Scalar Arguments ..
32936      INTEGER            LDA, LDB, LDC, M, N
32937*     ..
32938*     .. Array Arguments ..
32939      DOUBLE PRECISION   A( LDA, * ), RWORK( * )
32940      COMPLEX*16         B( LDB, * ), C( LDC, * )
32941*     ..
32942*
32943*  =====================================================================
32944*
32945*     .. Parameters ..
32946      DOUBLE PRECISION   ONE, ZERO
32947      PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0 )
32948*     ..
32949*     .. Local Scalars ..
32950      INTEGER            I, J, L
32951*     ..
32952*     .. Intrinsic Functions ..
32953      INTRINSIC          DBLE, DCMPLX, DIMAG
32954*     ..
32955*     .. External Subroutines ..
32956      EXTERNAL           DGEMM
32957*     ..
32958*     .. Executable Statements ..
32959*
32960*     Quick return if possible.
32961*
32962      IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) )
32963     $   RETURN
32964*
32965      DO 20 J = 1, N
32966         DO 10 I = 1, M
32967            RWORK( ( J-1 )*M+I ) = DBLE( B( I, J ) )
32968   10    CONTINUE
32969   20 CONTINUE
32970*
32971      L = M*N + 1
32972      CALL DGEMM( 'N', 'N', M, N, M, ONE, A, LDA, RWORK, M, ZERO,
32973     $            RWORK( L ), M )
32974      DO 40 J = 1, N
32975         DO 30 I = 1, M
32976            C( I, J ) = RWORK( L+( J-1 )*M+I-1 )
32977   30    CONTINUE
32978   40 CONTINUE
32979*
32980      DO 60 J = 1, N
32981         DO 50 I = 1, M
32982            RWORK( ( J-1 )*M+I ) = DIMAG( B( I, J ) )
32983   50    CONTINUE
32984   60 CONTINUE
32985      CALL DGEMM( 'N', 'N', M, N, M, ONE, A, LDA, RWORK, M, ZERO,
32986     $            RWORK( L ), M )
32987      DO 80 J = 1, N
32988         DO 70 I = 1, M
32989            C( I, J ) = DCMPLX( DBLE( C( I, J ) ),
32990     $                  RWORK( L+( J-1 )*M+I-1 ) )
32991   70    CONTINUE
32992   80 CONTINUE
32993*
32994      RETURN
32995*
32996*     End of ZLARCM
32997*
32998      END
32999*> \brief \b ZLARF applies an elementary reflector to a general rectangular matrix.
33000*
33001*  =========== DOCUMENTATION ===========
33002*
33003* Online html documentation available at
33004*            http://www.netlib.org/lapack/explore-html/
33005*
33006*> \htmlonly
33007*> Download ZLARF + dependencies
33008*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlarf.f">
33009*> [TGZ]</a>
33010*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlarf.f">
33011*> [ZIP]</a>
33012*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlarf.f">
33013*> [TXT]</a>
33014*> \endhtmlonly
33015*
33016*  Definition:
33017*  ===========
33018*
33019*       SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
33020*
33021*       .. Scalar Arguments ..
33022*       CHARACTER          SIDE
33023*       INTEGER            INCV, LDC, M, N
33024*       COMPLEX*16         TAU
33025*       ..
33026*       .. Array Arguments ..
33027*       COMPLEX*16         C( LDC, * ), V( * ), WORK( * )
33028*       ..
33029*
33030*
33031*> \par Purpose:
33032*  =============
33033*>
33034*> \verbatim
33035*>
33036*> ZLARF applies a complex elementary reflector H to a complex M-by-N
33037*> matrix C, from either the left or the right. H is represented in the
33038*> form
33039*>
33040*>       H = I - tau * v * v**H
33041*>
33042*> where tau is a complex scalar and v is a complex vector.
33043*>
33044*> If tau = 0, then H is taken to be the unit matrix.
33045*>
33046*> To apply H**H, supply conjg(tau) instead
33047*> tau.
33048*> \endverbatim
33049*
33050*  Arguments:
33051*  ==========
33052*
33053*> \param[in] SIDE
33054*> \verbatim
33055*>          SIDE is CHARACTER*1
33056*>          = 'L': form  H * C
33057*>          = 'R': form  C * H
33058*> \endverbatim
33059*>
33060*> \param[in] M
33061*> \verbatim
33062*>          M is INTEGER
33063*>          The number of rows of the matrix C.
33064*> \endverbatim
33065*>
33066*> \param[in] N
33067*> \verbatim
33068*>          N is INTEGER
33069*>          The number of columns of the matrix C.
33070*> \endverbatim
33071*>
33072*> \param[in] V
33073*> \verbatim
33074*>          V is COMPLEX*16 array, dimension
33075*>                     (1 + (M-1)*abs(INCV)) if SIDE = 'L'
33076*>                  or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
33077*>          The vector v in the representation of H. V is not used if
33078*>          TAU = 0.
33079*> \endverbatim
33080*>
33081*> \param[in] INCV
33082*> \verbatim
33083*>          INCV is INTEGER
33084*>          The increment between elements of v. INCV <> 0.
33085*> \endverbatim
33086*>
33087*> \param[in] TAU
33088*> \verbatim
33089*>          TAU is COMPLEX*16
33090*>          The value tau in the representation of H.
33091*> \endverbatim
33092*>
33093*> \param[in,out] C
33094*> \verbatim
33095*>          C is COMPLEX*16 array, dimension (LDC,N)
33096*>          On entry, the M-by-N matrix C.
33097*>          On exit, C is overwritten by the matrix H * C if SIDE = 'L',
33098*>          or C * H if SIDE = 'R'.
33099*> \endverbatim
33100*>
33101*> \param[in] LDC
33102*> \verbatim
33103*>          LDC is INTEGER
33104*>          The leading dimension of the array C. LDC >= max(1,M).
33105*> \endverbatim
33106*>
33107*> \param[out] WORK
33108*> \verbatim
33109*>          WORK is COMPLEX*16 array, dimension
33110*>                         (N) if SIDE = 'L'
33111*>                      or (M) if SIDE = 'R'
33112*> \endverbatim
33113*
33114*  Authors:
33115*  ========
33116*
33117*> \author Univ. of Tennessee
33118*> \author Univ. of California Berkeley
33119*> \author Univ. of Colorado Denver
33120*> \author NAG Ltd.
33121*
33122*> \date December 2016
33123*
33124*> \ingroup complex16OTHERauxiliary
33125*
33126*  =====================================================================
33127      SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
33128*
33129*  -- LAPACK auxiliary routine (version 3.7.0) --
33130*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
33131*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
33132*     December 2016
33133*
33134*     .. Scalar Arguments ..
33135      CHARACTER          SIDE
33136      INTEGER            INCV, LDC, M, N
33137      COMPLEX*16         TAU
33138*     ..
33139*     .. Array Arguments ..
33140      COMPLEX*16         C( LDC, * ), V( * ), WORK( * )
33141*     ..
33142*
33143*  =====================================================================
33144*
33145*     .. Parameters ..
33146      COMPLEX*16         ONE, ZERO
33147      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),
33148     $                   ZERO = ( 0.0D+0, 0.0D+0 ) )
33149*     ..
33150*     .. Local Scalars ..
33151      LOGICAL            APPLYLEFT
33152      INTEGER            I, LASTV, LASTC
33153*     ..
33154*     .. External Subroutines ..
33155      EXTERNAL           ZGEMV, ZGERC
33156*     ..
33157*     .. External Functions ..
33158      LOGICAL            LSAME
33159      INTEGER            ILAZLR, ILAZLC
33160      EXTERNAL           LSAME, ILAZLR, ILAZLC
33161*     ..
33162*     .. Executable Statements ..
33163*
33164      APPLYLEFT = LSAME( SIDE, 'L' )
33165      LASTV = 0
33166      LASTC = 0
33167      IF( TAU.NE.ZERO ) THEN
33168*     Set up variables for scanning V.  LASTV begins pointing to the end
33169*     of V.
33170         IF( APPLYLEFT ) THEN
33171            LASTV = M
33172         ELSE
33173            LASTV = N
33174         END IF
33175         IF( INCV.GT.0 ) THEN
33176            I = 1 + (LASTV-1) * INCV
33177         ELSE
33178            I = 1
33179         END IF
33180*     Look for the last non-zero row in V.
33181         DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO )
33182            LASTV = LASTV - 1
33183            I = I - INCV
33184         END DO
33185         IF( APPLYLEFT ) THEN
33186*     Scan for the last non-zero column in C(1:lastv,:).
33187            LASTC = ILAZLC(LASTV, N, C, LDC)
33188         ELSE
33189*     Scan for the last non-zero row in C(:,1:lastv).
33190            LASTC = ILAZLR(M, LASTV, C, LDC)
33191         END IF
33192      END IF
33193*     Note that lastc.eq.0 renders the BLAS operations null; no special
33194*     case is needed at this level.
33195      IF( APPLYLEFT ) THEN
33196*
33197*        Form  H * C
33198*
33199         IF( LASTV.GT.0 ) THEN
33200*
33201*           w(1:lastc,1) := C(1:lastv,1:lastc)**H * v(1:lastv,1)
33202*
33203            CALL ZGEMV( 'Conjugate transpose', LASTV, LASTC, ONE,
33204     $           C, LDC, V, INCV, ZERO, WORK, 1 )
33205*
33206*           C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**H
33207*
33208            CALL ZGERC( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC )
33209         END IF
33210      ELSE
33211*
33212*        Form  C * H
33213*
33214         IF( LASTV.GT.0 ) THEN
33215*
33216*           w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1)
33217*
33218            CALL ZGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC,
33219     $           V, INCV, ZERO, WORK, 1 )
33220*
33221*           C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**H
33222*
33223            CALL ZGERC( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC )
33224         END IF
33225      END IF
33226      RETURN
33227*
33228*     End of ZLARF
33229*
33230      END
33231*> \brief \b ZLARFB applies a block reflector or its conjugate-transpose to a general rectangular matrix.
33232*
33233*  =========== DOCUMENTATION ===========
33234*
33235* Online html documentation available at
33236*            http://www.netlib.org/lapack/explore-html/
33237*
33238*> \htmlonly
33239*> Download ZLARFB + dependencies
33240*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlarfb.f">
33241*> [TGZ]</a>
33242*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlarfb.f">
33243*> [ZIP]</a>
33244*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlarfb.f">
33245*> [TXT]</a>
33246*> \endhtmlonly
33247*
33248*  Definition:
33249*  ===========
33250*
33251*       SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
33252*                          T, LDT, C, LDC, WORK, LDWORK )
33253*
33254*       .. Scalar Arguments ..
33255*       CHARACTER          DIRECT, SIDE, STOREV, TRANS
33256*       INTEGER            K, LDC, LDT, LDV, LDWORK, M, N
33257*       ..
33258*       .. Array Arguments ..
33259*       COMPLEX*16         C( LDC, * ), T( LDT, * ), V( LDV, * ),
33260*      $                   WORK( LDWORK, * )
33261*       ..
33262*
33263*
33264*> \par Purpose:
33265*  =============
33266*>
33267*> \verbatim
33268*>
33269*> ZLARFB applies a complex block reflector H or its transpose H**H to a
33270*> complex M-by-N matrix C, from either the left or the right.
33271*> \endverbatim
33272*
33273*  Arguments:
33274*  ==========
33275*
33276*> \param[in] SIDE
33277*> \verbatim
33278*>          SIDE is CHARACTER*1
33279*>          = 'L': apply H or H**H from the Left
33280*>          = 'R': apply H or H**H from the Right
33281*> \endverbatim
33282*>
33283*> \param[in] TRANS
33284*> \verbatim
33285*>          TRANS is CHARACTER*1
33286*>          = 'N': apply H (No transpose)
33287*>          = 'C': apply H**H (Conjugate transpose)
33288*> \endverbatim
33289*>
33290*> \param[in] DIRECT
33291*> \verbatim
33292*>          DIRECT is CHARACTER*1
33293*>          Indicates how H is formed from a product of elementary
33294*>          reflectors
33295*>          = 'F': H = H(1) H(2) . . . H(k) (Forward)
33296*>          = 'B': H = H(k) . . . H(2) H(1) (Backward)
33297*> \endverbatim
33298*>
33299*> \param[in] STOREV
33300*> \verbatim
33301*>          STOREV is CHARACTER*1
33302*>          Indicates how the vectors which define the elementary
33303*>          reflectors are stored:
33304*>          = 'C': Columnwise
33305*>          = 'R': Rowwise
33306*> \endverbatim
33307*>
33308*> \param[in] M
33309*> \verbatim
33310*>          M is INTEGER
33311*>          The number of rows of the matrix C.
33312*> \endverbatim
33313*>
33314*> \param[in] N
33315*> \verbatim
33316*>          N is INTEGER
33317*>          The number of columns of the matrix C.
33318*> \endverbatim
33319*>
33320*> \param[in] K
33321*> \verbatim
33322*>          K is INTEGER
33323*>          The order of the matrix T (= the number of elementary
33324*>          reflectors whose product defines the block reflector).
33325*>          If SIDE = 'L', M >= K >= 0;
33326*>          if SIDE = 'R', N >= K >= 0.
33327*> \endverbatim
33328*>
33329*> \param[in] V
33330*> \verbatim
33331*>          V is COMPLEX*16 array, dimension
33332*>                                (LDV,K) if STOREV = 'C'
33333*>                                (LDV,M) if STOREV = 'R' and SIDE = 'L'
33334*>                                (LDV,N) if STOREV = 'R' and SIDE = 'R'
33335*>          See Further Details.
33336*> \endverbatim
33337*>
33338*> \param[in] LDV
33339*> \verbatim
33340*>          LDV is INTEGER
33341*>          The leading dimension of the array V.
33342*>          If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);
33343*>          if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
33344*>          if STOREV = 'R', LDV >= K.
33345*> \endverbatim
33346*>
33347*> \param[in] T
33348*> \verbatim
33349*>          T is COMPLEX*16 array, dimension (LDT,K)
33350*>          The triangular K-by-K matrix T in the representation of the
33351*>          block reflector.
33352*> \endverbatim
33353*>
33354*> \param[in] LDT
33355*> \verbatim
33356*>          LDT is INTEGER
33357*>          The leading dimension of the array T. LDT >= K.
33358*> \endverbatim
33359*>
33360*> \param[in,out] C
33361*> \verbatim
33362*>          C is COMPLEX*16 array, dimension (LDC,N)
33363*>          On entry, the M-by-N matrix C.
33364*>          On exit, C is overwritten by H*C or H**H*C or C*H or C*H**H.
33365*> \endverbatim
33366*>
33367*> \param[in] LDC
33368*> \verbatim
33369*>          LDC is INTEGER
33370*>          The leading dimension of the array C. LDC >= max(1,M).
33371*> \endverbatim
33372*>
33373*> \param[out] WORK
33374*> \verbatim
33375*>          WORK is COMPLEX*16 array, dimension (LDWORK,K)
33376*> \endverbatim
33377*>
33378*> \param[in] LDWORK
33379*> \verbatim
33380*>          LDWORK is INTEGER
33381*>          The leading dimension of the array WORK.
33382*>          If SIDE = 'L', LDWORK >= max(1,N);
33383*>          if SIDE = 'R', LDWORK >= max(1,M).
33384*> \endverbatim
33385*
33386*  Authors:
33387*  ========
33388*
33389*> \author Univ. of Tennessee
33390*> \author Univ. of California Berkeley
33391*> \author Univ. of Colorado Denver
33392*> \author NAG Ltd.
33393*
33394*> \date June 2013
33395*
33396*> \ingroup complex16OTHERauxiliary
33397*
33398*> \par Further Details:
33399*  =====================
33400*>
33401*> \verbatim
33402*>
33403*>  The shape of the matrix V and the storage of the vectors which define
33404*>  the H(i) is best illustrated by the following example with n = 5 and
33405*>  k = 3. The elements equal to 1 are not stored; the corresponding
33406*>  array elements are modified but restored on exit. The rest of the
33407*>  array is not used.
33408*>
33409*>  DIRECT = 'F' and STOREV = 'C':         DIRECT = 'F' and STOREV = 'R':
33410*>
33411*>               V = (  1       )                 V = (  1 v1 v1 v1 v1 )
33412*>                   ( v1  1    )                     (     1 v2 v2 v2 )
33413*>                   ( v1 v2  1 )                     (        1 v3 v3 )
33414*>                   ( v1 v2 v3 )
33415*>                   ( v1 v2 v3 )
33416*>
33417*>  DIRECT = 'B' and STOREV = 'C':         DIRECT = 'B' and STOREV = 'R':
33418*>
33419*>               V = ( v1 v2 v3 )                 V = ( v1 v1  1       )
33420*>                   ( v1 v2 v3 )                     ( v2 v2 v2  1    )
33421*>                   (  1 v2 v3 )                     ( v3 v3 v3 v3  1 )
33422*>                   (     1 v3 )
33423*>                   (        1 )
33424*> \endverbatim
33425*>
33426*  =====================================================================
33427      SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
33428     $                   T, LDT, C, LDC, WORK, LDWORK )
33429*
33430*  -- LAPACK auxiliary routine (version 3.7.0) --
33431*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
33432*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
33433*     June 2013
33434*
33435*     .. Scalar Arguments ..
33436      CHARACTER          DIRECT, SIDE, STOREV, TRANS
33437      INTEGER            K, LDC, LDT, LDV, LDWORK, M, N
33438*     ..
33439*     .. Array Arguments ..
33440      COMPLEX*16         C( LDC, * ), T( LDT, * ), V( LDV, * ),
33441     $                   WORK( LDWORK, * )
33442*     ..
33443*
33444*  =====================================================================
33445*
33446*     .. Parameters ..
33447      COMPLEX*16         ONE
33448      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
33449*     ..
33450*     .. Local Scalars ..
33451      CHARACTER          TRANST
33452      INTEGER            I, J
33453*     ..
33454*     .. External Functions ..
33455      LOGICAL            LSAME
33456      EXTERNAL           LSAME
33457*     ..
33458*     .. External Subroutines ..
33459      EXTERNAL           ZCOPY, ZGEMM, ZLACGV, ZTRMM
33460*     ..
33461*     .. Intrinsic Functions ..
33462      INTRINSIC          DCONJG
33463*     ..
33464*     .. Executable Statements ..
33465*
33466*     Quick return if possible
33467*
33468      IF( M.LE.0 .OR. N.LE.0 )
33469     $   RETURN
33470*
33471      IF( LSAME( TRANS, 'N' ) ) THEN
33472         TRANST = 'C'
33473      ELSE
33474         TRANST = 'N'
33475      END IF
33476*
33477      IF( LSAME( STOREV, 'C' ) ) THEN
33478*
33479         IF( LSAME( DIRECT, 'F' ) ) THEN
33480*
33481*           Let  V =  ( V1 )    (first K rows)
33482*                     ( V2 )
33483*           where  V1  is unit lower triangular.
33484*
33485            IF( LSAME( SIDE, 'L' ) ) THEN
33486*
33487*              Form  H * C  or  H**H * C  where  C = ( C1 )
33488*                                                    ( C2 )
33489*
33490*              W := C**H * V  =  (C1**H * V1 + C2**H * V2)  (stored in WORK)
33491*
33492*              W := C1**H
33493*
33494               DO 10 J = 1, K
33495                  CALL ZCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
33496                  CALL ZLACGV( N, WORK( 1, J ), 1 )
33497   10          CONTINUE
33498*
33499*              W := W * V1
33500*
33501               CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
33502     $                     K, ONE, V, LDV, WORK, LDWORK )
33503               IF( M.GT.K ) THEN
33504*
33505*                 W := W + C2**H * V2
33506*
33507                  CALL ZGEMM( 'Conjugate transpose', 'No transpose', N,
33508     $                        K, M-K, ONE, C( K+1, 1 ), LDC,
33509     $                        V( K+1, 1 ), LDV, ONE, WORK, LDWORK )
33510               END IF
33511*
33512*              W := W * T**H  or  W * T
33513*
33514               CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
33515     $                     ONE, T, LDT, WORK, LDWORK )
33516*
33517*              C := C - V * W**H
33518*
33519               IF( M.GT.K ) THEN
33520*
33521*                 C2 := C2 - V2 * W**H
33522*
33523                  CALL ZGEMM( 'No transpose', 'Conjugate transpose',
33524     $                        M-K, N, K, -ONE, V( K+1, 1 ), LDV, WORK,
33525     $                        LDWORK, ONE, C( K+1, 1 ), LDC )
33526               END IF
33527*
33528*              W := W * V1**H
33529*
33530               CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
33531     $                     'Unit', N, K, ONE, V, LDV, WORK, LDWORK )
33532*
33533*              C1 := C1 - W**H
33534*
33535               DO 30 J = 1, K
33536                  DO 20 I = 1, N
33537                     C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) )
33538   20             CONTINUE
33539   30          CONTINUE
33540*
33541            ELSE IF( LSAME( SIDE, 'R' ) ) THEN
33542*
33543*              Form  C * H  or  C * H**H  where  C = ( C1  C2 )
33544*
33545*              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
33546*
33547*              W := C1
33548*
33549               DO 40 J = 1, K
33550                  CALL ZCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
33551   40          CONTINUE
33552*
33553*              W := W * V1
33554*
33555               CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
33556     $                     K, ONE, V, LDV, WORK, LDWORK )
33557               IF( N.GT.K ) THEN
33558*
33559*                 W := W + C2 * V2
33560*
33561                  CALL ZGEMM( 'No transpose', 'No transpose', M, K, N-K,
33562     $                        ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
33563     $                        ONE, WORK, LDWORK )
33564               END IF
33565*
33566*              W := W * T  or  W * T**H
33567*
33568               CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
33569     $                     ONE, T, LDT, WORK, LDWORK )
33570*
33571*              C := C - W * V**H
33572*
33573               IF( N.GT.K ) THEN
33574*
33575*                 C2 := C2 - W * V2**H
33576*
33577                  CALL ZGEMM( 'No transpose', 'Conjugate transpose', M,
33578     $                        N-K, K, -ONE, WORK, LDWORK, V( K+1, 1 ),
33579     $                        LDV, ONE, C( 1, K+1 ), LDC )
33580               END IF
33581*
33582*              W := W * V1**H
33583*
33584               CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
33585     $                     'Unit', M, K, ONE, V, LDV, WORK, LDWORK )
33586*
33587*              C1 := C1 - W
33588*
33589               DO 60 J = 1, K
33590                  DO 50 I = 1, M
33591                     C( I, J ) = C( I, J ) - WORK( I, J )
33592   50             CONTINUE
33593   60          CONTINUE
33594            END IF
33595*
33596         ELSE
33597*
33598*           Let  V =  ( V1 )
33599*                     ( V2 )    (last K rows)
33600*           where  V2  is unit upper triangular.
33601*
33602            IF( LSAME( SIDE, 'L' ) ) THEN
33603*
33604*              Form  H * C  or  H**H * C  where  C = ( C1 )
33605*                                                    ( C2 )
33606*
33607*              W := C**H * V  =  (C1**H * V1 + C2**H * V2)  (stored in WORK)
33608*
33609*              W := C2**H
33610*
33611               DO 70 J = 1, K
33612                  CALL ZCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
33613                  CALL ZLACGV( N, WORK( 1, J ), 1 )
33614   70          CONTINUE
33615*
33616*              W := W * V2
33617*
33618               CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
33619     $                     K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
33620               IF( M.GT.K ) THEN
33621*
33622*                 W := W + C1**H * V1
33623*
33624                  CALL ZGEMM( 'Conjugate transpose', 'No transpose', N,
33625     $                        K, M-K, ONE, C, LDC, V, LDV, ONE, WORK,
33626     $                        LDWORK )
33627               END IF
33628*
33629*              W := W * T**H  or  W * T
33630*
33631               CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
33632     $                     ONE, T, LDT, WORK, LDWORK )
33633*
33634*              C := C - V * W**H
33635*
33636               IF( M.GT.K ) THEN
33637*
33638*                 C1 := C1 - V1 * W**H
33639*
33640                  CALL ZGEMM( 'No transpose', 'Conjugate transpose',
33641     $                        M-K, N, K, -ONE, V, LDV, WORK, LDWORK,
33642     $                        ONE, C, LDC )
33643               END IF
33644*
33645*              W := W * V2**H
33646*
33647               CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
33648     $                     'Unit', N, K, ONE, V( M-K+1, 1 ), LDV, WORK,
33649     $                     LDWORK )
33650*
33651*              C2 := C2 - W**H
33652*
33653               DO 90 J = 1, K
33654                  DO 80 I = 1, N
33655                     C( M-K+J, I ) = C( M-K+J, I ) -
33656     $                               DCONJG( WORK( I, J ) )
33657   80             CONTINUE
33658   90          CONTINUE
33659*
33660            ELSE IF( LSAME( SIDE, 'R' ) ) THEN
33661*
33662*              Form  C * H  or  C * H**H  where  C = ( C1  C2 )
33663*
33664*              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
33665*
33666*              W := C2
33667*
33668               DO 100 J = 1, K
33669                  CALL ZCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
33670  100          CONTINUE
33671*
33672*              W := W * V2
33673*
33674               CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
33675     $                     K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
33676               IF( N.GT.K ) THEN
33677*
33678*                 W := W + C1 * V1
33679*
33680                  CALL ZGEMM( 'No transpose', 'No transpose', M, K, N-K,
33681     $                        ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
33682               END IF
33683*
33684*              W := W * T  or  W * T**H
33685*
33686               CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
33687     $                     ONE, T, LDT, WORK, LDWORK )
33688*
33689*              C := C - W * V**H
33690*
33691               IF( N.GT.K ) THEN
33692*
33693*                 C1 := C1 - W * V1**H
33694*
33695                  CALL ZGEMM( 'No transpose', 'Conjugate transpose', M,
33696     $                        N-K, K, -ONE, WORK, LDWORK, V, LDV, ONE,
33697     $                        C, LDC )
33698               END IF
33699*
33700*              W := W * V2**H
33701*
33702               CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
33703     $                     'Unit', M, K, ONE, V( N-K+1, 1 ), LDV, WORK,
33704     $                     LDWORK )
33705*
33706*              C2 := C2 - W
33707*
33708               DO 120 J = 1, K
33709                  DO 110 I = 1, M
33710                     C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
33711  110             CONTINUE
33712  120          CONTINUE
33713            END IF
33714         END IF
33715*
33716      ELSE IF( LSAME( STOREV, 'R' ) ) THEN
33717*
33718         IF( LSAME( DIRECT, 'F' ) ) THEN
33719*
33720*           Let  V =  ( V1  V2 )    (V1: first K columns)
33721*           where  V1  is unit upper triangular.
33722*
33723            IF( LSAME( SIDE, 'L' ) ) THEN
33724*
33725*              Form  H * C  or  H**H * C  where  C = ( C1 )
33726*                                                    ( C2 )
33727*
33728*              W := C**H * V**H  =  (C1**H * V1**H + C2**H * V2**H) (stored in WORK)
33729*
33730*              W := C1**H
33731*
33732               DO 130 J = 1, K
33733                  CALL ZCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
33734                  CALL ZLACGV( N, WORK( 1, J ), 1 )
33735  130          CONTINUE
33736*
33737*              W := W * V1**H
33738*
33739               CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
33740     $                     'Unit', N, K, ONE, V, LDV, WORK, LDWORK )
33741               IF( M.GT.K ) THEN
33742*
33743*                 W := W + C2**H * V2**H
33744*
33745                  CALL ZGEMM( 'Conjugate transpose',
33746     $                        'Conjugate transpose', N, K, M-K, ONE,
33747     $                        C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE,
33748     $                        WORK, LDWORK )
33749               END IF
33750*
33751*              W := W * T**H  or  W * T
33752*
33753               CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
33754     $                     ONE, T, LDT, WORK, LDWORK )
33755*
33756*              C := C - V**H * W**H
33757*
33758               IF( M.GT.K ) THEN
33759*
33760*                 C2 := C2 - V2**H * W**H
33761*
33762                  CALL ZGEMM( 'Conjugate transpose',
33763     $                        'Conjugate transpose', M-K, N, K, -ONE,
33764     $                        V( 1, K+1 ), LDV, WORK, LDWORK, ONE,
33765     $                        C( K+1, 1 ), LDC )
33766               END IF
33767*
33768*              W := W * V1
33769*
33770               CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
33771     $                     K, ONE, V, LDV, WORK, LDWORK )
33772*
33773*              C1 := C1 - W**H
33774*
33775               DO 150 J = 1, K
33776                  DO 140 I = 1, N
33777                     C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) )
33778  140             CONTINUE
33779  150          CONTINUE
33780*
33781            ELSE IF( LSAME( SIDE, 'R' ) ) THEN
33782*
33783*              Form  C * H  or  C * H**H  where  C = ( C1  C2 )
33784*
33785*              W := C * V**H  =  (C1*V1**H + C2*V2**H)  (stored in WORK)
33786*
33787*              W := C1
33788*
33789               DO 160 J = 1, K
33790                  CALL ZCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
33791  160          CONTINUE
33792*
33793*              W := W * V1**H
33794*
33795               CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
33796     $                     'Unit', M, K, ONE, V, LDV, WORK, LDWORK )
33797               IF( N.GT.K ) THEN
33798*
33799*                 W := W + C2 * V2**H
33800*
33801                  CALL ZGEMM( 'No transpose', 'Conjugate transpose', M,
33802     $                        K, N-K, ONE, C( 1, K+1 ), LDC,
33803     $                        V( 1, K+1 ), LDV, ONE, WORK, LDWORK )
33804               END IF
33805*
33806*              W := W * T  or  W * T**H
33807*
33808               CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
33809     $                     ONE, T, LDT, WORK, LDWORK )
33810*
33811*              C := C - W * V
33812*
33813               IF( N.GT.K ) THEN
33814*
33815*                 C2 := C2 - W * V2
33816*
33817                  CALL ZGEMM( 'No transpose', 'No transpose', M, N-K, K,
33818     $                        -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE,
33819     $                        C( 1, K+1 ), LDC )
33820               END IF
33821*
33822*              W := W * V1
33823*
33824               CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
33825     $                     K, ONE, V, LDV, WORK, LDWORK )
33826*
33827*              C1 := C1 - W
33828*
33829               DO 180 J = 1, K
33830                  DO 170 I = 1, M
33831                     C( I, J ) = C( I, J ) - WORK( I, J )
33832  170             CONTINUE
33833  180          CONTINUE
33834*
33835            END IF
33836*
33837         ELSE
33838*
33839*           Let  V =  ( V1  V2 )    (V2: last K columns)
33840*           where  V2  is unit lower triangular.
33841*
33842            IF( LSAME( SIDE, 'L' ) ) THEN
33843*
33844*              Form  H * C  or  H**H * C  where  C = ( C1 )
33845*                                                    ( C2 )
33846*
33847*              W := C**H * V**H  =  (C1**H * V1**H + C2**H * V2**H) (stored in WORK)
33848*
33849*              W := C2**H
33850*
33851               DO 190 J = 1, K
33852                  CALL ZCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
33853                  CALL ZLACGV( N, WORK( 1, J ), 1 )
33854  190          CONTINUE
33855*
33856*              W := W * V2**H
33857*
33858               CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
33859     $                     'Unit', N, K, ONE, V( 1, M-K+1 ), LDV, WORK,
33860     $                     LDWORK )
33861               IF( M.GT.K ) THEN
33862*
33863*                 W := W + C1**H * V1**H
33864*
33865                  CALL ZGEMM( 'Conjugate transpose',
33866     $                        'Conjugate transpose', N, K, M-K, ONE, C,
33867     $                        LDC, V, LDV, ONE, WORK, LDWORK )
33868               END IF
33869*
33870*              W := W * T**H  or  W * T
33871*
33872               CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
33873     $                     ONE, T, LDT, WORK, LDWORK )
33874*
33875*              C := C - V**H * W**H
33876*
33877               IF( M.GT.K ) THEN
33878*
33879*                 C1 := C1 - V1**H * W**H
33880*
33881                  CALL ZGEMM( 'Conjugate transpose',
33882     $                        'Conjugate transpose', M-K, N, K, -ONE, V,
33883     $                        LDV, WORK, LDWORK, ONE, C, LDC )
33884               END IF
33885*
33886*              W := W * V2
33887*
33888               CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
33889     $                     K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
33890*
33891*              C2 := C2 - W**H
33892*
33893               DO 210 J = 1, K
33894                  DO 200 I = 1, N
33895                     C( M-K+J, I ) = C( M-K+J, I ) -
33896     $                               DCONJG( WORK( I, J ) )
33897  200             CONTINUE
33898  210          CONTINUE
33899*
33900            ELSE IF( LSAME( SIDE, 'R' ) ) THEN
33901*
33902*              Form  C * H  or  C * H**H  where  C = ( C1  C2 )
33903*
33904*              W := C * V**H  =  (C1*V1**H + C2*V2**H)  (stored in WORK)
33905*
33906*              W := C2
33907*
33908               DO 220 J = 1, K
33909                  CALL ZCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
33910  220          CONTINUE
33911*
33912*              W := W * V2**H
33913*
33914               CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
33915     $                     'Unit', M, K, ONE, V( 1, N-K+1 ), LDV, WORK,
33916     $                     LDWORK )
33917               IF( N.GT.K ) THEN
33918*
33919*                 W := W + C1 * V1**H
33920*
33921                  CALL ZGEMM( 'No transpose', 'Conjugate transpose', M,
33922     $                        K, N-K, ONE, C, LDC, V, LDV, ONE, WORK,
33923     $                        LDWORK )
33924               END IF
33925*
33926*              W := W * T  or  W * T**H
33927*
33928               CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
33929     $                     ONE, T, LDT, WORK, LDWORK )
33930*
33931*              C := C - W * V
33932*
33933               IF( N.GT.K ) THEN
33934*
33935*                 C1 := C1 - W * V1
33936*
33937                  CALL ZGEMM( 'No transpose', 'No transpose', M, N-K, K,
33938     $                        -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
33939               END IF
33940*
33941*              W := W * V2
33942*
33943               CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
33944     $                     K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
33945*
33946*              C1 := C1 - W
33947*
33948               DO 240 J = 1, K
33949                  DO 230 I = 1, M
33950                     C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
33951  230             CONTINUE
33952  240          CONTINUE
33953*
33954            END IF
33955*
33956         END IF
33957      END IF
33958*
33959      RETURN
33960*
33961*     End of ZLARFB
33962*
33963      END
33964*> \brief \b ZLARFG generates an elementary reflector (Householder matrix).
33965*
33966*  =========== DOCUMENTATION ===========
33967*
33968* Online html documentation available at
33969*            http://www.netlib.org/lapack/explore-html/
33970*
33971*> \htmlonly
33972*> Download ZLARFG + dependencies
33973*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlarfg.f">
33974*> [TGZ]</a>
33975*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlarfg.f">
33976*> [ZIP]</a>
33977*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlarfg.f">
33978*> [TXT]</a>
33979*> \endhtmlonly
33980*
33981*  Definition:
33982*  ===========
33983*
33984*       SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU )
33985*
33986*       .. Scalar Arguments ..
33987*       INTEGER            INCX, N
33988*       COMPLEX*16         ALPHA, TAU
33989*       ..
33990*       .. Array Arguments ..
33991*       COMPLEX*16         X( * )
33992*       ..
33993*
33994*
33995*> \par Purpose:
33996*  =============
33997*>
33998*> \verbatim
33999*>
34000*> ZLARFG generates a complex elementary reflector H of order n, such
34001*> that
34002*>
34003*>       H**H * ( alpha ) = ( beta ),   H**H * H = I.
34004*>              (   x   )   (   0  )
34005*>
34006*> where alpha and beta are scalars, with beta real, and x is an
34007*> (n-1)-element complex vector. H is represented in the form
34008*>
34009*>       H = I - tau * ( 1 ) * ( 1 v**H ) ,
34010*>                     ( v )
34011*>
34012*> where tau is a complex scalar and v is a complex (n-1)-element
34013*> vector. Note that H is not hermitian.
34014*>
34015*> If the elements of x are all zero and alpha is real, then tau = 0
34016*> and H is taken to be the unit matrix.
34017*>
34018*> Otherwise  1 <= real(tau) <= 2  and  abs(tau-1) <= 1 .
34019*> \endverbatim
34020*
34021*  Arguments:
34022*  ==========
34023*
34024*> \param[in] N
34025*> \verbatim
34026*>          N is INTEGER
34027*>          The order of the elementary reflector.
34028*> \endverbatim
34029*>
34030*> \param[in,out] ALPHA
34031*> \verbatim
34032*>          ALPHA is COMPLEX*16
34033*>          On entry, the value alpha.
34034*>          On exit, it is overwritten with the value beta.
34035*> \endverbatim
34036*>
34037*> \param[in,out] X
34038*> \verbatim
34039*>          X is COMPLEX*16 array, dimension
34040*>                         (1+(N-2)*abs(INCX))
34041*>          On entry, the vector x.
34042*>          On exit, it is overwritten with the vector v.
34043*> \endverbatim
34044*>
34045*> \param[in] INCX
34046*> \verbatim
34047*>          INCX is INTEGER
34048*>          The increment between elements of X. INCX > 0.
34049*> \endverbatim
34050*>
34051*> \param[out] TAU
34052*> \verbatim
34053*>          TAU is COMPLEX*16
34054*>          The value tau.
34055*> \endverbatim
34056*
34057*  Authors:
34058*  ========
34059*
34060*> \author Univ. of Tennessee
34061*> \author Univ. of California Berkeley
34062*> \author Univ. of Colorado Denver
34063*> \author NAG Ltd.
34064*
34065*> \date November 2017
34066*
34067*> \ingroup complex16OTHERauxiliary
34068*
34069*  =====================================================================
34070      SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU )
34071*
34072*  -- LAPACK auxiliary routine (version 3.8.0) --
34073*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
34074*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
34075*     November 2017
34076*
34077*     .. Scalar Arguments ..
34078      INTEGER            INCX, N
34079      COMPLEX*16         ALPHA, TAU
34080*     ..
34081*     .. Array Arguments ..
34082      COMPLEX*16         X( * )
34083*     ..
34084*
34085*  =====================================================================
34086*
34087*     .. Parameters ..
34088      DOUBLE PRECISION   ONE, ZERO
34089      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
34090*     ..
34091*     .. Local Scalars ..
34092      INTEGER            J, KNT
34093      DOUBLE PRECISION   ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM
34094*     ..
34095*     .. External Functions ..
34096      DOUBLE PRECISION   DLAMCH, DLAPY3, DZNRM2
34097      COMPLEX*16         ZLADIV
34098      EXTERNAL           DLAMCH, DLAPY3, DZNRM2, ZLADIV
34099*     ..
34100*     .. Intrinsic Functions ..
34101      INTRINSIC          ABS, DBLE, DCMPLX, DIMAG, SIGN
34102*     ..
34103*     .. External Subroutines ..
34104      EXTERNAL           ZDSCAL, ZSCAL
34105*     ..
34106*     .. Executable Statements ..
34107*
34108      IF( N.LE.0 ) THEN
34109         TAU = ZERO
34110         RETURN
34111      END IF
34112*
34113      XNORM = DZNRM2( N-1, X, INCX )
34114      ALPHR = DBLE( ALPHA )
34115      ALPHI = DIMAG( ALPHA )
34116*
34117      IF( XNORM.EQ.ZERO .AND. ALPHI.EQ.ZERO ) THEN
34118*
34119*        H  =  I
34120*
34121         TAU = ZERO
34122      ELSE
34123*
34124*        general case
34125*
34126         BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
34127         SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' )
34128         RSAFMN = ONE / SAFMIN
34129*
34130         KNT = 0
34131         IF( ABS( BETA ).LT.SAFMIN ) THEN
34132*
34133*           XNORM, BETA may be inaccurate; scale X and recompute them
34134*
34135   10       CONTINUE
34136            KNT = KNT + 1
34137            CALL ZDSCAL( N-1, RSAFMN, X, INCX )
34138            BETA = BETA*RSAFMN
34139            ALPHI = ALPHI*RSAFMN
34140            ALPHR = ALPHR*RSAFMN
34141            IF( (ABS( BETA ).LT.SAFMIN) .AND. (KNT .LT. 20) )
34142     $         GO TO 10
34143*
34144*           New BETA is at most 1, at least SAFMIN
34145*
34146            XNORM = DZNRM2( N-1, X, INCX )
34147            ALPHA = DCMPLX( ALPHR, ALPHI )
34148            BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
34149         END IF
34150         TAU = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA )
34151         ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA )
34152         CALL ZSCAL( N-1, ALPHA, X, INCX )
34153*
34154*        If ALPHA is subnormal, it may lose relative accuracy
34155*
34156         DO 20 J = 1, KNT
34157            BETA = BETA*SAFMIN
34158 20      CONTINUE
34159         ALPHA = BETA
34160      END IF
34161*
34162      RETURN
34163*
34164*     End of ZLARFG
34165*
34166      END
34167*> \brief \b ZLARFT forms the triangular factor T of a block reflector H = I - vtvH
34168*
34169*  =========== DOCUMENTATION ===========
34170*
34171* Online html documentation available at
34172*            http://www.netlib.org/lapack/explore-html/
34173*
34174*> \htmlonly
34175*> Download ZLARFT + dependencies
34176*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlarft.f">
34177*> [TGZ]</a>
34178*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlarft.f">
34179*> [ZIP]</a>
34180*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlarft.f">
34181*> [TXT]</a>
34182*> \endhtmlonly
34183*
34184*  Definition:
34185*  ===========
34186*
34187*       SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
34188*
34189*       .. Scalar Arguments ..
34190*       CHARACTER          DIRECT, STOREV
34191*       INTEGER            K, LDT, LDV, N
34192*       ..
34193*       .. Array Arguments ..
34194*       COMPLEX*16         T( LDT, * ), TAU( * ), V( LDV, * )
34195*       ..
34196*
34197*
34198*> \par Purpose:
34199*  =============
34200*>
34201*> \verbatim
34202*>
34203*> ZLARFT forms the triangular factor T of a complex block reflector H
34204*> of order n, which is defined as a product of k elementary reflectors.
34205*>
34206*> If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
34207*>
34208*> If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
34209*>
34210*> If STOREV = 'C', the vector which defines the elementary reflector
34211*> H(i) is stored in the i-th column of the array V, and
34212*>
34213*>    H  =  I - V * T * V**H
34214*>
34215*> If STOREV = 'R', the vector which defines the elementary reflector
34216*> H(i) is stored in the i-th row of the array V, and
34217*>
34218*>    H  =  I - V**H * T * V
34219*> \endverbatim
34220*
34221*  Arguments:
34222*  ==========
34223*
34224*> \param[in] DIRECT
34225*> \verbatim
34226*>          DIRECT is CHARACTER*1
34227*>          Specifies the order in which the elementary reflectors are
34228*>          multiplied to form the block reflector:
34229*>          = 'F': H = H(1) H(2) . . . H(k) (Forward)
34230*>          = 'B': H = H(k) . . . H(2) H(1) (Backward)
34231*> \endverbatim
34232*>
34233*> \param[in] STOREV
34234*> \verbatim
34235*>          STOREV is CHARACTER*1
34236*>          Specifies how the vectors which define the elementary
34237*>          reflectors are stored (see also Further Details):
34238*>          = 'C': columnwise
34239*>          = 'R': rowwise
34240*> \endverbatim
34241*>
34242*> \param[in] N
34243*> \verbatim
34244*>          N is INTEGER
34245*>          The order of the block reflector H. N >= 0.
34246*> \endverbatim
34247*>
34248*> \param[in] K
34249*> \verbatim
34250*>          K is INTEGER
34251*>          The order of the triangular factor T (= the number of
34252*>          elementary reflectors). K >= 1.
34253*> \endverbatim
34254*>
34255*> \param[in] V
34256*> \verbatim
34257*>          V is COMPLEX*16 array, dimension
34258*>                               (LDV,K) if STOREV = 'C'
34259*>                               (LDV,N) if STOREV = 'R'
34260*>          The matrix V. See further details.
34261*> \endverbatim
34262*>
34263*> \param[in] LDV
34264*> \verbatim
34265*>          LDV is INTEGER
34266*>          The leading dimension of the array V.
34267*>          If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
34268*> \endverbatim
34269*>
34270*> \param[in] TAU
34271*> \verbatim
34272*>          TAU is COMPLEX*16 array, dimension (K)
34273*>          TAU(i) must contain the scalar factor of the elementary
34274*>          reflector H(i).
34275*> \endverbatim
34276*>
34277*> \param[out] T
34278*> \verbatim
34279*>          T is COMPLEX*16 array, dimension (LDT,K)
34280*>          The k by k triangular factor T of the block reflector.
34281*>          If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
34282*>          lower triangular. The rest of the array is not used.
34283*> \endverbatim
34284*>
34285*> \param[in] LDT
34286*> \verbatim
34287*>          LDT is INTEGER
34288*>          The leading dimension of the array T. LDT >= K.
34289*> \endverbatim
34290*
34291*  Authors:
34292*  ========
34293*
34294*> \author Univ. of Tennessee
34295*> \author Univ. of California Berkeley
34296*> \author Univ. of Colorado Denver
34297*> \author NAG Ltd.
34298*
34299*> \date June 2016
34300*
34301*> \ingroup complex16OTHERauxiliary
34302*
34303*> \par Further Details:
34304*  =====================
34305*>
34306*> \verbatim
34307*>
34308*>  The shape of the matrix V and the storage of the vectors which define
34309*>  the H(i) is best illustrated by the following example with n = 5 and
34310*>  k = 3. The elements equal to 1 are not stored.
34311*>
34312*>  DIRECT = 'F' and STOREV = 'C':         DIRECT = 'F' and STOREV = 'R':
34313*>
34314*>               V = (  1       )                 V = (  1 v1 v1 v1 v1 )
34315*>                   ( v1  1    )                     (     1 v2 v2 v2 )
34316*>                   ( v1 v2  1 )                     (        1 v3 v3 )
34317*>                   ( v1 v2 v3 )
34318*>                   ( v1 v2 v3 )
34319*>
34320*>  DIRECT = 'B' and STOREV = 'C':         DIRECT = 'B' and STOREV = 'R':
34321*>
34322*>               V = ( v1 v2 v3 )                 V = ( v1 v1  1       )
34323*>                   ( v1 v2 v3 )                     ( v2 v2 v2  1    )
34324*>                   (  1 v2 v3 )                     ( v3 v3 v3 v3  1 )
34325*>                   (     1 v3 )
34326*>                   (        1 )
34327*> \endverbatim
34328*>
34329*  =====================================================================
34330      SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
34331*
34332*  -- LAPACK auxiliary routine (version 3.7.0) --
34333*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
34334*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
34335*     June 2016
34336*
34337*     .. Scalar Arguments ..
34338      CHARACTER          DIRECT, STOREV
34339      INTEGER            K, LDT, LDV, N
34340*     ..
34341*     .. Array Arguments ..
34342      COMPLEX*16         T( LDT, * ), TAU( * ), V( LDV, * )
34343*     ..
34344*
34345*  =====================================================================
34346*
34347*     .. Parameters ..
34348      COMPLEX*16         ONE, ZERO
34349      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),
34350     $                   ZERO = ( 0.0D+0, 0.0D+0 ) )
34351*     ..
34352*     .. Local Scalars ..
34353      INTEGER            I, J, PREVLASTV, LASTV
34354*     ..
34355*     .. External Subroutines ..
34356      EXTERNAL           ZGEMV, ZTRMV, ZGEMM
34357*     ..
34358*     .. External Functions ..
34359      LOGICAL            LSAME
34360      EXTERNAL           LSAME
34361*     ..
34362*     .. Executable Statements ..
34363*
34364*     Quick return if possible
34365*
34366      IF( N.EQ.0 )
34367     $   RETURN
34368*
34369      IF( LSAME( DIRECT, 'F' ) ) THEN
34370         PREVLASTV = N
34371         DO I = 1, K
34372            PREVLASTV = MAX( PREVLASTV, I )
34373            IF( TAU( I ).EQ.ZERO ) THEN
34374*
34375*              H(i)  =  I
34376*
34377               DO J = 1, I
34378                  T( J, I ) = ZERO
34379               END DO
34380            ELSE
34381*
34382*              general case
34383*
34384               IF( LSAME( STOREV, 'C' ) ) THEN
34385*                 Skip any trailing zeros.
34386                  DO LASTV = N, I+1, -1
34387                     IF( V( LASTV, I ).NE.ZERO ) EXIT
34388                  END DO
34389                  DO J = 1, I-1
34390                     T( J, I ) = -TAU( I ) * CONJG( V( I , J ) )
34391                  END DO
34392                  J = MIN( LASTV, PREVLASTV )
34393*
34394*                 T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**H * V(i:j,i)
34395*
34396                  CALL ZGEMV( 'Conjugate transpose', J-I, I-1,
34397     $                        -TAU( I ), V( I+1, 1 ), LDV,
34398     $                        V( I+1, I ), 1, ONE, T( 1, I ), 1 )
34399               ELSE
34400*                 Skip any trailing zeros.
34401                  DO LASTV = N, I+1, -1
34402                     IF( V( I, LASTV ).NE.ZERO ) EXIT
34403                  END DO
34404                  DO J = 1, I-1
34405                     T( J, I ) = -TAU( I ) * V( J , I )
34406                  END DO
34407                  J = MIN( LASTV, PREVLASTV )
34408*
34409*                 T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**H
34410*
34411                  CALL ZGEMM( 'N', 'C', I-1, 1, J-I, -TAU( I ),
34412     $                        V( 1, I+1 ), LDV, V( I, I+1 ), LDV,
34413     $                        ONE, T( 1, I ), LDT )
34414               END IF
34415*
34416*              T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i)
34417*
34418               CALL ZTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T,
34419     $                     LDT, T( 1, I ), 1 )
34420               T( I, I ) = TAU( I )
34421               IF( I.GT.1 ) THEN
34422                  PREVLASTV = MAX( PREVLASTV, LASTV )
34423               ELSE
34424                  PREVLASTV = LASTV
34425               END IF
34426             END IF
34427         END DO
34428      ELSE
34429         PREVLASTV = 1
34430         DO I = K, 1, -1
34431            IF( TAU( I ).EQ.ZERO ) THEN
34432*
34433*              H(i)  =  I
34434*
34435               DO J = I, K
34436                  T( J, I ) = ZERO
34437               END DO
34438            ELSE
34439*
34440*              general case
34441*
34442               IF( I.LT.K ) THEN
34443                  IF( LSAME( STOREV, 'C' ) ) THEN
34444*                    Skip any leading zeros.
34445                     DO LASTV = 1, I-1
34446                        IF( V( LASTV, I ).NE.ZERO ) EXIT
34447                     END DO
34448                     DO J = I+1, K
34449                        T( J, I ) = -TAU( I ) * CONJG( V( N-K+I , J ) )
34450                     END DO
34451                     J = MAX( LASTV, PREVLASTV )
34452*
34453*                    T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**H * V(j:n-k+i,i)
34454*
34455                     CALL ZGEMV( 'Conjugate transpose', N-K+I-J, K-I,
34456     $                           -TAU( I ), V( J, I+1 ), LDV, V( J, I ),
34457     $                           1, ONE, T( I+1, I ), 1 )
34458                  ELSE
34459*                    Skip any leading zeros.
34460                     DO LASTV = 1, I-1
34461                        IF( V( I, LASTV ).NE.ZERO ) EXIT
34462                     END DO
34463                     DO J = I+1, K
34464                        T( J, I ) = -TAU( I ) * V( J, N-K+I )
34465                     END DO
34466                     J = MAX( LASTV, PREVLASTV )
34467*
34468*                    T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**H
34469*
34470                     CALL ZGEMM( 'N', 'C', K-I, 1, N-K+I-J, -TAU( I ),
34471     $                           V( I+1, J ), LDV, V( I, J ), LDV,
34472     $                           ONE, T( I+1, I ), LDT )
34473                  END IF
34474*
34475*                 T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i)
34476*
34477                  CALL ZTRMV( 'Lower', 'No transpose', 'Non-unit', K-I,
34478     $                        T( I+1, I+1 ), LDT, T( I+1, I ), 1 )
34479                  IF( I.GT.1 ) THEN
34480                     PREVLASTV = MIN( PREVLASTV, LASTV )
34481                  ELSE
34482                     PREVLASTV = LASTV
34483                  END IF
34484               END IF
34485               T( I, I ) = TAU( I )
34486            END IF
34487         END DO
34488      END IF
34489      RETURN
34490*
34491*     End of ZLARFT
34492*
34493      END
34494*> \brief \b ZLARFX applies an elementary reflector to a general rectangular matrix, with loop unrolling when the reflector has order ≤ 10.
34495*
34496*  =========== DOCUMENTATION ===========
34497*
34498* Online html documentation available at
34499*            http://www.netlib.org/lapack/explore-html/
34500*
34501*> \htmlonly
34502*> Download ZLARFX + dependencies
34503*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlarfx.f">
34504*> [TGZ]</a>
34505*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlarfx.f">
34506*> [ZIP]</a>
34507*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlarfx.f">
34508*> [TXT]</a>
34509*> \endhtmlonly
34510*
34511*  Definition:
34512*  ===========
34513*
34514*       SUBROUTINE ZLARFX( SIDE, M, N, V, TAU, C, LDC, WORK )
34515*
34516*       .. Scalar Arguments ..
34517*       CHARACTER          SIDE
34518*       INTEGER            LDC, M, N
34519*       COMPLEX*16         TAU
34520*       ..
34521*       .. Array Arguments ..
34522*       COMPLEX*16         C( LDC, * ), V( * ), WORK( * )
34523*       ..
34524*
34525*
34526*> \par Purpose:
34527*  =============
34528*>
34529*> \verbatim
34530*>
34531*> ZLARFX applies a complex elementary reflector H to a complex m by n
34532*> matrix C, from either the left or the right. H is represented in the
34533*> form
34534*>
34535*>       H = I - tau * v * v**H
34536*>
34537*> where tau is a complex scalar and v is a complex vector.
34538*>
34539*> If tau = 0, then H is taken to be the unit matrix
34540*>
34541*> This version uses inline code if H has order < 11.
34542*> \endverbatim
34543*
34544*  Arguments:
34545*  ==========
34546*
34547*> \param[in] SIDE
34548*> \verbatim
34549*>          SIDE is CHARACTER*1
34550*>          = 'L': form  H * C
34551*>          = 'R': form  C * H
34552*> \endverbatim
34553*>
34554*> \param[in] M
34555*> \verbatim
34556*>          M is INTEGER
34557*>          The number of rows of the matrix C.
34558*> \endverbatim
34559*>
34560*> \param[in] N
34561*> \verbatim
34562*>          N is INTEGER
34563*>          The number of columns of the matrix C.
34564*> \endverbatim
34565*>
34566*> \param[in] V
34567*> \verbatim
34568*>          V is COMPLEX*16 array, dimension (M) if SIDE = 'L'
34569*>                                        or (N) if SIDE = 'R'
34570*>          The vector v in the representation of H.
34571*> \endverbatim
34572*>
34573*> \param[in] TAU
34574*> \verbatim
34575*>          TAU is COMPLEX*16
34576*>          The value tau in the representation of H.
34577*> \endverbatim
34578*>
34579*> \param[in,out] C
34580*> \verbatim
34581*>          C is COMPLEX*16 array, dimension (LDC,N)
34582*>          On entry, the m by n matrix C.
34583*>          On exit, C is overwritten by the matrix H * C if SIDE = 'L',
34584*>          or C * H if SIDE = 'R'.
34585*> \endverbatim
34586*>
34587*> \param[in] LDC
34588*> \verbatim
34589*>          LDC is INTEGER
34590*>          The leading dimension of the array C. LDC >= max(1,M).
34591*> \endverbatim
34592*>
34593*> \param[out] WORK
34594*> \verbatim
34595*>          WORK is COMPLEX*16 array, dimension (N) if SIDE = 'L'
34596*>                                            or (M) if SIDE = 'R'
34597*>          WORK is not referenced if H has order < 11.
34598*> \endverbatim
34599*
34600*  Authors:
34601*  ========
34602*
34603*> \author Univ. of Tennessee
34604*> \author Univ. of California Berkeley
34605*> \author Univ. of Colorado Denver
34606*> \author NAG Ltd.
34607*
34608*> \date December 2016
34609*
34610*> \ingroup complex16OTHERauxiliary
34611*
34612*  =====================================================================
34613      SUBROUTINE ZLARFX( SIDE, M, N, V, TAU, C, LDC, WORK )
34614*
34615*  -- LAPACK auxiliary routine (version 3.7.0) --
34616*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
34617*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
34618*     December 2016
34619*
34620*     .. Scalar Arguments ..
34621      CHARACTER          SIDE
34622      INTEGER            LDC, M, N
34623      COMPLEX*16         TAU
34624*     ..
34625*     .. Array Arguments ..
34626      COMPLEX*16         C( LDC, * ), V( * ), WORK( * )
34627*     ..
34628*
34629*  =====================================================================
34630*
34631*     .. Parameters ..
34632      COMPLEX*16         ZERO, ONE
34633      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ),
34634     $                   ONE = ( 1.0D+0, 0.0D+0 ) )
34635*     ..
34636*     .. Local Scalars ..
34637      INTEGER            J
34638      COMPLEX*16         SUM, T1, T10, T2, T3, T4, T5, T6, T7, T8, T9,
34639     $                   V1, V10, V2, V3, V4, V5, V6, V7, V8, V9
34640*     ..
34641*     .. External Functions ..
34642      LOGICAL            LSAME
34643      EXTERNAL           LSAME
34644*     ..
34645*     .. External Subroutines ..
34646      EXTERNAL           ZLARF
34647*     ..
34648*     .. Intrinsic Functions ..
34649      INTRINSIC          DCONJG
34650*     ..
34651*     .. Executable Statements ..
34652*
34653      IF( TAU.EQ.ZERO )
34654     $   RETURN
34655      IF( LSAME( SIDE, 'L' ) ) THEN
34656*
34657*        Form  H * C, where H has order m.
34658*
34659         GO TO ( 10, 30, 50, 70, 90, 110, 130, 150,
34660     $           170, 190 )M
34661*
34662*        Code for general M
34663*
34664         CALL ZLARF( SIDE, M, N, V, 1, TAU, C, LDC, WORK )
34665         GO TO 410
34666   10    CONTINUE
34667*
34668*        Special code for 1 x 1 Householder
34669*
34670         T1 = ONE - TAU*V( 1 )*DCONJG( V( 1 ) )
34671         DO 20 J = 1, N
34672            C( 1, J ) = T1*C( 1, J )
34673   20    CONTINUE
34674         GO TO 410
34675   30    CONTINUE
34676*
34677*        Special code for 2 x 2 Householder
34678*
34679         V1 = DCONJG( V( 1 ) )
34680         T1 = TAU*DCONJG( V1 )
34681         V2 = DCONJG( V( 2 ) )
34682         T2 = TAU*DCONJG( V2 )
34683         DO 40 J = 1, N
34684            SUM = V1*C( 1, J ) + V2*C( 2, J )
34685            C( 1, J ) = C( 1, J ) - SUM*T1
34686            C( 2, J ) = C( 2, J ) - SUM*T2
34687   40    CONTINUE
34688         GO TO 410
34689   50    CONTINUE
34690*
34691*        Special code for 3 x 3 Householder
34692*
34693         V1 = DCONJG( V( 1 ) )
34694         T1 = TAU*DCONJG( V1 )
34695         V2 = DCONJG( V( 2 ) )
34696         T2 = TAU*DCONJG( V2 )
34697         V3 = DCONJG( V( 3 ) )
34698         T3 = TAU*DCONJG( V3 )
34699         DO 60 J = 1, N
34700            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J )
34701            C( 1, J ) = C( 1, J ) - SUM*T1
34702            C( 2, J ) = C( 2, J ) - SUM*T2
34703            C( 3, J ) = C( 3, J ) - SUM*T3
34704   60    CONTINUE
34705         GO TO 410
34706   70    CONTINUE
34707*
34708*        Special code for 4 x 4 Householder
34709*
34710         V1 = DCONJG( V( 1 ) )
34711         T1 = TAU*DCONJG( V1 )
34712         V2 = DCONJG( V( 2 ) )
34713         T2 = TAU*DCONJG( V2 )
34714         V3 = DCONJG( V( 3 ) )
34715         T3 = TAU*DCONJG( V3 )
34716         V4 = DCONJG( V( 4 ) )
34717         T4 = TAU*DCONJG( V4 )
34718         DO 80 J = 1, N
34719            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
34720     $            V4*C( 4, J )
34721            C( 1, J ) = C( 1, J ) - SUM*T1
34722            C( 2, J ) = C( 2, J ) - SUM*T2
34723            C( 3, J ) = C( 3, J ) - SUM*T3
34724            C( 4, J ) = C( 4, J ) - SUM*T4
34725   80    CONTINUE
34726         GO TO 410
34727   90    CONTINUE
34728*
34729*        Special code for 5 x 5 Householder
34730*
34731         V1 = DCONJG( V( 1 ) )
34732         T1 = TAU*DCONJG( V1 )
34733         V2 = DCONJG( V( 2 ) )
34734         T2 = TAU*DCONJG( V2 )
34735         V3 = DCONJG( V( 3 ) )
34736         T3 = TAU*DCONJG( V3 )
34737         V4 = DCONJG( V( 4 ) )
34738         T4 = TAU*DCONJG( V4 )
34739         V5 = DCONJG( V( 5 ) )
34740         T5 = TAU*DCONJG( V5 )
34741         DO 100 J = 1, N
34742            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
34743     $            V4*C( 4, J ) + V5*C( 5, J )
34744            C( 1, J ) = C( 1, J ) - SUM*T1
34745            C( 2, J ) = C( 2, J ) - SUM*T2
34746            C( 3, J ) = C( 3, J ) - SUM*T3
34747            C( 4, J ) = C( 4, J ) - SUM*T4
34748            C( 5, J ) = C( 5, J ) - SUM*T5
34749  100    CONTINUE
34750         GO TO 410
34751  110    CONTINUE
34752*
34753*        Special code for 6 x 6 Householder
34754*
34755         V1 = DCONJG( V( 1 ) )
34756         T1 = TAU*DCONJG( V1 )
34757         V2 = DCONJG( V( 2 ) )
34758         T2 = TAU*DCONJG( V2 )
34759         V3 = DCONJG( V( 3 ) )
34760         T3 = TAU*DCONJG( V3 )
34761         V4 = DCONJG( V( 4 ) )
34762         T4 = TAU*DCONJG( V4 )
34763         V5 = DCONJG( V( 5 ) )
34764         T5 = TAU*DCONJG( V5 )
34765         V6 = DCONJG( V( 6 ) )
34766         T6 = TAU*DCONJG( V6 )
34767         DO 120 J = 1, N
34768            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
34769     $            V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J )
34770            C( 1, J ) = C( 1, J ) - SUM*T1
34771            C( 2, J ) = C( 2, J ) - SUM*T2
34772            C( 3, J ) = C( 3, J ) - SUM*T3
34773            C( 4, J ) = C( 4, J ) - SUM*T4
34774            C( 5, J ) = C( 5, J ) - SUM*T5
34775            C( 6, J ) = C( 6, J ) - SUM*T6
34776  120    CONTINUE
34777         GO TO 410
34778  130    CONTINUE
34779*
34780*        Special code for 7 x 7 Householder
34781*
34782         V1 = DCONJG( V( 1 ) )
34783         T1 = TAU*DCONJG( V1 )
34784         V2 = DCONJG( V( 2 ) )
34785         T2 = TAU*DCONJG( V2 )
34786         V3 = DCONJG( V( 3 ) )
34787         T3 = TAU*DCONJG( V3 )
34788         V4 = DCONJG( V( 4 ) )
34789         T4 = TAU*DCONJG( V4 )
34790         V5 = DCONJG( V( 5 ) )
34791         T5 = TAU*DCONJG( V5 )
34792         V6 = DCONJG( V( 6 ) )
34793         T6 = TAU*DCONJG( V6 )
34794         V7 = DCONJG( V( 7 ) )
34795         T7 = TAU*DCONJG( V7 )
34796         DO 140 J = 1, N
34797            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
34798     $            V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
34799     $            V7*C( 7, J )
34800            C( 1, J ) = C( 1, J ) - SUM*T1
34801            C( 2, J ) = C( 2, J ) - SUM*T2
34802            C( 3, J ) = C( 3, J ) - SUM*T3
34803            C( 4, J ) = C( 4, J ) - SUM*T4
34804            C( 5, J ) = C( 5, J ) - SUM*T5
34805            C( 6, J ) = C( 6, J ) - SUM*T6
34806            C( 7, J ) = C( 7, J ) - SUM*T7
34807  140    CONTINUE
34808         GO TO 410
34809  150    CONTINUE
34810*
34811*        Special code for 8 x 8 Householder
34812*
34813         V1 = DCONJG( V( 1 ) )
34814         T1 = TAU*DCONJG( V1 )
34815         V2 = DCONJG( V( 2 ) )
34816         T2 = TAU*DCONJG( V2 )
34817         V3 = DCONJG( V( 3 ) )
34818         T3 = TAU*DCONJG( V3 )
34819         V4 = DCONJG( V( 4 ) )
34820         T4 = TAU*DCONJG( V4 )
34821         V5 = DCONJG( V( 5 ) )
34822         T5 = TAU*DCONJG( V5 )
34823         V6 = DCONJG( V( 6 ) )
34824         T6 = TAU*DCONJG( V6 )
34825         V7 = DCONJG( V( 7 ) )
34826         T7 = TAU*DCONJG( V7 )
34827         V8 = DCONJG( V( 8 ) )
34828         T8 = TAU*DCONJG( V8 )
34829         DO 160 J = 1, N
34830            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
34831     $            V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
34832     $            V7*C( 7, J ) + V8*C( 8, J )
34833            C( 1, J ) = C( 1, J ) - SUM*T1
34834            C( 2, J ) = C( 2, J ) - SUM*T2
34835            C( 3, J ) = C( 3, J ) - SUM*T3
34836            C( 4, J ) = C( 4, J ) - SUM*T4
34837            C( 5, J ) = C( 5, J ) - SUM*T5
34838            C( 6, J ) = C( 6, J ) - SUM*T6
34839            C( 7, J ) = C( 7, J ) - SUM*T7
34840            C( 8, J ) = C( 8, J ) - SUM*T8
34841  160    CONTINUE
34842         GO TO 410
34843  170    CONTINUE
34844*
34845*        Special code for 9 x 9 Householder
34846*
34847         V1 = DCONJG( V( 1 ) )
34848         T1 = TAU*DCONJG( V1 )
34849         V2 = DCONJG( V( 2 ) )
34850         T2 = TAU*DCONJG( V2 )
34851         V3 = DCONJG( V( 3 ) )
34852         T3 = TAU*DCONJG( V3 )
34853         V4 = DCONJG( V( 4 ) )
34854         T4 = TAU*DCONJG( V4 )
34855         V5 = DCONJG( V( 5 ) )
34856         T5 = TAU*DCONJG( V5 )
34857         V6 = DCONJG( V( 6 ) )
34858         T6 = TAU*DCONJG( V6 )
34859         V7 = DCONJG( V( 7 ) )
34860         T7 = TAU*DCONJG( V7 )
34861         V8 = DCONJG( V( 8 ) )
34862         T8 = TAU*DCONJG( V8 )
34863         V9 = DCONJG( V( 9 ) )
34864         T9 = TAU*DCONJG( V9 )
34865         DO 180 J = 1, N
34866            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
34867     $            V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
34868     $            V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J )
34869            C( 1, J ) = C( 1, J ) - SUM*T1
34870            C( 2, J ) = C( 2, J ) - SUM*T2
34871            C( 3, J ) = C( 3, J ) - SUM*T3
34872            C( 4, J ) = C( 4, J ) - SUM*T4
34873            C( 5, J ) = C( 5, J ) - SUM*T5
34874            C( 6, J ) = C( 6, J ) - SUM*T6
34875            C( 7, J ) = C( 7, J ) - SUM*T7
34876            C( 8, J ) = C( 8, J ) - SUM*T8
34877            C( 9, J ) = C( 9, J ) - SUM*T9
34878  180    CONTINUE
34879         GO TO 410
34880  190    CONTINUE
34881*
34882*        Special code for 10 x 10 Householder
34883*
34884         V1 = DCONJG( V( 1 ) )
34885         T1 = TAU*DCONJG( V1 )
34886         V2 = DCONJG( V( 2 ) )
34887         T2 = TAU*DCONJG( V2 )
34888         V3 = DCONJG( V( 3 ) )
34889         T3 = TAU*DCONJG( V3 )
34890         V4 = DCONJG( V( 4 ) )
34891         T4 = TAU*DCONJG( V4 )
34892         V5 = DCONJG( V( 5 ) )
34893         T5 = TAU*DCONJG( V5 )
34894         V6 = DCONJG( V( 6 ) )
34895         T6 = TAU*DCONJG( V6 )
34896         V7 = DCONJG( V( 7 ) )
34897         T7 = TAU*DCONJG( V7 )
34898         V8 = DCONJG( V( 8 ) )
34899         T8 = TAU*DCONJG( V8 )
34900         V9 = DCONJG( V( 9 ) )
34901         T9 = TAU*DCONJG( V9 )
34902         V10 = DCONJG( V( 10 ) )
34903         T10 = TAU*DCONJG( V10 )
34904         DO 200 J = 1, N
34905            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
34906     $            V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
34907     $            V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) +
34908     $            V10*C( 10, J )
34909            C( 1, J ) = C( 1, J ) - SUM*T1
34910            C( 2, J ) = C( 2, J ) - SUM*T2
34911            C( 3, J ) = C( 3, J ) - SUM*T3
34912            C( 4, J ) = C( 4, J ) - SUM*T4
34913            C( 5, J ) = C( 5, J ) - SUM*T5
34914            C( 6, J ) = C( 6, J ) - SUM*T6
34915            C( 7, J ) = C( 7, J ) - SUM*T7
34916            C( 8, J ) = C( 8, J ) - SUM*T8
34917            C( 9, J ) = C( 9, J ) - SUM*T9
34918            C( 10, J ) = C( 10, J ) - SUM*T10
34919  200    CONTINUE
34920         GO TO 410
34921      ELSE
34922*
34923*        Form  C * H, where H has order n.
34924*
34925         GO TO ( 210, 230, 250, 270, 290, 310, 330, 350,
34926     $           370, 390 )N
34927*
34928*        Code for general N
34929*
34930         CALL ZLARF( SIDE, M, N, V, 1, TAU, C, LDC, WORK )
34931         GO TO 410
34932  210    CONTINUE
34933*
34934*        Special code for 1 x 1 Householder
34935*
34936         T1 = ONE - TAU*V( 1 )*DCONJG( V( 1 ) )
34937         DO 220 J = 1, M
34938            C( J, 1 ) = T1*C( J, 1 )
34939  220    CONTINUE
34940         GO TO 410
34941  230    CONTINUE
34942*
34943*        Special code for 2 x 2 Householder
34944*
34945         V1 = V( 1 )
34946         T1 = TAU*DCONJG( V1 )
34947         V2 = V( 2 )
34948         T2 = TAU*DCONJG( V2 )
34949         DO 240 J = 1, M
34950            SUM = V1*C( J, 1 ) + V2*C( J, 2 )
34951            C( J, 1 ) = C( J, 1 ) - SUM*T1
34952            C( J, 2 ) = C( J, 2 ) - SUM*T2
34953  240    CONTINUE
34954         GO TO 410
34955  250    CONTINUE
34956*
34957*        Special code for 3 x 3 Householder
34958*
34959         V1 = V( 1 )
34960         T1 = TAU*DCONJG( V1 )
34961         V2 = V( 2 )
34962         T2 = TAU*DCONJG( V2 )
34963         V3 = V( 3 )
34964         T3 = TAU*DCONJG( V3 )
34965         DO 260 J = 1, M
34966            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 )
34967            C( J, 1 ) = C( J, 1 ) - SUM*T1
34968            C( J, 2 ) = C( J, 2 ) - SUM*T2
34969            C( J, 3 ) = C( J, 3 ) - SUM*T3
34970  260    CONTINUE
34971         GO TO 410
34972  270    CONTINUE
34973*
34974*        Special code for 4 x 4 Householder
34975*
34976         V1 = V( 1 )
34977         T1 = TAU*DCONJG( V1 )
34978         V2 = V( 2 )
34979         T2 = TAU*DCONJG( V2 )
34980         V3 = V( 3 )
34981         T3 = TAU*DCONJG( V3 )
34982         V4 = V( 4 )
34983         T4 = TAU*DCONJG( V4 )
34984         DO 280 J = 1, M
34985            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
34986     $            V4*C( J, 4 )
34987            C( J, 1 ) = C( J, 1 ) - SUM*T1
34988            C( J, 2 ) = C( J, 2 ) - SUM*T2
34989            C( J, 3 ) = C( J, 3 ) - SUM*T3
34990            C( J, 4 ) = C( J, 4 ) - SUM*T4
34991  280    CONTINUE
34992         GO TO 410
34993  290    CONTINUE
34994*
34995*        Special code for 5 x 5 Householder
34996*
34997         V1 = V( 1 )
34998         T1 = TAU*DCONJG( V1 )
34999         V2 = V( 2 )
35000         T2 = TAU*DCONJG( V2 )
35001         V3 = V( 3 )
35002         T3 = TAU*DCONJG( V3 )
35003         V4 = V( 4 )
35004         T4 = TAU*DCONJG( V4 )
35005         V5 = V( 5 )
35006         T5 = TAU*DCONJG( V5 )
35007         DO 300 J = 1, M
35008            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
35009     $            V4*C( J, 4 ) + V5*C( J, 5 )
35010            C( J, 1 ) = C( J, 1 ) - SUM*T1
35011            C( J, 2 ) = C( J, 2 ) - SUM*T2
35012            C( J, 3 ) = C( J, 3 ) - SUM*T3
35013            C( J, 4 ) = C( J, 4 ) - SUM*T4
35014            C( J, 5 ) = C( J, 5 ) - SUM*T5
35015  300    CONTINUE
35016         GO TO 410
35017  310    CONTINUE
35018*
35019*        Special code for 6 x 6 Householder
35020*
35021         V1 = V( 1 )
35022         T1 = TAU*DCONJG( V1 )
35023         V2 = V( 2 )
35024         T2 = TAU*DCONJG( V2 )
35025         V3 = V( 3 )
35026         T3 = TAU*DCONJG( V3 )
35027         V4 = V( 4 )
35028         T4 = TAU*DCONJG( V4 )
35029         V5 = V( 5 )
35030         T5 = TAU*DCONJG( V5 )
35031         V6 = V( 6 )
35032         T6 = TAU*DCONJG( V6 )
35033         DO 320 J = 1, M
35034            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
35035     $            V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 )
35036            C( J, 1 ) = C( J, 1 ) - SUM*T1
35037            C( J, 2 ) = C( J, 2 ) - SUM*T2
35038            C( J, 3 ) = C( J, 3 ) - SUM*T3
35039            C( J, 4 ) = C( J, 4 ) - SUM*T4
35040            C( J, 5 ) = C( J, 5 ) - SUM*T5
35041            C( J, 6 ) = C( J, 6 ) - SUM*T6
35042  320    CONTINUE
35043         GO TO 410
35044  330    CONTINUE
35045*
35046*        Special code for 7 x 7 Householder
35047*
35048         V1 = V( 1 )
35049         T1 = TAU*DCONJG( V1 )
35050         V2 = V( 2 )
35051         T2 = TAU*DCONJG( V2 )
35052         V3 = V( 3 )
35053         T3 = TAU*DCONJG( V3 )
35054         V4 = V( 4 )
35055         T4 = TAU*DCONJG( V4 )
35056         V5 = V( 5 )
35057         T5 = TAU*DCONJG( V5 )
35058         V6 = V( 6 )
35059         T6 = TAU*DCONJG( V6 )
35060         V7 = V( 7 )
35061         T7 = TAU*DCONJG( V7 )
35062         DO 340 J = 1, M
35063            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
35064     $            V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
35065     $            V7*C( J, 7 )
35066            C( J, 1 ) = C( J, 1 ) - SUM*T1
35067            C( J, 2 ) = C( J, 2 ) - SUM*T2
35068            C( J, 3 ) = C( J, 3 ) - SUM*T3
35069            C( J, 4 ) = C( J, 4 ) - SUM*T4
35070            C( J, 5 ) = C( J, 5 ) - SUM*T5
35071            C( J, 6 ) = C( J, 6 ) - SUM*T6
35072            C( J, 7 ) = C( J, 7 ) - SUM*T7
35073  340    CONTINUE
35074         GO TO 410
35075  350    CONTINUE
35076*
35077*        Special code for 8 x 8 Householder
35078*
35079         V1 = V( 1 )
35080         T1 = TAU*DCONJG( V1 )
35081         V2 = V( 2 )
35082         T2 = TAU*DCONJG( V2 )
35083         V3 = V( 3 )
35084         T3 = TAU*DCONJG( V3 )
35085         V4 = V( 4 )
35086         T4 = TAU*DCONJG( V4 )
35087         V5 = V( 5 )
35088         T5 = TAU*DCONJG( V5 )
35089         V6 = V( 6 )
35090         T6 = TAU*DCONJG( V6 )
35091         V7 = V( 7 )
35092         T7 = TAU*DCONJG( V7 )
35093         V8 = V( 8 )
35094         T8 = TAU*DCONJG( V8 )
35095         DO 360 J = 1, M
35096            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
35097     $            V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
35098     $            V7*C( J, 7 ) + V8*C( J, 8 )
35099            C( J, 1 ) = C( J, 1 ) - SUM*T1
35100            C( J, 2 ) = C( J, 2 ) - SUM*T2
35101            C( J, 3 ) = C( J, 3 ) - SUM*T3
35102            C( J, 4 ) = C( J, 4 ) - SUM*T4
35103            C( J, 5 ) = C( J, 5 ) - SUM*T5
35104            C( J, 6 ) = C( J, 6 ) - SUM*T6
35105            C( J, 7 ) = C( J, 7 ) - SUM*T7
35106            C( J, 8 ) = C( J, 8 ) - SUM*T8
35107  360    CONTINUE
35108         GO TO 410
35109  370    CONTINUE
35110*
35111*        Special code for 9 x 9 Householder
35112*
35113         V1 = V( 1 )
35114         T1 = TAU*DCONJG( V1 )
35115         V2 = V( 2 )
35116         T2 = TAU*DCONJG( V2 )
35117         V3 = V( 3 )
35118         T3 = TAU*DCONJG( V3 )
35119         V4 = V( 4 )
35120         T4 = TAU*DCONJG( V4 )
35121         V5 = V( 5 )
35122         T5 = TAU*DCONJG( V5 )
35123         V6 = V( 6 )
35124         T6 = TAU*DCONJG( V6 )
35125         V7 = V( 7 )
35126         T7 = TAU*DCONJG( V7 )
35127         V8 = V( 8 )
35128         T8 = TAU*DCONJG( V8 )
35129         V9 = V( 9 )
35130         T9 = TAU*DCONJG( V9 )
35131         DO 380 J = 1, M
35132            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
35133     $            V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
35134     $            V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 )
35135            C( J, 1 ) = C( J, 1 ) - SUM*T1
35136            C( J, 2 ) = C( J, 2 ) - SUM*T2
35137            C( J, 3 ) = C( J, 3 ) - SUM*T3
35138            C( J, 4 ) = C( J, 4 ) - SUM*T4
35139            C( J, 5 ) = C( J, 5 ) - SUM*T5
35140            C( J, 6 ) = C( J, 6 ) - SUM*T6
35141            C( J, 7 ) = C( J, 7 ) - SUM*T7
35142            C( J, 8 ) = C( J, 8 ) - SUM*T8
35143            C( J, 9 ) = C( J, 9 ) - SUM*T9
35144  380    CONTINUE
35145         GO TO 410
35146  390    CONTINUE
35147*
35148*        Special code for 10 x 10 Householder
35149*
35150         V1 = V( 1 )
35151         T1 = TAU*DCONJG( V1 )
35152         V2 = V( 2 )
35153         T2 = TAU*DCONJG( V2 )
35154         V3 = V( 3 )
35155         T3 = TAU*DCONJG( V3 )
35156         V4 = V( 4 )
35157         T4 = TAU*DCONJG( V4 )
35158         V5 = V( 5 )
35159         T5 = TAU*DCONJG( V5 )
35160         V6 = V( 6 )
35161         T6 = TAU*DCONJG( V6 )
35162         V7 = V( 7 )
35163         T7 = TAU*DCONJG( V7 )
35164         V8 = V( 8 )
35165         T8 = TAU*DCONJG( V8 )
35166         V9 = V( 9 )
35167         T9 = TAU*DCONJG( V9 )
35168         V10 = V( 10 )
35169         T10 = TAU*DCONJG( V10 )
35170         DO 400 J = 1, M
35171            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
35172     $            V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
35173     $            V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) +
35174     $            V10*C( J, 10 )
35175            C( J, 1 ) = C( J, 1 ) - SUM*T1
35176            C( J, 2 ) = C( J, 2 ) - SUM*T2
35177            C( J, 3 ) = C( J, 3 ) - SUM*T3
35178            C( J, 4 ) = C( J, 4 ) - SUM*T4
35179            C( J, 5 ) = C( J, 5 ) - SUM*T5
35180            C( J, 6 ) = C( J, 6 ) - SUM*T6
35181            C( J, 7 ) = C( J, 7 ) - SUM*T7
35182            C( J, 8 ) = C( J, 8 ) - SUM*T8
35183            C( J, 9 ) = C( J, 9 ) - SUM*T9
35184            C( J, 10 ) = C( J, 10 ) - SUM*T10
35185  400    CONTINUE
35186         GO TO 410
35187      END IF
35188  410 CONTINUE
35189      RETURN
35190*
35191*     End of ZLARFX
35192*
35193      END
35194*> \brief \b ZLARTG generates a plane rotation with real cosine and complex sine.
35195*
35196*  =========== DOCUMENTATION ===========
35197*
35198* Online html documentation available at
35199*            http://www.netlib.org/lapack/explore-html/
35200*
35201*> \htmlonly
35202*> Download ZLARTG + dependencies
35203*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlartg.f">
35204*> [TGZ]</a>
35205*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlartg.f">
35206*> [ZIP]</a>
35207*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlartg.f">
35208*> [TXT]</a>
35209*> \endhtmlonly
35210*
35211*  Definition:
35212*  ===========
35213*
35214*       SUBROUTINE ZLARTG( F, G, CS, SN, R )
35215*
35216*       .. Scalar Arguments ..
35217*       DOUBLE PRECISION   CS
35218*       COMPLEX*16         F, G, R, SN
35219*       ..
35220*
35221*
35222*> \par Purpose:
35223*  =============
35224*>
35225*> \verbatim
35226*>
35227*> ZLARTG generates a plane rotation so that
35228*>
35229*>    [  CS  SN  ]     [ F ]     [ R ]
35230*>    [  __      ]  .  [   ]  =  [   ]   where CS**2 + |SN|**2 = 1.
35231*>    [ -SN  CS  ]     [ G ]     [ 0 ]
35232*>
35233*> This is a faster version of the BLAS1 routine ZROTG, except for
35234*> the following differences:
35235*>    F and G are unchanged on return.
35236*>    If G=0, then CS=1 and SN=0.
35237*>    If F=0, then CS=0 and SN is chosen so that R is real.
35238*> \endverbatim
35239*
35240*  Arguments:
35241*  ==========
35242*
35243*> \param[in] F
35244*> \verbatim
35245*>          F is COMPLEX*16
35246*>          The first component of vector to be rotated.
35247*> \endverbatim
35248*>
35249*> \param[in] G
35250*> \verbatim
35251*>          G is COMPLEX*16
35252*>          The second component of vector to be rotated.
35253*> \endverbatim
35254*>
35255*> \param[out] CS
35256*> \verbatim
35257*>          CS is DOUBLE PRECISION
35258*>          The cosine of the rotation.
35259*> \endverbatim
35260*>
35261*> \param[out] SN
35262*> \verbatim
35263*>          SN is COMPLEX*16
35264*>          The sine of the rotation.
35265*> \endverbatim
35266*>
35267*> \param[out] R
35268*> \verbatim
35269*>          R is COMPLEX*16
35270*>          The nonzero component of the rotated vector.
35271*> \endverbatim
35272*
35273*  Authors:
35274*  ========
35275*
35276*> \author Univ. of Tennessee
35277*> \author Univ. of California Berkeley
35278*> \author Univ. of Colorado Denver
35279*> \author NAG Ltd.
35280*
35281*> \date December 2016
35282*
35283*> \ingroup complex16OTHERauxiliary
35284*
35285*> \par Further Details:
35286*  =====================
35287*>
35288*> \verbatim
35289*>
35290*>  3-5-96 - Modified with a new algorithm by W. Kahan and J. Demmel
35291*>
35292*>  This version has a few statements commented out for thread safety
35293*>  (machine parameters are computed on each entry). 10 feb 03, SJH.
35294*> \endverbatim
35295*>
35296*  =====================================================================
35297      SUBROUTINE ZLARTG( F, G, CS, SN, R )
35298*
35299*  -- LAPACK auxiliary routine (version 3.7.0) --
35300*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
35301*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
35302*     December 2016
35303*
35304*     .. Scalar Arguments ..
35305      DOUBLE PRECISION   CS
35306      COMPLEX*16         F, G, R, SN
35307*     ..
35308*
35309*  =====================================================================
35310*
35311*     .. Parameters ..
35312      DOUBLE PRECISION   TWO, ONE, ZERO
35313      PARAMETER          ( TWO = 2.0D+0, ONE = 1.0D+0, ZERO = 0.0D+0 )
35314      COMPLEX*16         CZERO
35315      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ) )
35316*     ..
35317*     .. Local Scalars ..
35318*     LOGICAL            FIRST
35319      INTEGER            COUNT, I
35320      DOUBLE PRECISION   D, DI, DR, EPS, F2, F2S, G2, G2S, SAFMIN,
35321     $                   SAFMN2, SAFMX2, SCALE
35322      COMPLEX*16         FF, FS, GS
35323*     ..
35324*     .. External Functions ..
35325      DOUBLE PRECISION   DLAMCH, DLAPY2
35326      LOGICAL            DISNAN
35327      EXTERNAL           DLAMCH, DLAPY2, DISNAN
35328*     ..
35329*     .. Intrinsic Functions ..
35330      INTRINSIC          ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, LOG,
35331     $                   MAX, SQRT
35332*     ..
35333*     .. Statement Functions ..
35334      DOUBLE PRECISION   ABS1, ABSSQ
35335*     ..
35336*     .. Statement Function definitions ..
35337      ABS1( FF ) = MAX( ABS( DBLE( FF ) ), ABS( DIMAG( FF ) ) )
35338      ABSSQ( FF ) = DBLE( FF )**2 + DIMAG( FF )**2
35339*     ..
35340*     .. Executable Statements ..
35341*
35342      SAFMIN = DLAMCH( 'S' )
35343      EPS = DLAMCH( 'E' )
35344      SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
35345     $         LOG( DLAMCH( 'B' ) ) / TWO )
35346      SAFMX2 = ONE / SAFMN2
35347      SCALE = MAX( ABS1( F ), ABS1( G ) )
35348      FS = F
35349      GS = G
35350      COUNT = 0
35351      IF( SCALE.GE.SAFMX2 ) THEN
35352   10    CONTINUE
35353         COUNT = COUNT + 1
35354         FS = FS*SAFMN2
35355         GS = GS*SAFMN2
35356         SCALE = SCALE*SAFMN2
35357         IF( SCALE.GE.SAFMX2 )
35358     $      GO TO 10
35359      ELSE IF( SCALE.LE.SAFMN2 ) THEN
35360         IF( G.EQ.CZERO.OR.DISNAN( ABS( G ) ) ) THEN
35361            CS = ONE
35362            SN = CZERO
35363            R = F
35364            RETURN
35365         END IF
35366   20    CONTINUE
35367         COUNT = COUNT - 1
35368         FS = FS*SAFMX2
35369         GS = GS*SAFMX2
35370         SCALE = SCALE*SAFMX2
35371         IF( SCALE.LE.SAFMN2 )
35372     $      GO TO 20
35373      END IF
35374      F2 = ABSSQ( FS )
35375      G2 = ABSSQ( GS )
35376      IF( F2.LE.MAX( G2, ONE )*SAFMIN ) THEN
35377*
35378*        This is a rare case: F is very small.
35379*
35380         IF( F.EQ.CZERO ) THEN
35381            CS = ZERO
35382            R = DLAPY2( DBLE( G ), DIMAG( G ) )
35383*           Do complex/real division explicitly with two real divisions
35384            D = DLAPY2( DBLE( GS ), DIMAG( GS ) )
35385            SN = DCMPLX( DBLE( GS ) / D, -DIMAG( GS ) / D )
35386            RETURN
35387         END IF
35388         F2S = DLAPY2( DBLE( FS ), DIMAG( FS ) )
35389*        G2 and G2S are accurate
35390*        G2 is at least SAFMIN, and G2S is at least SAFMN2
35391         G2S = SQRT( G2 )
35392*        Error in CS from underflow in F2S is at most
35393*        UNFL / SAFMN2 .lt. sqrt(UNFL*EPS) .lt. EPS
35394*        If MAX(G2,ONE)=G2, then F2 .lt. G2*SAFMIN,
35395*        and so CS .lt. sqrt(SAFMIN)
35396*        If MAX(G2,ONE)=ONE, then F2 .lt. SAFMIN
35397*        and so CS .lt. sqrt(SAFMIN)/SAFMN2 = sqrt(EPS)
35398*        Therefore, CS = F2S/G2S / sqrt( 1 + (F2S/G2S)**2 ) = F2S/G2S
35399         CS = F2S / G2S
35400*        Make sure abs(FF) = 1
35401*        Do complex/real division explicitly with 2 real divisions
35402         IF( ABS1( F ).GT.ONE ) THEN
35403            D = DLAPY2( DBLE( F ), DIMAG( F ) )
35404            FF = DCMPLX( DBLE( F ) / D, DIMAG( F ) / D )
35405         ELSE
35406            DR = SAFMX2*DBLE( F )
35407            DI = SAFMX2*DIMAG( F )
35408            D = DLAPY2( DR, DI )
35409            FF = DCMPLX( DR / D, DI / D )
35410         END IF
35411         SN = FF*DCMPLX( DBLE( GS ) / G2S, -DIMAG( GS ) / G2S )
35412         R = CS*F + SN*G
35413      ELSE
35414*
35415*        This is the most common case.
35416*        Neither F2 nor F2/G2 are less than SAFMIN
35417*        F2S cannot overflow, and it is accurate
35418*
35419         F2S = SQRT( ONE+G2 / F2 )
35420*        Do the F2S(real)*FS(complex) multiply with two real multiplies
35421         R = DCMPLX( F2S*DBLE( FS ), F2S*DIMAG( FS ) )
35422         CS = ONE / F2S
35423         D = F2 + G2
35424*        Do complex/real division explicitly with two real divisions
35425         SN = DCMPLX( DBLE( R ) / D, DIMAG( R ) / D )
35426         SN = SN*DCONJG( GS )
35427         IF( COUNT.NE.0 ) THEN
35428            IF( COUNT.GT.0 ) THEN
35429               DO 30 I = 1, COUNT
35430                  R = R*SAFMX2
35431   30          CONTINUE
35432            ELSE
35433               DO 40 I = 1, -COUNT
35434                  R = R*SAFMN2
35435   40          CONTINUE
35436            END IF
35437         END IF
35438      END IF
35439      RETURN
35440*
35441*     End of ZLARTG
35442*
35443      END
35444*> \brief \b ZLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
35445*
35446*  =========== DOCUMENTATION ===========
35447*
35448* Online html documentation available at
35449*            http://www.netlib.org/lapack/explore-html/
35450*
35451*> \htmlonly
35452*> Download ZLASCL + dependencies
35453*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlascl.f">
35454*> [TGZ]</a>
35455*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlascl.f">
35456*> [ZIP]</a>
35457*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlascl.f">
35458*> [TXT]</a>
35459*> \endhtmlonly
35460*
35461*  Definition:
35462*  ===========
35463*
35464*       SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
35465*
35466*       .. Scalar Arguments ..
35467*       CHARACTER          TYPE
35468*       INTEGER            INFO, KL, KU, LDA, M, N
35469*       DOUBLE PRECISION   CFROM, CTO
35470*       ..
35471*       .. Array Arguments ..
35472*       COMPLEX*16         A( LDA, * )
35473*       ..
35474*
35475*
35476*> \par Purpose:
35477*  =============
35478*>
35479*> \verbatim
35480*>
35481*> ZLASCL multiplies the M by N complex matrix A by the real scalar
35482*> CTO/CFROM.  This is done without over/underflow as long as the final
35483*> result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
35484*> A may be full, upper triangular, lower triangular, upper Hessenberg,
35485*> or banded.
35486*> \endverbatim
35487*
35488*  Arguments:
35489*  ==========
35490*
35491*> \param[in] TYPE
35492*> \verbatim
35493*>          TYPE is CHARACTER*1
35494*>          TYPE indices the storage type of the input matrix.
35495*>          = 'G':  A is a full matrix.
35496*>          = 'L':  A is a lower triangular matrix.
35497*>          = 'U':  A is an upper triangular matrix.
35498*>          = 'H':  A is an upper Hessenberg matrix.
35499*>          = 'B':  A is a symmetric band matrix with lower bandwidth KL
35500*>                  and upper bandwidth KU and with the only the lower
35501*>                  half stored.
35502*>          = 'Q':  A is a symmetric band matrix with lower bandwidth KL
35503*>                  and upper bandwidth KU and with the only the upper
35504*>                  half stored.
35505*>          = 'Z':  A is a band matrix with lower bandwidth KL and upper
35506*>                  bandwidth KU. See ZGBTRF for storage details.
35507*> \endverbatim
35508*>
35509*> \param[in] KL
35510*> \verbatim
35511*>          KL is INTEGER
35512*>          The lower bandwidth of A.  Referenced only if TYPE = 'B',
35513*>          'Q' or 'Z'.
35514*> \endverbatim
35515*>
35516*> \param[in] KU
35517*> \verbatim
35518*>          KU is INTEGER
35519*>          The upper bandwidth of A.  Referenced only if TYPE = 'B',
35520*>          'Q' or 'Z'.
35521*> \endverbatim
35522*>
35523*> \param[in] CFROM
35524*> \verbatim
35525*>          CFROM is DOUBLE PRECISION
35526*> \endverbatim
35527*>
35528*> \param[in] CTO
35529*> \verbatim
35530*>          CTO is DOUBLE PRECISION
35531*>
35532*>          The matrix A is multiplied by CTO/CFROM. A(I,J) is computed
35533*>          without over/underflow if the final result CTO*A(I,J)/CFROM
35534*>          can be represented without over/underflow.  CFROM must be
35535*>          nonzero.
35536*> \endverbatim
35537*>
35538*> \param[in] M
35539*> \verbatim
35540*>          M is INTEGER
35541*>          The number of rows of the matrix A.  M >= 0.
35542*> \endverbatim
35543*>
35544*> \param[in] N
35545*> \verbatim
35546*>          N is INTEGER
35547*>          The number of columns of the matrix A.  N >= 0.
35548*> \endverbatim
35549*>
35550*> \param[in,out] A
35551*> \verbatim
35552*>          A is COMPLEX*16 array, dimension (LDA,N)
35553*>          The matrix to be multiplied by CTO/CFROM.  See TYPE for the
35554*>          storage type.
35555*> \endverbatim
35556*>
35557*> \param[in] LDA
35558*> \verbatim
35559*>          LDA is INTEGER
35560*>          The leading dimension of the array A.
35561*>          If TYPE = 'G', 'L', 'U', 'H', LDA >= max(1,M);
35562*>             TYPE = 'B', LDA >= KL+1;
35563*>             TYPE = 'Q', LDA >= KU+1;
35564*>             TYPE = 'Z', LDA >= 2*KL+KU+1.
35565*> \endverbatim
35566*>
35567*> \param[out] INFO
35568*> \verbatim
35569*>          INFO is INTEGER
35570*>          0  - successful exit
35571*>          <0 - if INFO = -i, the i-th argument had an illegal value.
35572*> \endverbatim
35573*
35574*  Authors:
35575*  ========
35576*
35577*> \author Univ. of Tennessee
35578*> \author Univ. of California Berkeley
35579*> \author Univ. of Colorado Denver
35580*> \author NAG Ltd.
35581*
35582*> \date June 2016
35583*
35584*> \ingroup complex16OTHERauxiliary
35585*
35586*  =====================================================================
35587      SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
35588*
35589*  -- LAPACK auxiliary routine (version 3.7.0) --
35590*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
35591*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
35592*     June 2016
35593*
35594*     .. Scalar Arguments ..
35595      CHARACTER          TYPE
35596      INTEGER            INFO, KL, KU, LDA, M, N
35597      DOUBLE PRECISION   CFROM, CTO
35598*     ..
35599*     .. Array Arguments ..
35600      COMPLEX*16         A( LDA, * )
35601*     ..
35602*
35603*  =====================================================================
35604*
35605*     .. Parameters ..
35606      DOUBLE PRECISION   ZERO, ONE
35607      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
35608*     ..
35609*     .. Local Scalars ..
35610      LOGICAL            DONE
35611      INTEGER            I, ITYPE, J, K1, K2, K3, K4
35612      DOUBLE PRECISION   BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
35613*     ..
35614*     .. External Functions ..
35615      LOGICAL            LSAME, DISNAN
35616      DOUBLE PRECISION   DLAMCH
35617      EXTERNAL           LSAME, DLAMCH, DISNAN
35618*     ..
35619*     .. Intrinsic Functions ..
35620      INTRINSIC          ABS, MAX, MIN
35621*     ..
35622*     .. External Subroutines ..
35623      EXTERNAL           XERBLA
35624*     ..
35625*     .. Executable Statements ..
35626*
35627*     Test the input arguments
35628*
35629      INFO = 0
35630*
35631      IF( LSAME( TYPE, 'G' ) ) THEN
35632         ITYPE = 0
35633      ELSE IF( LSAME( TYPE, 'L' ) ) THEN
35634         ITYPE = 1
35635      ELSE IF( LSAME( TYPE, 'U' ) ) THEN
35636         ITYPE = 2
35637      ELSE IF( LSAME( TYPE, 'H' ) ) THEN
35638         ITYPE = 3
35639      ELSE IF( LSAME( TYPE, 'B' ) ) THEN
35640         ITYPE = 4
35641      ELSE IF( LSAME( TYPE, 'Q' ) ) THEN
35642         ITYPE = 5
35643      ELSE IF( LSAME( TYPE, 'Z' ) ) THEN
35644         ITYPE = 6
35645      ELSE
35646         ITYPE = -1
35647      END IF
35648*
35649      IF( ITYPE.EQ.-1 ) THEN
35650         INFO = -1
35651      ELSE IF( CFROM.EQ.ZERO .OR. DISNAN(CFROM) ) THEN
35652         INFO = -4
35653      ELSE IF( DISNAN(CTO) ) THEN
35654         INFO = -5
35655      ELSE IF( M.LT.0 ) THEN
35656         INFO = -6
35657      ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR.
35658     $         ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN
35659         INFO = -7
35660      ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN
35661         INFO = -9
35662      ELSE IF( ITYPE.GE.4 ) THEN
35663         IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN
35664            INFO = -2
35665         ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR.
35666     $            ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) )
35667     $             THEN
35668            INFO = -3
35669         ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR.
35670     $            ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR.
35671     $            ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN
35672            INFO = -9
35673         END IF
35674      END IF
35675*
35676      IF( INFO.NE.0 ) THEN
35677         CALL XERBLA( 'ZLASCL', -INFO )
35678         RETURN
35679      END IF
35680*
35681*     Quick return if possible
35682*
35683      IF( N.EQ.0 .OR. M.EQ.0 )
35684     $   RETURN
35685*
35686*     Get machine parameters
35687*
35688      SMLNUM = DLAMCH( 'S' )
35689      BIGNUM = ONE / SMLNUM
35690*
35691      CFROMC = CFROM
35692      CTOC = CTO
35693*
35694   10 CONTINUE
35695      CFROM1 = CFROMC*SMLNUM
35696      IF( CFROM1.EQ.CFROMC ) THEN
35697!        CFROMC is an inf.  Multiply by a correctly signed zero for
35698!        finite CTOC, or a NaN if CTOC is infinite.
35699         MUL = CTOC / CFROMC
35700         DONE = .TRUE.
35701         CTO1 = CTOC
35702      ELSE
35703         CTO1 = CTOC / BIGNUM
35704         IF( CTO1.EQ.CTOC ) THEN
35705!           CTOC is either 0 or an inf.  In both cases, CTOC itself
35706!           serves as the correct multiplication factor.
35707            MUL = CTOC
35708            DONE = .TRUE.
35709            CFROMC = ONE
35710         ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
35711            MUL = SMLNUM
35712            DONE = .FALSE.
35713            CFROMC = CFROM1
35714         ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
35715            MUL = BIGNUM
35716            DONE = .FALSE.
35717            CTOC = CTO1
35718         ELSE
35719            MUL = CTOC / CFROMC
35720            DONE = .TRUE.
35721         END IF
35722      END IF
35723*
35724      IF( ITYPE.EQ.0 ) THEN
35725*
35726*        Full matrix
35727*
35728         DO 30 J = 1, N
35729            DO 20 I = 1, M
35730               A( I, J ) = A( I, J )*MUL
35731   20       CONTINUE
35732   30    CONTINUE
35733*
35734      ELSE IF( ITYPE.EQ.1 ) THEN
35735*
35736*        Lower triangular matrix
35737*
35738         DO 50 J = 1, N
35739            DO 40 I = J, M
35740               A( I, J ) = A( I, J )*MUL
35741   40       CONTINUE
35742   50    CONTINUE
35743*
35744      ELSE IF( ITYPE.EQ.2 ) THEN
35745*
35746*        Upper triangular matrix
35747*
35748         DO 70 J = 1, N
35749            DO 60 I = 1, MIN( J, M )
35750               A( I, J ) = A( I, J )*MUL
35751   60       CONTINUE
35752   70    CONTINUE
35753*
35754      ELSE IF( ITYPE.EQ.3 ) THEN
35755*
35756*        Upper Hessenberg matrix
35757*
35758         DO 90 J = 1, N
35759            DO 80 I = 1, MIN( J+1, M )
35760               A( I, J ) = A( I, J )*MUL
35761   80       CONTINUE
35762   90    CONTINUE
35763*
35764      ELSE IF( ITYPE.EQ.4 ) THEN
35765*
35766*        Lower half of a symmetric band matrix
35767*
35768         K3 = KL + 1
35769         K4 = N + 1
35770         DO 110 J = 1, N
35771            DO 100 I = 1, MIN( K3, K4-J )
35772               A( I, J ) = A( I, J )*MUL
35773  100       CONTINUE
35774  110    CONTINUE
35775*
35776      ELSE IF( ITYPE.EQ.5 ) THEN
35777*
35778*        Upper half of a symmetric band matrix
35779*
35780         K1 = KU + 2
35781         K3 = KU + 1
35782         DO 130 J = 1, N
35783            DO 120 I = MAX( K1-J, 1 ), K3
35784               A( I, J ) = A( I, J )*MUL
35785  120       CONTINUE
35786  130    CONTINUE
35787*
35788      ELSE IF( ITYPE.EQ.6 ) THEN
35789*
35790*        Band matrix
35791*
35792         K1 = KL + KU + 2
35793         K2 = KL + 1
35794         K3 = 2*KL + KU + 1
35795         K4 = KL + KU + 1 + M
35796         DO 150 J = 1, N
35797            DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
35798               A( I, J ) = A( I, J )*MUL
35799  140       CONTINUE
35800  150    CONTINUE
35801*
35802      END IF
35803*
35804      IF( .NOT.DONE )
35805     $   GO TO 10
35806*
35807      RETURN
35808*
35809*     End of ZLASCL
35810*
35811      END
35812*> \brief \b ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
35813*
35814*  =========== DOCUMENTATION ===========
35815*
35816* Online html documentation available at
35817*            http://www.netlib.org/lapack/explore-html/
35818*
35819*> \htmlonly
35820*> Download ZLASET + dependencies
35821*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlaset.f">
35822*> [TGZ]</a>
35823*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlaset.f">
35824*> [ZIP]</a>
35825*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlaset.f">
35826*> [TXT]</a>
35827*> \endhtmlonly
35828*
35829*  Definition:
35830*  ===========
35831*
35832*       SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA )
35833*
35834*       .. Scalar Arguments ..
35835*       CHARACTER          UPLO
35836*       INTEGER            LDA, M, N
35837*       COMPLEX*16         ALPHA, BETA
35838*       ..
35839*       .. Array Arguments ..
35840*       COMPLEX*16         A( LDA, * )
35841*       ..
35842*
35843*
35844*> \par Purpose:
35845*  =============
35846*>
35847*> \verbatim
35848*>
35849*> ZLASET initializes a 2-D array A to BETA on the diagonal and
35850*> ALPHA on the offdiagonals.
35851*> \endverbatim
35852*
35853*  Arguments:
35854*  ==========
35855*
35856*> \param[in] UPLO
35857*> \verbatim
35858*>          UPLO is CHARACTER*1
35859*>          Specifies the part of the matrix A to be set.
35860*>          = 'U':      Upper triangular part is set. The lower triangle
35861*>                      is unchanged.
35862*>          = 'L':      Lower triangular part is set. The upper triangle
35863*>                      is unchanged.
35864*>          Otherwise:  All of the matrix A is set.
35865*> \endverbatim
35866*>
35867*> \param[in] M
35868*> \verbatim
35869*>          M is INTEGER
35870*>          On entry, M specifies the number of rows of A.
35871*> \endverbatim
35872*>
35873*> \param[in] N
35874*> \verbatim
35875*>          N is INTEGER
35876*>          On entry, N specifies the number of columns of A.
35877*> \endverbatim
35878*>
35879*> \param[in] ALPHA
35880*> \verbatim
35881*>          ALPHA is COMPLEX*16
35882*>          All the offdiagonal array elements are set to ALPHA.
35883*> \endverbatim
35884*>
35885*> \param[in] BETA
35886*> \verbatim
35887*>          BETA is COMPLEX*16
35888*>          All the diagonal array elements are set to BETA.
35889*> \endverbatim
35890*>
35891*> \param[out] A
35892*> \verbatim
35893*>          A is COMPLEX*16 array, dimension (LDA,N)
35894*>          On entry, the m by n matrix A.
35895*>          On exit, A(i,j) = ALPHA, 1 <= i <= m, 1 <= j <= n, i.ne.j;
35896*>                   A(i,i) = BETA , 1 <= i <= min(m,n)
35897*> \endverbatim
35898*>
35899*> \param[in] LDA
35900*> \verbatim
35901*>          LDA is INTEGER
35902*>          The leading dimension of the array A.  LDA >= max(1,M).
35903*> \endverbatim
35904*
35905*  Authors:
35906*  ========
35907*
35908*> \author Univ. of Tennessee
35909*> \author Univ. of California Berkeley
35910*> \author Univ. of Colorado Denver
35911*> \author NAG Ltd.
35912*
35913*> \date December 2016
35914*
35915*> \ingroup complex16OTHERauxiliary
35916*
35917*  =====================================================================
35918      SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA )
35919*
35920*  -- LAPACK auxiliary routine (version 3.7.0) --
35921*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
35922*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
35923*     December 2016
35924*
35925*     .. Scalar Arguments ..
35926      CHARACTER          UPLO
35927      INTEGER            LDA, M, N
35928      COMPLEX*16         ALPHA, BETA
35929*     ..
35930*     .. Array Arguments ..
35931      COMPLEX*16         A( LDA, * )
35932*     ..
35933*
35934*  =====================================================================
35935*
35936*     .. Local Scalars ..
35937      INTEGER            I, J
35938*     ..
35939*     .. External Functions ..
35940      LOGICAL            LSAME
35941      EXTERNAL           LSAME
35942*     ..
35943*     .. Intrinsic Functions ..
35944      INTRINSIC          MIN
35945*     ..
35946*     .. Executable Statements ..
35947*
35948      IF( LSAME( UPLO, 'U' ) ) THEN
35949*
35950*        Set the diagonal to BETA and the strictly upper triangular
35951*        part of the array to ALPHA.
35952*
35953         DO 20 J = 2, N
35954            DO 10 I = 1, MIN( J-1, M )
35955               A( I, J ) = ALPHA
35956   10       CONTINUE
35957   20    CONTINUE
35958         DO 30 I = 1, MIN( N, M )
35959            A( I, I ) = BETA
35960   30    CONTINUE
35961*
35962      ELSE IF( LSAME( UPLO, 'L' ) ) THEN
35963*
35964*        Set the diagonal to BETA and the strictly lower triangular
35965*        part of the array to ALPHA.
35966*
35967         DO 50 J = 1, MIN( M, N )
35968            DO 40 I = J + 1, M
35969               A( I, J ) = ALPHA
35970   40       CONTINUE
35971   50    CONTINUE
35972         DO 60 I = 1, MIN( N, M )
35973            A( I, I ) = BETA
35974   60    CONTINUE
35975*
35976      ELSE
35977*
35978*        Set the array to BETA on the diagonal and ALPHA on the
35979*        offdiagonal.
35980*
35981         DO 80 J = 1, N
35982            DO 70 I = 1, M
35983               A( I, J ) = ALPHA
35984   70       CONTINUE
35985   80    CONTINUE
35986         DO 90 I = 1, MIN( M, N )
35987            A( I, I ) = BETA
35988   90    CONTINUE
35989      END IF
35990*
35991      RETURN
35992*
35993*     End of ZLASET
35994*
35995      END
35996*> \brief \b ZLASR applies a sequence of plane rotations to a general rectangular matrix.
35997*
35998*  =========== DOCUMENTATION ===========
35999*
36000* Online html documentation available at
36001*            http://www.netlib.org/lapack/explore-html/
36002*
36003*> \htmlonly
36004*> Download ZLASR + dependencies
36005*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlasr.f">
36006*> [TGZ]</a>
36007*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlasr.f">
36008*> [ZIP]</a>
36009*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlasr.f">
36010*> [TXT]</a>
36011*> \endhtmlonly
36012*
36013*  Definition:
36014*  ===========
36015*
36016*       SUBROUTINE ZLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )
36017*
36018*       .. Scalar Arguments ..
36019*       CHARACTER          DIRECT, PIVOT, SIDE
36020*       INTEGER            LDA, M, N
36021*       ..
36022*       .. Array Arguments ..
36023*       DOUBLE PRECISION   C( * ), S( * )
36024*       COMPLEX*16         A( LDA, * )
36025*       ..
36026*
36027*
36028*> \par Purpose:
36029*  =============
36030*>
36031*> \verbatim
36032*>
36033*> ZLASR applies a sequence of real plane rotations to a complex matrix
36034*> A, from either the left or the right.
36035*>
36036*> When SIDE = 'L', the transformation takes the form
36037*>
36038*>    A := P*A
36039*>
36040*> and when SIDE = 'R', the transformation takes the form
36041*>
36042*>    A := A*P**T
36043*>
36044*> where P is an orthogonal matrix consisting of a sequence of z plane
36045*> rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R',
36046*> and P**T is the transpose of P.
36047*>
36048*> When DIRECT = 'F' (Forward sequence), then
36049*>
36050*>    P = P(z-1) * ... * P(2) * P(1)
36051*>
36052*> and when DIRECT = 'B' (Backward sequence), then
36053*>
36054*>    P = P(1) * P(2) * ... * P(z-1)
36055*>
36056*> where P(k) is a plane rotation matrix defined by the 2-by-2 rotation
36057*>
36058*>    R(k) = (  c(k)  s(k) )
36059*>         = ( -s(k)  c(k) ).
36060*>
36061*> When PIVOT = 'V' (Variable pivot), the rotation is performed
36062*> for the plane (k,k+1), i.e., P(k) has the form
36063*>
36064*>    P(k) = (  1                                            )
36065*>           (       ...                                     )
36066*>           (              1                                )
36067*>           (                   c(k)  s(k)                  )
36068*>           (                  -s(k)  c(k)                  )
36069*>           (                                1              )
36070*>           (                                     ...       )
36071*>           (                                            1  )
36072*>
36073*> where R(k) appears as a rank-2 modification to the identity matrix in
36074*> rows and columns k and k+1.
36075*>
36076*> When PIVOT = 'T' (Top pivot), the rotation is performed for the
36077*> plane (1,k+1), so P(k) has the form
36078*>
36079*>    P(k) = (  c(k)                    s(k)                 )
36080*>           (         1                                     )
36081*>           (              ...                              )
36082*>           (                     1                         )
36083*>           ( -s(k)                    c(k)                 )
36084*>           (                                 1             )
36085*>           (                                      ...      )
36086*>           (                                             1 )
36087*>
36088*> where R(k) appears in rows and columns 1 and k+1.
36089*>
36090*> Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is
36091*> performed for the plane (k,z), giving P(k) the form
36092*>
36093*>    P(k) = ( 1                                             )
36094*>           (      ...                                      )
36095*>           (             1                                 )
36096*>           (                  c(k)                    s(k) )
36097*>           (                         1                     )
36098*>           (                              ...              )
36099*>           (                                     1         )
36100*>           (                 -s(k)                    c(k) )
36101*>
36102*> where R(k) appears in rows and columns k and z.  The rotations are
36103*> performed without ever forming P(k) explicitly.
36104*> \endverbatim
36105*
36106*  Arguments:
36107*  ==========
36108*
36109*> \param[in] SIDE
36110*> \verbatim
36111*>          SIDE is CHARACTER*1
36112*>          Specifies whether the plane rotation matrix P is applied to
36113*>          A on the left or the right.
36114*>          = 'L':  Left, compute A := P*A
36115*>          = 'R':  Right, compute A:= A*P**T
36116*> \endverbatim
36117*>
36118*> \param[in] PIVOT
36119*> \verbatim
36120*>          PIVOT is CHARACTER*1
36121*>          Specifies the plane for which P(k) is a plane rotation
36122*>          matrix.
36123*>          = 'V':  Variable pivot, the plane (k,k+1)
36124*>          = 'T':  Top pivot, the plane (1,k+1)
36125*>          = 'B':  Bottom pivot, the plane (k,z)
36126*> \endverbatim
36127*>
36128*> \param[in] DIRECT
36129*> \verbatim
36130*>          DIRECT is CHARACTER*1
36131*>          Specifies whether P is a forward or backward sequence of
36132*>          plane rotations.
36133*>          = 'F':  Forward, P = P(z-1)*...*P(2)*P(1)
36134*>          = 'B':  Backward, P = P(1)*P(2)*...*P(z-1)
36135*> \endverbatim
36136*>
36137*> \param[in] M
36138*> \verbatim
36139*>          M is INTEGER
36140*>          The number of rows of the matrix A.  If m <= 1, an immediate
36141*>          return is effected.
36142*> \endverbatim
36143*>
36144*> \param[in] N
36145*> \verbatim
36146*>          N is INTEGER
36147*>          The number of columns of the matrix A.  If n <= 1, an
36148*>          immediate return is effected.
36149*> \endverbatim
36150*>
36151*> \param[in] C
36152*> \verbatim
36153*>          C is DOUBLE PRECISION array, dimension
36154*>                  (M-1) if SIDE = 'L'
36155*>                  (N-1) if SIDE = 'R'
36156*>          The cosines c(k) of the plane rotations.
36157*> \endverbatim
36158*>
36159*> \param[in] S
36160*> \verbatim
36161*>          S is DOUBLE PRECISION array, dimension
36162*>                  (M-1) if SIDE = 'L'
36163*>                  (N-1) if SIDE = 'R'
36164*>          The sines s(k) of the plane rotations.  The 2-by-2 plane
36165*>          rotation part of the matrix P(k), R(k), has the form
36166*>          R(k) = (  c(k)  s(k) )
36167*>                 ( -s(k)  c(k) ).
36168*> \endverbatim
36169*>
36170*> \param[in,out] A
36171*> \verbatim
36172*>          A is COMPLEX*16 array, dimension (LDA,N)
36173*>          The M-by-N matrix A.  On exit, A is overwritten by P*A if
36174*>          SIDE = 'R' or by A*P**T if SIDE = 'L'.
36175*> \endverbatim
36176*>
36177*> \param[in] LDA
36178*> \verbatim
36179*>          LDA is INTEGER
36180*>          The leading dimension of the array A.  LDA >= max(1,M).
36181*> \endverbatim
36182*
36183*  Authors:
36184*  ========
36185*
36186*> \author Univ. of Tennessee
36187*> \author Univ. of California Berkeley
36188*> \author Univ. of Colorado Denver
36189*> \author NAG Ltd.
36190*
36191*> \date December 2016
36192*
36193*> \ingroup complex16OTHERauxiliary
36194*
36195*  =====================================================================
36196      SUBROUTINE ZLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )
36197*
36198*  -- LAPACK auxiliary routine (version 3.7.0) --
36199*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
36200*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
36201*     December 2016
36202*
36203*     .. Scalar Arguments ..
36204      CHARACTER          DIRECT, PIVOT, SIDE
36205      INTEGER            LDA, M, N
36206*     ..
36207*     .. Array Arguments ..
36208      DOUBLE PRECISION   C( * ), S( * )
36209      COMPLEX*16         A( LDA, * )
36210*     ..
36211*
36212*  =====================================================================
36213*
36214*     .. Parameters ..
36215      DOUBLE PRECISION   ONE, ZERO
36216      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
36217*     ..
36218*     .. Local Scalars ..
36219      INTEGER            I, INFO, J
36220      DOUBLE PRECISION   CTEMP, STEMP
36221      COMPLEX*16         TEMP
36222*     ..
36223*     .. Intrinsic Functions ..
36224      INTRINSIC          MAX
36225*     ..
36226*     .. External Functions ..
36227      LOGICAL            LSAME
36228      EXTERNAL           LSAME
36229*     ..
36230*     .. External Subroutines ..
36231      EXTERNAL           XERBLA
36232*     ..
36233*     .. Executable Statements ..
36234*
36235*     Test the input parameters
36236*
36237      INFO = 0
36238      IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN
36239         INFO = 1
36240      ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT,
36241     $         'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN
36242         INFO = 2
36243      ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) )
36244     $          THEN
36245         INFO = 3
36246      ELSE IF( M.LT.0 ) THEN
36247         INFO = 4
36248      ELSE IF( N.LT.0 ) THEN
36249         INFO = 5
36250      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
36251         INFO = 9
36252      END IF
36253      IF( INFO.NE.0 ) THEN
36254         CALL XERBLA( 'ZLASR ', INFO )
36255         RETURN
36256      END IF
36257*
36258*     Quick return if possible
36259*
36260      IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) )
36261     $   RETURN
36262      IF( LSAME( SIDE, 'L' ) ) THEN
36263*
36264*        Form  P * A
36265*
36266         IF( LSAME( PIVOT, 'V' ) ) THEN
36267            IF( LSAME( DIRECT, 'F' ) ) THEN
36268               DO 20 J = 1, M - 1
36269                  CTEMP = C( J )
36270                  STEMP = S( J )
36271                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
36272                     DO 10 I = 1, N
36273                        TEMP = A( J+1, I )
36274                        A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I )
36275                        A( J, I ) = STEMP*TEMP + CTEMP*A( J, I )
36276   10                CONTINUE
36277                  END IF
36278   20          CONTINUE
36279            ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
36280               DO 40 J = M - 1, 1, -1
36281                  CTEMP = C( J )
36282                  STEMP = S( J )
36283                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
36284                     DO 30 I = 1, N
36285                        TEMP = A( J+1, I )
36286                        A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I )
36287                        A( J, I ) = STEMP*TEMP + CTEMP*A( J, I )
36288   30                CONTINUE
36289                  END IF
36290   40          CONTINUE
36291            END IF
36292         ELSE IF( LSAME( PIVOT, 'T' ) ) THEN
36293            IF( LSAME( DIRECT, 'F' ) ) THEN
36294               DO 60 J = 2, M
36295                  CTEMP = C( J-1 )
36296                  STEMP = S( J-1 )
36297                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
36298                     DO 50 I = 1, N
36299                        TEMP = A( J, I )
36300                        A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I )
36301                        A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I )
36302   50                CONTINUE
36303                  END IF
36304   60          CONTINUE
36305            ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
36306               DO 80 J = M, 2, -1
36307                  CTEMP = C( J-1 )
36308                  STEMP = S( J-1 )
36309                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
36310                     DO 70 I = 1, N
36311                        TEMP = A( J, I )
36312                        A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I )
36313                        A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I )
36314   70                CONTINUE
36315                  END IF
36316   80          CONTINUE
36317            END IF
36318         ELSE IF( LSAME( PIVOT, 'B' ) ) THEN
36319            IF( LSAME( DIRECT, 'F' ) ) THEN
36320               DO 100 J = 1, M - 1
36321                  CTEMP = C( J )
36322                  STEMP = S( J )
36323                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
36324                     DO 90 I = 1, N
36325                        TEMP = A( J, I )
36326                        A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP
36327                        A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP
36328   90                CONTINUE
36329                  END IF
36330  100          CONTINUE
36331            ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
36332               DO 120 J = M - 1, 1, -1
36333                  CTEMP = C( J )
36334                  STEMP = S( J )
36335                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
36336                     DO 110 I = 1, N
36337                        TEMP = A( J, I )
36338                        A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP
36339                        A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP
36340  110                CONTINUE
36341                  END IF
36342  120          CONTINUE
36343            END IF
36344         END IF
36345      ELSE IF( LSAME( SIDE, 'R' ) ) THEN
36346*
36347*        Form A * P**T
36348*
36349         IF( LSAME( PIVOT, 'V' ) ) THEN
36350            IF( LSAME( DIRECT, 'F' ) ) THEN
36351               DO 140 J = 1, N - 1
36352                  CTEMP = C( J )
36353                  STEMP = S( J )
36354                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
36355                     DO 130 I = 1, M
36356                        TEMP = A( I, J+1 )
36357                        A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J )
36358                        A( I, J ) = STEMP*TEMP + CTEMP*A( I, J )
36359  130                CONTINUE
36360                  END IF
36361  140          CONTINUE
36362            ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
36363               DO 160 J = N - 1, 1, -1
36364                  CTEMP = C( J )
36365                  STEMP = S( J )
36366                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
36367                     DO 150 I = 1, M
36368                        TEMP = A( I, J+1 )
36369                        A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J )
36370                        A( I, J ) = STEMP*TEMP + CTEMP*A( I, J )
36371  150                CONTINUE
36372                  END IF
36373  160          CONTINUE
36374            END IF
36375         ELSE IF( LSAME( PIVOT, 'T' ) ) THEN
36376            IF( LSAME( DIRECT, 'F' ) ) THEN
36377               DO 180 J = 2, N
36378                  CTEMP = C( J-1 )
36379                  STEMP = S( J-1 )
36380                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
36381                     DO 170 I = 1, M
36382                        TEMP = A( I, J )
36383                        A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 )
36384                        A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 )
36385  170                CONTINUE
36386                  END IF
36387  180          CONTINUE
36388            ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
36389               DO 200 J = N, 2, -1
36390                  CTEMP = C( J-1 )
36391                  STEMP = S( J-1 )
36392                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
36393                     DO 190 I = 1, M
36394                        TEMP = A( I, J )
36395                        A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 )
36396                        A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 )
36397  190                CONTINUE
36398                  END IF
36399  200          CONTINUE
36400            END IF
36401         ELSE IF( LSAME( PIVOT, 'B' ) ) THEN
36402            IF( LSAME( DIRECT, 'F' ) ) THEN
36403               DO 220 J = 1, N - 1
36404                  CTEMP = C( J )
36405                  STEMP = S( J )
36406                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
36407                     DO 210 I = 1, M
36408                        TEMP = A( I, J )
36409                        A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP
36410                        A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP
36411  210                CONTINUE
36412                  END IF
36413  220          CONTINUE
36414            ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
36415               DO 240 J = N - 1, 1, -1
36416                  CTEMP = C( J )
36417                  STEMP = S( J )
36418                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
36419                     DO 230 I = 1, M
36420                        TEMP = A( I, J )
36421                        A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP
36422                        A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP
36423  230                CONTINUE
36424                  END IF
36425  240          CONTINUE
36426            END IF
36427         END IF
36428      END IF
36429*
36430      RETURN
36431*
36432*     End of ZLASR
36433*
36434      END
36435*> \brief \b ZLASSQ updates a sum of squares represented in scaled form.
36436*
36437*  =========== DOCUMENTATION ===========
36438*
36439* Online html documentation available at
36440*            http://www.netlib.org/lapack/explore-html/
36441*
36442*> \htmlonly
36443*> Download ZLASSQ + dependencies
36444*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlassq.f">
36445*> [TGZ]</a>
36446*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlassq.f">
36447*> [ZIP]</a>
36448*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlassq.f">
36449*> [TXT]</a>
36450*> \endhtmlonly
36451*
36452*  Definition:
36453*  ===========
36454*
36455*       SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ )
36456*
36457*       .. Scalar Arguments ..
36458*       INTEGER            INCX, N
36459*       DOUBLE PRECISION   SCALE, SUMSQ
36460*       ..
36461*       .. Array Arguments ..
36462*       COMPLEX*16         X( * )
36463*       ..
36464*
36465*
36466*> \par Purpose:
36467*  =============
36468*>
36469*> \verbatim
36470*>
36471*> ZLASSQ returns the values scl and ssq such that
36472*>
36473*>    ( scl**2 )*ssq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,
36474*>
36475*> where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is
36476*> assumed to be at least unity and the value of ssq will then satisfy
36477*>
36478*>    1.0 <= ssq <= ( sumsq + 2*n ).
36479*>
36480*> scale is assumed to be non-negative and scl returns the value
36481*>
36482*>    scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ),
36483*>           i
36484*>
36485*> scale and sumsq must be supplied in SCALE and SUMSQ respectively.
36486*> SCALE and SUMSQ are overwritten by scl and ssq respectively.
36487*>
36488*> The routine makes only one pass through the vector X.
36489*> \endverbatim
36490*
36491*  Arguments:
36492*  ==========
36493*
36494*> \param[in] N
36495*> \verbatim
36496*>          N is INTEGER
36497*>          The number of elements to be used from the vector X.
36498*> \endverbatim
36499*>
36500*> \param[in] X
36501*> \verbatim
36502*>          X is COMPLEX*16 array, dimension (1+(N-1)*INCX)
36503*>          The vector x as described above.
36504*>             x( i )  = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.
36505*> \endverbatim
36506*>
36507*> \param[in] INCX
36508*> \verbatim
36509*>          INCX is INTEGER
36510*>          The increment between successive values of the vector X.
36511*>          INCX > 0.
36512*> \endverbatim
36513*>
36514*> \param[in,out] SCALE
36515*> \verbatim
36516*>          SCALE is DOUBLE PRECISION
36517*>          On entry, the value  scale  in the equation above.
36518*>          On exit, SCALE is overwritten with the value  scl .
36519*> \endverbatim
36520*>
36521*> \param[in,out] SUMSQ
36522*> \verbatim
36523*>          SUMSQ is DOUBLE PRECISION
36524*>          On entry, the value  sumsq  in the equation above.
36525*>          On exit, SUMSQ is overwritten with the value  ssq .
36526*> \endverbatim
36527*
36528*  Authors:
36529*  ========
36530*
36531*> \author Univ. of Tennessee
36532*> \author Univ. of California Berkeley
36533*> \author Univ. of Colorado Denver
36534*> \author NAG Ltd.
36535*
36536*> \date December 2016
36537*
36538*> \ingroup complex16OTHERauxiliary
36539*
36540*  =====================================================================
36541      SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ )
36542*
36543*  -- LAPACK auxiliary routine (version 3.7.0) --
36544*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
36545*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
36546*     December 2016
36547*
36548*     .. Scalar Arguments ..
36549      INTEGER            INCX, N
36550      DOUBLE PRECISION   SCALE, SUMSQ
36551*     ..
36552*     .. Array Arguments ..
36553      COMPLEX*16         X( * )
36554*     ..
36555*
36556* =====================================================================
36557*
36558*     .. Parameters ..
36559      DOUBLE PRECISION   ZERO
36560      PARAMETER          ( ZERO = 0.0D+0 )
36561*     ..
36562*     .. Local Scalars ..
36563      INTEGER            IX
36564      DOUBLE PRECISION   TEMP1
36565*     ..
36566*     .. External Functions ..
36567      LOGICAL            DISNAN
36568      EXTERNAL           DISNAN
36569*     ..
36570*     .. Intrinsic Functions ..
36571      INTRINSIC          ABS, DBLE, DIMAG
36572*     ..
36573*     .. Executable Statements ..
36574*
36575      IF( N.GT.0 ) THEN
36576         DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX
36577            TEMP1 = ABS( DBLE( X( IX ) ) )
36578            IF( TEMP1.GT.ZERO.OR.DISNAN( TEMP1 ) ) THEN
36579               IF( SCALE.LT.TEMP1 ) THEN
36580                  SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2
36581                  SCALE = TEMP1
36582               ELSE
36583                  SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2
36584               END IF
36585            END IF
36586            TEMP1 = ABS( DIMAG( X( IX ) ) )
36587            IF( TEMP1.GT.ZERO.OR.DISNAN( TEMP1 ) ) THEN
36588               IF( SCALE.LT.TEMP1 ) THEN
36589                  SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2
36590                  SCALE = TEMP1
36591               ELSE
36592                  SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2
36593               END IF
36594            END IF
36595   10    CONTINUE
36596      END IF
36597*
36598      RETURN
36599*
36600*     End of ZLASSQ
36601*
36602      END
36603*> \brief \b ZLASWP performs a series of row interchanges on a general rectangular matrix.
36604*
36605*  =========== DOCUMENTATION ===========
36606*
36607* Online html documentation available at
36608*            http://www.netlib.org/lapack/explore-html/
36609*
36610*> \htmlonly
36611*> Download ZLASWP + dependencies
36612*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlaswp.f">
36613*> [TGZ]</a>
36614*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlaswp.f">
36615*> [ZIP]</a>
36616*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlaswp.f">
36617*> [TXT]</a>
36618*> \endhtmlonly
36619*
36620*  Definition:
36621*  ===========
36622*
36623*       SUBROUTINE ZLASWP( N, A, LDA, K1, K2, IPIV, INCX )
36624*
36625*       .. Scalar Arguments ..
36626*       INTEGER            INCX, K1, K2, LDA, N
36627*       ..
36628*       .. Array Arguments ..
36629*       INTEGER            IPIV( * )
36630*       COMPLEX*16         A( LDA, * )
36631*       ..
36632*
36633*
36634*> \par Purpose:
36635*  =============
36636*>
36637*> \verbatim
36638*>
36639*> ZLASWP performs a series of row interchanges on the matrix A.
36640*> One row interchange is initiated for each of rows K1 through K2 of A.
36641*> \endverbatim
36642*
36643*  Arguments:
36644*  ==========
36645*
36646*> \param[in] N
36647*> \verbatim
36648*>          N is INTEGER
36649*>          The number of columns of the matrix A.
36650*> \endverbatim
36651*>
36652*> \param[in,out] A
36653*> \verbatim
36654*>          A is COMPLEX*16 array, dimension (LDA,N)
36655*>          On entry, the matrix of column dimension N to which the row
36656*>          interchanges will be applied.
36657*>          On exit, the permuted matrix.
36658*> \endverbatim
36659*>
36660*> \param[in] LDA
36661*> \verbatim
36662*>          LDA is INTEGER
36663*>          The leading dimension of the array A.
36664*> \endverbatim
36665*>
36666*> \param[in] K1
36667*> \verbatim
36668*>          K1 is INTEGER
36669*>          The first element of IPIV for which a row interchange will
36670*>          be done.
36671*> \endverbatim
36672*>
36673*> \param[in] K2
36674*> \verbatim
36675*>          K2 is INTEGER
36676*>          (K2-K1+1) is the number of elements of IPIV for which a row
36677*>          interchange will be done.
36678*> \endverbatim
36679*>
36680*> \param[in] IPIV
36681*> \verbatim
36682*>          IPIV is INTEGER array, dimension (K1+(K2-K1)*abs(INCX))
36683*>          The vector of pivot indices. Only the elements in positions
36684*>          K1 through K1+(K2-K1)*abs(INCX) of IPIV are accessed.
36685*>          IPIV(K1+(K-K1)*abs(INCX)) = L implies rows K and L are to be
36686*>          interchanged.
36687*> \endverbatim
36688*>
36689*> \param[in] INCX
36690*> \verbatim
36691*>          INCX is INTEGER
36692*>          The increment between successive values of IPIV. If INCX
36693*>          is negative, the pivots are applied in reverse order.
36694*> \endverbatim
36695*
36696*  Authors:
36697*  ========
36698*
36699*> \author Univ. of Tennessee
36700*> \author Univ. of California Berkeley
36701*> \author Univ. of Colorado Denver
36702*> \author NAG Ltd.
36703*
36704*> \date June 2017
36705*
36706*> \ingroup complex16OTHERauxiliary
36707*
36708*> \par Further Details:
36709*  =====================
36710*>
36711*> \verbatim
36712*>
36713*>  Modified by
36714*>   R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA
36715*> \endverbatim
36716*>
36717*  =====================================================================
36718      SUBROUTINE ZLASWP( N, A, LDA, K1, K2, IPIV, INCX )
36719*
36720*  -- LAPACK auxiliary routine (version 3.7.1) --
36721*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
36722*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
36723*     June 2017
36724*
36725*     .. Scalar Arguments ..
36726      INTEGER            INCX, K1, K2, LDA, N
36727*     ..
36728*     .. Array Arguments ..
36729      INTEGER            IPIV( * )
36730      COMPLEX*16         A( LDA, * )
36731*     ..
36732*
36733* =====================================================================
36734*
36735*     .. Local Scalars ..
36736      INTEGER            I, I1, I2, INC, IP, IX, IX0, J, K, N32
36737      COMPLEX*16         TEMP
36738*     ..
36739*     .. Executable Statements ..
36740*
36741*     Interchange row I with row IPIV(K1+(I-K1)*abs(INCX)) for each of rows
36742*     K1 through K2.
36743*
36744      IF( INCX.GT.0 ) THEN
36745         IX0 = K1
36746         I1 = K1
36747         I2 = K2
36748         INC = 1
36749      ELSE IF( INCX.LT.0 ) THEN
36750         IX0 = K1 + ( K1-K2 )*INCX
36751         I1 = K2
36752         I2 = K1
36753         INC = -1
36754      ELSE
36755         RETURN
36756      END IF
36757*
36758      N32 = ( N / 32 )*32
36759      IF( N32.NE.0 ) THEN
36760         DO 30 J = 1, N32, 32
36761            IX = IX0
36762            DO 20 I = I1, I2, INC
36763               IP = IPIV( IX )
36764               IF( IP.NE.I ) THEN
36765                  DO 10 K = J, J + 31
36766                     TEMP = A( I, K )
36767                     A( I, K ) = A( IP, K )
36768                     A( IP, K ) = TEMP
36769   10             CONTINUE
36770               END IF
36771               IX = IX + INCX
36772   20       CONTINUE
36773   30    CONTINUE
36774      END IF
36775      IF( N32.NE.N ) THEN
36776         N32 = N32 + 1
36777         IX = IX0
36778         DO 50 I = I1, I2, INC
36779            IP = IPIV( IX )
36780            IF( IP.NE.I ) THEN
36781               DO 40 K = N32, N
36782                  TEMP = A( I, K )
36783                  A( I, K ) = A( IP, K )
36784                  A( IP, K ) = TEMP
36785   40          CONTINUE
36786            END IF
36787            IX = IX + INCX
36788   50    CONTINUE
36789      END IF
36790*
36791      RETURN
36792*
36793*     End of ZLASWP
36794*
36795      END
36796*> \brief \b ZLASYF computes a partial factorization of a complex symmetric matrix using the Bunch-Kaufman diagonal pivoting method.
36797*
36798*  =========== DOCUMENTATION ===========
36799*
36800* Online html documentation available at
36801*            http://www.netlib.org/lapack/explore-html/
36802*
36803*> \htmlonly
36804*> Download ZLASYF + dependencies
36805*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlasyf.f">
36806*> [TGZ]</a>
36807*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlasyf.f">
36808*> [ZIP]</a>
36809*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlasyf.f">
36810*> [TXT]</a>
36811*> \endhtmlonly
36812*
36813*  Definition:
36814*  ===========
36815*
36816*       SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )
36817*
36818*       .. Scalar Arguments ..
36819*       CHARACTER          UPLO
36820*       INTEGER            INFO, KB, LDA, LDW, N, NB
36821*       ..
36822*       .. Array Arguments ..
36823*       INTEGER            IPIV( * )
36824*       COMPLEX*16         A( LDA, * ), W( LDW, * )
36825*       ..
36826*
36827*
36828*> \par Purpose:
36829*  =============
36830*>
36831*> \verbatim
36832*>
36833*> ZLASYF computes a partial factorization of a complex symmetric matrix
36834*> A using the Bunch-Kaufman diagonal pivoting method. The partial
36835*> factorization has the form:
36836*>
36837*> A  =  ( I  U12 ) ( A11  0  ) (  I       0    )  if UPLO = 'U', or:
36838*>       ( 0  U22 ) (  0   D  ) ( U12**T U22**T )
36839*>
36840*> A  =  ( L11  0 ) ( D    0  ) ( L11**T L21**T )  if UPLO = 'L'
36841*>       ( L21  I ) ( 0   A22 ) (  0       I    )
36842*>
36843*> where the order of D is at most NB. The actual order is returned in
36844*> the argument KB, and is either NB or NB-1, or N if N <= NB.
36845*> Note that U**T denotes the transpose of U.
36846*>
36847*> ZLASYF is an auxiliary routine called by ZSYTRF. It uses blocked code
36848*> (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or
36849*> A22 (if UPLO = 'L').
36850*> \endverbatim
36851*
36852*  Arguments:
36853*  ==========
36854*
36855*> \param[in] UPLO
36856*> \verbatim
36857*>          UPLO is CHARACTER*1
36858*>          Specifies whether the upper or lower triangular part of the
36859*>          symmetric matrix A is stored:
36860*>          = 'U':  Upper triangular
36861*>          = 'L':  Lower triangular
36862*> \endverbatim
36863*>
36864*> \param[in] N
36865*> \verbatim
36866*>          N is INTEGER
36867*>          The order of the matrix A.  N >= 0.
36868*> \endverbatim
36869*>
36870*> \param[in] NB
36871*> \verbatim
36872*>          NB is INTEGER
36873*>          The maximum number of columns of the matrix A that should be
36874*>          factored.  NB should be at least 2 to allow for 2-by-2 pivot
36875*>          blocks.
36876*> \endverbatim
36877*>
36878*> \param[out] KB
36879*> \verbatim
36880*>          KB is INTEGER
36881*>          The number of columns of A that were actually factored.
36882*>          KB is either NB-1 or NB, or N if N <= NB.
36883*> \endverbatim
36884*>
36885*> \param[in,out] A
36886*> \verbatim
36887*>          A is COMPLEX*16 array, dimension (LDA,N)
36888*>          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
36889*>          n-by-n upper triangular part of A contains the upper
36890*>          triangular part of the matrix A, and the strictly lower
36891*>          triangular part of A is not referenced.  If UPLO = 'L', the
36892*>          leading n-by-n lower triangular part of A contains the lower
36893*>          triangular part of the matrix A, and the strictly upper
36894*>          triangular part of A is not referenced.
36895*>          On exit, A contains details of the partial factorization.
36896*> \endverbatim
36897*>
36898*> \param[in] LDA
36899*> \verbatim
36900*>          LDA is INTEGER
36901*>          The leading dimension of the array A.  LDA >= max(1,N).
36902*> \endverbatim
36903*>
36904*> \param[out] IPIV
36905*> \verbatim
36906*>          IPIV is INTEGER array, dimension (N)
36907*>          Details of the interchanges and the block structure of D.
36908*>
36909*>          If UPLO = 'U':
36910*>             Only the last KB elements of IPIV are set.
36911*>
36912*>             If IPIV(k) > 0, then rows and columns k and IPIV(k) were
36913*>             interchanged and D(k,k) is a 1-by-1 diagonal block.
36914*>
36915*>             If IPIV(k) = IPIV(k-1) < 0, then rows and columns
36916*>             k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
36917*>             is a 2-by-2 diagonal block.
36918*>
36919*>          If UPLO = 'L':
36920*>             Only the first KB elements of IPIV are set.
36921*>
36922*>             If IPIV(k) > 0, then rows and columns k and IPIV(k) were
36923*>             interchanged and D(k,k) is a 1-by-1 diagonal block.
36924*>
36925*>             If IPIV(k) = IPIV(k+1) < 0, then rows and columns
36926*>             k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1)
36927*>             is a 2-by-2 diagonal block.
36928*> \endverbatim
36929*>
36930*> \param[out] W
36931*> \verbatim
36932*>          W is COMPLEX*16 array, dimension (LDW,NB)
36933*> \endverbatim
36934*>
36935*> \param[in] LDW
36936*> \verbatim
36937*>          LDW is INTEGER
36938*>          The leading dimension of the array W.  LDW >= max(1,N).
36939*> \endverbatim
36940*>
36941*> \param[out] INFO
36942*> \verbatim
36943*>          INFO is INTEGER
36944*>          = 0: successful exit
36945*>          > 0: if INFO = k, D(k,k) is exactly zero.  The factorization
36946*>               has been completed, but the block diagonal matrix D is
36947*>               exactly singular.
36948*> \endverbatim
36949*
36950*  Authors:
36951*  ========
36952*
36953*> \author Univ. of Tennessee
36954*> \author Univ. of California Berkeley
36955*> \author Univ. of Colorado Denver
36956*> \author NAG Ltd.
36957*
36958*> \date November 2013
36959*
36960*> \ingroup complex16SYcomputational
36961*
36962*> \par Contributors:
36963*  ==================
36964*>
36965*> \verbatim
36966*>
36967*>  November 2013,  Igor Kozachenko,
36968*>                  Computer Science Division,
36969*>                  University of California, Berkeley
36970*> \endverbatim
36971*
36972*  =====================================================================
36973      SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )
36974*
36975*  -- LAPACK computational routine (version 3.5.0) --
36976*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
36977*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
36978*     November 2013
36979*
36980*     .. Scalar Arguments ..
36981      CHARACTER          UPLO
36982      INTEGER            INFO, KB, LDA, LDW, N, NB
36983*     ..
36984*     .. Array Arguments ..
36985      INTEGER            IPIV( * )
36986      COMPLEX*16         A( LDA, * ), W( LDW, * )
36987*     ..
36988*
36989*  =====================================================================
36990*
36991*     .. Parameters ..
36992      DOUBLE PRECISION   ZERO, ONE
36993      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
36994      DOUBLE PRECISION   EIGHT, SEVTEN
36995      PARAMETER          ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
36996      COMPLEX*16         CONE
36997      PARAMETER          ( CONE = ( 1.0D+0, 0.0D+0 ) )
36998*     ..
36999*     .. Local Scalars ..
37000      INTEGER            IMAX, J, JB, JJ, JMAX, JP, K, KK, KKW, KP,
37001     $                   KSTEP, KW
37002      DOUBLE PRECISION   ABSAKK, ALPHA, COLMAX, ROWMAX
37003      COMPLEX*16         D11, D21, D22, R1, T, Z
37004*     ..
37005*     .. External Functions ..
37006      LOGICAL            LSAME
37007      INTEGER            IZAMAX
37008      EXTERNAL           LSAME, IZAMAX
37009*     ..
37010*     .. External Subroutines ..
37011      EXTERNAL           ZCOPY, ZGEMM, ZGEMV, ZSCAL, ZSWAP
37012*     ..
37013*     .. Intrinsic Functions ..
37014      INTRINSIC          ABS, DBLE, DIMAG, MAX, MIN, SQRT
37015*     ..
37016*     .. Statement Functions ..
37017      DOUBLE PRECISION   CABS1
37018*     ..
37019*     .. Statement Function definitions ..
37020      CABS1( Z ) = ABS( DBLE( Z ) ) + ABS( DIMAG( Z ) )
37021*     ..
37022*     .. Executable Statements ..
37023*
37024      INFO = 0
37025*
37026*     Initialize ALPHA for use in choosing pivot block size.
37027*
37028      ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
37029*
37030      IF( LSAME( UPLO, 'U' ) ) THEN
37031*
37032*        Factorize the trailing columns of A using the upper triangle
37033*        of A and working backwards, and compute the matrix W = U12*D
37034*        for use in updating A11
37035*
37036*        K is the main loop index, decreasing from N in steps of 1 or 2
37037*
37038*        KW is the column of W which corresponds to column K of A
37039*
37040         K = N
37041   10    CONTINUE
37042         KW = NB + K - N
37043*
37044*        Exit from loop
37045*
37046         IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 )
37047     $      GO TO 30
37048*
37049*        Copy column K of A to column KW of W and update it
37050*
37051         CALL ZCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 )
37052         IF( K.LT.N )
37053     $      CALL ZGEMV( 'No transpose', K, N-K, -CONE, A( 1, K+1 ), LDA,
37054     $                  W( K, KW+1 ), LDW, CONE, W( 1, KW ), 1 )
37055*
37056         KSTEP = 1
37057*
37058*        Determine rows and columns to be interchanged and whether
37059*        a 1-by-1 or 2-by-2 pivot block will be used
37060*
37061         ABSAKK = CABS1( W( K, KW ) )
37062*
37063*        IMAX is the row-index of the largest off-diagonal element in
37064
37065*
37066         IF( K.GT.1 ) THEN
37067            IMAX = IZAMAX( K-1, W( 1, KW ), 1 )
37068            COLMAX = CABS1( W( IMAX, KW ) )
37069         ELSE
37070            COLMAX = ZERO
37071         END IF
37072*
37073         IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
37074*
37075*           Column K is zero or underflow: set INFO and continue
37076*
37077            IF( INFO.EQ.0 )
37078     $         INFO = K
37079            KP = K
37080         ELSE
37081            IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
37082*
37083*              no interchange, use 1-by-1 pivot block
37084*
37085               KP = K
37086            ELSE
37087*
37088*              Copy column IMAX to column KW-1 of W and update it
37089*
37090               CALL ZCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 )
37091               CALL ZCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA,
37092     $                     W( IMAX+1, KW-1 ), 1 )
37093               IF( K.LT.N )
37094     $            CALL ZGEMV( 'No transpose', K, N-K, -CONE,
37095     $                        A( 1, K+1 ), LDA, W( IMAX, KW+1 ), LDW,
37096     $                        CONE, W( 1, KW-1 ), 1 )
37097*
37098*              JMAX is the column-index of the largest off-diagonal
37099*              element in row IMAX, and ROWMAX is its absolute value
37100*
37101               JMAX = IMAX + IZAMAX( K-IMAX, W( IMAX+1, KW-1 ), 1 )
37102               ROWMAX = CABS1( W( JMAX, KW-1 ) )
37103               IF( IMAX.GT.1 ) THEN
37104                  JMAX = IZAMAX( IMAX-1, W( 1, KW-1 ), 1 )
37105                  ROWMAX = MAX( ROWMAX, CABS1( W( JMAX, KW-1 ) ) )
37106               END IF
37107*
37108               IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
37109*
37110*                 no interchange, use 1-by-1 pivot block
37111*
37112                  KP = K
37113               ELSE IF( CABS1( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX ) THEN
37114*
37115*                 interchange rows and columns K and IMAX, use 1-by-1
37116*                 pivot block
37117*
37118                  KP = IMAX
37119*
37120*                 copy column KW-1 of W to column KW of W
37121*
37122                  CALL ZCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
37123               ELSE
37124*
37125*                 interchange rows and columns K-1 and IMAX, use 2-by-2
37126*                 pivot block
37127*
37128                  KP = IMAX
37129                  KSTEP = 2
37130               END IF
37131            END IF
37132*
37133*           ============================================================
37134*
37135*           KK is the column of A where pivoting step stopped
37136*
37137            KK = K - KSTEP + 1
37138*
37139*           KKW is the column of W which corresponds to column KK of A
37140*
37141            KKW = NB + KK - N
37142*
37143*           Interchange rows and columns KP and KK.
37144*           Updated column KP is already stored in column KKW of W.
37145*
37146            IF( KP.NE.KK ) THEN
37147*
37148*              Copy non-updated column KK to column KP of submatrix A
37149*              at step K. No need to copy element into column K
37150*              (or K and K-1 for 2-by-2 pivot) of A, since these columns
37151*              will be later overwritten.
37152*
37153               A( KP, KP ) = A( KK, KK )
37154               CALL ZCOPY( KK-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
37155     $                     LDA )
37156               IF( KP.GT.1 )
37157     $            CALL ZCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
37158*
37159*              Interchange rows KK and KP in last K+1 to N columns of A
37160*              (columns K (or K and K-1 for 2-by-2 pivot) of A will be
37161*              later overwritten). Interchange rows KK and KP
37162*              in last KKW to NB columns of W.
37163*
37164               IF( K.LT.N )
37165     $            CALL ZSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ),
37166     $                        LDA )
37167               CALL ZSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ),
37168     $                     LDW )
37169            END IF
37170*
37171            IF( KSTEP.EQ.1 ) THEN
37172*
37173*              1-by-1 pivot block D(k): column kw of W now holds
37174*
37175*              W(kw) = U(k)*D(k),
37176*
37177*              where U(k) is the k-th column of U
37178*
37179*              Store subdiag. elements of column U(k)
37180*              and 1-by-1 block D(k) in column k of A.
37181*              NOTE: Diagonal element U(k,k) is a UNIT element
37182*              and not stored.
37183*                 A(k,k) := D(k,k) = W(k,kw)
37184*                 A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k)
37185*
37186               CALL ZCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
37187               R1 = CONE / A( K, K )
37188               CALL ZSCAL( K-1, R1, A( 1, K ), 1 )
37189*
37190            ELSE
37191*
37192*              2-by-2 pivot block D(k): columns kw and kw-1 of W now hold
37193*
37194*              ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k)
37195*
37196*              where U(k) and U(k-1) are the k-th and (k-1)-th columns
37197*              of U
37198*
37199*              Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2
37200*              block D(k-1:k,k-1:k) in columns k-1 and k of A.
37201*              NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT
37202*              block and not stored.
37203*                 A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw)
37204*                 A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) =
37205*                 = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) )
37206*
37207               IF( K.GT.2 ) THEN
37208*
37209*                 Compose the columns of the inverse of 2-by-2 pivot
37210*                 block D in the following way to reduce the number
37211*                 of FLOPS when we myltiply panel ( W(kw-1) W(kw) ) by
37212*                 this inverse
37213*
37214*                 D**(-1) = ( d11 d21 )**(-1) =
37215*                           ( d21 d22 )
37216*
37217*                 = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) =
37218*                                        ( (-d21 ) ( d11 ) )
37219*
37220*                 = 1/d21 * 1/((d11/d21)*(d22/d21)-1) *
37221*
37222*                   * ( ( d22/d21 ) (      -1 ) ) =
37223*                     ( (      -1 ) ( d11/d21 ) )
37224*
37225*                 = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) (  -1 ) ) =
37226*                                           ( ( -1  ) ( D22 ) )
37227*
37228*                 = 1/d21 * T * ( ( D11 ) (  -1 ) )
37229*                               ( (  -1 ) ( D22 ) )
37230*
37231*                 = D21 * ( ( D11 ) (  -1 ) )
37232*                         ( (  -1 ) ( D22 ) )
37233*
37234                  D21 = W( K-1, KW )
37235                  D11 = W( K, KW ) / D21
37236                  D22 = W( K-1, KW-1 ) / D21
37237                  T = CONE / ( D11*D22-CONE )
37238                  D21 = T / D21
37239*
37240*                 Update elements in columns A(k-1) and A(k) as
37241*                 dot products of rows of ( W(kw-1) W(kw) ) and columns
37242*                 of D**(-1)
37243*
37244                  DO 20 J = 1, K - 2
37245                     A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) )
37246                     A( J, K ) = D21*( D22*W( J, KW )-W( J, KW-1 ) )
37247   20             CONTINUE
37248               END IF
37249*
37250*              Copy D(k) to A
37251*
37252               A( K-1, K-1 ) = W( K-1, KW-1 )
37253               A( K-1, K ) = W( K-1, KW )
37254               A( K, K ) = W( K, KW )
37255*
37256            END IF
37257*
37258         END IF
37259*
37260*        Store details of the interchanges in IPIV
37261*
37262         IF( KSTEP.EQ.1 ) THEN
37263            IPIV( K ) = KP
37264         ELSE
37265            IPIV( K ) = -KP
37266            IPIV( K-1 ) = -KP
37267         END IF
37268*
37269*        Decrease K and return to the start of the main loop
37270*
37271         K = K - KSTEP
37272         GO TO 10
37273*
37274   30    CONTINUE
37275*
37276*        Update the upper triangle of A11 (= A(1:k,1:k)) as
37277*
37278*        A11 := A11 - U12*D*U12**T = A11 - U12*W**T
37279*
37280*        computing blocks of NB columns at a time
37281*
37282         DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB
37283            JB = MIN( NB, K-J+1 )
37284*
37285*           Update the upper triangle of the diagonal block
37286*
37287            DO 40 JJ = J, J + JB - 1
37288               CALL ZGEMV( 'No transpose', JJ-J+1, N-K, -CONE,
37289     $                     A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, CONE,
37290     $                     A( J, JJ ), 1 )
37291   40       CONTINUE
37292*
37293*           Update the rectangular superdiagonal block
37294*
37295            CALL ZGEMM( 'No transpose', 'Transpose', J-1, JB, N-K,
37296     $                  -CONE, A( 1, K+1 ), LDA, W( J, KW+1 ), LDW,
37297     $                  CONE, A( 1, J ), LDA )
37298   50    CONTINUE
37299*
37300*        Put U12 in standard form by partially undoing the interchanges
37301*        in columns k+1:n looping backwards from k+1 to n
37302*
37303         J = K + 1
37304   60    CONTINUE
37305*
37306*           Undo the interchanges (if any) of rows JJ and JP at each
37307*           step J
37308*
37309*           (Here, J is a diagonal index)
37310            JJ = J
37311            JP = IPIV( J )
37312            IF( JP.LT.0 ) THEN
37313               JP = -JP
37314*              (Here, J is a diagonal index)
37315               J = J + 1
37316            END IF
37317*           (NOTE: Here, J is used to determine row length. Length N-J+1
37318*           of the rows to swap back doesn't include diagonal element)
37319            J = J + 1
37320            IF( JP.NE.JJ .AND. J.LE.N )
37321     $         CALL ZSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA )
37322         IF( J.LT.N )
37323     $      GO TO 60
37324*
37325*        Set KB to the number of columns factorized
37326*
37327         KB = N - K
37328*
37329      ELSE
37330*
37331*        Factorize the leading columns of A using the lower triangle
37332*        of A and working forwards, and compute the matrix W = L21*D
37333*        for use in updating A22
37334*
37335*        K is the main loop index, increasing from 1 in steps of 1 or 2
37336*
37337         K = 1
37338   70    CONTINUE
37339*
37340*        Exit from loop
37341*
37342         IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N )
37343     $      GO TO 90
37344*
37345*        Copy column K of A to column K of W and update it
37346*
37347         CALL ZCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 )
37348         CALL ZGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ), LDA,
37349     $               W( K, 1 ), LDW, CONE, W( K, K ), 1 )
37350*
37351         KSTEP = 1
37352*
37353*        Determine rows and columns to be interchanged and whether
37354*        a 1-by-1 or 2-by-2 pivot block will be used
37355*
37356         ABSAKK = CABS1( W( K, K ) )
37357*
37358*        IMAX is the row-index of the largest off-diagonal element in
37359
37360*
37361         IF( K.LT.N ) THEN
37362            IMAX = K + IZAMAX( N-K, W( K+1, K ), 1 )
37363            COLMAX = CABS1( W( IMAX, K ) )
37364         ELSE
37365            COLMAX = ZERO
37366         END IF
37367*
37368         IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
37369*
37370*           Column K is zero or underflow: set INFO and continue
37371*
37372            IF( INFO.EQ.0 )
37373     $         INFO = K
37374            KP = K
37375         ELSE
37376            IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
37377*
37378*              no interchange, use 1-by-1 pivot block
37379*
37380               KP = K
37381            ELSE
37382*
37383*              Copy column IMAX to column K+1 of W and update it
37384*
37385               CALL ZCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1 )
37386               CALL ZCOPY( N-IMAX+1, A( IMAX, IMAX ), 1, W( IMAX, K+1 ),
37387     $                     1 )
37388               CALL ZGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ),
37389     $                     LDA, W( IMAX, 1 ), LDW, CONE, W( K, K+1 ),
37390     $                     1 )
37391*
37392*              JMAX is the column-index of the largest off-diagonal
37393*              element in row IMAX, and ROWMAX is its absolute value
37394*
37395               JMAX = K - 1 + IZAMAX( IMAX-K, W( K, K+1 ), 1 )
37396               ROWMAX = CABS1( W( JMAX, K+1 ) )
37397               IF( IMAX.LT.N ) THEN
37398                  JMAX = IMAX + IZAMAX( N-IMAX, W( IMAX+1, K+1 ), 1 )
37399                  ROWMAX = MAX( ROWMAX, CABS1( W( JMAX, K+1 ) ) )
37400               END IF
37401*
37402               IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
37403*
37404*                 no interchange, use 1-by-1 pivot block
37405*
37406                  KP = K
37407               ELSE IF( CABS1( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX ) THEN
37408*
37409*                 interchange rows and columns K and IMAX, use 1-by-1
37410*                 pivot block
37411*
37412                  KP = IMAX
37413*
37414*                 copy column K+1 of W to column K of W
37415*
37416                  CALL ZCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
37417               ELSE
37418*
37419*                 interchange rows and columns K+1 and IMAX, use 2-by-2
37420*                 pivot block
37421*
37422                  KP = IMAX
37423                  KSTEP = 2
37424               END IF
37425            END IF
37426*
37427*           ============================================================
37428*
37429*           KK is the column of A where pivoting step stopped
37430*
37431            KK = K + KSTEP - 1
37432*
37433*           Interchange rows and columns KP and KK.
37434*           Updated column KP is already stored in column KK of W.
37435*
37436            IF( KP.NE.KK ) THEN
37437*
37438*              Copy non-updated column KK to column KP of submatrix A
37439*              at step K. No need to copy element into column K
37440*              (or K and K+1 for 2-by-2 pivot) of A, since these columns
37441*              will be later overwritten.
37442*
37443               A( KP, KP ) = A( KK, KK )
37444               CALL ZCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ),
37445     $                     LDA )
37446               IF( KP.LT.N )
37447     $            CALL ZCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
37448*
37449*              Interchange rows KK and KP in first K-1 columns of A
37450*              (columns K (or K and K+1 for 2-by-2 pivot) of A will be
37451*              later overwritten). Interchange rows KK and KP
37452*              in first KK columns of W.
37453*
37454               IF( K.GT.1 )
37455     $            CALL ZSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
37456               CALL ZSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW )
37457            END IF
37458*
37459            IF( KSTEP.EQ.1 ) THEN
37460*
37461*              1-by-1 pivot block D(k): column k of W now holds
37462*
37463*              W(k) = L(k)*D(k),
37464*
37465*              where L(k) is the k-th column of L
37466*
37467*              Store subdiag. elements of column L(k)
37468*              and 1-by-1 block D(k) in column k of A.
37469*              (NOTE: Diagonal element L(k,k) is a UNIT element
37470*              and not stored)
37471*                 A(k,k) := D(k,k) = W(k,k)
37472*                 A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k)
37473*
37474               CALL ZCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
37475               IF( K.LT.N ) THEN
37476                  R1 = CONE / A( K, K )
37477                  CALL ZSCAL( N-K, R1, A( K+1, K ), 1 )
37478               END IF
37479*
37480            ELSE
37481*
37482*              2-by-2 pivot block D(k): columns k and k+1 of W now hold
37483*
37484*              ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
37485*
37486*              where L(k) and L(k+1) are the k-th and (k+1)-th columns
37487*              of L
37488*
37489*              Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2
37490*              block D(k:k+1,k:k+1) in columns k and k+1 of A.
37491*              (NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT
37492*              block and not stored)
37493*                 A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1)
37494*                 A(k+2:N,k:k+1) := L(k+2:N,k:k+1) =
37495*                 = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) )
37496*
37497               IF( K.LT.N-1 ) THEN
37498*
37499*                 Compose the columns of the inverse of 2-by-2 pivot
37500*                 block D in the following way to reduce the number
37501*                 of FLOPS when we myltiply panel ( W(k) W(k+1) ) by
37502*                 this inverse
37503*
37504*                 D**(-1) = ( d11 d21 )**(-1) =
37505*                           ( d21 d22 )
37506*
37507*                 = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) =
37508*                                        ( (-d21 ) ( d11 ) )
37509*
37510*                 = 1/d21 * 1/((d11/d21)*(d22/d21)-1) *
37511*
37512*                   * ( ( d22/d21 ) (      -1 ) ) =
37513*                     ( (      -1 ) ( d11/d21 ) )
37514*
37515*                 = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) (  -1 ) ) =
37516*                                           ( ( -1  ) ( D22 ) )
37517*
37518*                 = 1/d21 * T * ( ( D11 ) (  -1 ) )
37519*                               ( (  -1 ) ( D22 ) )
37520*
37521*                 = D21 * ( ( D11 ) (  -1 ) )
37522*                         ( (  -1 ) ( D22 ) )
37523*
37524                  D21 = W( K+1, K )
37525                  D11 = W( K+1, K+1 ) / D21
37526                  D22 = W( K, K ) / D21
37527                  T = CONE / ( D11*D22-CONE )
37528                  D21 = T / D21
37529*
37530*                 Update elements in columns A(k) and A(k+1) as
37531*                 dot products of rows of ( W(k) W(k+1) ) and columns
37532*                 of D**(-1)
37533*
37534                  DO 80 J = K + 2, N
37535                     A( J, K ) = D21*( D11*W( J, K )-W( J, K+1 ) )
37536                     A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) )
37537   80             CONTINUE
37538               END IF
37539*
37540*              Copy D(k) to A
37541*
37542               A( K, K ) = W( K, K )
37543               A( K+1, K ) = W( K+1, K )
37544               A( K+1, K+1 ) = W( K+1, K+1 )
37545*
37546            END IF
37547*
37548         END IF
37549*
37550*        Store details of the interchanges in IPIV
37551*
37552         IF( KSTEP.EQ.1 ) THEN
37553            IPIV( K ) = KP
37554         ELSE
37555            IPIV( K ) = -KP
37556            IPIV( K+1 ) = -KP
37557         END IF
37558*
37559*        Increase K and return to the start of the main loop
37560*
37561         K = K + KSTEP
37562         GO TO 70
37563*
37564   90    CONTINUE
37565*
37566*        Update the lower triangle of A22 (= A(k:n,k:n)) as
37567*
37568*        A22 := A22 - L21*D*L21**T = A22 - L21*W**T
37569*
37570*        computing blocks of NB columns at a time
37571*
37572         DO 110 J = K, N, NB
37573            JB = MIN( NB, N-J+1 )
37574*
37575*           Update the lower triangle of the diagonal block
37576*
37577            DO 100 JJ = J, J + JB - 1
37578               CALL ZGEMV( 'No transpose', J+JB-JJ, K-1, -CONE,
37579     $                     A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, CONE,
37580     $                     A( JJ, JJ ), 1 )
37581  100       CONTINUE
37582*
37583*           Update the rectangular subdiagonal block
37584*
37585            IF( J+JB.LE.N )
37586     $         CALL ZGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB,
37587     $                     K-1, -CONE, A( J+JB, 1 ), LDA, W( J, 1 ),
37588     $                     LDW, CONE, A( J+JB, J ), LDA )
37589  110    CONTINUE
37590*
37591*        Put L21 in standard form by partially undoing the interchanges
37592*        of rows in columns 1:k-1 looping backwards from k-1 to 1
37593*
37594         J = K - 1
37595  120    CONTINUE
37596*
37597*           Undo the interchanges (if any) of rows JJ and JP at each
37598*           step J
37599*
37600*           (Here, J is a diagonal index)
37601            JJ = J
37602            JP = IPIV( J )
37603            IF( JP.LT.0 ) THEN
37604               JP = -JP
37605*              (Here, J is a diagonal index)
37606               J = J - 1
37607            END IF
37608*           (NOTE: Here, J is used to determine row length. Length J
37609*           of the rows to swap back doesn't include diagonal element)
37610            J = J - 1
37611            IF( JP.NE.JJ .AND. J.GE.1 )
37612     $         CALL ZSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA )
37613         IF( J.GT.1 )
37614     $      GO TO 120
37615*
37616*        Set KB to the number of columns factorized
37617*
37618         KB = K - 1
37619*
37620      END IF
37621      RETURN
37622*
37623*     End of ZLASYF
37624*
37625      END
37626*> \brief \b ZLATDF uses the LU factorization of the n-by-n matrix computed by sgetc2 and computes a contribution to the reciprocal Dif-estimate.
37627*
37628*  =========== DOCUMENTATION ===========
37629*
37630* Online html documentation available at
37631*            http://www.netlib.org/lapack/explore-html/
37632*
37633*> \htmlonly
37634*> Download ZLATDF + dependencies
37635*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlatdf.f">
37636*> [TGZ]</a>
37637*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlatdf.f">
37638*> [ZIP]</a>
37639*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlatdf.f">
37640*> [TXT]</a>
37641*> \endhtmlonly
37642*
37643*  Definition:
37644*  ===========
37645*
37646*       SUBROUTINE ZLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV,
37647*                          JPIV )
37648*
37649*       .. Scalar Arguments ..
37650*       INTEGER            IJOB, LDZ, N
37651*       DOUBLE PRECISION   RDSCAL, RDSUM
37652*       ..
37653*       .. Array Arguments ..
37654*       INTEGER            IPIV( * ), JPIV( * )
37655*       COMPLEX*16         RHS( * ), Z( LDZ, * )
37656*       ..
37657*
37658*
37659*> \par Purpose:
37660*  =============
37661*>
37662*> \verbatim
37663*>
37664*> ZLATDF computes the contribution to the reciprocal Dif-estimate
37665*> by solving for x in Z * x = b, where b is chosen such that the norm
37666*> of x is as large as possible. It is assumed that LU decomposition
37667*> of Z has been computed by ZGETC2. On entry RHS = f holds the
37668*> contribution from earlier solved sub-systems, and on return RHS = x.
37669*>
37670*> The factorization of Z returned by ZGETC2 has the form
37671*> Z = P * L * U * Q, where P and Q are permutation matrices. L is lower
37672*> triangular with unit diagonal elements and U is upper triangular.
37673*> \endverbatim
37674*
37675*  Arguments:
37676*  ==========
37677*
37678*> \param[in] IJOB
37679*> \verbatim
37680*>          IJOB is INTEGER
37681*>          IJOB = 2: First compute an approximative null-vector e
37682*>              of Z using ZGECON, e is normalized and solve for
37683*>              Zx = +-e - f with the sign giving the greater value of
37684*>              2-norm(x).  About 5 times as expensive as Default.
37685*>          IJOB .ne. 2: Local look ahead strategy where
37686*>              all entries of the r.h.s. b is chosen as either +1 or
37687*>              -1.  Default.
37688*> \endverbatim
37689*>
37690*> \param[in] N
37691*> \verbatim
37692*>          N is INTEGER
37693*>          The number of columns of the matrix Z.
37694*> \endverbatim
37695*>
37696*> \param[in] Z
37697*> \verbatim
37698*>          Z is COMPLEX*16 array, dimension (LDZ, N)
37699*>          On entry, the LU part of the factorization of the n-by-n
37700*>          matrix Z computed by ZGETC2:  Z = P * L * U * Q
37701*> \endverbatim
37702*>
37703*> \param[in] LDZ
37704*> \verbatim
37705*>          LDZ is INTEGER
37706*>          The leading dimension of the array Z.  LDA >= max(1, N).
37707*> \endverbatim
37708*>
37709*> \param[in,out] RHS
37710*> \verbatim
37711*>          RHS is COMPLEX*16 array, dimension (N).
37712*>          On entry, RHS contains contributions from other subsystems.
37713*>          On exit, RHS contains the solution of the subsystem with
37714*>          entries according to the value of IJOB (see above).
37715*> \endverbatim
37716*>
37717*> \param[in,out] RDSUM
37718*> \verbatim
37719*>          RDSUM is DOUBLE PRECISION
37720*>          On entry, the sum of squares of computed contributions to
37721*>          the Dif-estimate under computation by ZTGSYL, where the
37722*>          scaling factor RDSCAL (see below) has been factored out.
37723*>          On exit, the corresponding sum of squares updated with the
37724*>          contributions from the current sub-system.
37725*>          If TRANS = 'T' RDSUM is not touched.
37726*>          NOTE: RDSUM only makes sense when ZTGSY2 is called by CTGSYL.
37727*> \endverbatim
37728*>
37729*> \param[in,out] RDSCAL
37730*> \verbatim
37731*>          RDSCAL is DOUBLE PRECISION
37732*>          On entry, scaling factor used to prevent overflow in RDSUM.
37733*>          On exit, RDSCAL is updated w.r.t. the current contributions
37734*>          in RDSUM.
37735*>          If TRANS = 'T', RDSCAL is not touched.
37736*>          NOTE: RDSCAL only makes sense when ZTGSY2 is called by
37737*>          ZTGSYL.
37738*> \endverbatim
37739*>
37740*> \param[in] IPIV
37741*> \verbatim
37742*>          IPIV is INTEGER array, dimension (N).
37743*>          The pivot indices; for 1 <= i <= N, row i of the
37744*>          matrix has been interchanged with row IPIV(i).
37745*> \endverbatim
37746*>
37747*> \param[in] JPIV
37748*> \verbatim
37749*>          JPIV is INTEGER array, dimension (N).
37750*>          The pivot indices; for 1 <= j <= N, column j of the
37751*>          matrix has been interchanged with column JPIV(j).
37752*> \endverbatim
37753*
37754*  Authors:
37755*  ========
37756*
37757*> \author Univ. of Tennessee
37758*> \author Univ. of California Berkeley
37759*> \author Univ. of Colorado Denver
37760*> \author NAG Ltd.
37761*
37762*> \date June 2016
37763*
37764*> \ingroup complex16OTHERauxiliary
37765*
37766*> \par Further Details:
37767*  =====================
37768*>
37769*>  This routine is a further developed implementation of algorithm
37770*>  BSOLVE in [1] using complete pivoting in the LU factorization.
37771*
37772*> \par Contributors:
37773*  ==================
37774*>
37775*>     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
37776*>     Umea University, S-901 87 Umea, Sweden.
37777*
37778*> \par References:
37779*  ================
37780*>
37781*>   [1]   Bo Kagstrom and Lars Westin,
37782*>         Generalized Schur Methods with Condition Estimators for
37783*>         Solving the Generalized Sylvester Equation, IEEE Transactions
37784*>         on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751.
37785*>\n
37786*>   [2]   Peter Poromaa,
37787*>         On Efficient and Robust Estimators for the Separation
37788*>         between two Regular Matrix Pairs with Applications in
37789*>         Condition Estimation. Report UMINF-95.05, Department of
37790*>         Computing Science, Umea University, S-901 87 Umea, Sweden,
37791*>         1995.
37792*
37793*  =====================================================================
37794      SUBROUTINE ZLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV,
37795     $                   JPIV )
37796*
37797*  -- LAPACK auxiliary routine (version 3.7.0) --
37798*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
37799*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
37800*     June 2016
37801*
37802*     .. Scalar Arguments ..
37803      INTEGER            IJOB, LDZ, N
37804      DOUBLE PRECISION   RDSCAL, RDSUM
37805*     ..
37806*     .. Array Arguments ..
37807      INTEGER            IPIV( * ), JPIV( * )
37808      COMPLEX*16         RHS( * ), Z( LDZ, * )
37809*     ..
37810*
37811*  =====================================================================
37812*
37813*     .. Parameters ..
37814      INTEGER            MAXDIM
37815      PARAMETER          ( MAXDIM = 2 )
37816      DOUBLE PRECISION   ZERO, ONE
37817      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
37818      COMPLEX*16         CONE
37819      PARAMETER          ( CONE = ( 1.0D+0, 0.0D+0 ) )
37820*     ..
37821*     .. Local Scalars ..
37822      INTEGER            I, INFO, J, K
37823      DOUBLE PRECISION   RTEMP, SCALE, SMINU, SPLUS
37824      COMPLEX*16         BM, BP, PMONE, TEMP
37825*     ..
37826*     .. Local Arrays ..
37827      DOUBLE PRECISION   RWORK( MAXDIM )
37828      COMPLEX*16         WORK( 4*MAXDIM ), XM( MAXDIM ), XP( MAXDIM )
37829*     ..
37830*     .. External Subroutines ..
37831      EXTERNAL           ZAXPY, ZCOPY, ZGECON, ZGESC2, ZLASSQ, ZLASWP,
37832     $                   ZSCAL
37833*     ..
37834*     .. External Functions ..
37835      DOUBLE PRECISION   DZASUM
37836      COMPLEX*16         ZDOTC
37837      EXTERNAL           DZASUM, ZDOTC
37838*     ..
37839*     .. Intrinsic Functions ..
37840      INTRINSIC          ABS, DBLE, SQRT
37841*     ..
37842*     .. Executable Statements ..
37843*
37844      IF( IJOB.NE.2 ) THEN
37845*
37846*        Apply permutations IPIV to RHS
37847*
37848         CALL ZLASWP( 1, RHS, LDZ, 1, N-1, IPIV, 1 )
37849*
37850*        Solve for L-part choosing RHS either to +1 or -1.
37851*
37852         PMONE = -CONE
37853         DO 10 J = 1, N - 1
37854            BP = RHS( J ) + CONE
37855            BM = RHS( J ) - CONE
37856            SPLUS = ONE
37857*
37858*           Lockahead for L- part RHS(1:N-1) = +-1
37859*           SPLUS and SMIN computed more efficiently than in BSOLVE[1].
37860*
37861            SPLUS = SPLUS + DBLE( ZDOTC( N-J, Z( J+1, J ), 1, Z( J+1,
37862     $              J ), 1 ) )
37863            SMINU = DBLE( ZDOTC( N-J, Z( J+1, J ), 1, RHS( J+1 ), 1 ) )
37864            SPLUS = SPLUS*DBLE( RHS( J ) )
37865            IF( SPLUS.GT.SMINU ) THEN
37866               RHS( J ) = BP
37867            ELSE IF( SMINU.GT.SPLUS ) THEN
37868               RHS( J ) = BM
37869            ELSE
37870*
37871*              In this case the updating sums are equal and we can
37872*              choose RHS(J) +1 or -1. The first time this happens we
37873*              choose -1, thereafter +1. This is a simple way to get
37874*              good estimates of matrices like Byers well-known example
37875*              (see [1]). (Not done in BSOLVE.)
37876*
37877               RHS( J ) = RHS( J ) + PMONE
37878               PMONE = CONE
37879            END IF
37880*
37881*           Compute the remaining r.h.s.
37882*
37883            TEMP = -RHS( J )
37884            CALL ZAXPY( N-J, TEMP, Z( J+1, J ), 1, RHS( J+1 ), 1 )
37885   10    CONTINUE
37886*
37887*        Solve for U- part, lockahead for RHS(N) = +-1. This is not done
37888*        In BSOLVE and will hopefully give us a better estimate because
37889*        any ill-conditioning of the original matrix is transferred to U
37890*        and not to L. U(N, N) is an approximation to sigma_min(LU).
37891*
37892         CALL ZCOPY( N-1, RHS, 1, WORK, 1 )
37893         WORK( N ) = RHS( N ) + CONE
37894         RHS( N ) = RHS( N ) - CONE
37895         SPLUS = ZERO
37896         SMINU = ZERO
37897         DO 30 I = N, 1, -1
37898            TEMP = CONE / Z( I, I )
37899            WORK( I ) = WORK( I )*TEMP
37900            RHS( I ) = RHS( I )*TEMP
37901            DO 20 K = I + 1, N
37902               WORK( I ) = WORK( I ) - WORK( K )*( Z( I, K )*TEMP )
37903               RHS( I ) = RHS( I ) - RHS( K )*( Z( I, K )*TEMP )
37904   20       CONTINUE
37905            SPLUS = SPLUS + ABS( WORK( I ) )
37906            SMINU = SMINU + ABS( RHS( I ) )
37907   30    CONTINUE
37908         IF( SPLUS.GT.SMINU )
37909     $      CALL ZCOPY( N, WORK, 1, RHS, 1 )
37910*
37911*        Apply the permutations JPIV to the computed solution (RHS)
37912*
37913         CALL ZLASWP( 1, RHS, LDZ, 1, N-1, JPIV, -1 )
37914*
37915*        Compute the sum of squares
37916*
37917         CALL ZLASSQ( N, RHS, 1, RDSCAL, RDSUM )
37918         RETURN
37919      END IF
37920*
37921*     ENTRY IJOB = 2
37922*
37923*     Compute approximate nullvector XM of Z
37924*
37925      CALL ZGECON( 'I', N, Z, LDZ, ONE, RTEMP, WORK, RWORK, INFO )
37926      CALL ZCOPY( N, WORK( N+1 ), 1, XM, 1 )
37927*
37928*     Compute RHS
37929*
37930      CALL ZLASWP( 1, XM, LDZ, 1, N-1, IPIV, -1 )
37931      TEMP = CONE / SQRT( ZDOTC( N, XM, 1, XM, 1 ) )
37932      CALL ZSCAL( N, TEMP, XM, 1 )
37933      CALL ZCOPY( N, XM, 1, XP, 1 )
37934      CALL ZAXPY( N, CONE, RHS, 1, XP, 1 )
37935      CALL ZAXPY( N, -CONE, XM, 1, RHS, 1 )
37936      CALL ZGESC2( N, Z, LDZ, RHS, IPIV, JPIV, SCALE )
37937      CALL ZGESC2( N, Z, LDZ, XP, IPIV, JPIV, SCALE )
37938      IF( DZASUM( N, XP, 1 ).GT.DZASUM( N, RHS, 1 ) )
37939     $   CALL ZCOPY( N, XP, 1, RHS, 1 )
37940*
37941*     Compute the sum of squares
37942*
37943      CALL ZLASSQ( N, RHS, 1, RDSCAL, RDSUM )
37944      RETURN
37945*
37946*     End of ZLATDF
37947*
37948      END
37949*> \brief \b ZLATRD reduces the first nb rows and columns of a symmetric/Hermitian matrix A to real tridiagonal form by an unitary similarity transformation.
37950*
37951*  =========== DOCUMENTATION ===========
37952*
37953* Online html documentation available at
37954*            http://www.netlib.org/lapack/explore-html/
37955*
37956*> \htmlonly
37957*> Download ZLATRD + dependencies
37958*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlatrd.f">
37959*> [TGZ]</a>
37960*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlatrd.f">
37961*> [ZIP]</a>
37962*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlatrd.f">
37963*> [TXT]</a>
37964*> \endhtmlonly
37965*
37966*  Definition:
37967*  ===========
37968*
37969*       SUBROUTINE ZLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )
37970*
37971*       .. Scalar Arguments ..
37972*       CHARACTER          UPLO
37973*       INTEGER            LDA, LDW, N, NB
37974*       ..
37975*       .. Array Arguments ..
37976*       DOUBLE PRECISION   E( * )
37977*       COMPLEX*16         A( LDA, * ), TAU( * ), W( LDW, * )
37978*       ..
37979*
37980*
37981*> \par Purpose:
37982*  =============
37983*>
37984*> \verbatim
37985*>
37986*> ZLATRD reduces NB rows and columns of a complex Hermitian matrix A to
37987*> Hermitian tridiagonal form by a unitary similarity
37988*> transformation Q**H * A * Q, and returns the matrices V and W which are
37989*> needed to apply the transformation to the unreduced part of A.
37990*>
37991*> If UPLO = 'U', ZLATRD reduces the last NB rows and columns of a
37992*> matrix, of which the upper triangle is supplied;
37993*> if UPLO = 'L', ZLATRD reduces the first NB rows and columns of a
37994*> matrix, of which the lower triangle is supplied.
37995*>
37996*> This is an auxiliary routine called by ZHETRD.
37997*> \endverbatim
37998*
37999*  Arguments:
38000*  ==========
38001*
38002*> \param[in] UPLO
38003*> \verbatim
38004*>          UPLO is CHARACTER*1
38005*>          Specifies whether the upper or lower triangular part of the
38006*>          Hermitian matrix A is stored:
38007*>          = 'U': Upper triangular
38008*>          = 'L': Lower triangular
38009*> \endverbatim
38010*>
38011*> \param[in] N
38012*> \verbatim
38013*>          N is INTEGER
38014*>          The order of the matrix A.
38015*> \endverbatim
38016*>
38017*> \param[in] NB
38018*> \verbatim
38019*>          NB is INTEGER
38020*>          The number of rows and columns to be reduced.
38021*> \endverbatim
38022*>
38023*> \param[in,out] A
38024*> \verbatim
38025*>          A is COMPLEX*16 array, dimension (LDA,N)
38026*>          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading
38027*>          n-by-n upper triangular part of A contains the upper
38028*>          triangular part of the matrix A, and the strictly lower
38029*>          triangular part of A is not referenced.  If UPLO = 'L', the
38030*>          leading n-by-n lower triangular part of A contains the lower
38031*>          triangular part of the matrix A, and the strictly upper
38032*>          triangular part of A is not referenced.
38033*>          On exit:
38034*>          if UPLO = 'U', the last NB columns have been reduced to
38035*>            tridiagonal form, with the diagonal elements overwriting
38036*>            the diagonal elements of A; the elements above the diagonal
38037*>            with the array TAU, represent the unitary matrix Q as a
38038*>            product of elementary reflectors;
38039*>          if UPLO = 'L', the first NB columns have been reduced to
38040*>            tridiagonal form, with the diagonal elements overwriting
38041*>            the diagonal elements of A; the elements below the diagonal
38042*>            with the array TAU, represent the  unitary matrix Q as a
38043*>            product of elementary reflectors.
38044*>          See Further Details.
38045*> \endverbatim
38046*>
38047*> \param[in] LDA
38048*> \verbatim
38049*>          LDA is INTEGER
38050*>          The leading dimension of the array A.  LDA >= max(1,N).
38051*> \endverbatim
38052*>
38053*> \param[out] E
38054*> \verbatim
38055*>          E is DOUBLE PRECISION array, dimension (N-1)
38056*>          If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal
38057*>          elements of the last NB columns of the reduced matrix;
38058*>          if UPLO = 'L', E(1:nb) contains the subdiagonal elements of
38059*>          the first NB columns of the reduced matrix.
38060*> \endverbatim
38061*>
38062*> \param[out] TAU
38063*> \verbatim
38064*>          TAU is COMPLEX*16 array, dimension (N-1)
38065*>          The scalar factors of the elementary reflectors, stored in
38066*>          TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.
38067*>          See Further Details.
38068*> \endverbatim
38069*>
38070*> \param[out] W
38071*> \verbatim
38072*>          W is COMPLEX*16 array, dimension (LDW,NB)
38073*>          The n-by-nb matrix W required to update the unreduced part
38074*>          of A.
38075*> \endverbatim
38076*>
38077*> \param[in] LDW
38078*> \verbatim
38079*>          LDW is INTEGER
38080*>          The leading dimension of the array W. LDW >= max(1,N).
38081*> \endverbatim
38082*
38083*  Authors:
38084*  ========
38085*
38086*> \author Univ. of Tennessee
38087*> \author Univ. of California Berkeley
38088*> \author Univ. of Colorado Denver
38089*> \author NAG Ltd.
38090*
38091*> \date December 2016
38092*
38093*> \ingroup complex16OTHERauxiliary
38094*
38095*> \par Further Details:
38096*  =====================
38097*>
38098*> \verbatim
38099*>
38100*>  If UPLO = 'U', the matrix Q is represented as a product of elementary
38101*>  reflectors
38102*>
38103*>     Q = H(n) H(n-1) . . . H(n-nb+1).
38104*>
38105*>  Each H(i) has the form
38106*>
38107*>     H(i) = I - tau * v * v**H
38108*>
38109*>  where tau is a complex scalar, and v is a complex vector with
38110*>  v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),
38111*>  and tau in TAU(i-1).
38112*>
38113*>  If UPLO = 'L', the matrix Q is represented as a product of elementary
38114*>  reflectors
38115*>
38116*>     Q = H(1) H(2) . . . H(nb).
38117*>
38118*>  Each H(i) has the form
38119*>
38120*>     H(i) = I - tau * v * v**H
38121*>
38122*>  where tau is a complex scalar, and v is a complex vector with
38123*>  v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),
38124*>  and tau in TAU(i).
38125*>
38126*>  The elements of the vectors v together form the n-by-nb matrix V
38127*>  which is needed, with W, to apply the transformation to the unreduced
38128*>  part of the matrix, using a Hermitian rank-2k update of the form:
38129*>  A := A - V*W**H - W*V**H.
38130*>
38131*>  The contents of A on exit are illustrated by the following examples
38132*>  with n = 5 and nb = 2:
38133*>
38134*>  if UPLO = 'U':                       if UPLO = 'L':
38135*>
38136*>    (  a   a   a   v4  v5 )              (  d                  )
38137*>    (      a   a   v4  v5 )              (  1   d              )
38138*>    (          a   1   v5 )              (  v1  1   a          )
38139*>    (              d   1  )              (  v1  v2  a   a      )
38140*>    (                  d  )              (  v1  v2  a   a   a  )
38141*>
38142*>  where d denotes a diagonal element of the reduced matrix, a denotes
38143*>  an element of the original matrix that is unchanged, and vi denotes
38144*>  an element of the vector defining H(i).
38145*> \endverbatim
38146*>
38147*  =====================================================================
38148      SUBROUTINE ZLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )
38149*
38150*  -- LAPACK auxiliary routine (version 3.7.0) --
38151*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
38152*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
38153*     December 2016
38154*
38155*     .. Scalar Arguments ..
38156      CHARACTER          UPLO
38157      INTEGER            LDA, LDW, N, NB
38158*     ..
38159*     .. Array Arguments ..
38160      DOUBLE PRECISION   E( * )
38161      COMPLEX*16         A( LDA, * ), TAU( * ), W( LDW, * )
38162*     ..
38163*
38164*  =====================================================================
38165*
38166*     .. Parameters ..
38167      COMPLEX*16         ZERO, ONE, HALF
38168      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ),
38169     $                   ONE = ( 1.0D+0, 0.0D+0 ),
38170     $                   HALF = ( 0.5D+0, 0.0D+0 ) )
38171*     ..
38172*     .. Local Scalars ..
38173      INTEGER            I, IW
38174      COMPLEX*16         ALPHA
38175*     ..
38176*     .. External Subroutines ..
38177      EXTERNAL           ZAXPY, ZGEMV, ZHEMV, ZLACGV, ZLARFG, ZSCAL
38178*     ..
38179*     .. External Functions ..
38180      LOGICAL            LSAME
38181      COMPLEX*16         ZDOTC
38182      EXTERNAL           LSAME, ZDOTC
38183*     ..
38184*     .. Intrinsic Functions ..
38185      INTRINSIC          DBLE, MIN
38186*     ..
38187*     .. Executable Statements ..
38188*
38189*     Quick return if possible
38190*
38191      IF( N.LE.0 )
38192     $   RETURN
38193*
38194      IF( LSAME( UPLO, 'U' ) ) THEN
38195*
38196*        Reduce last NB columns of upper triangle
38197*
38198         DO 10 I = N, N - NB + 1, -1
38199            IW = I - N + NB
38200            IF( I.LT.N ) THEN
38201*
38202*              Update A(1:i,i)
38203*
38204               A( I, I ) = DBLE( A( I, I ) )
38205               CALL ZLACGV( N-I, W( I, IW+1 ), LDW )
38206               CALL ZGEMV( 'No transpose', I, N-I, -ONE, A( 1, I+1 ),
38207     $                     LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 )
38208               CALL ZLACGV( N-I, W( I, IW+1 ), LDW )
38209               CALL ZLACGV( N-I, A( I, I+1 ), LDA )
38210               CALL ZGEMV( 'No transpose', I, N-I, -ONE, W( 1, IW+1 ),
38211     $                     LDW, A( I, I+1 ), LDA, ONE, A( 1, I ), 1 )
38212               CALL ZLACGV( N-I, A( I, I+1 ), LDA )
38213               A( I, I ) = DBLE( A( I, I ) )
38214            END IF
38215            IF( I.GT.1 ) THEN
38216*
38217*              Generate elementary reflector H(i) to annihilate
38218*              A(1:i-2,i)
38219*
38220               ALPHA = A( I-1, I )
38221               CALL ZLARFG( I-1, ALPHA, A( 1, I ), 1, TAU( I-1 ) )
38222               E( I-1 ) = ALPHA
38223               A( I-1, I ) = ONE
38224*
38225*              Compute W(1:i-1,i)
38226*
38227               CALL ZHEMV( 'Upper', I-1, ONE, A, LDA, A( 1, I ), 1,
38228     $                     ZERO, W( 1, IW ), 1 )
38229               IF( I.LT.N ) THEN
38230                  CALL ZGEMV( 'Conjugate transpose', I-1, N-I, ONE,
38231     $                        W( 1, IW+1 ), LDW, A( 1, I ), 1, ZERO,
38232     $                        W( I+1, IW ), 1 )
38233                  CALL ZGEMV( 'No transpose', I-1, N-I, -ONE,
38234     $                        A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE,
38235     $                        W( 1, IW ), 1 )
38236                  CALL ZGEMV( 'Conjugate transpose', I-1, N-I, ONE,
38237     $                        A( 1, I+1 ), LDA, A( 1, I ), 1, ZERO,
38238     $                        W( I+1, IW ), 1 )
38239                  CALL ZGEMV( 'No transpose', I-1, N-I, -ONE,
38240     $                        W( 1, IW+1 ), LDW, W( I+1, IW ), 1, ONE,
38241     $                        W( 1, IW ), 1 )
38242               END IF
38243               CALL ZSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 )
38244               ALPHA = -HALF*TAU( I-1 )*ZDOTC( I-1, W( 1, IW ), 1,
38245     $                 A( 1, I ), 1 )
38246               CALL ZAXPY( I-1, ALPHA, A( 1, I ), 1, W( 1, IW ), 1 )
38247            END IF
38248*
38249   10    CONTINUE
38250      ELSE
38251*
38252*        Reduce first NB columns of lower triangle
38253*
38254         DO 20 I = 1, NB
38255*
38256*           Update A(i:n,i)
38257*
38258            A( I, I ) = DBLE( A( I, I ) )
38259            CALL ZLACGV( I-1, W( I, 1 ), LDW )
38260            CALL ZGEMV( 'No transpose', N-I+1, I-1, -ONE, A( I, 1 ),
38261     $                  LDA, W( I, 1 ), LDW, ONE, A( I, I ), 1 )
38262            CALL ZLACGV( I-1, W( I, 1 ), LDW )
38263            CALL ZLACGV( I-1, A( I, 1 ), LDA )
38264            CALL ZGEMV( 'No transpose', N-I+1, I-1, -ONE, W( I, 1 ),
38265     $                  LDW, A( I, 1 ), LDA, ONE, A( I, I ), 1 )
38266            CALL ZLACGV( I-1, A( I, 1 ), LDA )
38267            A( I, I ) = DBLE( A( I, I ) )
38268            IF( I.LT.N ) THEN
38269*
38270*              Generate elementary reflector H(i) to annihilate
38271*              A(i+2:n,i)
38272*
38273               ALPHA = A( I+1, I )
38274               CALL ZLARFG( N-I, ALPHA, A( MIN( I+2, N ), I ), 1,
38275     $                      TAU( I ) )
38276               E( I ) = ALPHA
38277               A( I+1, I ) = ONE
38278*
38279*              Compute W(i+1:n,i)
38280*
38281               CALL ZHEMV( 'Lower', N-I, ONE, A( I+1, I+1 ), LDA,
38282     $                     A( I+1, I ), 1, ZERO, W( I+1, I ), 1 )
38283               CALL ZGEMV( 'Conjugate transpose', N-I, I-1, ONE,
38284     $                     W( I+1, 1 ), LDW, A( I+1, I ), 1, ZERO,
38285     $                     W( 1, I ), 1 )
38286               CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, A( I+1, 1 ),
38287     $                     LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 )
38288               CALL ZGEMV( 'Conjugate transpose', N-I, I-1, ONE,
38289     $                     A( I+1, 1 ), LDA, A( I+1, I ), 1, ZERO,
38290     $                     W( 1, I ), 1 )
38291               CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1, 1 ),
38292     $                     LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 )
38293               CALL ZSCAL( N-I, TAU( I ), W( I+1, I ), 1 )
38294               ALPHA = -HALF*TAU( I )*ZDOTC( N-I, W( I+1, I ), 1,
38295     $                 A( I+1, I ), 1 )
38296               CALL ZAXPY( N-I, ALPHA, A( I+1, I ), 1, W( I+1, I ), 1 )
38297            END IF
38298*
38299   20    CONTINUE
38300      END IF
38301*
38302      RETURN
38303*
38304*     End of ZLATRD
38305*
38306      END
38307*> \brief \b ZLATRS solves a triangular system of equations with the scale factor set to prevent overflow.
38308*
38309*  =========== DOCUMENTATION ===========
38310*
38311* Online html documentation available at
38312*            http://www.netlib.org/lapack/explore-html/
38313*
38314*> \htmlonly
38315*> Download ZLATRS + dependencies
38316*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlatrs.f">
38317*> [TGZ]</a>
38318*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlatrs.f">
38319*> [ZIP]</a>
38320*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlatrs.f">
38321*> [TXT]</a>
38322*> \endhtmlonly
38323*
38324*  Definition:
38325*  ===========
38326*
38327*       SUBROUTINE ZLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE,
38328*                          CNORM, INFO )
38329*
38330*       .. Scalar Arguments ..
38331*       CHARACTER          DIAG, NORMIN, TRANS, UPLO
38332*       INTEGER            INFO, LDA, N
38333*       DOUBLE PRECISION   SCALE
38334*       ..
38335*       .. Array Arguments ..
38336*       DOUBLE PRECISION   CNORM( * )
38337*       COMPLEX*16         A( LDA, * ), X( * )
38338*       ..
38339*
38340*
38341*> \par Purpose:
38342*  =============
38343*>
38344*> \verbatim
38345*>
38346*> ZLATRS solves one of the triangular systems
38347*>
38348*>    A * x = s*b,  A**T * x = s*b,  or  A**H * x = s*b,
38349*>
38350*> with scaling to prevent overflow.  Here A is an upper or lower
38351*> triangular matrix, A**T denotes the transpose of A, A**H denotes the
38352*> conjugate transpose of A, x and b are n-element vectors, and s is a
38353*> scaling factor, usually less than or equal to 1, chosen so that the
38354*> components of x will be less than the overflow threshold.  If the
38355*> unscaled problem will not cause overflow, the Level 2 BLAS routine
38356*> ZTRSV is called. If the matrix A is singular (A(j,j) = 0 for some j),
38357*> then s is set to 0 and a non-trivial solution to A*x = 0 is returned.
38358*> \endverbatim
38359*
38360*  Arguments:
38361*  ==========
38362*
38363*> \param[in] UPLO
38364*> \verbatim
38365*>          UPLO is CHARACTER*1
38366*>          Specifies whether the matrix A is upper or lower triangular.
38367*>          = 'U':  Upper triangular
38368*>          = 'L':  Lower triangular
38369*> \endverbatim
38370*>
38371*> \param[in] TRANS
38372*> \verbatim
38373*>          TRANS is CHARACTER*1
38374*>          Specifies the operation applied to A.
38375*>          = 'N':  Solve A * x = s*b     (No transpose)
38376*>          = 'T':  Solve A**T * x = s*b  (Transpose)
38377*>          = 'C':  Solve A**H * x = s*b  (Conjugate transpose)
38378*> \endverbatim
38379*>
38380*> \param[in] DIAG
38381*> \verbatim
38382*>          DIAG is CHARACTER*1
38383*>          Specifies whether or not the matrix A is unit triangular.
38384*>          = 'N':  Non-unit triangular
38385*>          = 'U':  Unit triangular
38386*> \endverbatim
38387*>
38388*> \param[in] NORMIN
38389*> \verbatim
38390*>          NORMIN is CHARACTER*1
38391*>          Specifies whether CNORM has been set or not.
38392*>          = 'Y':  CNORM contains the column norms on entry
38393*>          = 'N':  CNORM is not set on entry.  On exit, the norms will
38394*>                  be computed and stored in CNORM.
38395*> \endverbatim
38396*>
38397*> \param[in] N
38398*> \verbatim
38399*>          N is INTEGER
38400*>          The order of the matrix A.  N >= 0.
38401*> \endverbatim
38402*>
38403*> \param[in] A
38404*> \verbatim
38405*>          A is COMPLEX*16 array, dimension (LDA,N)
38406*>          The triangular matrix A.  If UPLO = 'U', the leading n by n
38407*>          upper triangular part of the array A contains the upper
38408*>          triangular matrix, and the strictly lower triangular part of
38409*>          A is not referenced.  If UPLO = 'L', the leading n by n lower
38410*>          triangular part of the array A contains the lower triangular
38411*>          matrix, and the strictly upper triangular part of A is not
38412*>          referenced.  If DIAG = 'U', the diagonal elements of A are
38413*>          also not referenced and are assumed to be 1.
38414*> \endverbatim
38415*>
38416*> \param[in] LDA
38417*> \verbatim
38418*>          LDA is INTEGER
38419*>          The leading dimension of the array A.  LDA >= max (1,N).
38420*> \endverbatim
38421*>
38422*> \param[in,out] X
38423*> \verbatim
38424*>          X is COMPLEX*16 array, dimension (N)
38425*>          On entry, the right hand side b of the triangular system.
38426*>          On exit, X is overwritten by the solution vector x.
38427*> \endverbatim
38428*>
38429*> \param[out] SCALE
38430*> \verbatim
38431*>          SCALE is DOUBLE PRECISION
38432*>          The scaling factor s for the triangular system
38433*>             A * x = s*b,  A**T * x = s*b,  or  A**H * x = s*b.
38434*>          If SCALE = 0, the matrix A is singular or badly scaled, and
38435*>          the vector x is an exact or approximate solution to A*x = 0.
38436*> \endverbatim
38437*>
38438*> \param[in,out] CNORM
38439*> \verbatim
38440*>          CNORM is DOUBLE PRECISION array, dimension (N)
38441*>
38442*>          If NORMIN = 'Y', CNORM is an input argument and CNORM(j)
38443*>          contains the norm of the off-diagonal part of the j-th column
38444*>          of A.  If TRANS = 'N', CNORM(j) must be greater than or equal
38445*>          to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)
38446*>          must be greater than or equal to the 1-norm.
38447*>
38448*>          If NORMIN = 'N', CNORM is an output argument and CNORM(j)
38449*>          returns the 1-norm of the offdiagonal part of the j-th column
38450*>          of A.
38451*> \endverbatim
38452*>
38453*> \param[out] INFO
38454*> \verbatim
38455*>          INFO is INTEGER
38456*>          = 0:  successful exit
38457*>          < 0:  if INFO = -k, the k-th argument had an illegal value
38458*> \endverbatim
38459*
38460*  Authors:
38461*  ========
38462*
38463*> \author Univ. of Tennessee
38464*> \author Univ. of California Berkeley
38465*> \author Univ. of Colorado Denver
38466*> \author NAG Ltd.
38467*
38468*> \date November 2017
38469*
38470*> \ingroup complex16OTHERauxiliary
38471*
38472*> \par Further Details:
38473*  =====================
38474*>
38475*> \verbatim
38476*>
38477*>  A rough bound on x is computed; if that is less than overflow, ZTRSV
38478*>  is called, otherwise, specific code is used which checks for possible
38479*>  overflow or divide-by-zero at every operation.
38480*>
38481*>  A columnwise scheme is used for solving A*x = b.  The basic algorithm
38482*>  if A is lower triangular is
38483*>
38484*>       x[1:n] := b[1:n]
38485*>       for j = 1, ..., n
38486*>            x(j) := x(j) / A(j,j)
38487*>            x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]
38488*>       end
38489*>
38490*>  Define bounds on the components of x after j iterations of the loop:
38491*>     M(j) = bound on x[1:j]
38492*>     G(j) = bound on x[j+1:n]
38493*>  Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.
38494*>
38495*>  Then for iteration j+1 we have
38496*>     M(j+1) <= G(j) / | A(j+1,j+1) |
38497*>     G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |
38498*>            <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )
38499*>
38500*>  where CNORM(j+1) is greater than or equal to the infinity-norm of
38501*>  column j+1 of A, not counting the diagonal.  Hence
38502*>
38503*>     G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )
38504*>                  1<=i<=j
38505*>  and
38506*>
38507*>     |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )
38508*>                                   1<=i< j
38509*>
38510*>  Since |x(j)| <= M(j), we use the Level 2 BLAS routine ZTRSV if the
38511*>  reciprocal of the largest M(j), j=1,..,n, is larger than
38512*>  max(underflow, 1/overflow).
38513*>
38514*>  The bound on x(j) is also used to determine when a step in the
38515*>  columnwise method can be performed without fear of overflow.  If
38516*>  the computed bound is greater than a large constant, x is scaled to
38517*>  prevent overflow, but if the bound overflows, x is set to 0, x(j) to
38518*>  1, and scale to 0, and a non-trivial solution to A*x = 0 is found.
38519*>
38520*>  Similarly, a row-wise scheme is used to solve A**T *x = b  or
38521*>  A**H *x = b.  The basic algorithm for A upper triangular is
38522*>
38523*>       for j = 1, ..., n
38524*>            x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)
38525*>       end
38526*>
38527*>  We simultaneously compute two bounds
38528*>       G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j
38529*>       M(j) = bound on x(i), 1<=i<=j
38530*>
38531*>  The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we
38532*>  add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.
38533*>  Then the bound on x(j) is
38534*>
38535*>       M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |
38536*>
38537*>            <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )
38538*>                      1<=i<=j
38539*>
38540*>  and we can safely call ZTRSV if 1/M(n) and 1/G(n) are both greater
38541*>  than max(underflow, 1/overflow).
38542*> \endverbatim
38543*>
38544*  =====================================================================
38545      SUBROUTINE ZLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE,
38546     $                   CNORM, INFO )
38547*
38548*  -- LAPACK auxiliary routine (version 3.8.0) --
38549*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
38550*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
38551*     November 2017
38552*
38553*     .. Scalar Arguments ..
38554      CHARACTER          DIAG, NORMIN, TRANS, UPLO
38555      INTEGER            INFO, LDA, N
38556      DOUBLE PRECISION   SCALE
38557*     ..
38558*     .. Array Arguments ..
38559      DOUBLE PRECISION   CNORM( * )
38560      COMPLEX*16         A( LDA, * ), X( * )
38561*     ..
38562*
38563*  =====================================================================
38564*
38565*     .. Parameters ..
38566      DOUBLE PRECISION   ZERO, HALF, ONE, TWO
38567      PARAMETER          ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0,
38568     $                   TWO = 2.0D+0 )
38569*     ..
38570*     .. Local Scalars ..
38571      LOGICAL            NOTRAN, NOUNIT, UPPER
38572      INTEGER            I, IMAX, J, JFIRST, JINC, JLAST
38573      DOUBLE PRECISION   BIGNUM, GROW, REC, SMLNUM, TJJ, TMAX, TSCAL,
38574     $                   XBND, XJ, XMAX
38575      COMPLEX*16         CSUMJ, TJJS, USCAL, ZDUM
38576*     ..
38577*     .. External Functions ..
38578      LOGICAL            LSAME
38579      INTEGER            IDAMAX, IZAMAX
38580      DOUBLE PRECISION   DLAMCH, DZASUM
38581      COMPLEX*16         ZDOTC, ZDOTU, ZLADIV
38582      EXTERNAL           LSAME, IDAMAX, IZAMAX, DLAMCH, DZASUM, ZDOTC,
38583     $                   ZDOTU, ZLADIV
38584*     ..
38585*     .. External Subroutines ..
38586      EXTERNAL           DSCAL, XERBLA, ZAXPY, ZDSCAL, ZTRSV, DLABAD
38587*     ..
38588*     .. Intrinsic Functions ..
38589      INTRINSIC          ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN
38590*     ..
38591*     .. Statement Functions ..
38592      DOUBLE PRECISION   CABS1, CABS2
38593*     ..
38594*     .. Statement Function definitions ..
38595      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
38596      CABS2( ZDUM ) = ABS( DBLE( ZDUM ) / 2.D0 ) +
38597     $                ABS( DIMAG( ZDUM ) / 2.D0 )
38598*     ..
38599*     .. Executable Statements ..
38600*
38601      INFO = 0
38602      UPPER = LSAME( UPLO, 'U' )
38603      NOTRAN = LSAME( TRANS, 'N' )
38604      NOUNIT = LSAME( DIAG, 'N' )
38605*
38606*     Test the input parameters.
38607*
38608      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
38609         INFO = -1
38610      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
38611     $         LSAME( TRANS, 'C' ) ) THEN
38612         INFO = -2
38613      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
38614         INFO = -3
38615      ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT.
38616     $         LSAME( NORMIN, 'N' ) ) THEN
38617         INFO = -4
38618      ELSE IF( N.LT.0 ) THEN
38619         INFO = -5
38620      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
38621         INFO = -7
38622      END IF
38623      IF( INFO.NE.0 ) THEN
38624         CALL XERBLA( 'ZLATRS', -INFO )
38625         RETURN
38626      END IF
38627*
38628*     Quick return if possible
38629*
38630      IF( N.EQ.0 )
38631     $   RETURN
38632*
38633*     Determine machine dependent parameters to control overflow.
38634*
38635      SMLNUM = DLAMCH( 'Safe minimum' )
38636      BIGNUM = ONE / SMLNUM
38637      CALL DLABAD( SMLNUM, BIGNUM )
38638      SMLNUM = SMLNUM / DLAMCH( 'Precision' )
38639      BIGNUM = ONE / SMLNUM
38640      SCALE = ONE
38641*
38642      IF( LSAME( NORMIN, 'N' ) ) THEN
38643*
38644*        Compute the 1-norm of each column, not including the diagonal.
38645*
38646         IF( UPPER ) THEN
38647*
38648*           A is upper triangular.
38649*
38650            DO 10 J = 1, N
38651               CNORM( J ) = DZASUM( J-1, A( 1, J ), 1 )
38652   10       CONTINUE
38653         ELSE
38654*
38655*           A is lower triangular.
38656*
38657            DO 20 J = 1, N - 1
38658               CNORM( J ) = DZASUM( N-J, A( J+1, J ), 1 )
38659   20       CONTINUE
38660            CNORM( N ) = ZERO
38661         END IF
38662      END IF
38663*
38664*     Scale the column norms by TSCAL if the maximum element in CNORM is
38665*     greater than BIGNUM/2.
38666*
38667      IMAX = IDAMAX( N, CNORM, 1 )
38668      TMAX = CNORM( IMAX )
38669      IF( TMAX.LE.BIGNUM*HALF ) THEN
38670         TSCAL = ONE
38671      ELSE
38672         TSCAL = HALF / ( SMLNUM*TMAX )
38673         CALL DSCAL( N, TSCAL, CNORM, 1 )
38674      END IF
38675*
38676*     Compute a bound on the computed solution vector to see if the
38677*     Level 2 BLAS routine ZTRSV can be used.
38678*
38679      XMAX = ZERO
38680      DO 30 J = 1, N
38681         XMAX = MAX( XMAX, CABS2( X( J ) ) )
38682   30 CONTINUE
38683      XBND = XMAX
38684*
38685      IF( NOTRAN ) THEN
38686*
38687*        Compute the growth in A * x = b.
38688*
38689         IF( UPPER ) THEN
38690            JFIRST = N
38691            JLAST = 1
38692            JINC = -1
38693         ELSE
38694            JFIRST = 1
38695            JLAST = N
38696            JINC = 1
38697         END IF
38698*
38699         IF( TSCAL.NE.ONE ) THEN
38700            GROW = ZERO
38701            GO TO 60
38702         END IF
38703*
38704         IF( NOUNIT ) THEN
38705*
38706*           A is non-unit triangular.
38707*
38708*           Compute GROW = 1/G(j) and XBND = 1/M(j).
38709*           Initially, G(0) = max{x(i), i=1,...,n}.
38710*
38711            GROW = HALF / MAX( XBND, SMLNUM )
38712            XBND = GROW
38713            DO 40 J = JFIRST, JLAST, JINC
38714*
38715*              Exit the loop if the growth factor is too small.
38716*
38717               IF( GROW.LE.SMLNUM )
38718     $            GO TO 60
38719*
38720               TJJS = A( J, J )
38721               TJJ = CABS1( TJJS )
38722*
38723               IF( TJJ.GE.SMLNUM ) THEN
38724*
38725*                 M(j) = G(j-1) / abs(A(j,j))
38726*
38727                  XBND = MIN( XBND, MIN( ONE, TJJ )*GROW )
38728               ELSE
38729*
38730*                 M(j) could overflow, set XBND to 0.
38731*
38732                  XBND = ZERO
38733               END IF
38734*
38735               IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN
38736*
38737*                 G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) )
38738*
38739                  GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) )
38740               ELSE
38741*
38742*                 G(j) could overflow, set GROW to 0.
38743*
38744                  GROW = ZERO
38745               END IF
38746   40       CONTINUE
38747            GROW = XBND
38748         ELSE
38749*
38750*           A is unit triangular.
38751*
38752*           Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
38753*
38754            GROW = MIN( ONE, HALF / MAX( XBND, SMLNUM ) )
38755            DO 50 J = JFIRST, JLAST, JINC
38756*
38757*              Exit the loop if the growth factor is too small.
38758*
38759               IF( GROW.LE.SMLNUM )
38760     $            GO TO 60
38761*
38762*              G(j) = G(j-1)*( 1 + CNORM(j) )
38763*
38764               GROW = GROW*( ONE / ( ONE+CNORM( J ) ) )
38765   50       CONTINUE
38766         END IF
38767   60    CONTINUE
38768*
38769      ELSE
38770*
38771*        Compute the growth in A**T * x = b  or  A**H * x = b.
38772*
38773         IF( UPPER ) THEN
38774            JFIRST = 1
38775            JLAST = N
38776            JINC = 1
38777         ELSE
38778            JFIRST = N
38779            JLAST = 1
38780            JINC = -1
38781         END IF
38782*
38783         IF( TSCAL.NE.ONE ) THEN
38784            GROW = ZERO
38785            GO TO 90
38786         END IF
38787*
38788         IF( NOUNIT ) THEN
38789*
38790*           A is non-unit triangular.
38791*
38792*           Compute GROW = 1/G(j) and XBND = 1/M(j).
38793*           Initially, M(0) = max{x(i), i=1,...,n}.
38794*
38795            GROW = HALF / MAX( XBND, SMLNUM )
38796            XBND = GROW
38797            DO 70 J = JFIRST, JLAST, JINC
38798*
38799*              Exit the loop if the growth factor is too small.
38800*
38801               IF( GROW.LE.SMLNUM )
38802     $            GO TO 90
38803*
38804*              G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
38805*
38806               XJ = ONE + CNORM( J )
38807               GROW = MIN( GROW, XBND / XJ )
38808*
38809               TJJS = A( J, J )
38810               TJJ = CABS1( TJJS )
38811*
38812               IF( TJJ.GE.SMLNUM ) THEN
38813*
38814*                 M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j))
38815*
38816                  IF( XJ.GT.TJJ )
38817     $               XBND = XBND*( TJJ / XJ )
38818               ELSE
38819*
38820*                 M(j) could overflow, set XBND to 0.
38821*
38822                  XBND = ZERO
38823               END IF
38824   70       CONTINUE
38825            GROW = MIN( GROW, XBND )
38826         ELSE
38827*
38828*           A is unit triangular.
38829*
38830*           Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
38831*
38832            GROW = MIN( ONE, HALF / MAX( XBND, SMLNUM ) )
38833            DO 80 J = JFIRST, JLAST, JINC
38834*
38835*              Exit the loop if the growth factor is too small.
38836*
38837               IF( GROW.LE.SMLNUM )
38838     $            GO TO 90
38839*
38840*              G(j) = ( 1 + CNORM(j) )*G(j-1)
38841*
38842               XJ = ONE + CNORM( J )
38843               GROW = GROW / XJ
38844   80       CONTINUE
38845         END IF
38846   90    CONTINUE
38847      END IF
38848*
38849      IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN
38850*
38851*        Use the Level 2 BLAS solve if the reciprocal of the bound on
38852*        elements of X is not too small.
38853*
38854         CALL ZTRSV( UPLO, TRANS, DIAG, N, A, LDA, X, 1 )
38855      ELSE
38856*
38857*        Use a Level 1 BLAS solve, scaling intermediate results.
38858*
38859         IF( XMAX.GT.BIGNUM*HALF ) THEN
38860*
38861*           Scale X so that its components are less than or equal to
38862*           BIGNUM in absolute value.
38863*
38864            SCALE = ( BIGNUM*HALF ) / XMAX
38865            CALL ZDSCAL( N, SCALE, X, 1 )
38866            XMAX = BIGNUM
38867         ELSE
38868            XMAX = XMAX*TWO
38869         END IF
38870*
38871         IF( NOTRAN ) THEN
38872*
38873*           Solve A * x = b
38874*
38875            DO 120 J = JFIRST, JLAST, JINC
38876*
38877*              Compute x(j) = b(j) / A(j,j), scaling x if necessary.
38878*
38879               XJ = CABS1( X( J ) )
38880               IF( NOUNIT ) THEN
38881                  TJJS = A( J, J )*TSCAL
38882               ELSE
38883                  TJJS = TSCAL
38884                  IF( TSCAL.EQ.ONE )
38885     $               GO TO 110
38886               END IF
38887               TJJ = CABS1( TJJS )
38888               IF( TJJ.GT.SMLNUM ) THEN
38889*
38890*                    abs(A(j,j)) > SMLNUM:
38891*
38892                  IF( TJJ.LT.ONE ) THEN
38893                     IF( XJ.GT.TJJ*BIGNUM ) THEN
38894*
38895*                          Scale x by 1/b(j).
38896*
38897                        REC = ONE / XJ
38898                        CALL ZDSCAL( N, REC, X, 1 )
38899                        SCALE = SCALE*REC
38900                        XMAX = XMAX*REC
38901                     END IF
38902                  END IF
38903                  X( J ) = ZLADIV( X( J ), TJJS )
38904                  XJ = CABS1( X( J ) )
38905               ELSE IF( TJJ.GT.ZERO ) THEN
38906*
38907*                    0 < abs(A(j,j)) <= SMLNUM:
38908*
38909                  IF( XJ.GT.TJJ*BIGNUM ) THEN
38910*
38911*                       Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM
38912*                       to avoid overflow when dividing by A(j,j).
38913*
38914                     REC = ( TJJ*BIGNUM ) / XJ
38915                     IF( CNORM( J ).GT.ONE ) THEN
38916*
38917*                          Scale by 1/CNORM(j) to avoid overflow when
38918*                          multiplying x(j) times column j.
38919*
38920                        REC = REC / CNORM( J )
38921                     END IF
38922                     CALL ZDSCAL( N, REC, X, 1 )
38923                     SCALE = SCALE*REC
38924                     XMAX = XMAX*REC
38925                  END IF
38926                  X( J ) = ZLADIV( X( J ), TJJS )
38927                  XJ = CABS1( X( J ) )
38928               ELSE
38929*
38930*                    A(j,j) = 0:  Set x(1:n) = 0, x(j) = 1, and
38931*                    scale = 0, and compute a solution to A*x = 0.
38932*
38933                  DO 100 I = 1, N
38934                     X( I ) = ZERO
38935  100             CONTINUE
38936                  X( J ) = ONE
38937                  XJ = ONE
38938                  SCALE = ZERO
38939                  XMAX = ZERO
38940               END IF
38941  110          CONTINUE
38942*
38943*              Scale x if necessary to avoid overflow when adding a
38944*              multiple of column j of A.
38945*
38946               IF( XJ.GT.ONE ) THEN
38947                  REC = ONE / XJ
38948                  IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN
38949*
38950*                    Scale x by 1/(2*abs(x(j))).
38951*
38952                     REC = REC*HALF
38953                     CALL ZDSCAL( N, REC, X, 1 )
38954                     SCALE = SCALE*REC
38955                  END IF
38956               ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN
38957*
38958*                 Scale x by 1/2.
38959*
38960                  CALL ZDSCAL( N, HALF, X, 1 )
38961                  SCALE = SCALE*HALF
38962               END IF
38963*
38964               IF( UPPER ) THEN
38965                  IF( J.GT.1 ) THEN
38966*
38967*                    Compute the update
38968*                       x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j)
38969*
38970                     CALL ZAXPY( J-1, -X( J )*TSCAL, A( 1, J ), 1, X,
38971     $                           1 )
38972                     I = IZAMAX( J-1, X, 1 )
38973                     XMAX = CABS1( X( I ) )
38974                  END IF
38975               ELSE
38976                  IF( J.LT.N ) THEN
38977*
38978*                    Compute the update
38979*                       x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j)
38980*
38981                     CALL ZAXPY( N-J, -X( J )*TSCAL, A( J+1, J ), 1,
38982     $                           X( J+1 ), 1 )
38983                     I = J + IZAMAX( N-J, X( J+1 ), 1 )
38984                     XMAX = CABS1( X( I ) )
38985                  END IF
38986               END IF
38987  120       CONTINUE
38988*
38989         ELSE IF( LSAME( TRANS, 'T' ) ) THEN
38990*
38991*           Solve A**T * x = b
38992*
38993            DO 170 J = JFIRST, JLAST, JINC
38994*
38995*              Compute x(j) = b(j) - sum A(k,j)*x(k).
38996*                                    k<>j
38997*
38998               XJ = CABS1( X( J ) )
38999               USCAL = TSCAL
39000               REC = ONE / MAX( XMAX, ONE )
39001               IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN
39002*
39003*                 If x(j) could overflow, scale x by 1/(2*XMAX).
39004*
39005                  REC = REC*HALF
39006                  IF( NOUNIT ) THEN
39007                     TJJS = A( J, J )*TSCAL
39008                  ELSE
39009                     TJJS = TSCAL
39010                  END IF
39011                  TJJ = CABS1( TJJS )
39012                  IF( TJJ.GT.ONE ) THEN
39013*
39014*                       Divide by A(j,j) when scaling x if A(j,j) > 1.
39015*
39016                     REC = MIN( ONE, REC*TJJ )
39017                     USCAL = ZLADIV( USCAL, TJJS )
39018                  END IF
39019                  IF( REC.LT.ONE ) THEN
39020                     CALL ZDSCAL( N, REC, X, 1 )
39021                     SCALE = SCALE*REC
39022                     XMAX = XMAX*REC
39023                  END IF
39024               END IF
39025*
39026               CSUMJ = ZERO
39027               IF( USCAL.EQ.DCMPLX( ONE ) ) THEN
39028*
39029*                 If the scaling needed for A in the dot product is 1,
39030*                 call ZDOTU to perform the dot product.
39031*
39032                  IF( UPPER ) THEN
39033                     CSUMJ = ZDOTU( J-1, A( 1, J ), 1, X, 1 )
39034                  ELSE IF( J.LT.N ) THEN
39035                     CSUMJ = ZDOTU( N-J, A( J+1, J ), 1, X( J+1 ), 1 )
39036                  END IF
39037               ELSE
39038*
39039*                 Otherwise, use in-line code for the dot product.
39040*
39041                  IF( UPPER ) THEN
39042                     DO 130 I = 1, J - 1
39043                        CSUMJ = CSUMJ + ( A( I, J )*USCAL )*X( I )
39044  130                CONTINUE
39045                  ELSE IF( J.LT.N ) THEN
39046                     DO 140 I = J + 1, N
39047                        CSUMJ = CSUMJ + ( A( I, J )*USCAL )*X( I )
39048  140                CONTINUE
39049                  END IF
39050               END IF
39051*
39052               IF( USCAL.EQ.DCMPLX( TSCAL ) ) THEN
39053*
39054*                 Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j)
39055*                 was not used to scale the dotproduct.
39056*
39057                  X( J ) = X( J ) - CSUMJ
39058                  XJ = CABS1( X( J ) )
39059                  IF( NOUNIT ) THEN
39060                     TJJS = A( J, J )*TSCAL
39061                  ELSE
39062                     TJJS = TSCAL
39063                     IF( TSCAL.EQ.ONE )
39064     $                  GO TO 160
39065                  END IF
39066*
39067*                    Compute x(j) = x(j) / A(j,j), scaling if necessary.
39068*
39069                  TJJ = CABS1( TJJS )
39070                  IF( TJJ.GT.SMLNUM ) THEN
39071*
39072*                       abs(A(j,j)) > SMLNUM:
39073*
39074                     IF( TJJ.LT.ONE ) THEN
39075                        IF( XJ.GT.TJJ*BIGNUM ) THEN
39076*
39077*                             Scale X by 1/abs(x(j)).
39078*
39079                           REC = ONE / XJ
39080                           CALL ZDSCAL( N, REC, X, 1 )
39081                           SCALE = SCALE*REC
39082                           XMAX = XMAX*REC
39083                        END IF
39084                     END IF
39085                     X( J ) = ZLADIV( X( J ), TJJS )
39086                  ELSE IF( TJJ.GT.ZERO ) THEN
39087*
39088*                       0 < abs(A(j,j)) <= SMLNUM:
39089*
39090                     IF( XJ.GT.TJJ*BIGNUM ) THEN
39091*
39092*                          Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
39093*
39094                        REC = ( TJJ*BIGNUM ) / XJ
39095                        CALL ZDSCAL( N, REC, X, 1 )
39096                        SCALE = SCALE*REC
39097                        XMAX = XMAX*REC
39098                     END IF
39099                     X( J ) = ZLADIV( X( J ), TJJS )
39100                  ELSE
39101*
39102*                       A(j,j) = 0:  Set x(1:n) = 0, x(j) = 1, and
39103*                       scale = 0 and compute a solution to A**T *x = 0.
39104*
39105                     DO 150 I = 1, N
39106                        X( I ) = ZERO
39107  150                CONTINUE
39108                     X( J ) = ONE
39109                     SCALE = ZERO
39110                     XMAX = ZERO
39111                  END IF
39112  160             CONTINUE
39113               ELSE
39114*
39115*                 Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot
39116*                 product has already been divided by 1/A(j,j).
39117*
39118                  X( J ) = ZLADIV( X( J ), TJJS ) - CSUMJ
39119               END IF
39120               XMAX = MAX( XMAX, CABS1( X( J ) ) )
39121  170       CONTINUE
39122*
39123         ELSE
39124*
39125*           Solve A**H * x = b
39126*
39127            DO 220 J = JFIRST, JLAST, JINC
39128*
39129*              Compute x(j) = b(j) - sum A(k,j)*x(k).
39130*                                    k<>j
39131*
39132               XJ = CABS1( X( J ) )
39133               USCAL = TSCAL
39134               REC = ONE / MAX( XMAX, ONE )
39135               IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN
39136*
39137*                 If x(j) could overflow, scale x by 1/(2*XMAX).
39138*
39139                  REC = REC*HALF
39140                  IF( NOUNIT ) THEN
39141                     TJJS = DCONJG( A( J, J ) )*TSCAL
39142                  ELSE
39143                     TJJS = TSCAL
39144                  END IF
39145                  TJJ = CABS1( TJJS )
39146                  IF( TJJ.GT.ONE ) THEN
39147*
39148*                       Divide by A(j,j) when scaling x if A(j,j) > 1.
39149*
39150                     REC = MIN( ONE, REC*TJJ )
39151                     USCAL = ZLADIV( USCAL, TJJS )
39152                  END IF
39153                  IF( REC.LT.ONE ) THEN
39154                     CALL ZDSCAL( N, REC, X, 1 )
39155                     SCALE = SCALE*REC
39156                     XMAX = XMAX*REC
39157                  END IF
39158               END IF
39159*
39160               CSUMJ = ZERO
39161               IF( USCAL.EQ.DCMPLX( ONE ) ) THEN
39162*
39163*                 If the scaling needed for A in the dot product is 1,
39164*                 call ZDOTC to perform the dot product.
39165*
39166                  IF( UPPER ) THEN
39167                     CSUMJ = ZDOTC( J-1, A( 1, J ), 1, X, 1 )
39168                  ELSE IF( J.LT.N ) THEN
39169                     CSUMJ = ZDOTC( N-J, A( J+1, J ), 1, X( J+1 ), 1 )
39170                  END IF
39171               ELSE
39172*
39173*                 Otherwise, use in-line code for the dot product.
39174*
39175                  IF( UPPER ) THEN
39176                     DO 180 I = 1, J - 1
39177                        CSUMJ = CSUMJ + ( DCONJG( A( I, J ) )*USCAL )*
39178     $                          X( I )
39179  180                CONTINUE
39180                  ELSE IF( J.LT.N ) THEN
39181                     DO 190 I = J + 1, N
39182                        CSUMJ = CSUMJ + ( DCONJG( A( I, J ) )*USCAL )*
39183     $                          X( I )
39184  190                CONTINUE
39185                  END IF
39186               END IF
39187*
39188               IF( USCAL.EQ.DCMPLX( TSCAL ) ) THEN
39189*
39190*                 Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j)
39191*                 was not used to scale the dotproduct.
39192*
39193                  X( J ) = X( J ) - CSUMJ
39194                  XJ = CABS1( X( J ) )
39195                  IF( NOUNIT ) THEN
39196                     TJJS = DCONJG( A( J, J ) )*TSCAL
39197                  ELSE
39198                     TJJS = TSCAL
39199                     IF( TSCAL.EQ.ONE )
39200     $                  GO TO 210
39201                  END IF
39202*
39203*                    Compute x(j) = x(j) / A(j,j), scaling if necessary.
39204*
39205                  TJJ = CABS1( TJJS )
39206                  IF( TJJ.GT.SMLNUM ) THEN
39207*
39208*                       abs(A(j,j)) > SMLNUM:
39209*
39210                     IF( TJJ.LT.ONE ) THEN
39211                        IF( XJ.GT.TJJ*BIGNUM ) THEN
39212*
39213*                             Scale X by 1/abs(x(j)).
39214*
39215                           REC = ONE / XJ
39216                           CALL ZDSCAL( N, REC, X, 1 )
39217                           SCALE = SCALE*REC
39218                           XMAX = XMAX*REC
39219                        END IF
39220                     END IF
39221                     X( J ) = ZLADIV( X( J ), TJJS )
39222                  ELSE IF( TJJ.GT.ZERO ) THEN
39223*
39224*                       0 < abs(A(j,j)) <= SMLNUM:
39225*
39226                     IF( XJ.GT.TJJ*BIGNUM ) THEN
39227*
39228*                          Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
39229*
39230                        REC = ( TJJ*BIGNUM ) / XJ
39231                        CALL ZDSCAL( N, REC, X, 1 )
39232                        SCALE = SCALE*REC
39233                        XMAX = XMAX*REC
39234                     END IF
39235                     X( J ) = ZLADIV( X( J ), TJJS )
39236                  ELSE
39237*
39238*                       A(j,j) = 0:  Set x(1:n) = 0, x(j) = 1, and
39239*                       scale = 0 and compute a solution to A**H *x = 0.
39240*
39241                     DO 200 I = 1, N
39242                        X( I ) = ZERO
39243  200                CONTINUE
39244                     X( J ) = ONE
39245                     SCALE = ZERO
39246                     XMAX = ZERO
39247                  END IF
39248  210             CONTINUE
39249               ELSE
39250*
39251*                 Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot
39252*                 product has already been divided by 1/A(j,j).
39253*
39254                  X( J ) = ZLADIV( X( J ), TJJS ) - CSUMJ
39255               END IF
39256               XMAX = MAX( XMAX, CABS1( X( J ) ) )
39257  220       CONTINUE
39258         END IF
39259         SCALE = SCALE / TSCAL
39260      END IF
39261*
39262*     Scale the column norms by 1/TSCAL for return.
39263*
39264      IF( TSCAL.NE.ONE ) THEN
39265         CALL DSCAL( N, ONE / TSCAL, CNORM, 1 )
39266      END IF
39267*
39268      RETURN
39269*
39270*     End of ZLATRS
39271*
39272      END
39273*> \brief \b ZLAUU2 computes the product UUH or LHL, where U and L are upper or lower triangular matrices (unblocked algorithm).
39274*
39275*  =========== DOCUMENTATION ===========
39276*
39277* Online html documentation available at
39278*            http://www.netlib.org/lapack/explore-html/
39279*
39280*> \htmlonly
39281*> Download ZLAUU2 + dependencies
39282*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlauu2.f">
39283*> [TGZ]</a>
39284*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlauu2.f">
39285*> [ZIP]</a>
39286*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlauu2.f">
39287*> [TXT]</a>
39288*> \endhtmlonly
39289*
39290*  Definition:
39291*  ===========
39292*
39293*       SUBROUTINE ZLAUU2( UPLO, N, A, LDA, INFO )
39294*
39295*       .. Scalar Arguments ..
39296*       CHARACTER          UPLO
39297*       INTEGER            INFO, LDA, N
39298*       ..
39299*       .. Array Arguments ..
39300*       COMPLEX*16         A( LDA, * )
39301*       ..
39302*
39303*
39304*> \par Purpose:
39305*  =============
39306*>
39307*> \verbatim
39308*>
39309*> ZLAUU2 computes the product U * U**H or L**H * L, where the triangular
39310*> factor U or L is stored in the upper or lower triangular part of
39311*> the array A.
39312*>
39313*> If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
39314*> overwriting the factor U in A.
39315*> If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
39316*> overwriting the factor L in A.
39317*>
39318*> This is the unblocked form of the algorithm, calling Level 2 BLAS.
39319*> \endverbatim
39320*
39321*  Arguments:
39322*  ==========
39323*
39324*> \param[in] UPLO
39325*> \verbatim
39326*>          UPLO is CHARACTER*1
39327*>          Specifies whether the triangular factor stored in the array A
39328*>          is upper or lower triangular:
39329*>          = 'U':  Upper triangular
39330*>          = 'L':  Lower triangular
39331*> \endverbatim
39332*>
39333*> \param[in] N
39334*> \verbatim
39335*>          N is INTEGER
39336*>          The order of the triangular factor U or L.  N >= 0.
39337*> \endverbatim
39338*>
39339*> \param[in,out] A
39340*> \verbatim
39341*>          A is COMPLEX*16 array, dimension (LDA,N)
39342*>          On entry, the triangular factor U or L.
39343*>          On exit, if UPLO = 'U', the upper triangle of A is
39344*>          overwritten with the upper triangle of the product U * U**H;
39345*>          if UPLO = 'L', the lower triangle of A is overwritten with
39346*>          the lower triangle of the product L**H * L.
39347*> \endverbatim
39348*>
39349*> \param[in] LDA
39350*> \verbatim
39351*>          LDA is INTEGER
39352*>          The leading dimension of the array A.  LDA >= max(1,N).
39353*> \endverbatim
39354*>
39355*> \param[out] INFO
39356*> \verbatim
39357*>          INFO is INTEGER
39358*>          = 0: successful exit
39359*>          < 0: if INFO = -k, the k-th argument had an illegal value
39360*> \endverbatim
39361*
39362*  Authors:
39363*  ========
39364*
39365*> \author Univ. of Tennessee
39366*> \author Univ. of California Berkeley
39367*> \author Univ. of Colorado Denver
39368*> \author NAG Ltd.
39369*
39370*> \date December 2016
39371*
39372*> \ingroup complex16OTHERauxiliary
39373*
39374*  =====================================================================
39375      SUBROUTINE ZLAUU2( UPLO, N, A, LDA, INFO )
39376*
39377*  -- LAPACK auxiliary routine (version 3.7.0) --
39378*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
39379*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
39380*     December 2016
39381*
39382*     .. Scalar Arguments ..
39383      CHARACTER          UPLO
39384      INTEGER            INFO, LDA, N
39385*     ..
39386*     .. Array Arguments ..
39387      COMPLEX*16         A( LDA, * )
39388*     ..
39389*
39390*  =====================================================================
39391*
39392*     .. Parameters ..
39393      COMPLEX*16         ONE
39394      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
39395*     ..
39396*     .. Local Scalars ..
39397      LOGICAL            UPPER
39398      INTEGER            I
39399      DOUBLE PRECISION   AII
39400*     ..
39401*     .. External Functions ..
39402      LOGICAL            LSAME
39403      COMPLEX*16         ZDOTC
39404      EXTERNAL           LSAME, ZDOTC
39405*     ..
39406*     .. External Subroutines ..
39407      EXTERNAL           XERBLA, ZDSCAL, ZGEMV, ZLACGV
39408*     ..
39409*     .. Intrinsic Functions ..
39410      INTRINSIC          DBLE, DCMPLX, MAX
39411*     ..
39412*     .. Executable Statements ..
39413*
39414*     Test the input parameters.
39415*
39416      INFO = 0
39417      UPPER = LSAME( UPLO, 'U' )
39418      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
39419         INFO = -1
39420      ELSE IF( N.LT.0 ) THEN
39421         INFO = -2
39422      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
39423         INFO = -4
39424      END IF
39425      IF( INFO.NE.0 ) THEN
39426         CALL XERBLA( 'ZLAUU2', -INFO )
39427         RETURN
39428      END IF
39429*
39430*     Quick return if possible
39431*
39432      IF( N.EQ.0 )
39433     $   RETURN
39434*
39435      IF( UPPER ) THEN
39436*
39437*        Compute the product U * U**H.
39438*
39439         DO 10 I = 1, N
39440            AII = A( I, I )
39441            IF( I.LT.N ) THEN
39442               A( I, I ) = AII*AII + DBLE( ZDOTC( N-I, A( I, I+1 ), LDA,
39443     $                     A( I, I+1 ), LDA ) )
39444               CALL ZLACGV( N-I, A( I, I+1 ), LDA )
39445               CALL ZGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ),
39446     $                     LDA, A( I, I+1 ), LDA, DCMPLX( AII ),
39447     $                     A( 1, I ), 1 )
39448               CALL ZLACGV( N-I, A( I, I+1 ), LDA )
39449            ELSE
39450               CALL ZDSCAL( I, AII, A( 1, I ), 1 )
39451            END IF
39452   10    CONTINUE
39453*
39454      ELSE
39455*
39456*        Compute the product L**H * L.
39457*
39458         DO 20 I = 1, N
39459            AII = A( I, I )
39460            IF( I.LT.N ) THEN
39461               A( I, I ) = AII*AII + DBLE( ZDOTC( N-I, A( I+1, I ), 1,
39462     $                     A( I+1, I ), 1 ) )
39463               CALL ZLACGV( I-1, A( I, 1 ), LDA )
39464               CALL ZGEMV( 'Conjugate transpose', N-I, I-1, ONE,
39465     $                     A( I+1, 1 ), LDA, A( I+1, I ), 1,
39466     $                     DCMPLX( AII ), A( I, 1 ), LDA )
39467               CALL ZLACGV( I-1, A( I, 1 ), LDA )
39468            ELSE
39469               CALL ZDSCAL( I, AII, A( I, 1 ), LDA )
39470            END IF
39471   20    CONTINUE
39472      END IF
39473*
39474      RETURN
39475*
39476*     End of ZLAUU2
39477*
39478      END
39479*> \brief \b ZLAUUM computes the product UUH or LHL, where U and L are upper or lower triangular matrices (blocked algorithm).
39480*
39481*  =========== DOCUMENTATION ===========
39482*
39483* Online html documentation available at
39484*            http://www.netlib.org/lapack/explore-html/
39485*
39486*> \htmlonly
39487*> Download ZLAUUM + dependencies
39488*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlauum.f">
39489*> [TGZ]</a>
39490*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlauum.f">
39491*> [ZIP]</a>
39492*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlauum.f">
39493*> [TXT]</a>
39494*> \endhtmlonly
39495*
39496*  Definition:
39497*  ===========
39498*
39499*       SUBROUTINE ZLAUUM( UPLO, N, A, LDA, INFO )
39500*
39501*       .. Scalar Arguments ..
39502*       CHARACTER          UPLO
39503*       INTEGER            INFO, LDA, N
39504*       ..
39505*       .. Array Arguments ..
39506*       COMPLEX*16         A( LDA, * )
39507*       ..
39508*
39509*
39510*> \par Purpose:
39511*  =============
39512*>
39513*> \verbatim
39514*>
39515*> ZLAUUM computes the product U * U**H or L**H * L, where the triangular
39516*> factor U or L is stored in the upper or lower triangular part of
39517*> the array A.
39518*>
39519*> If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
39520*> overwriting the factor U in A.
39521*> If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
39522*> overwriting the factor L in A.
39523*>
39524*> This is the blocked form of the algorithm, calling Level 3 BLAS.
39525*> \endverbatim
39526*
39527*  Arguments:
39528*  ==========
39529*
39530*> \param[in] UPLO
39531*> \verbatim
39532*>          UPLO is CHARACTER*1
39533*>          Specifies whether the triangular factor stored in the array A
39534*>          is upper or lower triangular:
39535*>          = 'U':  Upper triangular
39536*>          = 'L':  Lower triangular
39537*> \endverbatim
39538*>
39539*> \param[in] N
39540*> \verbatim
39541*>          N is INTEGER
39542*>          The order of the triangular factor U or L.  N >= 0.
39543*> \endverbatim
39544*>
39545*> \param[in,out] A
39546*> \verbatim
39547*>          A is COMPLEX*16 array, dimension (LDA,N)
39548*>          On entry, the triangular factor U or L.
39549*>          On exit, if UPLO = 'U', the upper triangle of A is
39550*>          overwritten with the upper triangle of the product U * U**H;
39551*>          if UPLO = 'L', the lower triangle of A is overwritten with
39552*>          the lower triangle of the product L**H * L.
39553*> \endverbatim
39554*>
39555*> \param[in] LDA
39556*> \verbatim
39557*>          LDA is INTEGER
39558*>          The leading dimension of the array A.  LDA >= max(1,N).
39559*> \endverbatim
39560*>
39561*> \param[out] INFO
39562*> \verbatim
39563*>          INFO is INTEGER
39564*>          = 0: successful exit
39565*>          < 0: if INFO = -k, the k-th argument had an illegal value
39566*> \endverbatim
39567*
39568*  Authors:
39569*  ========
39570*
39571*> \author Univ. of Tennessee
39572*> \author Univ. of California Berkeley
39573*> \author Univ. of Colorado Denver
39574*> \author NAG Ltd.
39575*
39576*> \date December 2016
39577*
39578*> \ingroup complex16OTHERauxiliary
39579*
39580*  =====================================================================
39581      SUBROUTINE ZLAUUM( UPLO, N, A, LDA, INFO )
39582*
39583*  -- LAPACK auxiliary routine (version 3.7.0) --
39584*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
39585*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
39586*     December 2016
39587*
39588*     .. Scalar Arguments ..
39589      CHARACTER          UPLO
39590      INTEGER            INFO, LDA, N
39591*     ..
39592*     .. Array Arguments ..
39593      COMPLEX*16         A( LDA, * )
39594*     ..
39595*
39596*  =====================================================================
39597*
39598*     .. Parameters ..
39599      DOUBLE PRECISION   ONE
39600      PARAMETER          ( ONE = 1.0D+0 )
39601      COMPLEX*16         CONE
39602      PARAMETER          ( CONE = ( 1.0D+0, 0.0D+0 ) )
39603*     ..
39604*     .. Local Scalars ..
39605      LOGICAL            UPPER
39606      INTEGER            I, IB, NB
39607*     ..
39608*     .. External Functions ..
39609      LOGICAL            LSAME
39610      INTEGER            ILAENV
39611      EXTERNAL           LSAME, ILAENV
39612*     ..
39613*     .. External Subroutines ..
39614      EXTERNAL           XERBLA, ZGEMM, ZHERK, ZLAUU2, ZTRMM
39615*     ..
39616*     .. Intrinsic Functions ..
39617      INTRINSIC          MAX, MIN
39618*     ..
39619*     .. Executable Statements ..
39620*
39621*     Test the input parameters.
39622*
39623      INFO = 0
39624      UPPER = LSAME( UPLO, 'U' )
39625      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
39626         INFO = -1
39627      ELSE IF( N.LT.0 ) THEN
39628         INFO = -2
39629      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
39630         INFO = -4
39631      END IF
39632      IF( INFO.NE.0 ) THEN
39633         CALL XERBLA( 'ZLAUUM', -INFO )
39634         RETURN
39635      END IF
39636*
39637*     Quick return if possible
39638*
39639      IF( N.EQ.0 )
39640     $   RETURN
39641*
39642*     Determine the block size for this environment.
39643*
39644      NB = ILAENV( 1, 'ZLAUUM', UPLO, N, -1, -1, -1 )
39645*
39646      IF( NB.LE.1 .OR. NB.GE.N ) THEN
39647*
39648*        Use unblocked code
39649*
39650         CALL ZLAUU2( UPLO, N, A, LDA, INFO )
39651      ELSE
39652*
39653*        Use blocked code
39654*
39655         IF( UPPER ) THEN
39656*
39657*           Compute the product U * U**H.
39658*
39659            DO 10 I = 1, N, NB
39660               IB = MIN( NB, N-I+1 )
39661               CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
39662     $                     'Non-unit', I-1, IB, CONE, A( I, I ), LDA,
39663     $                     A( 1, I ), LDA )
39664               CALL ZLAUU2( 'Upper', IB, A( I, I ), LDA, INFO )
39665               IF( I+IB.LE.N ) THEN
39666                  CALL ZGEMM( 'No transpose', 'Conjugate transpose',
39667     $                        I-1, IB, N-I-IB+1, CONE, A( 1, I+IB ),
39668     $                        LDA, A( I, I+IB ), LDA, CONE, A( 1, I ),
39669     $                        LDA )
39670                  CALL ZHERK( 'Upper', 'No transpose', IB, N-I-IB+1,
39671     $                        ONE, A( I, I+IB ), LDA, ONE, A( I, I ),
39672     $                        LDA )
39673               END IF
39674   10       CONTINUE
39675         ELSE
39676*
39677*           Compute the product L**H * L.
39678*
39679            DO 20 I = 1, N, NB
39680               IB = MIN( NB, N-I+1 )
39681               CALL ZTRMM( 'Left', 'Lower', 'Conjugate transpose',
39682     $                     'Non-unit', IB, I-1, CONE, A( I, I ), LDA,
39683     $                     A( I, 1 ), LDA )
39684               CALL ZLAUU2( 'Lower', IB, A( I, I ), LDA, INFO )
39685               IF( I+IB.LE.N ) THEN
39686                  CALL ZGEMM( 'Conjugate transpose', 'No transpose', IB,
39687     $                        I-1, N-I-IB+1, CONE, A( I+IB, I ), LDA,
39688     $                        A( I+IB, 1 ), LDA, CONE, A( I, 1 ), LDA )
39689                  CALL ZHERK( 'Lower', 'Conjugate transpose', IB,
39690     $                        N-I-IB+1, ONE, A( I+IB, I ), LDA, ONE,
39691     $                        A( I, I ), LDA )
39692               END IF
39693   20       CONTINUE
39694         END IF
39695      END IF
39696*
39697      RETURN
39698*
39699*     End of ZLAUUM
39700*
39701      END
39702*> \brief \b ZPOTF2 computes the Cholesky factorization of a symmetric/Hermitian positive definite matrix (unblocked algorithm).
39703*
39704*  =========== DOCUMENTATION ===========
39705*
39706* Online html documentation available at
39707*            http://www.netlib.org/lapack/explore-html/
39708*
39709*> \htmlonly
39710*> Download ZPOTF2 + dependencies
39711*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zpotf2.f">
39712*> [TGZ]</a>
39713*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zpotf2.f">
39714*> [ZIP]</a>
39715*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zpotf2.f">
39716*> [TXT]</a>
39717*> \endhtmlonly
39718*
39719*  Definition:
39720*  ===========
39721*
39722*       SUBROUTINE ZPOTF2( UPLO, N, A, LDA, INFO )
39723*
39724*       .. Scalar Arguments ..
39725*       CHARACTER          UPLO
39726*       INTEGER            INFO, LDA, N
39727*       ..
39728*       .. Array Arguments ..
39729*       COMPLEX*16         A( LDA, * )
39730*       ..
39731*
39732*
39733*> \par Purpose:
39734*  =============
39735*>
39736*> \verbatim
39737*>
39738*> ZPOTF2 computes the Cholesky factorization of a complex Hermitian
39739*> positive definite matrix A.
39740*>
39741*> The factorization has the form
39742*>    A = U**H * U ,  if UPLO = 'U', or
39743*>    A = L  * L**H,  if UPLO = 'L',
39744*> where U is an upper triangular matrix and L is lower triangular.
39745*>
39746*> This is the unblocked version of the algorithm, calling Level 2 BLAS.
39747*> \endverbatim
39748*
39749*  Arguments:
39750*  ==========
39751*
39752*> \param[in] UPLO
39753*> \verbatim
39754*>          UPLO is CHARACTER*1
39755*>          Specifies whether the upper or lower triangular part of the
39756*>          Hermitian matrix A is stored.
39757*>          = 'U':  Upper triangular
39758*>          = 'L':  Lower triangular
39759*> \endverbatim
39760*>
39761*> \param[in] N
39762*> \verbatim
39763*>          N is INTEGER
39764*>          The order of the matrix A.  N >= 0.
39765*> \endverbatim
39766*>
39767*> \param[in,out] A
39768*> \verbatim
39769*>          A is COMPLEX*16 array, dimension (LDA,N)
39770*>          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading
39771*>          n by n upper triangular part of A contains the upper
39772*>          triangular part of the matrix A, and the strictly lower
39773*>          triangular part of A is not referenced.  If UPLO = 'L', the
39774*>          leading n by n lower triangular part of A contains the lower
39775*>          triangular part of the matrix A, and the strictly upper
39776*>          triangular part of A is not referenced.
39777*>
39778*>          On exit, if INFO = 0, the factor U or L from the Cholesky
39779*>          factorization A = U**H *U  or A = L*L**H.
39780*> \endverbatim
39781*>
39782*> \param[in] LDA
39783*> \verbatim
39784*>          LDA is INTEGER
39785*>          The leading dimension of the array A.  LDA >= max(1,N).
39786*> \endverbatim
39787*>
39788*> \param[out] INFO
39789*> \verbatim
39790*>          INFO is INTEGER
39791*>          = 0: successful exit
39792*>          < 0: if INFO = -k, the k-th argument had an illegal value
39793*>          > 0: if INFO = k, the leading minor of order k is not
39794*>               positive definite, and the factorization could not be
39795*>               completed.
39796*> \endverbatim
39797*
39798*  Authors:
39799*  ========
39800*
39801*> \author Univ. of Tennessee
39802*> \author Univ. of California Berkeley
39803*> \author Univ. of Colorado Denver
39804*> \author NAG Ltd.
39805*
39806*> \date December 2016
39807*
39808*> \ingroup complex16POcomputational
39809*
39810*  =====================================================================
39811      SUBROUTINE ZPOTF2( UPLO, N, A, LDA, INFO )
39812*
39813*  -- LAPACK computational routine (version 3.7.0) --
39814*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
39815*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
39816*     December 2016
39817*
39818*     .. Scalar Arguments ..
39819      CHARACTER          UPLO
39820      INTEGER            INFO, LDA, N
39821*     ..
39822*     .. Array Arguments ..
39823      COMPLEX*16         A( LDA, * )
39824*     ..
39825*
39826*  =====================================================================
39827*
39828*     .. Parameters ..
39829      DOUBLE PRECISION   ONE, ZERO
39830      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
39831      COMPLEX*16         CONE
39832      PARAMETER          ( CONE = ( 1.0D+0, 0.0D+0 ) )
39833*     ..
39834*     .. Local Scalars ..
39835      LOGICAL            UPPER
39836      INTEGER            J
39837      DOUBLE PRECISION   AJJ
39838*     ..
39839*     .. External Functions ..
39840      LOGICAL            LSAME, DISNAN
39841      COMPLEX*16         ZDOTC
39842      EXTERNAL           LSAME, ZDOTC, DISNAN
39843*     ..
39844*     .. External Subroutines ..
39845      EXTERNAL           XERBLA, ZDSCAL, ZGEMV, ZLACGV
39846*     ..
39847*     .. Intrinsic Functions ..
39848      INTRINSIC          DBLE, MAX, SQRT
39849*     ..
39850*     .. Executable Statements ..
39851*
39852*     Test the input parameters.
39853*
39854      INFO = 0
39855      UPPER = LSAME( UPLO, 'U' )
39856      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
39857         INFO = -1
39858      ELSE IF( N.LT.0 ) THEN
39859         INFO = -2
39860      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
39861         INFO = -4
39862      END IF
39863      IF( INFO.NE.0 ) THEN
39864         CALL XERBLA( 'ZPOTF2', -INFO )
39865         RETURN
39866      END IF
39867*
39868*     Quick return if possible
39869*
39870      IF( N.EQ.0 )
39871     $   RETURN
39872*
39873      IF( UPPER ) THEN
39874*
39875*        Compute the Cholesky factorization A = U**H *U.
39876*
39877         DO 10 J = 1, N
39878*
39879*           Compute U(J,J) and test for non-positive-definiteness.
39880*
39881            AJJ = DBLE( A( J, J ) ) - ZDOTC( J-1, A( 1, J ), 1,
39882     $            A( 1, J ), 1 )
39883            IF( AJJ.LE.ZERO.OR.DISNAN( AJJ ) ) THEN
39884               A( J, J ) = AJJ
39885               GO TO 30
39886            END IF
39887            AJJ = SQRT( AJJ )
39888            A( J, J ) = AJJ
39889*
39890*           Compute elements J+1:N of row J.
39891*
39892            IF( J.LT.N ) THEN
39893               CALL ZLACGV( J-1, A( 1, J ), 1 )
39894               CALL ZGEMV( 'Transpose', J-1, N-J, -CONE, A( 1, J+1 ),
39895     $                     LDA, A( 1, J ), 1, CONE, A( J, J+1 ), LDA )
39896               CALL ZLACGV( J-1, A( 1, J ), 1 )
39897               CALL ZDSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA )
39898            END IF
39899   10    CONTINUE
39900      ELSE
39901*
39902*        Compute the Cholesky factorization A = L*L**H.
39903*
39904         DO 20 J = 1, N
39905*
39906*           Compute L(J,J) and test for non-positive-definiteness.
39907*
39908            AJJ = DBLE( A( J, J ) ) - ZDOTC( J-1, A( J, 1 ), LDA,
39909     $            A( J, 1 ), LDA )
39910            IF( AJJ.LE.ZERO.OR.DISNAN( AJJ ) ) THEN
39911               A( J, J ) = AJJ
39912               GO TO 30
39913            END IF
39914            AJJ = SQRT( AJJ )
39915            A( J, J ) = AJJ
39916*
39917*           Compute elements J+1:N of column J.
39918*
39919            IF( J.LT.N ) THEN
39920               CALL ZLACGV( J-1, A( J, 1 ), LDA )
39921               CALL ZGEMV( 'No transpose', N-J, J-1, -CONE, A( J+1, 1 ),
39922     $                     LDA, A( J, 1 ), LDA, CONE, A( J+1, J ), 1 )
39923               CALL ZLACGV( J-1, A( J, 1 ), LDA )
39924               CALL ZDSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 )
39925            END IF
39926   20    CONTINUE
39927      END IF
39928      GO TO 40
39929*
39930   30 CONTINUE
39931      INFO = J
39932*
39933   40 CONTINUE
39934      RETURN
39935*
39936*     End of ZPOTF2
39937*
39938      END
39939*> \brief \b ZPOTRF
39940*
39941*  =========== DOCUMENTATION ===========
39942*
39943* Online html documentation available at
39944*            http://www.netlib.org/lapack/explore-html/
39945*
39946*> \htmlonly
39947*> Download ZPOTRF + dependencies
39948*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zpotrf.f">
39949*> [TGZ]</a>
39950*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zpotrf.f">
39951*> [ZIP]</a>
39952*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zpotrf.f">
39953*> [TXT]</a>
39954*> \endhtmlonly
39955*
39956*  Definition:
39957*  ===========
39958*
39959*       SUBROUTINE ZPOTRF( UPLO, N, A, LDA, INFO )
39960*
39961*       .. Scalar Arguments ..
39962*       CHARACTER          UPLO
39963*       INTEGER            INFO, LDA, N
39964*       ..
39965*       .. Array Arguments ..
39966*       COMPLEX*16         A( LDA, * )
39967*       ..
39968*
39969*
39970*> \par Purpose:
39971*  =============
39972*>
39973*> \verbatim
39974*>
39975*> ZPOTRF computes the Cholesky factorization of a complex Hermitian
39976*> positive definite matrix A.
39977*>
39978*> The factorization has the form
39979*>    A = U**H * U,  if UPLO = 'U', or
39980*>    A = L  * L**H,  if UPLO = 'L',
39981*> where U is an upper triangular matrix and L is lower triangular.
39982*>
39983*> This is the block version of the algorithm, calling Level 3 BLAS.
39984*> \endverbatim
39985*
39986*  Arguments:
39987*  ==========
39988*
39989*> \param[in] UPLO
39990*> \verbatim
39991*>          UPLO is CHARACTER*1
39992*>          = 'U':  Upper triangle of A is stored;
39993*>          = 'L':  Lower triangle of A is stored.
39994*> \endverbatim
39995*>
39996*> \param[in] N
39997*> \verbatim
39998*>          N is INTEGER
39999*>          The order of the matrix A.  N >= 0.
40000*> \endverbatim
40001*>
40002*> \param[in,out] A
40003*> \verbatim
40004*>          A is COMPLEX*16 array, dimension (LDA,N)
40005*>          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading
40006*>          N-by-N upper triangular part of A contains the upper
40007*>          triangular part of the matrix A, and the strictly lower
40008*>          triangular part of A is not referenced.  If UPLO = 'L', the
40009*>          leading N-by-N lower triangular part of A contains the lower
40010*>          triangular part of the matrix A, and the strictly upper
40011*>          triangular part of A is not referenced.
40012*>
40013*>          On exit, if INFO = 0, the factor U or L from the Cholesky
40014*>          factorization A = U**H *U or A = L*L**H.
40015*> \endverbatim
40016*>
40017*> \param[in] LDA
40018*> \verbatim
40019*>          LDA is INTEGER
40020*>          The leading dimension of the array A.  LDA >= max(1,N).
40021*> \endverbatim
40022*>
40023*> \param[out] INFO
40024*> \verbatim
40025*>          INFO is INTEGER
40026*>          = 0:  successful exit
40027*>          < 0:  if INFO = -i, the i-th argument had an illegal value
40028*>          > 0:  if INFO = i, the leading minor of order i is not
40029*>                positive definite, and the factorization could not be
40030*>                completed.
40031*> \endverbatim
40032*
40033*  Authors:
40034*  ========
40035*
40036*> \author Univ. of Tennessee
40037*> \author Univ. of California Berkeley
40038*> \author Univ. of Colorado Denver
40039*> \author NAG Ltd.
40040*
40041*> \date December 2016
40042*
40043*> \ingroup complex16POcomputational
40044*
40045*  =====================================================================
40046      SUBROUTINE ZPOTRF( UPLO, N, A, LDA, INFO )
40047*
40048*  -- LAPACK computational routine (version 3.7.0) --
40049*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
40050*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
40051*     December 2016
40052*
40053*     .. Scalar Arguments ..
40054      CHARACTER          UPLO
40055      INTEGER            INFO, LDA, N
40056*     ..
40057*     .. Array Arguments ..
40058      COMPLEX*16         A( LDA, * )
40059*     ..
40060*
40061*  =====================================================================
40062*
40063*     .. Parameters ..
40064      DOUBLE PRECISION   ONE
40065      COMPLEX*16         CONE
40066      PARAMETER          ( ONE = 1.0D+0, CONE = ( 1.0D+0, 0.0D+0 ) )
40067*     ..
40068*     .. Local Scalars ..
40069      LOGICAL            UPPER
40070      INTEGER            J, JB, NB
40071*     ..
40072*     .. External Functions ..
40073      LOGICAL            LSAME
40074      INTEGER            ILAENV
40075      EXTERNAL           LSAME, ILAENV
40076*     ..
40077*     .. External Subroutines ..
40078      EXTERNAL           XERBLA, ZGEMM, ZHERK, ZPOTRF2, ZTRSM
40079*     ..
40080*     .. Intrinsic Functions ..
40081      INTRINSIC          MAX, MIN
40082*     ..
40083*     .. Executable Statements ..
40084*
40085*     Test the input parameters.
40086*
40087      INFO = 0
40088      UPPER = LSAME( UPLO, 'U' )
40089      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
40090         INFO = -1
40091      ELSE IF( N.LT.0 ) THEN
40092         INFO = -2
40093      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
40094         INFO = -4
40095      END IF
40096      IF( INFO.NE.0 ) THEN
40097         CALL XERBLA( 'ZPOTRF', -INFO )
40098         RETURN
40099      END IF
40100*
40101*     Quick return if possible
40102*
40103      IF( N.EQ.0 )
40104     $   RETURN
40105*
40106*     Determine the block size for this environment.
40107*
40108      NB = ILAENV( 1, 'ZPOTRF', UPLO, N, -1, -1, -1 )
40109      IF( NB.LE.1 .OR. NB.GE.N ) THEN
40110*
40111*        Use unblocked code.
40112*
40113         CALL ZPOTRF2( UPLO, N, A, LDA, INFO )
40114      ELSE
40115*
40116*        Use blocked code.
40117*
40118         IF( UPPER ) THEN
40119*
40120*           Compute the Cholesky factorization A = U**H *U.
40121*
40122            DO 10 J = 1, N, NB
40123*
40124*              Update and factorize the current diagonal block and test
40125*              for non-positive-definiteness.
40126*
40127               JB = MIN( NB, N-J+1 )
40128               CALL ZHERK( 'Upper', 'Conjugate transpose', JB, J-1,
40129     $                     -ONE, A( 1, J ), LDA, ONE, A( J, J ), LDA )
40130               CALL ZPOTRF2( 'Upper', JB, A( J, J ), LDA, INFO )
40131               IF( INFO.NE.0 )
40132     $            GO TO 30
40133               IF( J+JB.LE.N ) THEN
40134*
40135*                 Compute the current block row.
40136*
40137                  CALL ZGEMM( 'Conjugate transpose', 'No transpose', JB,
40138     $                        N-J-JB+1, J-1, -CONE, A( 1, J ), LDA,
40139     $                        A( 1, J+JB ), LDA, CONE, A( J, J+JB ),
40140     $                        LDA )
40141                  CALL ZTRSM( 'Left', 'Upper', 'Conjugate transpose',
40142     $                        'Non-unit', JB, N-J-JB+1, CONE, A( J, J ),
40143     $                        LDA, A( J, J+JB ), LDA )
40144               END IF
40145   10       CONTINUE
40146*
40147         ELSE
40148*
40149*           Compute the Cholesky factorization A = L*L**H.
40150*
40151            DO 20 J = 1, N, NB
40152*
40153*              Update and factorize the current diagonal block and test
40154*              for non-positive-definiteness.
40155*
40156               JB = MIN( NB, N-J+1 )
40157               CALL ZHERK( 'Lower', 'No transpose', JB, J-1, -ONE,
40158     $                     A( J, 1 ), LDA, ONE, A( J, J ), LDA )
40159               CALL ZPOTRF2( 'Lower', JB, A( J, J ), LDA, INFO )
40160               IF( INFO.NE.0 )
40161     $            GO TO 30
40162               IF( J+JB.LE.N ) THEN
40163*
40164*                 Compute the current block column.
40165*
40166                  CALL ZGEMM( 'No transpose', 'Conjugate transpose',
40167     $                        N-J-JB+1, JB, J-1, -CONE, A( J+JB, 1 ),
40168     $                        LDA, A( J, 1 ), LDA, CONE, A( J+JB, J ),
40169     $                        LDA )
40170                  CALL ZTRSM( 'Right', 'Lower', 'Conjugate transpose',
40171     $                        'Non-unit', N-J-JB+1, JB, CONE, A( J, J ),
40172     $                        LDA, A( J+JB, J ), LDA )
40173               END IF
40174   20       CONTINUE
40175         END IF
40176      END IF
40177      GO TO 40
40178*
40179   30 CONTINUE
40180      INFO = INFO + J - 1
40181*
40182   40 CONTINUE
40183      RETURN
40184*
40185*     End of ZPOTRF
40186*
40187      END
40188*> \brief \b ZPOTRF2
40189*
40190*  =========== DOCUMENTATION ===========
40191*
40192* Online html documentation available at
40193*            http://www.netlib.org/lapack/explore-html/
40194*
40195*  Definition:
40196*  ===========
40197*
40198*       RECURSIVE SUBROUTINE ZPOTRF2( UPLO, N, A, LDA, INFO )
40199*
40200*       .. Scalar Arguments ..
40201*       CHARACTER          UPLO
40202*       INTEGER            INFO, LDA, N
40203*       ..
40204*       .. Array Arguments ..
40205*       COMPLEX*16         A( LDA, * )
40206*       ..
40207*
40208*
40209*> \par Purpose:
40210*  =============
40211*>
40212*> \verbatim
40213*>
40214*> ZPOTRF2 computes the Cholesky factorization of a Hermitian
40215*> positive definite matrix A using the recursive algorithm.
40216*>
40217*> The factorization has the form
40218*>    A = U**H * U,  if UPLO = 'U', or
40219*>    A = L  * L**H,  if UPLO = 'L',
40220*> where U is an upper triangular matrix and L is lower triangular.
40221*>
40222*> This is the recursive version of the algorithm. It divides
40223*> the matrix into four submatrices:
40224*>
40225*>        [  A11 | A12  ]  where A11 is n1 by n1 and A22 is n2 by n2
40226*>    A = [ -----|----- ]  with n1 = n/2
40227*>        [  A21 | A22  ]       n2 = n-n1
40228*>
40229*> The subroutine calls itself to factor A11. Update and scale A21
40230*> or A12, update A22 then call itself to factor A22.
40231*>
40232*> \endverbatim
40233*
40234*  Arguments:
40235*  ==========
40236*
40237*> \param[in] UPLO
40238*> \verbatim
40239*>          UPLO is CHARACTER*1
40240*>          = 'U':  Upper triangle of A is stored;
40241*>          = 'L':  Lower triangle of A is stored.
40242*> \endverbatim
40243*>
40244*> \param[in] N
40245*> \verbatim
40246*>          N is INTEGER
40247*>          The order of the matrix A.  N >= 0.
40248*> \endverbatim
40249*>
40250*> \param[in,out] A
40251*> \verbatim
40252*>          A is COMPLEX*16 array, dimension (LDA,N)
40253*>          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading
40254*>          N-by-N upper triangular part of A contains the upper
40255*>          triangular part of the matrix A, and the strictly lower
40256*>          triangular part of A is not referenced.  If UPLO = 'L', the
40257*>          leading N-by-N lower triangular part of A contains the lower
40258*>          triangular part of the matrix A, and the strictly upper
40259*>          triangular part of A is not referenced.
40260*>
40261*>          On exit, if INFO = 0, the factor U or L from the Cholesky
40262*>          factorization A = U**H*U or A = L*L**H.
40263*> \endverbatim
40264*>
40265*> \param[in] LDA
40266*> \verbatim
40267*>          LDA is INTEGER
40268*>          The leading dimension of the array A.  LDA >= max(1,N).
40269*> \endverbatim
40270*>
40271*> \param[out] INFO
40272*> \verbatim
40273*>          INFO is INTEGER
40274*>          = 0:  successful exit
40275*>          < 0:  if INFO = -i, the i-th argument had an illegal value
40276*>          > 0:  if INFO = i, the leading minor of order i is not
40277*>                positive definite, and the factorization could not be
40278*>                completed.
40279*> \endverbatim
40280*
40281*  Authors:
40282*  ========
40283*
40284*> \author Univ. of Tennessee
40285*> \author Univ. of California Berkeley
40286*> \author Univ. of Colorado Denver
40287*> \author NAG Ltd.
40288*
40289*> \date December 2016
40290*
40291*> \ingroup complex16POcomputational
40292*
40293*  =====================================================================
40294      RECURSIVE SUBROUTINE ZPOTRF2( UPLO, N, A, LDA, INFO )
40295*
40296*  -- LAPACK computational routine (version 3.7.0) --
40297*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
40298*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
40299*     December 2016
40300*
40301*     .. Scalar Arguments ..
40302      CHARACTER          UPLO
40303      INTEGER            INFO, LDA, N
40304*     ..
40305*     .. Array Arguments ..
40306      COMPLEX*16         A( LDA, * )
40307*     ..
40308*
40309*  =====================================================================
40310*
40311*     .. Parameters ..
40312      DOUBLE PRECISION   ONE, ZERO
40313      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
40314      COMPLEX*16         CONE
40315      PARAMETER          ( CONE = (1.0D+0, 0.0D+0) )
40316*     ..
40317*     .. Local Scalars ..
40318      LOGICAL            UPPER
40319      INTEGER            N1, N2, IINFO
40320      DOUBLE PRECISION   AJJ
40321*     ..
40322*     .. External Functions ..
40323      LOGICAL            LSAME, DISNAN
40324      EXTERNAL           LSAME, DISNAN
40325*     ..
40326*     .. External Subroutines ..
40327      EXTERNAL           ZHERK, ZTRSM, XERBLA
40328*     ..
40329*     .. Intrinsic Functions ..
40330      INTRINSIC          MAX, DBLE, SQRT
40331*     ..
40332*     .. Executable Statements ..
40333*
40334*     Test the input parameters
40335*
40336      INFO = 0
40337      UPPER = LSAME( UPLO, 'U' )
40338      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
40339         INFO = -1
40340      ELSE IF( N.LT.0 ) THEN
40341         INFO = -2
40342      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
40343         INFO = -4
40344      END IF
40345      IF( INFO.NE.0 ) THEN
40346         CALL XERBLA( 'ZPOTRF2', -INFO )
40347         RETURN
40348      END IF
40349*
40350*     Quick return if possible
40351*
40352      IF( N.EQ.0 )
40353     $   RETURN
40354*
40355*     N=1 case
40356*
40357      IF( N.EQ.1 ) THEN
40358*
40359*        Test for non-positive-definiteness
40360*
40361         AJJ = DBLE( A( 1, 1 ) )
40362         IF( AJJ.LE.ZERO.OR.DISNAN( AJJ ) ) THEN
40363            INFO = 1
40364            RETURN
40365         END IF
40366*
40367*        Factor
40368*
40369         A( 1, 1 ) = SQRT( AJJ )
40370*
40371*     Use recursive code
40372*
40373      ELSE
40374         N1 = N/2
40375         N2 = N-N1
40376*
40377*        Factor A11
40378*
40379         CALL ZPOTRF2( UPLO, N1, A( 1, 1 ), LDA, IINFO )
40380         IF ( IINFO.NE.0 ) THEN
40381            INFO = IINFO
40382            RETURN
40383         END IF
40384*
40385*        Compute the Cholesky factorization A = U**H*U
40386*
40387         IF( UPPER ) THEN
40388*
40389*           Update and scale A12
40390*
40391            CALL ZTRSM( 'L', 'U', 'C', 'N', N1, N2, CONE,
40392     $                  A( 1, 1 ), LDA, A( 1, N1+1 ), LDA )
40393*
40394*           Update and factor A22
40395*
40396            CALL ZHERK( UPLO, 'C', N2, N1, -ONE, A( 1, N1+1 ), LDA,
40397     $                  ONE, A( N1+1, N1+1 ), LDA )
40398            CALL ZPOTRF2( UPLO, N2, A( N1+1, N1+1 ), LDA, IINFO )
40399            IF ( IINFO.NE.0 ) THEN
40400               INFO = IINFO + N1
40401               RETURN
40402            END IF
40403*
40404*        Compute the Cholesky factorization A = L*L**H
40405*
40406         ELSE
40407*
40408*           Update and scale A21
40409*
40410            CALL ZTRSM( 'R', 'L', 'C', 'N', N2, N1, CONE,
40411     $                  A( 1, 1 ), LDA, A( N1+1, 1 ), LDA )
40412*
40413*           Update and factor A22
40414*
40415            CALL ZHERK( UPLO, 'N', N2, N1, -ONE, A( N1+1, 1 ), LDA,
40416     $                  ONE, A( N1+1, N1+1 ), LDA )
40417            CALL ZPOTRF2( UPLO, N2, A( N1+1, N1+1 ), LDA, IINFO )
40418            IF ( IINFO.NE.0 ) THEN
40419               INFO = IINFO + N1
40420               RETURN
40421            END IF
40422         END IF
40423      END IF
40424      RETURN
40425*
40426*     End of ZPOTRF2
40427*
40428      END
40429*> \brief \b ZPOTRI
40430*
40431*  =========== DOCUMENTATION ===========
40432*
40433* Online html documentation available at
40434*            http://www.netlib.org/lapack/explore-html/
40435*
40436*> \htmlonly
40437*> Download ZPOTRI + dependencies
40438*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zpotri.f">
40439*> [TGZ]</a>
40440*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zpotri.f">
40441*> [ZIP]</a>
40442*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zpotri.f">
40443*> [TXT]</a>
40444*> \endhtmlonly
40445*
40446*  Definition:
40447*  ===========
40448*
40449*       SUBROUTINE ZPOTRI( UPLO, N, A, LDA, INFO )
40450*
40451*       .. Scalar Arguments ..
40452*       CHARACTER          UPLO
40453*       INTEGER            INFO, LDA, N
40454*       ..
40455*       .. Array Arguments ..
40456*       COMPLEX*16         A( LDA, * )
40457*       ..
40458*
40459*
40460*> \par Purpose:
40461*  =============
40462*>
40463*> \verbatim
40464*>
40465*> ZPOTRI computes the inverse of a complex Hermitian positive definite
40466*> matrix A using the Cholesky factorization A = U**H*U or A = L*L**H
40467*> computed by ZPOTRF.
40468*> \endverbatim
40469*
40470*  Arguments:
40471*  ==========
40472*
40473*> \param[in] UPLO
40474*> \verbatim
40475*>          UPLO is CHARACTER*1
40476*>          = 'U':  Upper triangle of A is stored;
40477*>          = 'L':  Lower triangle of A is stored.
40478*> \endverbatim
40479*>
40480*> \param[in] N
40481*> \verbatim
40482*>          N is INTEGER
40483*>          The order of the matrix A.  N >= 0.
40484*> \endverbatim
40485*>
40486*> \param[in,out] A
40487*> \verbatim
40488*>          A is COMPLEX*16 array, dimension (LDA,N)
40489*>          On entry, the triangular factor U or L from the Cholesky
40490*>          factorization A = U**H*U or A = L*L**H, as computed by
40491*>          ZPOTRF.
40492*>          On exit, the upper or lower triangle of the (Hermitian)
40493*>          inverse of A, overwriting the input factor U or L.
40494*> \endverbatim
40495*>
40496*> \param[in] LDA
40497*> \verbatim
40498*>          LDA is INTEGER
40499*>          The leading dimension of the array A.  LDA >= max(1,N).
40500*> \endverbatim
40501*>
40502*> \param[out] INFO
40503*> \verbatim
40504*>          INFO is INTEGER
40505*>          = 0:  successful exit
40506*>          < 0:  if INFO = -i, the i-th argument had an illegal value
40507*>          > 0:  if INFO = i, the (i,i) element of the factor U or L is
40508*>                zero, and the inverse could not be computed.
40509*> \endverbatim
40510*
40511*  Authors:
40512*  ========
40513*
40514*> \author Univ. of Tennessee
40515*> \author Univ. of California Berkeley
40516*> \author Univ. of Colorado Denver
40517*> \author NAG Ltd.
40518*
40519*> \date December 2016
40520*
40521*> \ingroup complex16POcomputational
40522*
40523*  =====================================================================
40524      SUBROUTINE ZPOTRI( UPLO, N, A, LDA, INFO )
40525*
40526*  -- LAPACK computational routine (version 3.7.0) --
40527*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
40528*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
40529*     December 2016
40530*
40531*     .. Scalar Arguments ..
40532      CHARACTER          UPLO
40533      INTEGER            INFO, LDA, N
40534*     ..
40535*     .. Array Arguments ..
40536      COMPLEX*16         A( LDA, * )
40537*     ..
40538*
40539*  =====================================================================
40540*
40541*     .. External Functions ..
40542      LOGICAL            LSAME
40543      EXTERNAL           LSAME
40544*     ..
40545*     .. External Subroutines ..
40546      EXTERNAL           XERBLA, ZLAUUM, ZTRTRI
40547*     ..
40548*     .. Intrinsic Functions ..
40549      INTRINSIC          MAX
40550*     ..
40551*     .. Executable Statements ..
40552*
40553*     Test the input parameters.
40554*
40555      INFO = 0
40556      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
40557         INFO = -1
40558      ELSE IF( N.LT.0 ) THEN
40559         INFO = -2
40560      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
40561         INFO = -4
40562      END IF
40563      IF( INFO.NE.0 ) THEN
40564         CALL XERBLA( 'ZPOTRI', -INFO )
40565         RETURN
40566      END IF
40567*
40568*     Quick return if possible
40569*
40570      IF( N.EQ.0 )
40571     $   RETURN
40572*
40573*     Invert the triangular Cholesky factor U or L.
40574*
40575      CALL ZTRTRI( UPLO, 'Non-unit', N, A, LDA, INFO )
40576      IF( INFO.GT.0 )
40577     $   RETURN
40578*
40579*     Form inv(U) * inv(U)**H or inv(L)**H * inv(L).
40580*
40581      CALL ZLAUUM( UPLO, N, A, LDA, INFO )
40582*
40583      RETURN
40584*
40585*     End of ZPOTRI
40586*
40587      END
40588*> \brief \b ZROT applies a plane rotation with real cosine and complex sine to a pair of complex vectors.
40589*
40590*  =========== DOCUMENTATION ===========
40591*
40592* Online html documentation available at
40593*            http://www.netlib.org/lapack/explore-html/
40594*
40595*> \htmlonly
40596*> Download ZROT + dependencies
40597*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zrot.f">
40598*> [TGZ]</a>
40599*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zrot.f">
40600*> [ZIP]</a>
40601*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zrot.f">
40602*> [TXT]</a>
40603*> \endhtmlonly
40604*
40605*  Definition:
40606*  ===========
40607*
40608*       SUBROUTINE ZROT( N, CX, INCX, CY, INCY, C, S )
40609*
40610*       .. Scalar Arguments ..
40611*       INTEGER            INCX, INCY, N
40612*       DOUBLE PRECISION   C
40613*       COMPLEX*16         S
40614*       ..
40615*       .. Array Arguments ..
40616*       COMPLEX*16         CX( * ), CY( * )
40617*       ..
40618*
40619*
40620*> \par Purpose:
40621*  =============
40622*>
40623*> \verbatim
40624*>
40625*> ZROT   applies a plane rotation, where the cos (C) is real and the
40626*> sin (S) is complex, and the vectors CX and CY are complex.
40627*> \endverbatim
40628*
40629*  Arguments:
40630*  ==========
40631*
40632*> \param[in] N
40633*> \verbatim
40634*>          N is INTEGER
40635*>          The number of elements in the vectors CX and CY.
40636*> \endverbatim
40637*>
40638*> \param[in,out] CX
40639*> \verbatim
40640*>          CX is COMPLEX*16 array, dimension (N)
40641*>          On input, the vector X.
40642*>          On output, CX is overwritten with C*X + S*Y.
40643*> \endverbatim
40644*>
40645*> \param[in] INCX
40646*> \verbatim
40647*>          INCX is INTEGER
40648*>          The increment between successive values of CY.  INCX <> 0.
40649*> \endverbatim
40650*>
40651*> \param[in,out] CY
40652*> \verbatim
40653*>          CY is COMPLEX*16 array, dimension (N)
40654*>          On input, the vector Y.
40655*>          On output, CY is overwritten with -CONJG(S)*X + C*Y.
40656*> \endverbatim
40657*>
40658*> \param[in] INCY
40659*> \verbatim
40660*>          INCY is INTEGER
40661*>          The increment between successive values of CY.  INCX <> 0.
40662*> \endverbatim
40663*>
40664*> \param[in] C
40665*> \verbatim
40666*>          C is DOUBLE PRECISION
40667*> \endverbatim
40668*>
40669*> \param[in] S
40670*> \verbatim
40671*>          S is COMPLEX*16
40672*>          C and S define a rotation
40673*>             [  C          S  ]
40674*>             [ -conjg(S)   C  ]
40675*>          where C*C + S*CONJG(S) = 1.0.
40676*> \endverbatim
40677*
40678*  Authors:
40679*  ========
40680*
40681*> \author Univ. of Tennessee
40682*> \author Univ. of California Berkeley
40683*> \author Univ. of Colorado Denver
40684*> \author NAG Ltd.
40685*
40686*> \date December 2016
40687*
40688*> \ingroup complex16OTHERauxiliary
40689*
40690*  =====================================================================
40691      SUBROUTINE ZROT( N, CX, INCX, CY, INCY, C, S )
40692*
40693*  -- LAPACK auxiliary routine (version 3.7.0) --
40694*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
40695*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
40696*     December 2016
40697*
40698*     .. Scalar Arguments ..
40699      INTEGER            INCX, INCY, N
40700      DOUBLE PRECISION   C
40701      COMPLEX*16         S
40702*     ..
40703*     .. Array Arguments ..
40704      COMPLEX*16         CX( * ), CY( * )
40705*     ..
40706*
40707* =====================================================================
40708*
40709*     .. Local Scalars ..
40710      INTEGER            I, IX, IY
40711      COMPLEX*16         STEMP
40712*     ..
40713*     .. Intrinsic Functions ..
40714      INTRINSIC          DCONJG
40715*     ..
40716*     .. Executable Statements ..
40717*
40718      IF( N.LE.0 )
40719     $   RETURN
40720      IF( INCX.EQ.1 .AND. INCY.EQ.1 )
40721     $   GO TO 20
40722*
40723*     Code for unequal increments or equal increments not equal to 1
40724*
40725      IX = 1
40726      IY = 1
40727      IF( INCX.LT.0 )
40728     $   IX = ( -N+1 )*INCX + 1
40729      IF( INCY.LT.0 )
40730     $   IY = ( -N+1 )*INCY + 1
40731      DO 10 I = 1, N
40732         STEMP = C*CX( IX ) + S*CY( IY )
40733         CY( IY ) = C*CY( IY ) - DCONJG( S )*CX( IX )
40734         CX( IX ) = STEMP
40735         IX = IX + INCX
40736         IY = IY + INCY
40737   10 CONTINUE
40738      RETURN
40739*
40740*     Code for both increments equal to 1
40741*
40742   20 CONTINUE
40743      DO 30 I = 1, N
40744         STEMP = C*CX( I ) + S*CY( I )
40745         CY( I ) = C*CY( I ) - DCONJG( S )*CX( I )
40746         CX( I ) = STEMP
40747   30 CONTINUE
40748      RETURN
40749      END
40750*> \brief \b ZSTEDC
40751*
40752*  =========== DOCUMENTATION ===========
40753*
40754* Online html documentation available at
40755*            http://www.netlib.org/lapack/explore-html/
40756*
40757*> \htmlonly
40758*> Download ZSTEDC + dependencies
40759*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zstedc.f">
40760*> [TGZ]</a>
40761*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zstedc.f">
40762*> [ZIP]</a>
40763*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zstedc.f">
40764*> [TXT]</a>
40765*> \endhtmlonly
40766*
40767*  Definition:
40768*  ===========
40769*
40770*       SUBROUTINE ZSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, RWORK,
40771*                          LRWORK, IWORK, LIWORK, INFO )
40772*
40773*       .. Scalar Arguments ..
40774*       CHARACTER          COMPZ
40775*       INTEGER            INFO, LDZ, LIWORK, LRWORK, LWORK, N
40776*       ..
40777*       .. Array Arguments ..
40778*       INTEGER            IWORK( * )
40779*       DOUBLE PRECISION   D( * ), E( * ), RWORK( * )
40780*       COMPLEX*16         WORK( * ), Z( LDZ, * )
40781*       ..
40782*
40783*
40784*> \par Purpose:
40785*  =============
40786*>
40787*> \verbatim
40788*>
40789*> ZSTEDC computes all eigenvalues and, optionally, eigenvectors of a
40790*> symmetric tridiagonal matrix using the divide and conquer method.
40791*> The eigenvectors of a full or band complex Hermitian matrix can also
40792*> be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this
40793*> matrix to tridiagonal form.
40794*>
40795*> This code makes very mild assumptions about floating point
40796*> arithmetic. It will work on machines with a guard digit in
40797*> add/subtract, or on those binary machines without guard digits
40798*> which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
40799*> It could conceivably fail on hexadecimal or decimal machines
40800*> without guard digits, but we know of none.  See DLAED3 for details.
40801*> \endverbatim
40802*
40803*  Arguments:
40804*  ==========
40805*
40806*> \param[in] COMPZ
40807*> \verbatim
40808*>          COMPZ is CHARACTER*1
40809*>          = 'N':  Compute eigenvalues only.
40810*>          = 'I':  Compute eigenvectors of tridiagonal matrix also.
40811*>          = 'V':  Compute eigenvectors of original Hermitian matrix
40812*>                  also.  On entry, Z contains the unitary matrix used
40813*>                  to reduce the original matrix to tridiagonal form.
40814*> \endverbatim
40815*>
40816*> \param[in] N
40817*> \verbatim
40818*>          N is INTEGER
40819*>          The dimension of the symmetric tridiagonal matrix.  N >= 0.
40820*> \endverbatim
40821*>
40822*> \param[in,out] D
40823*> \verbatim
40824*>          D is DOUBLE PRECISION array, dimension (N)
40825*>          On entry, the diagonal elements of the tridiagonal matrix.
40826*>          On exit, if INFO = 0, the eigenvalues in ascending order.
40827*> \endverbatim
40828*>
40829*> \param[in,out] E
40830*> \verbatim
40831*>          E is DOUBLE PRECISION array, dimension (N-1)
40832*>          On entry, the subdiagonal elements of the tridiagonal matrix.
40833*>          On exit, E has been destroyed.
40834*> \endverbatim
40835*>
40836*> \param[in,out] Z
40837*> \verbatim
40838*>          Z is COMPLEX*16 array, dimension (LDZ,N)
40839*>          On entry, if COMPZ = 'V', then Z contains the unitary
40840*>          matrix used in the reduction to tridiagonal form.
40841*>          On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
40842*>          orthonormal eigenvectors of the original Hermitian matrix,
40843*>          and if COMPZ = 'I', Z contains the orthonormal eigenvectors
40844*>          of the symmetric tridiagonal matrix.
40845*>          If  COMPZ = 'N', then Z is not referenced.
40846*> \endverbatim
40847*>
40848*> \param[in] LDZ
40849*> \verbatim
40850*>          LDZ is INTEGER
40851*>          The leading dimension of the array Z.  LDZ >= 1.
40852*>          If eigenvectors are desired, then LDZ >= max(1,N).
40853*> \endverbatim
40854*>
40855*> \param[out] WORK
40856*> \verbatim
40857*>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
40858*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
40859*> \endverbatim
40860*>
40861*> \param[in] LWORK
40862*> \verbatim
40863*>          LWORK is INTEGER
40864*>          The dimension of the array WORK.
40865*>          If COMPZ = 'N' or 'I', or N <= 1, LWORK must be at least 1.
40866*>          If COMPZ = 'V' and N > 1, LWORK must be at least N*N.
40867*>          Note that for COMPZ = 'V', then if N is less than or
40868*>          equal to the minimum divide size, usually 25, then LWORK need
40869*>          only be 1.
40870*>
40871*>          If LWORK = -1, then a workspace query is assumed; the routine
40872*>          only calculates the optimal sizes of the WORK, RWORK and
40873*>          IWORK arrays, returns these values as the first entries of
40874*>          the WORK, RWORK and IWORK arrays, and no error message
40875*>          related to LWORK or LRWORK or LIWORK is issued by XERBLA.
40876*> \endverbatim
40877*>
40878*> \param[out] RWORK
40879*> \verbatim
40880*>          RWORK is DOUBLE PRECISION array, dimension (MAX(1,LRWORK))
40881*>          On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.
40882*> \endverbatim
40883*>
40884*> \param[in] LRWORK
40885*> \verbatim
40886*>          LRWORK is INTEGER
40887*>          The dimension of the array RWORK.
40888*>          If COMPZ = 'N' or N <= 1, LRWORK must be at least 1.
40889*>          If COMPZ = 'V' and N > 1, LRWORK must be at least
40890*>                         1 + 3*N + 2*N*lg N + 4*N**2 ,
40891*>                         where lg( N ) = smallest integer k such
40892*>                         that 2**k >= N.
40893*>          If COMPZ = 'I' and N > 1, LRWORK must be at least
40894*>                         1 + 4*N + 2*N**2 .
40895*>          Note that for COMPZ = 'I' or 'V', then if N is less than or
40896*>          equal to the minimum divide size, usually 25, then LRWORK
40897*>          need only be max(1,2*(N-1)).
40898*>
40899*>          If LRWORK = -1, then a workspace query is assumed; the
40900*>          routine only calculates the optimal sizes of the WORK, RWORK
40901*>          and IWORK arrays, returns these values as the first entries
40902*>          of the WORK, RWORK and IWORK arrays, and no error message
40903*>          related to LWORK or LRWORK or LIWORK is issued by XERBLA.
40904*> \endverbatim
40905*>
40906*> \param[out] IWORK
40907*> \verbatim
40908*>          IWORK is INTEGER array, dimension (MAX(1,LIWORK))
40909*>          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
40910*> \endverbatim
40911*>
40912*> \param[in] LIWORK
40913*> \verbatim
40914*>          LIWORK is INTEGER
40915*>          The dimension of the array IWORK.
40916*>          If COMPZ = 'N' or N <= 1, LIWORK must be at least 1.
40917*>          If COMPZ = 'V' or N > 1,  LIWORK must be at least
40918*>                                    6 + 6*N + 5*N*lg N.
40919*>          If COMPZ = 'I' or N > 1,  LIWORK must be at least
40920*>                                    3 + 5*N .
40921*>          Note that for COMPZ = 'I' or 'V', then if N is less than or
40922*>          equal to the minimum divide size, usually 25, then LIWORK
40923*>          need only be 1.
40924*>
40925*>          If LIWORK = -1, then a workspace query is assumed; the
40926*>          routine only calculates the optimal sizes of the WORK, RWORK
40927*>          and IWORK arrays, returns these values as the first entries
40928*>          of the WORK, RWORK and IWORK arrays, and no error message
40929*>          related to LWORK or LRWORK or LIWORK is issued by XERBLA.
40930*> \endverbatim
40931*>
40932*> \param[out] INFO
40933*> \verbatim
40934*>          INFO is INTEGER
40935*>          = 0:  successful exit.
40936*>          < 0:  if INFO = -i, the i-th argument had an illegal value.
40937*>          > 0:  The algorithm failed to compute an eigenvalue while
40938*>                working on the submatrix lying in rows and columns
40939*>                INFO/(N+1) through mod(INFO,N+1).
40940*> \endverbatim
40941*
40942*  Authors:
40943*  ========
40944*
40945*> \author Univ. of Tennessee
40946*> \author Univ. of California Berkeley
40947*> \author Univ. of Colorado Denver
40948*> \author NAG Ltd.
40949*
40950*> \date June 2017
40951*
40952*> \ingroup complex16OTHERcomputational
40953*
40954*> \par Contributors:
40955*  ==================
40956*>
40957*> Jeff Rutter, Computer Science Division, University of California
40958*> at Berkeley, USA
40959*
40960*  =====================================================================
40961      SUBROUTINE ZSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, RWORK,
40962     $                   LRWORK, IWORK, LIWORK, INFO )
40963*
40964*  -- LAPACK computational routine (version 3.7.1) --
40965*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
40966*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
40967*     June 2017
40968*
40969*     .. Scalar Arguments ..
40970      CHARACTER          COMPZ
40971      INTEGER            INFO, LDZ, LIWORK, LRWORK, LWORK, N
40972*     ..
40973*     .. Array Arguments ..
40974      INTEGER            IWORK( * )
40975      DOUBLE PRECISION   D( * ), E( * ), RWORK( * )
40976      COMPLEX*16         WORK( * ), Z( LDZ, * )
40977*     ..
40978*
40979*  =====================================================================
40980*
40981*     .. Parameters ..
40982      DOUBLE PRECISION   ZERO, ONE, TWO
40983      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
40984*     ..
40985*     .. Local Scalars ..
40986      LOGICAL            LQUERY
40987      INTEGER            FINISH, I, ICOMPZ, II, J, K, LGN, LIWMIN, LL,
40988     $                   LRWMIN, LWMIN, M, SMLSIZ, START
40989      DOUBLE PRECISION   EPS, ORGNRM, P, TINY
40990*     ..
40991*     .. External Functions ..
40992      LOGICAL            LSAME
40993      INTEGER            ILAENV
40994      DOUBLE PRECISION   DLAMCH, DLANST
40995      EXTERNAL           LSAME, ILAENV, DLAMCH, DLANST
40996*     ..
40997*     .. External Subroutines ..
40998      EXTERNAL           DLASCL, DLASET, DSTEDC, DSTEQR, DSTERF, XERBLA,
40999     $                   ZLACPY, ZLACRM, ZLAED0, ZSTEQR, ZSWAP
41000*     ..
41001*     .. Intrinsic Functions ..
41002      INTRINSIC          ABS, DBLE, INT, LOG, MAX, MOD, SQRT
41003*     ..
41004*     .. Executable Statements ..
41005*
41006*     Test the input parameters.
41007*
41008      INFO = 0
41009      LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
41010*
41011      IF( LSAME( COMPZ, 'N' ) ) THEN
41012         ICOMPZ = 0
41013      ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
41014         ICOMPZ = 1
41015      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
41016         ICOMPZ = 2
41017      ELSE
41018         ICOMPZ = -1
41019      END IF
41020      IF( ICOMPZ.LT.0 ) THEN
41021         INFO = -1
41022      ELSE IF( N.LT.0 ) THEN
41023         INFO = -2
41024      ELSE IF( ( LDZ.LT.1 ) .OR.
41025     $         ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, N ) ) ) THEN
41026         INFO = -6
41027      END IF
41028*
41029      IF( INFO.EQ.0 ) THEN
41030*
41031*        Compute the workspace requirements
41032*
41033         SMLSIZ = ILAENV( 9, 'ZSTEDC', ' ', 0, 0, 0, 0 )
41034         IF( N.LE.1 .OR. ICOMPZ.EQ.0 ) THEN
41035            LWMIN = 1
41036            LIWMIN = 1
41037            LRWMIN = 1
41038         ELSE IF( N.LE.SMLSIZ ) THEN
41039            LWMIN = 1
41040            LIWMIN = 1
41041            LRWMIN = 2*( N - 1 )
41042         ELSE IF( ICOMPZ.EQ.1 ) THEN
41043            LGN = INT( LOG( DBLE( N ) ) / LOG( TWO ) )
41044            IF( 2**LGN.LT.N )
41045     $         LGN = LGN + 1
41046            IF( 2**LGN.LT.N )
41047     $         LGN = LGN + 1
41048            LWMIN = N*N
41049            LRWMIN = 1 + 3*N + 2*N*LGN + 4*N**2
41050            LIWMIN = 6 + 6*N + 5*N*LGN
41051         ELSE IF( ICOMPZ.EQ.2 ) THEN
41052            LWMIN = 1
41053            LRWMIN = 1 + 4*N + 2*N**2
41054            LIWMIN = 3 + 5*N
41055         END IF
41056         WORK( 1 ) = LWMIN
41057         RWORK( 1 ) = LRWMIN
41058         IWORK( 1 ) = LIWMIN
41059*
41060         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
41061            INFO = -8
41062         ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN
41063            INFO = -10
41064         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
41065            INFO = -12
41066         END IF
41067      END IF
41068*
41069      IF( INFO.NE.0 ) THEN
41070         CALL XERBLA( 'ZSTEDC', -INFO )
41071         RETURN
41072      ELSE IF( LQUERY ) THEN
41073         RETURN
41074      END IF
41075*
41076*     Quick return if possible
41077*
41078      IF( N.EQ.0 )
41079     $   RETURN
41080      IF( N.EQ.1 ) THEN
41081         IF( ICOMPZ.NE.0 )
41082     $      Z( 1, 1 ) = ONE
41083         RETURN
41084      END IF
41085*
41086*     If the following conditional clause is removed, then the routine
41087*     will use the Divide and Conquer routine to compute only the
41088*     eigenvalues, which requires (3N + 3N**2) real workspace and
41089*     (2 + 5N + 2N lg(N)) integer workspace.
41090*     Since on many architectures DSTERF is much faster than any other
41091*     algorithm for finding eigenvalues only, it is used here
41092*     as the default. If the conditional clause is removed, then
41093*     information on the size of workspace needs to be changed.
41094*
41095*     If COMPZ = 'N', use DSTERF to compute the eigenvalues.
41096*
41097      IF( ICOMPZ.EQ.0 ) THEN
41098         CALL DSTERF( N, D, E, INFO )
41099         GO TO 70
41100      END IF
41101*
41102*     If N is smaller than the minimum divide size (SMLSIZ+1), then
41103*     solve the problem with another solver.
41104*
41105      IF( N.LE.SMLSIZ ) THEN
41106*
41107         CALL ZSTEQR( COMPZ, N, D, E, Z, LDZ, RWORK, INFO )
41108*
41109      ELSE
41110*
41111*        If COMPZ = 'I', we simply call DSTEDC instead.
41112*
41113         IF( ICOMPZ.EQ.2 ) THEN
41114            CALL DLASET( 'Full', N, N, ZERO, ONE, RWORK, N )
41115            LL = N*N + 1
41116            CALL DSTEDC( 'I', N, D, E, RWORK, N,
41117     $                   RWORK( LL ), LRWORK-LL+1, IWORK, LIWORK, INFO )
41118            DO 20 J = 1, N
41119               DO 10 I = 1, N
41120                  Z( I, J ) = RWORK( ( J-1 )*N+I )
41121   10          CONTINUE
41122   20       CONTINUE
41123            GO TO 70
41124         END IF
41125*
41126*        From now on, only option left to be handled is COMPZ = 'V',
41127*        i.e. ICOMPZ = 1.
41128*
41129*        Scale.
41130*
41131         ORGNRM = DLANST( 'M', N, D, E )
41132         IF( ORGNRM.EQ.ZERO )
41133     $      GO TO 70
41134*
41135         EPS = DLAMCH( 'Epsilon' )
41136*
41137         START = 1
41138*
41139*        while ( START <= N )
41140*
41141   30    CONTINUE
41142         IF( START.LE.N ) THEN
41143*
41144*           Let FINISH be the position of the next subdiagonal entry
41145*           such that E( FINISH ) <= TINY or FINISH = N if no such
41146*           subdiagonal exists.  The matrix identified by the elements
41147*           between START and FINISH constitutes an independent
41148*           sub-problem.
41149*
41150            FINISH = START
41151   40       CONTINUE
41152            IF( FINISH.LT.N ) THEN
41153               TINY = EPS*SQRT( ABS( D( FINISH ) ) )*
41154     $                    SQRT( ABS( D( FINISH+1 ) ) )
41155               IF( ABS( E( FINISH ) ).GT.TINY ) THEN
41156                  FINISH = FINISH + 1
41157                  GO TO 40
41158               END IF
41159            END IF
41160*
41161*           (Sub) Problem determined.  Compute its size and solve it.
41162*
41163            M = FINISH - START + 1
41164            IF( M.GT.SMLSIZ ) THEN
41165*
41166*              Scale.
41167*
41168               ORGNRM = DLANST( 'M', M, D( START ), E( START ) )
41169               CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M, 1, D( START ), M,
41170     $                      INFO )
41171               CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M-1, 1, E( START ),
41172     $                      M-1, INFO )
41173*
41174               CALL ZLAED0( N, M, D( START ), E( START ), Z( 1, START ),
41175     $                      LDZ, WORK, N, RWORK, IWORK, INFO )
41176               IF( INFO.GT.0 ) THEN
41177                  INFO = ( INFO / ( M+1 )+START-1 )*( N+1 ) +
41178     $                   MOD( INFO, ( M+1 ) ) + START - 1
41179                  GO TO 70
41180               END IF
41181*
41182*              Scale back.
41183*
41184               CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, M, 1, D( START ), M,
41185     $                      INFO )
41186*
41187            ELSE
41188               CALL DSTEQR( 'I', M, D( START ), E( START ), RWORK, M,
41189     $                      RWORK( M*M+1 ), INFO )
41190               CALL ZLACRM( N, M, Z( 1, START ), LDZ, RWORK, M, WORK, N,
41191     $                      RWORK( M*M+1 ) )
41192               CALL ZLACPY( 'A', N, M, WORK, N, Z( 1, START ), LDZ )
41193               IF( INFO.GT.0 ) THEN
41194                  INFO = START*( N+1 ) + FINISH
41195                  GO TO 70
41196               END IF
41197            END IF
41198*
41199            START = FINISH + 1
41200            GO TO 30
41201         END IF
41202*
41203*        endwhile
41204*
41205*
41206*        Use Selection Sort to minimize swaps of eigenvectors
41207*
41208         DO 60 II = 2, N
41209           I = II - 1
41210           K = I
41211           P = D( I )
41212           DO 50 J = II, N
41213              IF( D( J ).LT.P ) THEN
41214                 K = J
41215                 P = D( J )
41216              END IF
41217   50      CONTINUE
41218           IF( K.NE.I ) THEN
41219              D( K ) = D( I )
41220              D( I ) = P
41221              CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
41222           END IF
41223   60    CONTINUE
41224      END IF
41225*
41226   70 CONTINUE
41227      WORK( 1 ) = LWMIN
41228      RWORK( 1 ) = LRWMIN
41229      IWORK( 1 ) = LIWMIN
41230*
41231      RETURN
41232*
41233*     End of ZSTEDC
41234*
41235      END
41236*> \brief \b ZSTEQR
41237*
41238*  =========== DOCUMENTATION ===========
41239*
41240* Online html documentation available at
41241*            http://www.netlib.org/lapack/explore-html/
41242*
41243*> \htmlonly
41244*> Download ZSTEQR + dependencies
41245*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zsteqr.f">
41246*> [TGZ]</a>
41247*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zsteqr.f">
41248*> [ZIP]</a>
41249*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zsteqr.f">
41250*> [TXT]</a>
41251*> \endhtmlonly
41252*
41253*  Definition:
41254*  ===========
41255*
41256*       SUBROUTINE ZSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
41257*
41258*       .. Scalar Arguments ..
41259*       CHARACTER          COMPZ
41260*       INTEGER            INFO, LDZ, N
41261*       ..
41262*       .. Array Arguments ..
41263*       DOUBLE PRECISION   D( * ), E( * ), WORK( * )
41264*       COMPLEX*16         Z( LDZ, * )
41265*       ..
41266*
41267*
41268*> \par Purpose:
41269*  =============
41270*>
41271*> \verbatim
41272*>
41273*> ZSTEQR computes all eigenvalues and, optionally, eigenvectors of a
41274*> symmetric tridiagonal matrix using the implicit QL or QR method.
41275*> The eigenvectors of a full or band complex Hermitian matrix can also
41276*> be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this
41277*> matrix to tridiagonal form.
41278*> \endverbatim
41279*
41280*  Arguments:
41281*  ==========
41282*
41283*> \param[in] COMPZ
41284*> \verbatim
41285*>          COMPZ is CHARACTER*1
41286*>          = 'N':  Compute eigenvalues only.
41287*>          = 'V':  Compute eigenvalues and eigenvectors of the original
41288*>                  Hermitian matrix.  On entry, Z must contain the
41289*>                  unitary matrix used to reduce the original matrix
41290*>                  to tridiagonal form.
41291*>          = 'I':  Compute eigenvalues and eigenvectors of the
41292*>                  tridiagonal matrix.  Z is initialized to the identity
41293*>                  matrix.
41294*> \endverbatim
41295*>
41296*> \param[in] N
41297*> \verbatim
41298*>          N is INTEGER
41299*>          The order of the matrix.  N >= 0.
41300*> \endverbatim
41301*>
41302*> \param[in,out] D
41303*> \verbatim
41304*>          D is DOUBLE PRECISION array, dimension (N)
41305*>          On entry, the diagonal elements of the tridiagonal matrix.
41306*>          On exit, if INFO = 0, the eigenvalues in ascending order.
41307*> \endverbatim
41308*>
41309*> \param[in,out] E
41310*> \verbatim
41311*>          E is DOUBLE PRECISION array, dimension (N-1)
41312*>          On entry, the (n-1) subdiagonal elements of the tridiagonal
41313*>          matrix.
41314*>          On exit, E has been destroyed.
41315*> \endverbatim
41316*>
41317*> \param[in,out] Z
41318*> \verbatim
41319*>          Z is COMPLEX*16 array, dimension (LDZ, N)
41320*>          On entry, if  COMPZ = 'V', then Z contains the unitary
41321*>          matrix used in the reduction to tridiagonal form.
41322*>          On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
41323*>          orthonormal eigenvectors of the original Hermitian matrix,
41324*>          and if COMPZ = 'I', Z contains the orthonormal eigenvectors
41325*>          of the symmetric tridiagonal matrix.
41326*>          If COMPZ = 'N', then Z is not referenced.
41327*> \endverbatim
41328*>
41329*> \param[in] LDZ
41330*> \verbatim
41331*>          LDZ is INTEGER
41332*>          The leading dimension of the array Z.  LDZ >= 1, and if
41333*>          eigenvectors are desired, then  LDZ >= max(1,N).
41334*> \endverbatim
41335*>
41336*> \param[out] WORK
41337*> \verbatim
41338*>          WORK is DOUBLE PRECISION array, dimension (max(1,2*N-2))
41339*>          If COMPZ = 'N', then WORK is not referenced.
41340*> \endverbatim
41341*>
41342*> \param[out] INFO
41343*> \verbatim
41344*>          INFO is INTEGER
41345*>          = 0:  successful exit
41346*>          < 0:  if INFO = -i, the i-th argument had an illegal value
41347*>          > 0:  the algorithm has failed to find all the eigenvalues in
41348*>                a total of 30*N iterations; if INFO = i, then i
41349*>                elements of E have not converged to zero; on exit, D
41350*>                and E contain the elements of a symmetric tridiagonal
41351*>                matrix which is unitarily similar to the original
41352*>                matrix.
41353*> \endverbatim
41354*
41355*  Authors:
41356*  ========
41357*
41358*> \author Univ. of Tennessee
41359*> \author Univ. of California Berkeley
41360*> \author Univ. of Colorado Denver
41361*> \author NAG Ltd.
41362*
41363*> \date December 2016
41364*
41365*> \ingroup complex16OTHERcomputational
41366*
41367*  =====================================================================
41368      SUBROUTINE ZSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
41369*
41370*  -- LAPACK computational routine (version 3.7.0) --
41371*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
41372*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
41373*     December 2016
41374*
41375*     .. Scalar Arguments ..
41376      CHARACTER          COMPZ
41377      INTEGER            INFO, LDZ, N
41378*     ..
41379*     .. Array Arguments ..
41380      DOUBLE PRECISION   D( * ), E( * ), WORK( * )
41381      COMPLEX*16         Z( LDZ, * )
41382*     ..
41383*
41384*  =====================================================================
41385*
41386*     .. Parameters ..
41387      DOUBLE PRECISION   ZERO, ONE, TWO, THREE
41388      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
41389     $                   THREE = 3.0D0 )
41390      COMPLEX*16         CZERO, CONE
41391      PARAMETER          ( CZERO = ( 0.0D0, 0.0D0 ),
41392     $                   CONE = ( 1.0D0, 0.0D0 ) )
41393      INTEGER            MAXIT
41394      PARAMETER          ( MAXIT = 30 )
41395*     ..
41396*     .. Local Scalars ..
41397      INTEGER            I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND,
41398     $                   LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1,
41399     $                   NM1, NMAXIT
41400      DOUBLE PRECISION   ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2,
41401     $                   S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST
41402*     ..
41403*     .. External Functions ..
41404      LOGICAL            LSAME
41405      DOUBLE PRECISION   DLAMCH, DLANST, DLAPY2
41406      EXTERNAL           LSAME, DLAMCH, DLANST, DLAPY2
41407*     ..
41408*     .. External Subroutines ..
41409      EXTERNAL           DLAE2, DLAEV2, DLARTG, DLASCL, DLASRT, XERBLA,
41410     $                   ZLASET, ZLASR, ZSWAP
41411*     ..
41412*     .. Intrinsic Functions ..
41413      INTRINSIC          ABS, MAX, SIGN, SQRT
41414*     ..
41415*     .. Executable Statements ..
41416*
41417*     Test the input parameters.
41418*
41419      INFO = 0
41420*
41421      IF( LSAME( COMPZ, 'N' ) ) THEN
41422         ICOMPZ = 0
41423      ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
41424         ICOMPZ = 1
41425      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
41426         ICOMPZ = 2
41427      ELSE
41428         ICOMPZ = -1
41429      END IF
41430      IF( ICOMPZ.LT.0 ) THEN
41431         INFO = -1
41432      ELSE IF( N.LT.0 ) THEN
41433         INFO = -2
41434      ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1,
41435     $         N ) ) ) THEN
41436         INFO = -6
41437      END IF
41438      IF( INFO.NE.0 ) THEN
41439         CALL XERBLA( 'ZSTEQR', -INFO )
41440         RETURN
41441      END IF
41442*
41443*     Quick return if possible
41444*
41445      IF( N.EQ.0 )
41446     $   RETURN
41447*
41448      IF( N.EQ.1 ) THEN
41449         IF( ICOMPZ.EQ.2 )
41450     $      Z( 1, 1 ) = CONE
41451         RETURN
41452      END IF
41453*
41454*     Determine the unit roundoff and over/underflow thresholds.
41455*
41456      EPS = DLAMCH( 'E' )
41457      EPS2 = EPS**2
41458      SAFMIN = DLAMCH( 'S' )
41459      SAFMAX = ONE / SAFMIN
41460      SSFMAX = SQRT( SAFMAX ) / THREE
41461      SSFMIN = SQRT( SAFMIN ) / EPS2
41462*
41463*     Compute the eigenvalues and eigenvectors of the tridiagonal
41464*     matrix.
41465*
41466      IF( ICOMPZ.EQ.2 )
41467     $   CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDZ )
41468*
41469      NMAXIT = N*MAXIT
41470      JTOT = 0
41471*
41472*     Determine where the matrix splits and choose QL or QR iteration
41473*     for each block, according to whether top or bottom diagonal
41474*     element is smaller.
41475*
41476      L1 = 1
41477      NM1 = N - 1
41478*
41479   10 CONTINUE
41480      IF( L1.GT.N )
41481     $   GO TO 160
41482      IF( L1.GT.1 )
41483     $   E( L1-1 ) = ZERO
41484      IF( L1.LE.NM1 ) THEN
41485         DO 20 M = L1, NM1
41486            TST = ABS( E( M ) )
41487            IF( TST.EQ.ZERO )
41488     $         GO TO 30
41489            IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+
41490     $          1 ) ) ) )*EPS ) THEN
41491               E( M ) = ZERO
41492               GO TO 30
41493            END IF
41494   20    CONTINUE
41495      END IF
41496      M = N
41497*
41498   30 CONTINUE
41499      L = L1
41500      LSV = L
41501      LEND = M
41502      LENDSV = LEND
41503      L1 = M + 1
41504      IF( LEND.EQ.L )
41505     $   GO TO 10
41506*
41507*     Scale submatrix in rows and columns L to LEND
41508*
41509      ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) )
41510      ISCALE = 0
41511      IF( ANORM.EQ.ZERO )
41512     $   GO TO 10
41513      IF( ANORM.GT.SSFMAX ) THEN
41514         ISCALE = 1
41515         CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N,
41516     $                INFO )
41517         CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N,
41518     $                INFO )
41519      ELSE IF( ANORM.LT.SSFMIN ) THEN
41520         ISCALE = 2
41521         CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N,
41522     $                INFO )
41523         CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N,
41524     $                INFO )
41525      END IF
41526*
41527*     Choose between QL and QR iteration
41528*
41529      IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN
41530         LEND = LSV
41531         L = LENDSV
41532      END IF
41533*
41534      IF( LEND.GT.L ) THEN
41535*
41536*        QL Iteration
41537*
41538*        Look for small subdiagonal element.
41539*
41540   40    CONTINUE
41541         IF( L.NE.LEND ) THEN
41542            LENDM1 = LEND - 1
41543            DO 50 M = L, LENDM1
41544               TST = ABS( E( M ) )**2
41545               IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+
41546     $             SAFMIN )GO TO 60
41547   50       CONTINUE
41548         END IF
41549*
41550         M = LEND
41551*
41552   60    CONTINUE
41553         IF( M.LT.LEND )
41554     $      E( M ) = ZERO
41555         P = D( L )
41556         IF( M.EQ.L )
41557     $      GO TO 80
41558*
41559*        If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
41560*        to compute its eigensystem.
41561*
41562         IF( M.EQ.L+1 ) THEN
41563            IF( ICOMPZ.GT.0 ) THEN
41564               CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S )
41565               WORK( L ) = C
41566               WORK( N-1+L ) = S
41567               CALL ZLASR( 'R', 'V', 'B', N, 2, WORK( L ),
41568     $                     WORK( N-1+L ), Z( 1, L ), LDZ )
41569            ELSE
41570               CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 )
41571            END IF
41572            D( L ) = RT1
41573            D( L+1 ) = RT2
41574            E( L ) = ZERO
41575            L = L + 2
41576            IF( L.LE.LEND )
41577     $         GO TO 40
41578            GO TO 140
41579         END IF
41580*
41581         IF( JTOT.EQ.NMAXIT )
41582     $      GO TO 140
41583         JTOT = JTOT + 1
41584*
41585*        Form shift.
41586*
41587         G = ( D( L+1 )-P ) / ( TWO*E( L ) )
41588         R = DLAPY2( G, ONE )
41589         G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) )
41590*
41591         S = ONE
41592         C = ONE
41593         P = ZERO
41594*
41595*        Inner loop
41596*
41597         MM1 = M - 1
41598         DO 70 I = MM1, L, -1
41599            F = S*E( I )
41600            B = C*E( I )
41601            CALL DLARTG( G, F, C, S, R )
41602            IF( I.NE.M-1 )
41603     $         E( I+1 ) = R
41604            G = D( I+1 ) - P
41605            R = ( D( I )-G )*S + TWO*C*B
41606            P = S*R
41607            D( I+1 ) = G + P
41608            G = C*R - B
41609*
41610*           If eigenvectors are desired, then save rotations.
41611*
41612            IF( ICOMPZ.GT.0 ) THEN
41613               WORK( I ) = C
41614               WORK( N-1+I ) = -S
41615            END IF
41616*
41617   70    CONTINUE
41618*
41619*        If eigenvectors are desired, then apply saved rotations.
41620*
41621         IF( ICOMPZ.GT.0 ) THEN
41622            MM = M - L + 1
41623            CALL ZLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ),
41624     $                  Z( 1, L ), LDZ )
41625         END IF
41626*
41627         D( L ) = D( L ) - P
41628         E( L ) = G
41629         GO TO 40
41630*
41631*        Eigenvalue found.
41632*
41633   80    CONTINUE
41634         D( L ) = P
41635*
41636         L = L + 1
41637         IF( L.LE.LEND )
41638     $      GO TO 40
41639         GO TO 140
41640*
41641      ELSE
41642*
41643*        QR Iteration
41644*
41645*        Look for small superdiagonal element.
41646*
41647   90    CONTINUE
41648         IF( L.NE.LEND ) THEN
41649            LENDP1 = LEND + 1
41650            DO 100 M = L, LENDP1, -1
41651               TST = ABS( E( M-1 ) )**2
41652               IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+
41653     $             SAFMIN )GO TO 110
41654  100       CONTINUE
41655         END IF
41656*
41657         M = LEND
41658*
41659  110    CONTINUE
41660         IF( M.GT.LEND )
41661     $      E( M-1 ) = ZERO
41662         P = D( L )
41663         IF( M.EQ.L )
41664     $      GO TO 130
41665*
41666*        If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
41667*        to compute its eigensystem.
41668*
41669         IF( M.EQ.L-1 ) THEN
41670            IF( ICOMPZ.GT.0 ) THEN
41671               CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S )
41672               WORK( M ) = C
41673               WORK( N-1+M ) = S
41674               CALL ZLASR( 'R', 'V', 'F', N, 2, WORK( M ),
41675     $                     WORK( N-1+M ), Z( 1, L-1 ), LDZ )
41676            ELSE
41677               CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 )
41678            END IF
41679            D( L-1 ) = RT1
41680            D( L ) = RT2
41681            E( L-1 ) = ZERO
41682            L = L - 2
41683            IF( L.GE.LEND )
41684     $         GO TO 90
41685            GO TO 140
41686         END IF
41687*
41688         IF( JTOT.EQ.NMAXIT )
41689     $      GO TO 140
41690         JTOT = JTOT + 1
41691*
41692*        Form shift.
41693*
41694         G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) )
41695         R = DLAPY2( G, ONE )
41696         G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) )
41697*
41698         S = ONE
41699         C = ONE
41700         P = ZERO
41701*
41702*        Inner loop
41703*
41704         LM1 = L - 1
41705         DO 120 I = M, LM1
41706            F = S*E( I )
41707            B = C*E( I )
41708            CALL DLARTG( G, F, C, S, R )
41709            IF( I.NE.M )
41710     $         E( I-1 ) = R
41711            G = D( I ) - P
41712            R = ( D( I+1 )-G )*S + TWO*C*B
41713            P = S*R
41714            D( I ) = G + P
41715            G = C*R - B
41716*
41717*           If eigenvectors are desired, then save rotations.
41718*
41719            IF( ICOMPZ.GT.0 ) THEN
41720               WORK( I ) = C
41721               WORK( N-1+I ) = S
41722            END IF
41723*
41724  120    CONTINUE
41725*
41726*        If eigenvectors are desired, then apply saved rotations.
41727*
41728         IF( ICOMPZ.GT.0 ) THEN
41729            MM = L - M + 1
41730            CALL ZLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ),
41731     $                  Z( 1, M ), LDZ )
41732         END IF
41733*
41734         D( L ) = D( L ) - P
41735         E( LM1 ) = G
41736         GO TO 90
41737*
41738*        Eigenvalue found.
41739*
41740  130    CONTINUE
41741         D( L ) = P
41742*
41743         L = L - 1
41744         IF( L.GE.LEND )
41745     $      GO TO 90
41746         GO TO 140
41747*
41748      END IF
41749*
41750*     Undo scaling if necessary
41751*
41752  140 CONTINUE
41753      IF( ISCALE.EQ.1 ) THEN
41754         CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1,
41755     $                D( LSV ), N, INFO )
41756         CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ),
41757     $                N, INFO )
41758      ELSE IF( ISCALE.EQ.2 ) THEN
41759         CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1,
41760     $                D( LSV ), N, INFO )
41761         CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ),
41762     $                N, INFO )
41763      END IF
41764*
41765*     Check for no convergence to an eigenvalue after a total
41766*     of N*MAXIT iterations.
41767*
41768      IF( JTOT.EQ.NMAXIT ) THEN
41769         DO 150 I = 1, N - 1
41770            IF( E( I ).NE.ZERO )
41771     $         INFO = INFO + 1
41772  150    CONTINUE
41773         RETURN
41774      END IF
41775      GO TO 10
41776*
41777*     Order eigenvalues and eigenvectors.
41778*
41779  160 CONTINUE
41780      IF( ICOMPZ.EQ.0 ) THEN
41781*
41782*        Use Quick Sort
41783*
41784         CALL DLASRT( 'I', N, D, INFO )
41785*
41786      ELSE
41787*
41788*        Use Selection Sort to minimize swaps of eigenvectors
41789*
41790         DO 180 II = 2, N
41791            I = II - 1
41792            K = I
41793            P = D( I )
41794            DO 170 J = II, N
41795               IF( D( J ).LT.P ) THEN
41796                  K = J
41797                  P = D( J )
41798               END IF
41799  170       CONTINUE
41800            IF( K.NE.I ) THEN
41801               D( K ) = D( I )
41802               D( I ) = P
41803               CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
41804            END IF
41805  180    CONTINUE
41806      END IF
41807      RETURN
41808*
41809*     End of ZSTEQR
41810*
41811      END
41812*> \brief \b ZSYMV computes a matrix-vector product for a complex symmetric matrix.
41813*
41814*  =========== DOCUMENTATION ===========
41815*
41816* Online html documentation available at
41817*            http://www.netlib.org/lapack/explore-html/
41818*
41819*> \htmlonly
41820*> Download ZSYMV + dependencies
41821*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zsymv.f">
41822*> [TGZ]</a>
41823*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zsymv.f">
41824*> [ZIP]</a>
41825*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zsymv.f">
41826*> [TXT]</a>
41827*> \endhtmlonly
41828*
41829*  Definition:
41830*  ===========
41831*
41832*       SUBROUTINE ZSYMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )
41833*
41834*       .. Scalar Arguments ..
41835*       CHARACTER          UPLO
41836*       INTEGER            INCX, INCY, LDA, N
41837*       COMPLEX*16         ALPHA, BETA
41838*       ..
41839*       .. Array Arguments ..
41840*       COMPLEX*16         A( LDA, * ), X( * ), Y( * )
41841*       ..
41842*
41843*
41844*> \par Purpose:
41845*  =============
41846*>
41847*> \verbatim
41848*>
41849*> ZSYMV  performs the matrix-vector  operation
41850*>
41851*>    y := alpha*A*x + beta*y,
41852*>
41853*> where alpha and beta are scalars, x and y are n element vectors and
41854*> A is an n by n symmetric matrix.
41855*> \endverbatim
41856*
41857*  Arguments:
41858*  ==========
41859*
41860*> \param[in] UPLO
41861*> \verbatim
41862*>          UPLO is CHARACTER*1
41863*>           On entry, UPLO specifies whether the upper or lower
41864*>           triangular part of the array A is to be referenced as
41865*>           follows:
41866*>
41867*>              UPLO = 'U' or 'u'   Only the upper triangular part of A
41868*>                                  is to be referenced.
41869*>
41870*>              UPLO = 'L' or 'l'   Only the lower triangular part of A
41871*>                                  is to be referenced.
41872*>
41873*>           Unchanged on exit.
41874*> \endverbatim
41875*>
41876*> \param[in] N
41877*> \verbatim
41878*>          N is INTEGER
41879*>           On entry, N specifies the order of the matrix A.
41880*>           N must be at least zero.
41881*>           Unchanged on exit.
41882*> \endverbatim
41883*>
41884*> \param[in] ALPHA
41885*> \verbatim
41886*>          ALPHA is COMPLEX*16
41887*>           On entry, ALPHA specifies the scalar alpha.
41888*>           Unchanged on exit.
41889*> \endverbatim
41890*>
41891*> \param[in] A
41892*> \verbatim
41893*>          A is COMPLEX*16 array, dimension ( LDA, N )
41894*>           Before entry, with  UPLO = 'U' or 'u', the leading n by n
41895*>           upper triangular part of the array A must contain the upper
41896*>           triangular part of the symmetric matrix and the strictly
41897*>           lower triangular part of A is not referenced.
41898*>           Before entry, with UPLO = 'L' or 'l', the leading n by n
41899*>           lower triangular part of the array A must contain the lower
41900*>           triangular part of the symmetric matrix and the strictly
41901*>           upper triangular part of A is not referenced.
41902*>           Unchanged on exit.
41903*> \endverbatim
41904*>
41905*> \param[in] LDA
41906*> \verbatim
41907*>          LDA is INTEGER
41908*>           On entry, LDA specifies the first dimension of A as declared
41909*>           in the calling (sub) program. LDA must be at least
41910*>           max( 1, N ).
41911*>           Unchanged on exit.
41912*> \endverbatim
41913*>
41914*> \param[in] X
41915*> \verbatim
41916*>          X is COMPLEX*16 array, dimension at least
41917*>           ( 1 + ( N - 1 )*abs( INCX ) ).
41918*>           Before entry, the incremented array X must contain the N-
41919*>           element vector x.
41920*>           Unchanged on exit.
41921*> \endverbatim
41922*>
41923*> \param[in] INCX
41924*> \verbatim
41925*>          INCX is INTEGER
41926*>           On entry, INCX specifies the increment for the elements of
41927*>           X. INCX must not be zero.
41928*>           Unchanged on exit.
41929*> \endverbatim
41930*>
41931*> \param[in] BETA
41932*> \verbatim
41933*>          BETA is COMPLEX*16
41934*>           On entry, BETA specifies the scalar beta. When BETA is
41935*>           supplied as zero then Y need not be set on input.
41936*>           Unchanged on exit.
41937*> \endverbatim
41938*>
41939*> \param[in,out] Y
41940*> \verbatim
41941*>          Y is COMPLEX*16 array, dimension at least
41942*>           ( 1 + ( N - 1 )*abs( INCY ) ).
41943*>           Before entry, the incremented array Y must contain the n
41944*>           element vector y. On exit, Y is overwritten by the updated
41945*>           vector y.
41946*> \endverbatim
41947*>
41948*> \param[in] INCY
41949*> \verbatim
41950*>          INCY is INTEGER
41951*>           On entry, INCY specifies the increment for the elements of
41952*>           Y. INCY must not be zero.
41953*>           Unchanged on exit.
41954*> \endverbatim
41955*
41956*  Authors:
41957*  ========
41958*
41959*> \author Univ. of Tennessee
41960*> \author Univ. of California Berkeley
41961*> \author Univ. of Colorado Denver
41962*> \author NAG Ltd.
41963*
41964*> \date December 2016
41965*
41966*> \ingroup complex16SYauxiliary
41967*
41968*  =====================================================================
41969      SUBROUTINE ZSYMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )
41970*
41971*  -- LAPACK auxiliary routine (version 3.7.0) --
41972*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
41973*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
41974*     December 2016
41975*
41976*     .. Scalar Arguments ..
41977      CHARACTER          UPLO
41978      INTEGER            INCX, INCY, LDA, N
41979      COMPLEX*16         ALPHA, BETA
41980*     ..
41981*     .. Array Arguments ..
41982      COMPLEX*16         A( LDA, * ), X( * ), Y( * )
41983*     ..
41984*
41985* =====================================================================
41986*
41987*     .. Parameters ..
41988      COMPLEX*16         ONE
41989      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
41990      COMPLEX*16         ZERO
41991      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ) )
41992*     ..
41993*     .. Local Scalars ..
41994      INTEGER            I, INFO, IX, IY, J, JX, JY, KX, KY
41995      COMPLEX*16         TEMP1, TEMP2
41996*     ..
41997*     .. External Functions ..
41998      LOGICAL            LSAME
41999      EXTERNAL           LSAME
42000*     ..
42001*     .. External Subroutines ..
42002      EXTERNAL           XERBLA
42003*     ..
42004*     .. Intrinsic Functions ..
42005      INTRINSIC          MAX
42006*     ..
42007*     .. Executable Statements ..
42008*
42009*     Test the input parameters.
42010*
42011      INFO = 0
42012      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
42013         INFO = 1
42014      ELSE IF( N.LT.0 ) THEN
42015         INFO = 2
42016      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
42017         INFO = 5
42018      ELSE IF( INCX.EQ.0 ) THEN
42019         INFO = 7
42020      ELSE IF( INCY.EQ.0 ) THEN
42021         INFO = 10
42022      END IF
42023      IF( INFO.NE.0 ) THEN
42024         CALL XERBLA( 'ZSYMV ', INFO )
42025         RETURN
42026      END IF
42027*
42028*     Quick return if possible.
42029*
42030      IF( ( N.EQ.0 ) .OR. ( ( ALPHA.EQ.ZERO ) .AND. ( BETA.EQ.ONE ) ) )
42031     $   RETURN
42032*
42033*     Set up the start points in  X  and  Y.
42034*
42035      IF( INCX.GT.0 ) THEN
42036         KX = 1
42037      ELSE
42038         KX = 1 - ( N-1 )*INCX
42039      END IF
42040      IF( INCY.GT.0 ) THEN
42041         KY = 1
42042      ELSE
42043         KY = 1 - ( N-1 )*INCY
42044      END IF
42045*
42046*     Start the operations. In this version the elements of A are
42047*     accessed sequentially with one pass through the triangular part
42048*     of A.
42049*
42050*     First form  y := beta*y.
42051*
42052      IF( BETA.NE.ONE ) THEN
42053         IF( INCY.EQ.1 ) THEN
42054            IF( BETA.EQ.ZERO ) THEN
42055               DO 10 I = 1, N
42056                  Y( I ) = ZERO
42057   10          CONTINUE
42058            ELSE
42059               DO 20 I = 1, N
42060                  Y( I ) = BETA*Y( I )
42061   20          CONTINUE
42062            END IF
42063         ELSE
42064            IY = KY
42065            IF( BETA.EQ.ZERO ) THEN
42066               DO 30 I = 1, N
42067                  Y( IY ) = ZERO
42068                  IY = IY + INCY
42069   30          CONTINUE
42070            ELSE
42071               DO 40 I = 1, N
42072                  Y( IY ) = BETA*Y( IY )
42073                  IY = IY + INCY
42074   40          CONTINUE
42075            END IF
42076         END IF
42077      END IF
42078      IF( ALPHA.EQ.ZERO )
42079     $   RETURN
42080      IF( LSAME( UPLO, 'U' ) ) THEN
42081*
42082*        Form  y  when A is stored in upper triangle.
42083*
42084         IF( ( INCX.EQ.1 ) .AND. ( INCY.EQ.1 ) ) THEN
42085            DO 60 J = 1, N
42086               TEMP1 = ALPHA*X( J )
42087               TEMP2 = ZERO
42088               DO 50 I = 1, J - 1
42089                  Y( I ) = Y( I ) + TEMP1*A( I, J )
42090                  TEMP2 = TEMP2 + A( I, J )*X( I )
42091   50          CONTINUE
42092               Y( J ) = Y( J ) + TEMP1*A( J, J ) + ALPHA*TEMP2
42093   60       CONTINUE
42094         ELSE
42095            JX = KX
42096            JY = KY
42097            DO 80 J = 1, N
42098               TEMP1 = ALPHA*X( JX )
42099               TEMP2 = ZERO
42100               IX = KX
42101               IY = KY
42102               DO 70 I = 1, J - 1
42103                  Y( IY ) = Y( IY ) + TEMP1*A( I, J )
42104                  TEMP2 = TEMP2 + A( I, J )*X( IX )
42105                  IX = IX + INCX
42106                  IY = IY + INCY
42107   70          CONTINUE
42108               Y( JY ) = Y( JY ) + TEMP1*A( J, J ) + ALPHA*TEMP2
42109               JX = JX + INCX
42110               JY = JY + INCY
42111   80       CONTINUE
42112         END IF
42113      ELSE
42114*
42115*        Form  y  when A is stored in lower triangle.
42116*
42117         IF( ( INCX.EQ.1 ) .AND. ( INCY.EQ.1 ) ) THEN
42118            DO 100 J = 1, N
42119               TEMP1 = ALPHA*X( J )
42120               TEMP2 = ZERO
42121               Y( J ) = Y( J ) + TEMP1*A( J, J )
42122               DO 90 I = J + 1, N
42123                  Y( I ) = Y( I ) + TEMP1*A( I, J )
42124                  TEMP2 = TEMP2 + A( I, J )*X( I )
42125   90          CONTINUE
42126               Y( J ) = Y( J ) + ALPHA*TEMP2
42127  100       CONTINUE
42128         ELSE
42129            JX = KX
42130            JY = KY
42131            DO 120 J = 1, N
42132               TEMP1 = ALPHA*X( JX )
42133               TEMP2 = ZERO
42134               Y( JY ) = Y( JY ) + TEMP1*A( J, J )
42135               IX = JX
42136               IY = JY
42137               DO 110 I = J + 1, N
42138                  IX = IX + INCX
42139                  IY = IY + INCY
42140                  Y( IY ) = Y( IY ) + TEMP1*A( I, J )
42141                  TEMP2 = TEMP2 + A( I, J )*X( IX )
42142  110          CONTINUE
42143               Y( JY ) = Y( JY ) + ALPHA*TEMP2
42144               JX = JX + INCX
42145               JY = JY + INCY
42146  120       CONTINUE
42147         END IF
42148      END IF
42149*
42150      RETURN
42151*
42152*     End of ZSYMV
42153*
42154      END
42155*> \brief \b ZSYR performs the symmetric rank-1 update of a complex symmetric matrix.
42156*
42157*  =========== DOCUMENTATION ===========
42158*
42159* Online html documentation available at
42160*            http://www.netlib.org/lapack/explore-html/
42161*
42162*> \htmlonly
42163*> Download ZSYR + dependencies
42164*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zsyr.f">
42165*> [TGZ]</a>
42166*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zsyr.f">
42167*> [ZIP]</a>
42168*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zsyr.f">
42169*> [TXT]</a>
42170*> \endhtmlonly
42171*
42172*  Definition:
42173*  ===========
42174*
42175*       SUBROUTINE ZSYR( UPLO, N, ALPHA, X, INCX, A, LDA )
42176*
42177*       .. Scalar Arguments ..
42178*       CHARACTER          UPLO
42179*       INTEGER            INCX, LDA, N
42180*       COMPLEX*16         ALPHA
42181*       ..
42182*       .. Array Arguments ..
42183*       COMPLEX*16         A( LDA, * ), X( * )
42184*       ..
42185*
42186*
42187*> \par Purpose:
42188*  =============
42189*>
42190*> \verbatim
42191*>
42192*> ZSYR   performs the symmetric rank 1 operation
42193*>
42194*>    A := alpha*x*x**H + A,
42195*>
42196*> where alpha is a complex scalar, x is an n element vector and A is an
42197*> n by n symmetric matrix.
42198*> \endverbatim
42199*
42200*  Arguments:
42201*  ==========
42202*
42203*> \param[in] UPLO
42204*> \verbatim
42205*>          UPLO is CHARACTER*1
42206*>           On entry, UPLO specifies whether the upper or lower
42207*>           triangular part of the array A is to be referenced as
42208*>           follows:
42209*>
42210*>              UPLO = 'U' or 'u'   Only the upper triangular part of A
42211*>                                  is to be referenced.
42212*>
42213*>              UPLO = 'L' or 'l'   Only the lower triangular part of A
42214*>                                  is to be referenced.
42215*>
42216*>           Unchanged on exit.
42217*> \endverbatim
42218*>
42219*> \param[in] N
42220*> \verbatim
42221*>          N is INTEGER
42222*>           On entry, N specifies the order of the matrix A.
42223*>           N must be at least zero.
42224*>           Unchanged on exit.
42225*> \endverbatim
42226*>
42227*> \param[in] ALPHA
42228*> \verbatim
42229*>          ALPHA is COMPLEX*16
42230*>           On entry, ALPHA specifies the scalar alpha.
42231*>           Unchanged on exit.
42232*> \endverbatim
42233*>
42234*> \param[in] X
42235*> \verbatim
42236*>          X is COMPLEX*16 array, dimension at least
42237*>           ( 1 + ( N - 1 )*abs( INCX ) ).
42238*>           Before entry, the incremented array X must contain the N-
42239*>           element vector x.
42240*>           Unchanged on exit.
42241*> \endverbatim
42242*>
42243*> \param[in] INCX
42244*> \verbatim
42245*>          INCX is INTEGER
42246*>           On entry, INCX specifies the increment for the elements of
42247*>           X. INCX must not be zero.
42248*>           Unchanged on exit.
42249*> \endverbatim
42250*>
42251*> \param[in,out] A
42252*> \verbatim
42253*>          A is COMPLEX*16 array, dimension ( LDA, N )
42254*>           Before entry, with  UPLO = 'U' or 'u', the leading n by n
42255*>           upper triangular part of the array A must contain the upper
42256*>           triangular part of the symmetric matrix and the strictly
42257*>           lower triangular part of A is not referenced. On exit, the
42258*>           upper triangular part of the array A is overwritten by the
42259*>           upper triangular part of the updated matrix.
42260*>           Before entry, with UPLO = 'L' or 'l', the leading n by n
42261*>           lower triangular part of the array A must contain the lower
42262*>           triangular part of the symmetric matrix and the strictly
42263*>           upper triangular part of A is not referenced. On exit, the
42264*>           lower triangular part of the array A is overwritten by the
42265*>           lower triangular part of the updated matrix.
42266*> \endverbatim
42267*>
42268*> \param[in] LDA
42269*> \verbatim
42270*>          LDA is INTEGER
42271*>           On entry, LDA specifies the first dimension of A as declared
42272*>           in the calling (sub) program. LDA must be at least
42273*>           max( 1, N ).
42274*>           Unchanged on exit.
42275*> \endverbatim
42276*
42277*  Authors:
42278*  ========
42279*
42280*> \author Univ. of Tennessee
42281*> \author Univ. of California Berkeley
42282*> \author Univ. of Colorado Denver
42283*> \author NAG Ltd.
42284*
42285*> \date December 2016
42286*
42287*> \ingroup complex16SYauxiliary
42288*
42289*  =====================================================================
42290      SUBROUTINE ZSYR( UPLO, N, ALPHA, X, INCX, A, LDA )
42291*
42292*  -- LAPACK auxiliary routine (version 3.7.0) --
42293*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
42294*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
42295*     December 2016
42296*
42297*     .. Scalar Arguments ..
42298      CHARACTER          UPLO
42299      INTEGER            INCX, LDA, N
42300      COMPLEX*16         ALPHA
42301*     ..
42302*     .. Array Arguments ..
42303      COMPLEX*16         A( LDA, * ), X( * )
42304*     ..
42305*
42306* =====================================================================
42307*
42308*     .. Parameters ..
42309      COMPLEX*16         ZERO
42310      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ) )
42311*     ..
42312*     .. Local Scalars ..
42313      INTEGER            I, INFO, IX, J, JX, KX
42314      COMPLEX*16         TEMP
42315*     ..
42316*     .. External Functions ..
42317      LOGICAL            LSAME
42318      EXTERNAL           LSAME
42319*     ..
42320*     .. External Subroutines ..
42321      EXTERNAL           XERBLA
42322*     ..
42323*     .. Intrinsic Functions ..
42324      INTRINSIC          MAX
42325*     ..
42326*     .. Executable Statements ..
42327*
42328*     Test the input parameters.
42329*
42330      INFO = 0
42331      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
42332         INFO = 1
42333      ELSE IF( N.LT.0 ) THEN
42334         INFO = 2
42335      ELSE IF( INCX.EQ.0 ) THEN
42336         INFO = 5
42337      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
42338         INFO = 7
42339      END IF
42340      IF( INFO.NE.0 ) THEN
42341         CALL XERBLA( 'ZSYR  ', INFO )
42342         RETURN
42343      END IF
42344*
42345*     Quick return if possible.
42346*
42347      IF( ( N.EQ.0 ) .OR. ( ALPHA.EQ.ZERO ) )
42348     $   RETURN
42349*
42350*     Set the start point in X if the increment is not unity.
42351*
42352      IF( INCX.LE.0 ) THEN
42353         KX = 1 - ( N-1 )*INCX
42354      ELSE IF( INCX.NE.1 ) THEN
42355         KX = 1
42356      END IF
42357*
42358*     Start the operations. In this version the elements of A are
42359*     accessed sequentially with one pass through the triangular part
42360*     of A.
42361*
42362      IF( LSAME( UPLO, 'U' ) ) THEN
42363*
42364*        Form  A  when A is stored in upper triangle.
42365*
42366         IF( INCX.EQ.1 ) THEN
42367            DO 20 J = 1, N
42368               IF( X( J ).NE.ZERO ) THEN
42369                  TEMP = ALPHA*X( J )
42370                  DO 10 I = 1, J
42371                     A( I, J ) = A( I, J ) + X( I )*TEMP
42372   10             CONTINUE
42373               END IF
42374   20       CONTINUE
42375         ELSE
42376            JX = KX
42377            DO 40 J = 1, N
42378               IF( X( JX ).NE.ZERO ) THEN
42379                  TEMP = ALPHA*X( JX )
42380                  IX = KX
42381                  DO 30 I = 1, J
42382                     A( I, J ) = A( I, J ) + X( IX )*TEMP
42383                     IX = IX + INCX
42384   30             CONTINUE
42385               END IF
42386               JX = JX + INCX
42387   40       CONTINUE
42388         END IF
42389      ELSE
42390*
42391*        Form  A  when A is stored in lower triangle.
42392*
42393         IF( INCX.EQ.1 ) THEN
42394            DO 60 J = 1, N
42395               IF( X( J ).NE.ZERO ) THEN
42396                  TEMP = ALPHA*X( J )
42397                  DO 50 I = J, N
42398                     A( I, J ) = A( I, J ) + X( I )*TEMP
42399   50             CONTINUE
42400               END IF
42401   60       CONTINUE
42402         ELSE
42403            JX = KX
42404            DO 80 J = 1, N
42405               IF( X( JX ).NE.ZERO ) THEN
42406                  TEMP = ALPHA*X( JX )
42407                  IX = JX
42408                  DO 70 I = J, N
42409                     A( I, J ) = A( I, J ) + X( IX )*TEMP
42410                     IX = IX + INCX
42411   70             CONTINUE
42412               END IF
42413               JX = JX + INCX
42414   80       CONTINUE
42415         END IF
42416      END IF
42417*
42418      RETURN
42419*
42420*     End of ZSYR
42421*
42422      END
42423*> \brief \b ZSYTF2 computes the factorization of a real symmetric indefinite matrix, using the diagonal pivoting method (unblocked algorithm).
42424*
42425*  =========== DOCUMENTATION ===========
42426*
42427* Online html documentation available at
42428*            http://www.netlib.org/lapack/explore-html/
42429*
42430*> \htmlonly
42431*> Download ZSYTF2 + dependencies
42432*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zsytf2.f">
42433*> [TGZ]</a>
42434*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zsytf2.f">
42435*> [ZIP]</a>
42436*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zsytf2.f">
42437*> [TXT]</a>
42438*> \endhtmlonly
42439*
42440*  Definition:
42441*  ===========
42442*
42443*       SUBROUTINE ZSYTF2( UPLO, N, A, LDA, IPIV, INFO )
42444*
42445*       .. Scalar Arguments ..
42446*       CHARACTER          UPLO
42447*       INTEGER            INFO, LDA, N
42448*       ..
42449*       .. Array Arguments ..
42450*       INTEGER            IPIV( * )
42451*       COMPLEX*16         A( LDA, * )
42452*       ..
42453*
42454*
42455*> \par Purpose:
42456*  =============
42457*>
42458*> \verbatim
42459*>
42460*> ZSYTF2 computes the factorization of a complex symmetric matrix A
42461*> using the Bunch-Kaufman diagonal pivoting method:
42462*>
42463*>    A = U*D*U**T  or  A = L*D*L**T
42464*>
42465*> where U (or L) is a product of permutation and unit upper (lower)
42466*> triangular matrices, U**T is the transpose of U, and D is symmetric and
42467*> block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
42468*>
42469*> This is the unblocked version of the algorithm, calling Level 2 BLAS.
42470*> \endverbatim
42471*
42472*  Arguments:
42473*  ==========
42474*
42475*> \param[in] UPLO
42476*> \verbatim
42477*>          UPLO is CHARACTER*1
42478*>          Specifies whether the upper or lower triangular part of the
42479*>          symmetric matrix A is stored:
42480*>          = 'U':  Upper triangular
42481*>          = 'L':  Lower triangular
42482*> \endverbatim
42483*>
42484*> \param[in] N
42485*> \verbatim
42486*>          N is INTEGER
42487*>          The order of the matrix A.  N >= 0.
42488*> \endverbatim
42489*>
42490*> \param[in,out] A
42491*> \verbatim
42492*>          A is COMPLEX*16 array, dimension (LDA,N)
42493*>          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
42494*>          n-by-n upper triangular part of A contains the upper
42495*>          triangular part of the matrix A, and the strictly lower
42496*>          triangular part of A is not referenced.  If UPLO = 'L', the
42497*>          leading n-by-n lower triangular part of A contains the lower
42498*>          triangular part of the matrix A, and the strictly upper
42499*>          triangular part of A is not referenced.
42500*>
42501*>          On exit, the block diagonal matrix D and the multipliers used
42502*>          to obtain the factor U or L (see below for further details).
42503*> \endverbatim
42504*>
42505*> \param[in] LDA
42506*> \verbatim
42507*>          LDA is INTEGER
42508*>          The leading dimension of the array A.  LDA >= max(1,N).
42509*> \endverbatim
42510*>
42511*> \param[out] IPIV
42512*> \verbatim
42513*>          IPIV is INTEGER array, dimension (N)
42514*>          Details of the interchanges and the block structure of D.
42515*>
42516*>          If UPLO = 'U':
42517*>             If IPIV(k) > 0, then rows and columns k and IPIV(k) were
42518*>             interchanged and D(k,k) is a 1-by-1 diagonal block.
42519*>
42520*>             If IPIV(k) = IPIV(k-1) < 0, then rows and columns
42521*>             k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
42522*>             is a 2-by-2 diagonal block.
42523*>
42524*>          If UPLO = 'L':
42525*>             If IPIV(k) > 0, then rows and columns k and IPIV(k) were
42526*>             interchanged and D(k,k) is a 1-by-1 diagonal block.
42527*>
42528*>             If IPIV(k) = IPIV(k+1) < 0, then rows and columns
42529*>             k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1)
42530*>             is a 2-by-2 diagonal block.
42531*> \endverbatim
42532*>
42533*> \param[out] INFO
42534*> \verbatim
42535*>          INFO is INTEGER
42536*>          = 0: successful exit
42537*>          < 0: if INFO = -k, the k-th argument had an illegal value
42538*>          > 0: if INFO = k, D(k,k) is exactly zero.  The factorization
42539*>               has been completed, but the block diagonal matrix D is
42540*>               exactly singular, and division by zero will occur if it
42541*>               is used to solve a system of equations.
42542*> \endverbatim
42543*
42544*  Authors:
42545*  ========
42546*
42547*> \author Univ. of Tennessee
42548*> \author Univ. of California Berkeley
42549*> \author Univ. of Colorado Denver
42550*> \author NAG Ltd.
42551*
42552*> \date December 2016
42553*
42554*> \ingroup complex16SYcomputational
42555*
42556*> \par Further Details:
42557*  =====================
42558*>
42559*> \verbatim
42560*>
42561*>  If UPLO = 'U', then A = U*D*U**T, where
42562*>     U = P(n)*U(n)* ... *P(k)U(k)* ...,
42563*>  i.e., U is a product of terms P(k)*U(k), where k decreases from n to
42564*>  1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
42565*>  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as
42566*>  defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
42567*>  that if the diagonal block D(k) is of order s (s = 1 or 2), then
42568*>
42569*>             (   I    v    0   )   k-s
42570*>     U(k) =  (   0    I    0   )   s
42571*>             (   0    0    I   )   n-k
42572*>                k-s   s   n-k
42573*>
42574*>  If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
42575*>  If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
42576*>  and A(k,k), and v overwrites A(1:k-2,k-1:k).
42577*>
42578*>  If UPLO = 'L', then A = L*D*L**T, where
42579*>     L = P(1)*L(1)* ... *P(k)*L(k)* ...,
42580*>  i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
42581*>  n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
42582*>  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as
42583*>  defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
42584*>  that if the diagonal block D(k) is of order s (s = 1 or 2), then
42585*>
42586*>             (   I    0     0   )  k-1
42587*>     L(k) =  (   0    I     0   )  s
42588*>             (   0    v     I   )  n-k-s+1
42589*>                k-1   s  n-k-s+1
42590*>
42591*>  If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
42592*>  If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
42593*>  and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
42594*> \endverbatim
42595*
42596*> \par Contributors:
42597*  ==================
42598*>
42599*> \verbatim
42600*>
42601*>  09-29-06 - patch from
42602*>    Bobby Cheng, MathWorks
42603*>
42604*>    Replace l.209 and l.377
42605*>         IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
42606*>    by
42607*>         IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN
42608*>
42609*>  1-96 - Based on modifications by J. Lewis, Boeing Computer Services
42610*>         Company
42611*> \endverbatim
42612*
42613*  =====================================================================
42614      SUBROUTINE ZSYTF2( UPLO, N, A, LDA, IPIV, INFO )
42615*
42616*  -- LAPACK computational routine (version 3.7.0) --
42617*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
42618*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
42619*     December 2016
42620*
42621*     .. Scalar Arguments ..
42622      CHARACTER          UPLO
42623      INTEGER            INFO, LDA, N
42624*     ..
42625*     .. Array Arguments ..
42626      INTEGER            IPIV( * )
42627      COMPLEX*16         A( LDA, * )
42628*     ..
42629*
42630*  =====================================================================
42631*
42632*     .. Parameters ..
42633      DOUBLE PRECISION   ZERO, ONE
42634      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
42635      DOUBLE PRECISION   EIGHT, SEVTEN
42636      PARAMETER          ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
42637      COMPLEX*16         CONE
42638      PARAMETER          ( CONE = ( 1.0D+0, 0.0D+0 ) )
42639*     ..
42640*     .. Local Scalars ..
42641      LOGICAL            UPPER
42642      INTEGER            I, IMAX, J, JMAX, K, KK, KP, KSTEP
42643      DOUBLE PRECISION   ABSAKK, ALPHA, COLMAX, ROWMAX
42644      COMPLEX*16         D11, D12, D21, D22, R1, T, WK, WKM1, WKP1, Z
42645*     ..
42646*     .. External Functions ..
42647      LOGICAL            DISNAN, LSAME
42648      INTEGER            IZAMAX
42649      EXTERNAL           DISNAN, LSAME, IZAMAX
42650*     ..
42651*     .. External Subroutines ..
42652      EXTERNAL           XERBLA, ZSCAL, ZSWAP, ZSYR
42653*     ..
42654*     .. Intrinsic Functions ..
42655      INTRINSIC          ABS, DBLE, DIMAG, MAX, SQRT
42656*     ..
42657*     .. Statement Functions ..
42658      DOUBLE PRECISION   CABS1
42659*     ..
42660*     .. Statement Function definitions ..
42661      CABS1( Z ) = ABS( DBLE( Z ) ) + ABS( DIMAG( Z ) )
42662*     ..
42663*     .. Executable Statements ..
42664*
42665*     Test the input parameters.
42666*
42667      INFO = 0
42668      UPPER = LSAME( UPLO, 'U' )
42669      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
42670         INFO = -1
42671      ELSE IF( N.LT.0 ) THEN
42672         INFO = -2
42673      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
42674         INFO = -4
42675      END IF
42676      IF( INFO.NE.0 ) THEN
42677         CALL XERBLA( 'ZSYTF2', -INFO )
42678         RETURN
42679      END IF
42680*
42681*     Initialize ALPHA for use in choosing pivot block size.
42682*
42683      ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
42684*
42685      IF( UPPER ) THEN
42686*
42687*        Factorize A as U*D*U**T using the upper triangle of A
42688*
42689*        K is the main loop index, decreasing from N to 1 in steps of
42690*        1 or 2
42691*
42692         K = N
42693   10    CONTINUE
42694*
42695*        If K < 1, exit from loop
42696*
42697         IF( K.LT.1 )
42698     $      GO TO 70
42699         KSTEP = 1
42700*
42701*        Determine rows and columns to be interchanged and whether
42702*        a 1-by-1 or 2-by-2 pivot block will be used
42703*
42704         ABSAKK = CABS1( A( K, K ) )
42705*
42706*        IMAX is the row-index of the largest off-diagonal element in
42707*        column K, and COLMAX is its absolute value.
42708*        Determine both COLMAX and IMAX.
42709*
42710         IF( K.GT.1 ) THEN
42711            IMAX = IZAMAX( K-1, A( 1, K ), 1 )
42712            COLMAX = CABS1( A( IMAX, K ) )
42713         ELSE
42714            COLMAX = ZERO
42715         END IF
42716*
42717         IF( MAX( ABSAKK, COLMAX ).EQ.ZERO .OR. DISNAN(ABSAKK) ) THEN
42718*
42719*           Column K is zero or underflow, or contains a NaN:
42720*           set INFO and continue
42721*
42722            IF( INFO.EQ.0 )
42723     $         INFO = K
42724            KP = K
42725         ELSE
42726            IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
42727*
42728*              no interchange, use 1-by-1 pivot block
42729*
42730               KP = K
42731            ELSE
42732*
42733*              JMAX is the column-index of the largest off-diagonal
42734*              element in row IMAX, and ROWMAX is its absolute value
42735*
42736               JMAX = IMAX + IZAMAX( K-IMAX, A( IMAX, IMAX+1 ), LDA )
42737               ROWMAX = CABS1( A( IMAX, JMAX ) )
42738               IF( IMAX.GT.1 ) THEN
42739                  JMAX = IZAMAX( IMAX-1, A( 1, IMAX ), 1 )
42740                  ROWMAX = MAX( ROWMAX, CABS1( A( JMAX, IMAX ) ) )
42741               END IF
42742*
42743               IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
42744*
42745*                 no interchange, use 1-by-1 pivot block
42746*
42747                  KP = K
42748               ELSE IF( CABS1( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX ) THEN
42749*
42750*                 interchange rows and columns K and IMAX, use 1-by-1
42751*                 pivot block
42752*
42753                  KP = IMAX
42754               ELSE
42755*
42756*                 interchange rows and columns K-1 and IMAX, use 2-by-2
42757*                 pivot block
42758*
42759                  KP = IMAX
42760                  KSTEP = 2
42761               END IF
42762            END IF
42763*
42764            KK = K - KSTEP + 1
42765            IF( KP.NE.KK ) THEN
42766*
42767*              Interchange rows and columns KK and KP in the leading
42768*              submatrix A(1:k,1:k)
42769*
42770               CALL ZSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
42771               CALL ZSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ),
42772     $                     LDA )
42773               T = A( KK, KK )
42774               A( KK, KK ) = A( KP, KP )
42775               A( KP, KP ) = T
42776               IF( KSTEP.EQ.2 ) THEN
42777                  T = A( K-1, K )
42778                  A( K-1, K ) = A( KP, K )
42779                  A( KP, K ) = T
42780               END IF
42781            END IF
42782*
42783*           Update the leading submatrix
42784*
42785            IF( KSTEP.EQ.1 ) THEN
42786*
42787*              1-by-1 pivot block D(k): column k now holds
42788*
42789*              W(k) = U(k)*D(k)
42790*
42791*              where U(k) is the k-th column of U
42792*
42793*              Perform a rank-1 update of A(1:k-1,1:k-1) as
42794*
42795*              A := A - U(k)*D(k)*U(k)**T = A - W(k)*1/D(k)*W(k)**T
42796*
42797               R1 = CONE / A( K, K )
42798               CALL ZSYR( UPLO, K-1, -R1, A( 1, K ), 1, A, LDA )
42799*
42800*              Store U(k) in column k
42801*
42802               CALL ZSCAL( K-1, R1, A( 1, K ), 1 )
42803            ELSE
42804*
42805*              2-by-2 pivot block D(k): columns k and k-1 now hold
42806*
42807*              ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
42808*
42809*              where U(k) and U(k-1) are the k-th and (k-1)-th columns
42810*              of U
42811*
42812*              Perform a rank-2 update of A(1:k-2,1:k-2) as
42813*
42814*              A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T
42815*                 = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )**T
42816*
42817               IF( K.GT.2 ) THEN
42818*
42819                  D12 = A( K-1, K )
42820                  D22 = A( K-1, K-1 ) / D12
42821                  D11 = A( K, K ) / D12
42822                  T = CONE / ( D11*D22-CONE )
42823                  D12 = T / D12
42824*
42825                  DO 30 J = K - 2, 1, -1
42826                     WKM1 = D12*( D11*A( J, K-1 )-A( J, K ) )
42827                     WK = D12*( D22*A( J, K )-A( J, K-1 ) )
42828                     DO 20 I = J, 1, -1
42829                        A( I, J ) = A( I, J ) - A( I, K )*WK -
42830     $                              A( I, K-1 )*WKM1
42831   20                CONTINUE
42832                     A( J, K ) = WK
42833                     A( J, K-1 ) = WKM1
42834   30             CONTINUE
42835*
42836               END IF
42837*
42838            END IF
42839         END IF
42840*
42841*        Store details of the interchanges in IPIV
42842*
42843         IF( KSTEP.EQ.1 ) THEN
42844            IPIV( K ) = KP
42845         ELSE
42846            IPIV( K ) = -KP
42847            IPIV( K-1 ) = -KP
42848         END IF
42849*
42850*        Decrease K and return to the start of the main loop
42851*
42852         K = K - KSTEP
42853         GO TO 10
42854*
42855      ELSE
42856*
42857*        Factorize A as L*D*L**T using the lower triangle of A
42858*
42859*        K is the main loop index, increasing from 1 to N in steps of
42860*        1 or 2
42861*
42862         K = 1
42863   40    CONTINUE
42864*
42865*        If K > N, exit from loop
42866*
42867         IF( K.GT.N )
42868     $      GO TO 70
42869         KSTEP = 1
42870*
42871*        Determine rows and columns to be interchanged and whether
42872*        a 1-by-1 or 2-by-2 pivot block will be used
42873*
42874         ABSAKK = CABS1( A( K, K ) )
42875*
42876*        IMAX is the row-index of the largest off-diagonal element in
42877*        column K, and COLMAX is its absolute value.
42878*        Determine both COLMAX and IMAX.
42879*
42880         IF( K.LT.N ) THEN
42881            IMAX = K + IZAMAX( N-K, A( K+1, K ), 1 )
42882            COLMAX = CABS1( A( IMAX, K ) )
42883         ELSE
42884            COLMAX = ZERO
42885         END IF
42886*
42887         IF( MAX( ABSAKK, COLMAX ).EQ.ZERO .OR. DISNAN(ABSAKK) ) THEN
42888*
42889*           Column K is zero or underflow, or contains a NaN:
42890*           set INFO and continue
42891*
42892            IF( INFO.EQ.0 )
42893     $         INFO = K
42894            KP = K
42895         ELSE
42896            IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
42897*
42898*              no interchange, use 1-by-1 pivot block
42899*
42900               KP = K
42901            ELSE
42902*
42903*              JMAX is the column-index of the largest off-diagonal
42904*              element in row IMAX, and ROWMAX is its absolute value
42905*
42906               JMAX = K - 1 + IZAMAX( IMAX-K, A( IMAX, K ), LDA )
42907               ROWMAX = CABS1( A( IMAX, JMAX ) )
42908               IF( IMAX.LT.N ) THEN
42909                  JMAX = IMAX + IZAMAX( N-IMAX, A( IMAX+1, IMAX ), 1 )
42910                  ROWMAX = MAX( ROWMAX, CABS1( A( JMAX, IMAX ) ) )
42911               END IF
42912*
42913               IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
42914*
42915*                 no interchange, use 1-by-1 pivot block
42916*
42917                  KP = K
42918               ELSE IF( CABS1( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX ) THEN
42919*
42920*                 interchange rows and columns K and IMAX, use 1-by-1
42921*                 pivot block
42922*
42923                  KP = IMAX
42924               ELSE
42925*
42926*                 interchange rows and columns K+1 and IMAX, use 2-by-2
42927*                 pivot block
42928*
42929                  KP = IMAX
42930                  KSTEP = 2
42931               END IF
42932            END IF
42933*
42934            KK = K + KSTEP - 1
42935            IF( KP.NE.KK ) THEN
42936*
42937*              Interchange rows and columns KK and KP in the trailing
42938*              submatrix A(k:n,k:n)
42939*
42940               IF( KP.LT.N )
42941     $            CALL ZSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
42942               CALL ZSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ),
42943     $                     LDA )
42944               T = A( KK, KK )
42945               A( KK, KK ) = A( KP, KP )
42946               A( KP, KP ) = T
42947               IF( KSTEP.EQ.2 ) THEN
42948                  T = A( K+1, K )
42949                  A( K+1, K ) = A( KP, K )
42950                  A( KP, K ) = T
42951               END IF
42952            END IF
42953*
42954*           Update the trailing submatrix
42955*
42956            IF( KSTEP.EQ.1 ) THEN
42957*
42958*              1-by-1 pivot block D(k): column k now holds
42959*
42960*              W(k) = L(k)*D(k)
42961*
42962*              where L(k) is the k-th column of L
42963*
42964               IF( K.LT.N ) THEN
42965*
42966*                 Perform a rank-1 update of A(k+1:n,k+1:n) as
42967*
42968*                 A := A - L(k)*D(k)*L(k)**T = A - W(k)*(1/D(k))*W(k)**T
42969*
42970                  R1 = CONE / A( K, K )
42971                  CALL ZSYR( UPLO, N-K, -R1, A( K+1, K ), 1,
42972     $                       A( K+1, K+1 ), LDA )
42973*
42974*                 Store L(k) in column K
42975*
42976                  CALL ZSCAL( N-K, R1, A( K+1, K ), 1 )
42977               END IF
42978            ELSE
42979*
42980*              2-by-2 pivot block D(k)
42981*
42982               IF( K.LT.N-1 ) THEN
42983*
42984*                 Perform a rank-2 update of A(k+2:n,k+2:n) as
42985*
42986*                 A := A - ( L(k) L(k+1) )*D(k)*( L(k) L(k+1) )**T
42987*                    = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )**T
42988*
42989*                 where L(k) and L(k+1) are the k-th and (k+1)-th
42990*                 columns of L
42991*
42992                  D21 = A( K+1, K )
42993                  D11 = A( K+1, K+1 ) / D21
42994                  D22 = A( K, K ) / D21
42995                  T = CONE / ( D11*D22-CONE )
42996                  D21 = T / D21
42997*
42998                  DO 60 J = K + 2, N
42999                     WK = D21*( D11*A( J, K )-A( J, K+1 ) )
43000                     WKP1 = D21*( D22*A( J, K+1 )-A( J, K ) )
43001                     DO 50 I = J, N
43002                        A( I, J ) = A( I, J ) - A( I, K )*WK -
43003     $                              A( I, K+1 )*WKP1
43004   50                CONTINUE
43005                     A( J, K ) = WK
43006                     A( J, K+1 ) = WKP1
43007   60             CONTINUE
43008               END IF
43009            END IF
43010         END IF
43011*
43012*        Store details of the interchanges in IPIV
43013*
43014         IF( KSTEP.EQ.1 ) THEN
43015            IPIV( K ) = KP
43016         ELSE
43017            IPIV( K ) = -KP
43018            IPIV( K+1 ) = -KP
43019         END IF
43020*
43021*        Increase K and return to the start of the main loop
43022*
43023         K = K + KSTEP
43024         GO TO 40
43025*
43026      END IF
43027*
43028   70 CONTINUE
43029      RETURN
43030*
43031*     End of ZSYTF2
43032*
43033      END
43034*> \brief \b ZSYTRF
43035*
43036*  =========== DOCUMENTATION ===========
43037*
43038* Online html documentation available at
43039*            http://www.netlib.org/lapack/explore-html/
43040*
43041*> \htmlonly
43042*> Download ZSYTRF + dependencies
43043*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zsytrf.f">
43044*> [TGZ]</a>
43045*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zsytrf.f">
43046*> [ZIP]</a>
43047*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zsytrf.f">
43048*> [TXT]</a>
43049*> \endhtmlonly
43050*
43051*  Definition:
43052*  ===========
43053*
43054*       SUBROUTINE ZSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
43055*
43056*       .. Scalar Arguments ..
43057*       CHARACTER          UPLO
43058*       INTEGER            INFO, LDA, LWORK, N
43059*       ..
43060*       .. Array Arguments ..
43061*       INTEGER            IPIV( * )
43062*       COMPLEX*16         A( LDA, * ), WORK( * )
43063*       ..
43064*
43065*
43066*> \par Purpose:
43067*  =============
43068*>
43069*> \verbatim
43070*>
43071*> ZSYTRF computes the factorization of a complex symmetric matrix A
43072*> using the Bunch-Kaufman diagonal pivoting method.  The form of the
43073*> factorization is
43074*>
43075*>    A = U*D*U**T  or  A = L*D*L**T
43076*>
43077*> where U (or L) is a product of permutation and unit upper (lower)
43078*> triangular matrices, and D is symmetric and block diagonal with
43079*> 1-by-1 and 2-by-2 diagonal blocks.
43080*>
43081*> This is the blocked version of the algorithm, calling Level 3 BLAS.
43082*> \endverbatim
43083*
43084*  Arguments:
43085*  ==========
43086*
43087*> \param[in] UPLO
43088*> \verbatim
43089*>          UPLO is CHARACTER*1
43090*>          = 'U':  Upper triangle of A is stored;
43091*>          = 'L':  Lower triangle of A is stored.
43092*> \endverbatim
43093*>
43094*> \param[in] N
43095*> \verbatim
43096*>          N is INTEGER
43097*>          The order of the matrix A.  N >= 0.
43098*> \endverbatim
43099*>
43100*> \param[in,out] A
43101*> \verbatim
43102*>          A is COMPLEX*16 array, dimension (LDA,N)
43103*>          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
43104*>          N-by-N upper triangular part of A contains the upper
43105*>          triangular part of the matrix A, and the strictly lower
43106*>          triangular part of A is not referenced.  If UPLO = 'L', the
43107*>          leading N-by-N lower triangular part of A contains the lower
43108*>          triangular part of the matrix A, and the strictly upper
43109*>          triangular part of A is not referenced.
43110*>
43111*>          On exit, the block diagonal matrix D and the multipliers used
43112*>          to obtain the factor U or L (see below for further details).
43113*> \endverbatim
43114*>
43115*> \param[in] LDA
43116*> \verbatim
43117*>          LDA is INTEGER
43118*>          The leading dimension of the array A.  LDA >= max(1,N).
43119*> \endverbatim
43120*>
43121*> \param[out] IPIV
43122*> \verbatim
43123*>          IPIV is INTEGER array, dimension (N)
43124*>          Details of the interchanges and the block structure of D.
43125*>          If IPIV(k) > 0, then rows and columns k and IPIV(k) were
43126*>          interchanged and D(k,k) is a 1-by-1 diagonal block.
43127*>          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
43128*>          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
43129*>          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =
43130*>          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
43131*>          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
43132*> \endverbatim
43133*>
43134*> \param[out] WORK
43135*> \verbatim
43136*>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
43137*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
43138*> \endverbatim
43139*>
43140*> \param[in] LWORK
43141*> \verbatim
43142*>          LWORK is INTEGER
43143*>          The length of WORK.  LWORK >=1.  For best performance
43144*>          LWORK >= N*NB, where NB is the block size returned by ILAENV.
43145*>
43146*>          If LWORK = -1, then a workspace query is assumed; the routine
43147*>          only calculates the optimal size of the WORK array, returns
43148*>          this value as the first entry of the WORK array, and no error
43149*>          message related to LWORK is issued by XERBLA.
43150*> \endverbatim
43151*>
43152*> \param[out] INFO
43153*> \verbatim
43154*>          INFO is INTEGER
43155*>          = 0:  successful exit
43156*>          < 0:  if INFO = -i, the i-th argument had an illegal value
43157*>          > 0:  if INFO = i, D(i,i) is exactly zero.  The factorization
43158*>                has been completed, but the block diagonal matrix D is
43159*>                exactly singular, and division by zero will occur if it
43160*>                is used to solve a system of equations.
43161*> \endverbatim
43162*
43163*  Authors:
43164*  ========
43165*
43166*> \author Univ. of Tennessee
43167*> \author Univ. of California Berkeley
43168*> \author Univ. of Colorado Denver
43169*> \author NAG Ltd.
43170*
43171*> \date December 2016
43172*
43173*> \ingroup complex16SYcomputational
43174*
43175*> \par Further Details:
43176*  =====================
43177*>
43178*> \verbatim
43179*>
43180*>  If UPLO = 'U', then A = U*D*U**T, where
43181*>     U = P(n)*U(n)* ... *P(k)U(k)* ...,
43182*>  i.e., U is a product of terms P(k)*U(k), where k decreases from n to
43183*>  1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
43184*>  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as
43185*>  defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
43186*>  that if the diagonal block D(k) is of order s (s = 1 or 2), then
43187*>
43188*>             (   I    v    0   )   k-s
43189*>     U(k) =  (   0    I    0   )   s
43190*>             (   0    0    I   )   n-k
43191*>                k-s   s   n-k
43192*>
43193*>  If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
43194*>  If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
43195*>  and A(k,k), and v overwrites A(1:k-2,k-1:k).
43196*>
43197*>  If UPLO = 'L', then A = L*D*L**T, where
43198*>     L = P(1)*L(1)* ... *P(k)*L(k)* ...,
43199*>  i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
43200*>  n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
43201*>  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as
43202*>  defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
43203*>  that if the diagonal block D(k) is of order s (s = 1 or 2), then
43204*>
43205*>             (   I    0     0   )  k-1
43206*>     L(k) =  (   0    I     0   )  s
43207*>             (   0    v     I   )  n-k-s+1
43208*>                k-1   s  n-k-s+1
43209*>
43210*>  If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
43211*>  If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
43212*>  and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
43213*> \endverbatim
43214*>
43215*  =====================================================================
43216      SUBROUTINE ZSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
43217*
43218*  -- LAPACK computational routine (version 3.7.0) --
43219*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
43220*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
43221*     December 2016
43222*
43223*     .. Scalar Arguments ..
43224      CHARACTER          UPLO
43225      INTEGER            INFO, LDA, LWORK, N
43226*     ..
43227*     .. Array Arguments ..
43228      INTEGER            IPIV( * )
43229      COMPLEX*16         A( LDA, * ), WORK( * )
43230*     ..
43231*
43232*  =====================================================================
43233*
43234*     .. Local Scalars ..
43235      LOGICAL            LQUERY, UPPER
43236      INTEGER            IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN
43237*     ..
43238*     .. External Functions ..
43239      LOGICAL            LSAME
43240      INTEGER            ILAENV
43241      EXTERNAL           LSAME, ILAENV
43242*     ..
43243*     .. External Subroutines ..
43244      EXTERNAL           XERBLA, ZLASYF, ZSYTF2
43245*     ..
43246*     .. Intrinsic Functions ..
43247      INTRINSIC          MAX
43248*     ..
43249*     .. Executable Statements ..
43250*
43251*     Test the input parameters.
43252*
43253      INFO = 0
43254      UPPER = LSAME( UPLO, 'U' )
43255      LQUERY = ( LWORK.EQ.-1 )
43256      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
43257         INFO = -1
43258      ELSE IF( N.LT.0 ) THEN
43259         INFO = -2
43260      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
43261         INFO = -4
43262      ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
43263         INFO = -7
43264      END IF
43265*
43266      IF( INFO.EQ.0 ) THEN
43267*
43268*        Determine the block size
43269*
43270         NB = ILAENV( 1, 'ZSYTRF', UPLO, N, -1, -1, -1 )
43271         LWKOPT = N*NB
43272         WORK( 1 ) = LWKOPT
43273      END IF
43274*
43275      IF( INFO.NE.0 ) THEN
43276         CALL XERBLA( 'ZSYTRF', -INFO )
43277         RETURN
43278      ELSE IF( LQUERY ) THEN
43279         RETURN
43280      END IF
43281*
43282      NBMIN = 2
43283      LDWORK = N
43284      IF( NB.GT.1 .AND. NB.LT.N ) THEN
43285         IWS = LDWORK*NB
43286         IF( LWORK.LT.IWS ) THEN
43287            NB = MAX( LWORK / LDWORK, 1 )
43288            NBMIN = MAX( 2, ILAENV( 2, 'ZSYTRF', UPLO, N, -1, -1, -1 ) )
43289         END IF
43290      ELSE
43291         IWS = 1
43292      END IF
43293      IF( NB.LT.NBMIN )
43294     $   NB = N
43295*
43296      IF( UPPER ) THEN
43297*
43298*        Factorize A as U*D*U**T using the upper triangle of A
43299*
43300*        K is the main loop index, decreasing from N to 1 in steps of
43301*        KB, where KB is the number of columns factorized by ZLASYF;
43302*        KB is either NB or NB-1, or K for the last block
43303*
43304         K = N
43305   10    CONTINUE
43306*
43307*        If K < 1, exit from loop
43308*
43309         IF( K.LT.1 )
43310     $      GO TO 40
43311*
43312         IF( K.GT.NB ) THEN
43313*
43314*           Factorize columns k-kb+1:k of A and use blocked code to
43315*           update columns 1:k-kb
43316*
43317            CALL ZLASYF( UPLO, K, NB, KB, A, LDA, IPIV, WORK, N, IINFO )
43318         ELSE
43319*
43320*           Use unblocked code to factorize columns 1:k of A
43321*
43322            CALL ZSYTF2( UPLO, K, A, LDA, IPIV, IINFO )
43323            KB = K
43324         END IF
43325*
43326*        Set INFO on the first occurrence of a zero pivot
43327*
43328         IF( INFO.EQ.0 .AND. IINFO.GT.0 )
43329     $      INFO = IINFO
43330*
43331*        Decrease K and return to the start of the main loop
43332*
43333         K = K - KB
43334         GO TO 10
43335*
43336      ELSE
43337*
43338*        Factorize A as L*D*L**T using the lower triangle of A
43339*
43340*        K is the main loop index, increasing from 1 to N in steps of
43341*        KB, where KB is the number of columns factorized by ZLASYF;
43342*        KB is either NB or NB-1, or N-K+1 for the last block
43343*
43344         K = 1
43345   20    CONTINUE
43346*
43347*        If K > N, exit from loop
43348*
43349         IF( K.GT.N )
43350     $      GO TO 40
43351*
43352         IF( K.LE.N-NB ) THEN
43353*
43354*           Factorize columns k:k+kb-1 of A and use blocked code to
43355*           update columns k+kb:n
43356*
43357            CALL ZLASYF( UPLO, N-K+1, NB, KB, A( K, K ), LDA, IPIV( K ),
43358     $                   WORK, N, IINFO )
43359         ELSE
43360*
43361*           Use unblocked code to factorize columns k:n of A
43362*
43363            CALL ZSYTF2( UPLO, N-K+1, A( K, K ), LDA, IPIV( K ), IINFO )
43364            KB = N - K + 1
43365         END IF
43366*
43367*        Set INFO on the first occurrence of a zero pivot
43368*
43369         IF( INFO.EQ.0 .AND. IINFO.GT.0 )
43370     $      INFO = IINFO + K - 1
43371*
43372*        Adjust IPIV
43373*
43374         DO 30 J = K, K + KB - 1
43375            IF( IPIV( J ).GT.0 ) THEN
43376               IPIV( J ) = IPIV( J ) + K - 1
43377            ELSE
43378               IPIV( J ) = IPIV( J ) - K + 1
43379            END IF
43380   30    CONTINUE
43381*
43382*        Increase K and return to the start of the main loop
43383*
43384         K = K + KB
43385         GO TO 20
43386*
43387      END IF
43388*
43389   40 CONTINUE
43390      WORK( 1 ) = LWKOPT
43391      RETURN
43392*
43393*     End of ZSYTRF
43394*
43395      END
43396*> \brief \b ZSYTRI
43397*
43398*  =========== DOCUMENTATION ===========
43399*
43400* Online html documentation available at
43401*            http://www.netlib.org/lapack/explore-html/
43402*
43403*> \htmlonly
43404*> Download ZSYTRI + dependencies
43405*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zsytri.f">
43406*> [TGZ]</a>
43407*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zsytri.f">
43408*> [ZIP]</a>
43409*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zsytri.f">
43410*> [TXT]</a>
43411*> \endhtmlonly
43412*
43413*  Definition:
43414*  ===========
43415*
43416*       SUBROUTINE ZSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO )
43417*
43418*       .. Scalar Arguments ..
43419*       CHARACTER          UPLO
43420*       INTEGER            INFO, LDA, N
43421*       ..
43422*       .. Array Arguments ..
43423*       INTEGER            IPIV( * )
43424*       COMPLEX*16         A( LDA, * ), WORK( * )
43425*       ..
43426*
43427*
43428*> \par Purpose:
43429*  =============
43430*>
43431*> \verbatim
43432*>
43433*> ZSYTRI computes the inverse of a complex symmetric indefinite matrix
43434*> A using the factorization A = U*D*U**T or A = L*D*L**T computed by
43435*> ZSYTRF.
43436*> \endverbatim
43437*
43438*  Arguments:
43439*  ==========
43440*
43441*> \param[in] UPLO
43442*> \verbatim
43443*>          UPLO is CHARACTER*1
43444*>          Specifies whether the details of the factorization are stored
43445*>          as an upper or lower triangular matrix.
43446*>          = 'U':  Upper triangular, form is A = U*D*U**T;
43447*>          = 'L':  Lower triangular, form is A = L*D*L**T.
43448*> \endverbatim
43449*>
43450*> \param[in] N
43451*> \verbatim
43452*>          N is INTEGER
43453*>          The order of the matrix A.  N >= 0.
43454*> \endverbatim
43455*>
43456*> \param[in,out] A
43457*> \verbatim
43458*>          A is COMPLEX*16 array, dimension (LDA,N)
43459*>          On entry, the block diagonal matrix D and the multipliers
43460*>          used to obtain the factor U or L as computed by ZSYTRF.
43461*>
43462*>          On exit, if INFO = 0, the (symmetric) inverse of the original
43463*>          matrix.  If UPLO = 'U', the upper triangular part of the
43464*>          inverse is formed and the part of A below the diagonal is not
43465*>          referenced; if UPLO = 'L' the lower triangular part of the
43466*>          inverse is formed and the part of A above the diagonal is
43467*>          not referenced.
43468*> \endverbatim
43469*>
43470*> \param[in] LDA
43471*> \verbatim
43472*>          LDA is INTEGER
43473*>          The leading dimension of the array A.  LDA >= max(1,N).
43474*> \endverbatim
43475*>
43476*> \param[in] IPIV
43477*> \verbatim
43478*>          IPIV is INTEGER array, dimension (N)
43479*>          Details of the interchanges and the block structure of D
43480*>          as determined by ZSYTRF.
43481*> \endverbatim
43482*>
43483*> \param[out] WORK
43484*> \verbatim
43485*>          WORK is COMPLEX*16 array, dimension (2*N)
43486*> \endverbatim
43487*>
43488*> \param[out] INFO
43489*> \verbatim
43490*>          INFO is INTEGER
43491*>          = 0: successful exit
43492*>          < 0: if INFO = -i, the i-th argument had an illegal value
43493*>          > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
43494*>               inverse could not be computed.
43495*> \endverbatim
43496*
43497*  Authors:
43498*  ========
43499*
43500*> \author Univ. of Tennessee
43501*> \author Univ. of California Berkeley
43502*> \author Univ. of Colorado Denver
43503*> \author NAG Ltd.
43504*
43505*> \date December 2016
43506*
43507*> \ingroup complex16SYcomputational
43508*
43509*  =====================================================================
43510      SUBROUTINE ZSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO )
43511*
43512*  -- LAPACK computational routine (version 3.7.0) --
43513*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
43514*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
43515*     December 2016
43516*
43517*     .. Scalar Arguments ..
43518      CHARACTER          UPLO
43519      INTEGER            INFO, LDA, N
43520*     ..
43521*     .. Array Arguments ..
43522      INTEGER            IPIV( * )
43523      COMPLEX*16         A( LDA, * ), WORK( * )
43524*     ..
43525*
43526*  =====================================================================
43527*
43528*     .. Parameters ..
43529      COMPLEX*16         ONE, ZERO
43530      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),
43531     $                   ZERO = ( 0.0D+0, 0.0D+0 ) )
43532*     ..
43533*     .. Local Scalars ..
43534      LOGICAL            UPPER
43535      INTEGER            K, KP, KSTEP
43536      COMPLEX*16         AK, AKKP1, AKP1, D, T, TEMP
43537*     ..
43538*     .. External Functions ..
43539      LOGICAL            LSAME
43540      COMPLEX*16         ZDOTU
43541      EXTERNAL           LSAME, ZDOTU
43542*     ..
43543*     .. External Subroutines ..
43544      EXTERNAL           XERBLA, ZCOPY, ZSWAP, ZSYMV
43545*     ..
43546*     .. Intrinsic Functions ..
43547      INTRINSIC          ABS, MAX
43548*     ..
43549*     .. Executable Statements ..
43550*
43551*     Test the input parameters.
43552*
43553      INFO = 0
43554      UPPER = LSAME( UPLO, 'U' )
43555      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
43556         INFO = -1
43557      ELSE IF( N.LT.0 ) THEN
43558         INFO = -2
43559      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
43560         INFO = -4
43561      END IF
43562      IF( INFO.NE.0 ) THEN
43563         CALL XERBLA( 'ZSYTRI', -INFO )
43564         RETURN
43565      END IF
43566*
43567*     Quick return if possible
43568*
43569      IF( N.EQ.0 )
43570     $   RETURN
43571*
43572*     Check that the diagonal matrix D is nonsingular.
43573*
43574      IF( UPPER ) THEN
43575*
43576*        Upper triangular storage: examine D from bottom to top
43577*
43578         DO 10 INFO = N, 1, -1
43579            IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO )
43580     $         RETURN
43581   10    CONTINUE
43582      ELSE
43583*
43584*        Lower triangular storage: examine D from top to bottom.
43585*
43586         DO 20 INFO = 1, N
43587            IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO )
43588     $         RETURN
43589   20    CONTINUE
43590      END IF
43591      INFO = 0
43592*
43593      IF( UPPER ) THEN
43594*
43595*        Compute inv(A) from the factorization A = U*D*U**T.
43596*
43597*        K is the main loop index, increasing from 1 to N in steps of
43598*        1 or 2, depending on the size of the diagonal blocks.
43599*
43600         K = 1
43601   30    CONTINUE
43602*
43603*        If K > N, exit from loop.
43604*
43605         IF( K.GT.N )
43606     $      GO TO 40
43607*
43608         IF( IPIV( K ).GT.0 ) THEN
43609*
43610*           1 x 1 diagonal block
43611*
43612*           Invert the diagonal block.
43613*
43614            A( K, K ) = ONE / A( K, K )
43615*
43616*           Compute column K of the inverse.
43617*
43618            IF( K.GT.1 ) THEN
43619               CALL ZCOPY( K-1, A( 1, K ), 1, WORK, 1 )
43620               CALL ZSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
43621     $                     A( 1, K ), 1 )
43622               A( K, K ) = A( K, K ) - ZDOTU( K-1, WORK, 1, A( 1, K ),
43623     $                     1 )
43624            END IF
43625            KSTEP = 1
43626         ELSE
43627*
43628*           2 x 2 diagonal block
43629*
43630*           Invert the diagonal block.
43631*
43632            T = A( K, K+1 )
43633            AK = A( K, K ) / T
43634            AKP1 = A( K+1, K+1 ) / T
43635            AKKP1 = A( K, K+1 ) / T
43636            D = T*( AK*AKP1-ONE )
43637            A( K, K ) = AKP1 / D
43638            A( K+1, K+1 ) = AK / D
43639            A( K, K+1 ) = -AKKP1 / D
43640*
43641*           Compute columns K and K+1 of the inverse.
43642*
43643            IF( K.GT.1 ) THEN
43644               CALL ZCOPY( K-1, A( 1, K ), 1, WORK, 1 )
43645               CALL ZSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
43646     $                     A( 1, K ), 1 )
43647               A( K, K ) = A( K, K ) - ZDOTU( K-1, WORK, 1, A( 1, K ),
43648     $                     1 )
43649               A( K, K+1 ) = A( K, K+1 ) -
43650     $                       ZDOTU( K-1, A( 1, K ), 1, A( 1, K+1 ), 1 )
43651               CALL ZCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 )
43652               CALL ZSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
43653     $                     A( 1, K+1 ), 1 )
43654               A( K+1, K+1 ) = A( K+1, K+1 ) -
43655     $                         ZDOTU( K-1, WORK, 1, A( 1, K+1 ), 1 )
43656            END IF
43657            KSTEP = 2
43658         END IF
43659*
43660         KP = ABS( IPIV( K ) )
43661         IF( KP.NE.K ) THEN
43662*
43663*           Interchange rows and columns K and KP in the leading
43664*           submatrix A(1:k+1,1:k+1)
43665*
43666            CALL ZSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
43667            CALL ZSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA )
43668            TEMP = A( K, K )
43669            A( K, K ) = A( KP, KP )
43670            A( KP, KP ) = TEMP
43671            IF( KSTEP.EQ.2 ) THEN
43672               TEMP = A( K, K+1 )
43673               A( K, K+1 ) = A( KP, K+1 )
43674               A( KP, K+1 ) = TEMP
43675            END IF
43676         END IF
43677*
43678         K = K + KSTEP
43679         GO TO 30
43680   40    CONTINUE
43681*
43682      ELSE
43683*
43684*        Compute inv(A) from the factorization A = L*D*L**T.
43685*
43686*        K is the main loop index, increasing from 1 to N in steps of
43687*        1 or 2, depending on the size of the diagonal blocks.
43688*
43689         K = N
43690   50    CONTINUE
43691*
43692*        If K < 1, exit from loop.
43693*
43694         IF( K.LT.1 )
43695     $      GO TO 60
43696*
43697         IF( IPIV( K ).GT.0 ) THEN
43698*
43699*           1 x 1 diagonal block
43700*
43701*           Invert the diagonal block.
43702*
43703            A( K, K ) = ONE / A( K, K )
43704*
43705*           Compute column K of the inverse.
43706*
43707            IF( K.LT.N ) THEN
43708               CALL ZCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
43709               CALL ZSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1,
43710     $                     ZERO, A( K+1, K ), 1 )
43711               A( K, K ) = A( K, K ) - ZDOTU( N-K, WORK, 1, A( K+1, K ),
43712     $                     1 )
43713            END IF
43714            KSTEP = 1
43715         ELSE
43716*
43717*           2 x 2 diagonal block
43718*
43719*           Invert the diagonal block.
43720*
43721            T = A( K, K-1 )
43722            AK = A( K-1, K-1 ) / T
43723            AKP1 = A( K, K ) / T
43724            AKKP1 = A( K, K-1 ) / T
43725            D = T*( AK*AKP1-ONE )
43726            A( K-1, K-1 ) = AKP1 / D
43727            A( K, K ) = AK / D
43728            A( K, K-1 ) = -AKKP1 / D
43729*
43730*           Compute columns K-1 and K of the inverse.
43731*
43732            IF( K.LT.N ) THEN
43733               CALL ZCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
43734               CALL ZSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1,
43735     $                     ZERO, A( K+1, K ), 1 )
43736               A( K, K ) = A( K, K ) - ZDOTU( N-K, WORK, 1, A( K+1, K ),
43737     $                     1 )
43738               A( K, K-1 ) = A( K, K-1 ) -
43739     $                       ZDOTU( N-K, A( K+1, K ), 1, A( K+1, K-1 ),
43740     $                       1 )
43741               CALL ZCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 )
43742               CALL ZSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1,
43743     $                     ZERO, A( K+1, K-1 ), 1 )
43744               A( K-1, K-1 ) = A( K-1, K-1 ) -
43745     $                         ZDOTU( N-K, WORK, 1, A( K+1, K-1 ), 1 )
43746            END IF
43747            KSTEP = 2
43748         END IF
43749*
43750         KP = ABS( IPIV( K ) )
43751         IF( KP.NE.K ) THEN
43752*
43753*           Interchange rows and columns K and KP in the trailing
43754*           submatrix A(k-1:n,k-1:n)
43755*
43756            IF( KP.LT.N )
43757     $         CALL ZSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
43758            CALL ZSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA )
43759            TEMP = A( K, K )
43760            A( K, K ) = A( KP, KP )
43761            A( KP, KP ) = TEMP
43762            IF( KSTEP.EQ.2 ) THEN
43763               TEMP = A( K, K-1 )
43764               A( K, K-1 ) = A( KP, K-1 )
43765               A( KP, K-1 ) = TEMP
43766            END IF
43767         END IF
43768*
43769         K = K - KSTEP
43770         GO TO 50
43771   60    CONTINUE
43772      END IF
43773*
43774      RETURN
43775*
43776*     End of ZSYTRI
43777*
43778      END
43779*> \brief \b ZTGEVC
43780*
43781*  =========== DOCUMENTATION ===========
43782*
43783* Online html documentation available at
43784*            http://www.netlib.org/lapack/explore-html/
43785*
43786*> \htmlonly
43787*> Download ZTGEVC + dependencies
43788*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztgevc.f">
43789*> [TGZ]</a>
43790*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztgevc.f">
43791*> [ZIP]</a>
43792*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztgevc.f">
43793*> [TXT]</a>
43794*> \endhtmlonly
43795*
43796*  Definition:
43797*  ===========
43798*
43799*       SUBROUTINE ZTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL,
43800*                          LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO )
43801*
43802*       .. Scalar Arguments ..
43803*       CHARACTER          HOWMNY, SIDE
43804*       INTEGER            INFO, LDP, LDS, LDVL, LDVR, M, MM, N
43805*       ..
43806*       .. Array Arguments ..
43807*       LOGICAL            SELECT( * )
43808*       DOUBLE PRECISION   RWORK( * )
43809*       COMPLEX*16         P( LDP, * ), S( LDS, * ), VL( LDVL, * ),
43810*      $                   VR( LDVR, * ), WORK( * )
43811*       ..
43812*
43813*
43814*
43815*> \par Purpose:
43816*  =============
43817*>
43818*> \verbatim
43819*>
43820*> ZTGEVC computes some or all of the right and/or left eigenvectors of
43821*> a pair of complex matrices (S,P), where S and P are upper triangular.
43822*> Matrix pairs of this type are produced by the generalized Schur
43823*> factorization of a complex matrix pair (A,B):
43824*>
43825*>    A = Q*S*Z**H,  B = Q*P*Z**H
43826*>
43827*> as computed by ZGGHRD + ZHGEQZ.
43828*>
43829*> The right eigenvector x and the left eigenvector y of (S,P)
43830*> corresponding to an eigenvalue w are defined by:
43831*>
43832*>    S*x = w*P*x,  (y**H)*S = w*(y**H)*P,
43833*>
43834*> where y**H denotes the conjugate tranpose of y.
43835*> The eigenvalues are not input to this routine, but are computed
43836*> directly from the diagonal elements of S and P.
43837*>
43838*> This routine returns the matrices X and/or Y of right and left
43839*> eigenvectors of (S,P), or the products Z*X and/or Q*Y,
43840*> where Z and Q are input matrices.
43841*> If Q and Z are the unitary factors from the generalized Schur
43842*> factorization of a matrix pair (A,B), then Z*X and Q*Y
43843*> are the matrices of right and left eigenvectors of (A,B).
43844*> \endverbatim
43845*
43846*  Arguments:
43847*  ==========
43848*
43849*> \param[in] SIDE
43850*> \verbatim
43851*>          SIDE is CHARACTER*1
43852*>          = 'R': compute right eigenvectors only;
43853*>          = 'L': compute left eigenvectors only;
43854*>          = 'B': compute both right and left eigenvectors.
43855*> \endverbatim
43856*>
43857*> \param[in] HOWMNY
43858*> \verbatim
43859*>          HOWMNY is CHARACTER*1
43860*>          = 'A': compute all right and/or left eigenvectors;
43861*>          = 'B': compute all right and/or left eigenvectors,
43862*>                 backtransformed by the matrices in VR and/or VL;
43863*>          = 'S': compute selected right and/or left eigenvectors,
43864*>                 specified by the logical array SELECT.
43865*> \endverbatim
43866*>
43867*> \param[in] SELECT
43868*> \verbatim
43869*>          SELECT is LOGICAL array, dimension (N)
43870*>          If HOWMNY='S', SELECT specifies the eigenvectors to be
43871*>          computed.  The eigenvector corresponding to the j-th
43872*>          eigenvalue is computed if SELECT(j) = .TRUE..
43873*>          Not referenced if HOWMNY = 'A' or 'B'.
43874*> \endverbatim
43875*>
43876*> \param[in] N
43877*> \verbatim
43878*>          N is INTEGER
43879*>          The order of the matrices S and P.  N >= 0.
43880*> \endverbatim
43881*>
43882*> \param[in] S
43883*> \verbatim
43884*>          S is COMPLEX*16 array, dimension (LDS,N)
43885*>          The upper triangular matrix S from a generalized Schur
43886*>          factorization, as computed by ZHGEQZ.
43887*> \endverbatim
43888*>
43889*> \param[in] LDS
43890*> \verbatim
43891*>          LDS is INTEGER
43892*>          The leading dimension of array S.  LDS >= max(1,N).
43893*> \endverbatim
43894*>
43895*> \param[in] P
43896*> \verbatim
43897*>          P is COMPLEX*16 array, dimension (LDP,N)
43898*>          The upper triangular matrix P from a generalized Schur
43899*>          factorization, as computed by ZHGEQZ.  P must have real
43900*>          diagonal elements.
43901*> \endverbatim
43902*>
43903*> \param[in] LDP
43904*> \verbatim
43905*>          LDP is INTEGER
43906*>          The leading dimension of array P.  LDP >= max(1,N).
43907*> \endverbatim
43908*>
43909*> \param[in,out] VL
43910*> \verbatim
43911*>          VL is COMPLEX*16 array, dimension (LDVL,MM)
43912*>          On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
43913*>          contain an N-by-N matrix Q (usually the unitary matrix Q
43914*>          of left Schur vectors returned by ZHGEQZ).
43915*>          On exit, if SIDE = 'L' or 'B', VL contains:
43916*>          if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P);
43917*>          if HOWMNY = 'B', the matrix Q*Y;
43918*>          if HOWMNY = 'S', the left eigenvectors of (S,P) specified by
43919*>                      SELECT, stored consecutively in the columns of
43920*>                      VL, in the same order as their eigenvalues.
43921*>          Not referenced if SIDE = 'R'.
43922*> \endverbatim
43923*>
43924*> \param[in] LDVL
43925*> \verbatim
43926*>          LDVL is INTEGER
43927*>          The leading dimension of array VL.  LDVL >= 1, and if
43928*>          SIDE = 'L' or 'l' or 'B' or 'b', LDVL >= N.
43929*> \endverbatim
43930*>
43931*> \param[in,out] VR
43932*> \verbatim
43933*>          VR is COMPLEX*16 array, dimension (LDVR,MM)
43934*>          On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
43935*>          contain an N-by-N matrix Q (usually the unitary matrix Z
43936*>          of right Schur vectors returned by ZHGEQZ).
43937*>          On exit, if SIDE = 'R' or 'B', VR contains:
43938*>          if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P);
43939*>          if HOWMNY = 'B', the matrix Z*X;
43940*>          if HOWMNY = 'S', the right eigenvectors of (S,P) specified by
43941*>                      SELECT, stored consecutively in the columns of
43942*>                      VR, in the same order as their eigenvalues.
43943*>          Not referenced if SIDE = 'L'.
43944*> \endverbatim
43945*>
43946*> \param[in] LDVR
43947*> \verbatim
43948*>          LDVR is INTEGER
43949*>          The leading dimension of the array VR.  LDVR >= 1, and if
43950*>          SIDE = 'R' or 'B', LDVR >= N.
43951*> \endverbatim
43952*>
43953*> \param[in] MM
43954*> \verbatim
43955*>          MM is INTEGER
43956*>          The number of columns in the arrays VL and/or VR. MM >= M.
43957*> \endverbatim
43958*>
43959*> \param[out] M
43960*> \verbatim
43961*>          M is INTEGER
43962*>          The number of columns in the arrays VL and/or VR actually
43963*>          used to store the eigenvectors.  If HOWMNY = 'A' or 'B', M
43964*>          is set to N.  Each selected eigenvector occupies one column.
43965*> \endverbatim
43966*>
43967*> \param[out] WORK
43968*> \verbatim
43969*>          WORK is COMPLEX*16 array, dimension (2*N)
43970*> \endverbatim
43971*>
43972*> \param[out] RWORK
43973*> \verbatim
43974*>          RWORK is DOUBLE PRECISION array, dimension (2*N)
43975*> \endverbatim
43976*>
43977*> \param[out] INFO
43978*> \verbatim
43979*>          INFO is INTEGER
43980*>          = 0:  successful exit.
43981*>          < 0:  if INFO = -i, the i-th argument had an illegal value.
43982*> \endverbatim
43983*
43984*  Authors:
43985*  ========
43986*
43987*> \author Univ. of Tennessee
43988*> \author Univ. of California Berkeley
43989*> \author Univ. of Colorado Denver
43990*> \author NAG Ltd.
43991*
43992*> \date December 2016
43993*
43994*> \ingroup complex16GEcomputational
43995*
43996*  =====================================================================
43997      SUBROUTINE ZTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL,
43998     $                   LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO )
43999*
44000*  -- LAPACK computational routine (version 3.7.0) --
44001*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
44002*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
44003*     December 2016
44004*
44005*     .. Scalar Arguments ..
44006      CHARACTER          HOWMNY, SIDE
44007      INTEGER            INFO, LDP, LDS, LDVL, LDVR, M, MM, N
44008*     ..
44009*     .. Array Arguments ..
44010      LOGICAL            SELECT( * )
44011      DOUBLE PRECISION   RWORK( * )
44012      COMPLEX*16         P( LDP, * ), S( LDS, * ), VL( LDVL, * ),
44013     $                   VR( LDVR, * ), WORK( * )
44014*     ..
44015*
44016*
44017*  =====================================================================
44018*
44019*     .. Parameters ..
44020      DOUBLE PRECISION   ZERO, ONE
44021      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
44022      COMPLEX*16         CZERO, CONE
44023      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ),
44024     $                   CONE = ( 1.0D+0, 0.0D+0 ) )
44025*     ..
44026*     .. Local Scalars ..
44027      LOGICAL            COMPL, COMPR, ILALL, ILBACK, ILBBAD, ILCOMP,
44028     $                   LSA, LSB
44029      INTEGER            I, IBEG, IEIG, IEND, IHWMNY, IM, ISIDE, ISRC,
44030     $                   J, JE, JR
44031      DOUBLE PRECISION   ACOEFA, ACOEFF, ANORM, ASCALE, BCOEFA, BIG,
44032     $                   BIGNUM, BNORM, BSCALE, DMIN, SAFMIN, SBETA,
44033     $                   SCALE, SMALL, TEMP, ULP, XMAX
44034      COMPLEX*16         BCOEFF, CA, CB, D, SALPHA, SUM, SUMA, SUMB, X
44035*     ..
44036*     .. External Functions ..
44037      LOGICAL            LSAME
44038      DOUBLE PRECISION   DLAMCH
44039      COMPLEX*16         ZLADIV
44040      EXTERNAL           LSAME, DLAMCH, ZLADIV
44041*     ..
44042*     .. External Subroutines ..
44043      EXTERNAL           DLABAD, XERBLA, ZGEMV
44044*     ..
44045*     .. Intrinsic Functions ..
44046      INTRINSIC          ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN
44047*     ..
44048*     .. Statement Functions ..
44049      DOUBLE PRECISION   ABS1
44050*     ..
44051*     .. Statement Function definitions ..
44052      ABS1( X ) = ABS( DBLE( X ) ) + ABS( DIMAG( X ) )
44053*     ..
44054*     .. Executable Statements ..
44055*
44056*     Decode and Test the input parameters
44057*
44058      IF( LSAME( HOWMNY, 'A' ) ) THEN
44059         IHWMNY = 1
44060         ILALL = .TRUE.
44061         ILBACK = .FALSE.
44062      ELSE IF( LSAME( HOWMNY, 'S' ) ) THEN
44063         IHWMNY = 2
44064         ILALL = .FALSE.
44065         ILBACK = .FALSE.
44066      ELSE IF( LSAME( HOWMNY, 'B' ) ) THEN
44067         IHWMNY = 3
44068         ILALL = .TRUE.
44069         ILBACK = .TRUE.
44070      ELSE
44071         IHWMNY = -1
44072      END IF
44073*
44074      IF( LSAME( SIDE, 'R' ) ) THEN
44075         ISIDE = 1
44076         COMPL = .FALSE.
44077         COMPR = .TRUE.
44078      ELSE IF( LSAME( SIDE, 'L' ) ) THEN
44079         ISIDE = 2
44080         COMPL = .TRUE.
44081         COMPR = .FALSE.
44082      ELSE IF( LSAME( SIDE, 'B' ) ) THEN
44083         ISIDE = 3
44084         COMPL = .TRUE.
44085         COMPR = .TRUE.
44086      ELSE
44087         ISIDE = -1
44088      END IF
44089*
44090      INFO = 0
44091      IF( ISIDE.LT.0 ) THEN
44092         INFO = -1
44093      ELSE IF( IHWMNY.LT.0 ) THEN
44094         INFO = -2
44095      ELSE IF( N.LT.0 ) THEN
44096         INFO = -4
44097      ELSE IF( LDS.LT.MAX( 1, N ) ) THEN
44098         INFO = -6
44099      ELSE IF( LDP.LT.MAX( 1, N ) ) THEN
44100         INFO = -8
44101      END IF
44102      IF( INFO.NE.0 ) THEN
44103         CALL XERBLA( 'ZTGEVC', -INFO )
44104         RETURN
44105      END IF
44106*
44107*     Count the number of eigenvectors
44108*
44109      IF( .NOT.ILALL ) THEN
44110         IM = 0
44111         DO 10 J = 1, N
44112            IF( SELECT( J ) )
44113     $         IM = IM + 1
44114   10    CONTINUE
44115      ELSE
44116         IM = N
44117      END IF
44118*
44119*     Check diagonal of B
44120*
44121      ILBBAD = .FALSE.
44122      DO 20 J = 1, N
44123         IF( DIMAG( P( J, J ) ).NE.ZERO )
44124     $      ILBBAD = .TRUE.
44125   20 CONTINUE
44126*
44127      IF( ILBBAD ) THEN
44128         INFO = -7
44129      ELSE IF( COMPL .AND. LDVL.LT.N .OR. LDVL.LT.1 ) THEN
44130         INFO = -10
44131      ELSE IF( COMPR .AND. LDVR.LT.N .OR. LDVR.LT.1 ) THEN
44132         INFO = -12
44133      ELSE IF( MM.LT.IM ) THEN
44134         INFO = -13
44135      END IF
44136      IF( INFO.NE.0 ) THEN
44137         CALL XERBLA( 'ZTGEVC', -INFO )
44138         RETURN
44139      END IF
44140*
44141*     Quick return if possible
44142*
44143      M = IM
44144      IF( N.EQ.0 )
44145     $   RETURN
44146*
44147*     Machine Constants
44148*
44149      SAFMIN = DLAMCH( 'Safe minimum' )
44150      BIG = ONE / SAFMIN
44151      CALL DLABAD( SAFMIN, BIG )
44152      ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
44153      SMALL = SAFMIN*N / ULP
44154      BIG = ONE / SMALL
44155      BIGNUM = ONE / ( SAFMIN*N )
44156*
44157*     Compute the 1-norm of each column of the strictly upper triangular
44158*     part of A and B to check for possible overflow in the triangular
44159*     solver.
44160*
44161      ANORM = ABS1( S( 1, 1 ) )
44162      BNORM = ABS1( P( 1, 1 ) )
44163      RWORK( 1 ) = ZERO
44164      RWORK( N+1 ) = ZERO
44165      DO 40 J = 2, N
44166         RWORK( J ) = ZERO
44167         RWORK( N+J ) = ZERO
44168         DO 30 I = 1, J - 1
44169            RWORK( J ) = RWORK( J ) + ABS1( S( I, J ) )
44170            RWORK( N+J ) = RWORK( N+J ) + ABS1( P( I, J ) )
44171   30    CONTINUE
44172         ANORM = MAX( ANORM, RWORK( J )+ABS1( S( J, J ) ) )
44173         BNORM = MAX( BNORM, RWORK( N+J )+ABS1( P( J, J ) ) )
44174   40 CONTINUE
44175*
44176      ASCALE = ONE / MAX( ANORM, SAFMIN )
44177      BSCALE = ONE / MAX( BNORM, SAFMIN )
44178*
44179*     Left eigenvectors
44180*
44181      IF( COMPL ) THEN
44182         IEIG = 0
44183*
44184*        Main loop over eigenvalues
44185*
44186         DO 140 JE = 1, N
44187            IF( ILALL ) THEN
44188               ILCOMP = .TRUE.
44189            ELSE
44190               ILCOMP = SELECT( JE )
44191            END IF
44192            IF( ILCOMP ) THEN
44193               IEIG = IEIG + 1
44194*
44195               IF( ABS1( S( JE, JE ) ).LE.SAFMIN .AND.
44196     $             ABS( DBLE( P( JE, JE ) ) ).LE.SAFMIN ) THEN
44197*
44198*                 Singular matrix pencil -- return unit eigenvector
44199*
44200                  DO 50 JR = 1, N
44201                     VL( JR, IEIG ) = CZERO
44202   50             CONTINUE
44203                  VL( IEIG, IEIG ) = CONE
44204                  GO TO 140
44205               END IF
44206*
44207*              Non-singular eigenvalue:
44208*              Compute coefficients  a  and  b  in
44209*                   H
44210*                 y  ( a A - b B ) = 0
44211*
44212               TEMP = ONE / MAX( ABS1( S( JE, JE ) )*ASCALE,
44213     $                ABS( DBLE( P( JE, JE ) ) )*BSCALE, SAFMIN )
44214               SALPHA = ( TEMP*S( JE, JE ) )*ASCALE
44215               SBETA = ( TEMP*DBLE( P( JE, JE ) ) )*BSCALE
44216               ACOEFF = SBETA*ASCALE
44217               BCOEFF = SALPHA*BSCALE
44218*
44219*              Scale to avoid underflow
44220*
44221               LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEFF ).LT.SMALL
44222               LSB = ABS1( SALPHA ).GE.SAFMIN .AND. ABS1( BCOEFF ).LT.
44223     $               SMALL
44224*
44225               SCALE = ONE
44226               IF( LSA )
44227     $            SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG )
44228               IF( LSB )
44229     $            SCALE = MAX( SCALE, ( SMALL / ABS1( SALPHA ) )*
44230     $                    MIN( BNORM, BIG ) )
44231               IF( LSA .OR. LSB ) THEN
44232                  SCALE = MIN( SCALE, ONE /
44233     $                    ( SAFMIN*MAX( ONE, ABS( ACOEFF ),
44234     $                    ABS1( BCOEFF ) ) ) )
44235                  IF( LSA ) THEN
44236                     ACOEFF = ASCALE*( SCALE*SBETA )
44237                  ELSE
44238                     ACOEFF = SCALE*ACOEFF
44239                  END IF
44240                  IF( LSB ) THEN
44241                     BCOEFF = BSCALE*( SCALE*SALPHA )
44242                  ELSE
44243                     BCOEFF = SCALE*BCOEFF
44244                  END IF
44245               END IF
44246*
44247               ACOEFA = ABS( ACOEFF )
44248               BCOEFA = ABS1( BCOEFF )
44249               XMAX = ONE
44250               DO 60 JR = 1, N
44251                  WORK( JR ) = CZERO
44252   60          CONTINUE
44253               WORK( JE ) = CONE
44254               DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN )
44255*
44256*                                              H
44257*              Triangular solve of  (a A - b B)  y = 0
44258*
44259*                                      H
44260*              (rowwise in  (a A - b B) , or columnwise in a A - b B)
44261*
44262               DO 100 J = JE + 1, N
44263*
44264*                 Compute
44265*                       j-1
44266*                 SUM = sum  conjg( a*S(k,j) - b*P(k,j) )*x(k)
44267*                       k=je
44268*                 (Scale if necessary)
44269*
44270                  TEMP = ONE / XMAX
44271                  IF( ACOEFA*RWORK( J )+BCOEFA*RWORK( N+J ).GT.BIGNUM*
44272     $                TEMP ) THEN
44273                     DO 70 JR = JE, J - 1
44274                        WORK( JR ) = TEMP*WORK( JR )
44275   70                CONTINUE
44276                     XMAX = ONE
44277                  END IF
44278                  SUMA = CZERO
44279                  SUMB = CZERO
44280*
44281                  DO 80 JR = JE, J - 1
44282                     SUMA = SUMA + DCONJG( S( JR, J ) )*WORK( JR )
44283                     SUMB = SUMB + DCONJG( P( JR, J ) )*WORK( JR )
44284   80             CONTINUE
44285                  SUM = ACOEFF*SUMA - DCONJG( BCOEFF )*SUMB
44286*
44287*                 Form x(j) = - SUM / conjg( a*S(j,j) - b*P(j,j) )
44288*
44289*                 with scaling and perturbation of the denominator
44290*
44291                  D = DCONJG( ACOEFF*S( J, J )-BCOEFF*P( J, J ) )
44292                  IF( ABS1( D ).LE.DMIN )
44293     $               D = DCMPLX( DMIN )
44294*
44295                  IF( ABS1( D ).LT.ONE ) THEN
44296                     IF( ABS1( SUM ).GE.BIGNUM*ABS1( D ) ) THEN
44297                        TEMP = ONE / ABS1( SUM )
44298                        DO 90 JR = JE, J - 1
44299                           WORK( JR ) = TEMP*WORK( JR )
44300   90                   CONTINUE
44301                        XMAX = TEMP*XMAX
44302                        SUM = TEMP*SUM
44303                     END IF
44304                  END IF
44305                  WORK( J ) = ZLADIV( -SUM, D )
44306                  XMAX = MAX( XMAX, ABS1( WORK( J ) ) )
44307  100          CONTINUE
44308*
44309*              Back transform eigenvector if HOWMNY='B'.
44310*
44311               IF( ILBACK ) THEN
44312                  CALL ZGEMV( 'N', N, N+1-JE, CONE, VL( 1, JE ), LDVL,
44313     $                        WORK( JE ), 1, CZERO, WORK( N+1 ), 1 )
44314                  ISRC = 2
44315                  IBEG = 1
44316               ELSE
44317                  ISRC = 1
44318                  IBEG = JE
44319               END IF
44320*
44321*              Copy and scale eigenvector into column of VL
44322*
44323               XMAX = ZERO
44324               DO 110 JR = IBEG, N
44325                  XMAX = MAX( XMAX, ABS1( WORK( ( ISRC-1 )*N+JR ) ) )
44326  110          CONTINUE
44327*
44328               IF( XMAX.GT.SAFMIN ) THEN
44329                  TEMP = ONE / XMAX
44330                  DO 120 JR = IBEG, N
44331                     VL( JR, IEIG ) = TEMP*WORK( ( ISRC-1 )*N+JR )
44332  120             CONTINUE
44333               ELSE
44334                  IBEG = N + 1
44335               END IF
44336*
44337               DO 130 JR = 1, IBEG - 1
44338                  VL( JR, IEIG ) = CZERO
44339  130          CONTINUE
44340*
44341            END IF
44342  140    CONTINUE
44343      END IF
44344*
44345*     Right eigenvectors
44346*
44347      IF( COMPR ) THEN
44348         IEIG = IM + 1
44349*
44350*        Main loop over eigenvalues
44351*
44352         DO 250 JE = N, 1, -1
44353            IF( ILALL ) THEN
44354               ILCOMP = .TRUE.
44355            ELSE
44356               ILCOMP = SELECT( JE )
44357            END IF
44358            IF( ILCOMP ) THEN
44359               IEIG = IEIG - 1
44360*
44361               IF( ABS1( S( JE, JE ) ).LE.SAFMIN .AND.
44362     $             ABS( DBLE( P( JE, JE ) ) ).LE.SAFMIN ) THEN
44363*
44364*                 Singular matrix pencil -- return unit eigenvector
44365*
44366                  DO 150 JR = 1, N
44367                     VR( JR, IEIG ) = CZERO
44368  150             CONTINUE
44369                  VR( IEIG, IEIG ) = CONE
44370                  GO TO 250
44371               END IF
44372*
44373*              Non-singular eigenvalue:
44374*              Compute coefficients  a  and  b  in
44375*
44376*              ( a A - b B ) x  = 0
44377*
44378               TEMP = ONE / MAX( ABS1( S( JE, JE ) )*ASCALE,
44379     $                ABS( DBLE( P( JE, JE ) ) )*BSCALE, SAFMIN )
44380               SALPHA = ( TEMP*S( JE, JE ) )*ASCALE
44381               SBETA = ( TEMP*DBLE( P( JE, JE ) ) )*BSCALE
44382               ACOEFF = SBETA*ASCALE
44383               BCOEFF = SALPHA*BSCALE
44384*
44385*              Scale to avoid underflow
44386*
44387               LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEFF ).LT.SMALL
44388               LSB = ABS1( SALPHA ).GE.SAFMIN .AND. ABS1( BCOEFF ).LT.
44389     $               SMALL
44390*
44391               SCALE = ONE
44392               IF( LSA )
44393     $            SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG )
44394               IF( LSB )
44395     $            SCALE = MAX( SCALE, ( SMALL / ABS1( SALPHA ) )*
44396     $                    MIN( BNORM, BIG ) )
44397               IF( LSA .OR. LSB ) THEN
44398                  SCALE = MIN( SCALE, ONE /
44399     $                    ( SAFMIN*MAX( ONE, ABS( ACOEFF ),
44400     $                    ABS1( BCOEFF ) ) ) )
44401                  IF( LSA ) THEN
44402                     ACOEFF = ASCALE*( SCALE*SBETA )
44403                  ELSE
44404                     ACOEFF = SCALE*ACOEFF
44405                  END IF
44406                  IF( LSB ) THEN
44407                     BCOEFF = BSCALE*( SCALE*SALPHA )
44408                  ELSE
44409                     BCOEFF = SCALE*BCOEFF
44410                  END IF
44411               END IF
44412*
44413               ACOEFA = ABS( ACOEFF )
44414               BCOEFA = ABS1( BCOEFF )
44415               XMAX = ONE
44416               DO 160 JR = 1, N
44417                  WORK( JR ) = CZERO
44418  160          CONTINUE
44419               WORK( JE ) = CONE
44420               DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN )
44421*
44422*              Triangular solve of  (a A - b B) x = 0  (columnwise)
44423*
44424*              WORK(1:j-1) contains sums w,
44425*              WORK(j+1:JE) contains x
44426*
44427               DO 170 JR = 1, JE - 1
44428                  WORK( JR ) = ACOEFF*S( JR, JE ) - BCOEFF*P( JR, JE )
44429  170          CONTINUE
44430               WORK( JE ) = CONE
44431*
44432               DO 210 J = JE - 1, 1, -1
44433*
44434*                 Form x(j) := - w(j) / d
44435*                 with scaling and perturbation of the denominator
44436*
44437                  D = ACOEFF*S( J, J ) - BCOEFF*P( J, J )
44438                  IF( ABS1( D ).LE.DMIN )
44439     $               D = DCMPLX( DMIN )
44440*
44441                  IF( ABS1( D ).LT.ONE ) THEN
44442                     IF( ABS1( WORK( J ) ).GE.BIGNUM*ABS1( D ) ) THEN
44443                        TEMP = ONE / ABS1( WORK( J ) )
44444                        DO 180 JR = 1, JE
44445                           WORK( JR ) = TEMP*WORK( JR )
44446  180                   CONTINUE
44447                     END IF
44448                  END IF
44449*
44450                  WORK( J ) = ZLADIV( -WORK( J ), D )
44451*
44452                  IF( J.GT.1 ) THEN
44453*
44454*                    w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling
44455*
44456                     IF( ABS1( WORK( J ) ).GT.ONE ) THEN
44457                        TEMP = ONE / ABS1( WORK( J ) )
44458                        IF( ACOEFA*RWORK( J )+BCOEFA*RWORK( N+J ).GE.
44459     $                      BIGNUM*TEMP ) THEN
44460                           DO 190 JR = 1, JE
44461                              WORK( JR ) = TEMP*WORK( JR )
44462  190                      CONTINUE
44463                        END IF
44464                     END IF
44465*
44466                     CA = ACOEFF*WORK( J )
44467                     CB = BCOEFF*WORK( J )
44468                     DO 200 JR = 1, J - 1
44469                        WORK( JR ) = WORK( JR ) + CA*S( JR, J ) -
44470     $                               CB*P( JR, J )
44471  200                CONTINUE
44472                  END IF
44473  210          CONTINUE
44474*
44475*              Back transform eigenvector if HOWMNY='B'.
44476*
44477               IF( ILBACK ) THEN
44478                  CALL ZGEMV( 'N', N, JE, CONE, VR, LDVR, WORK, 1,
44479     $                        CZERO, WORK( N+1 ), 1 )
44480                  ISRC = 2
44481                  IEND = N
44482               ELSE
44483                  ISRC = 1
44484                  IEND = JE
44485               END IF
44486*
44487*              Copy and scale eigenvector into column of VR
44488*
44489               XMAX = ZERO
44490               DO 220 JR = 1, IEND
44491                  XMAX = MAX( XMAX, ABS1( WORK( ( ISRC-1 )*N+JR ) ) )
44492  220          CONTINUE
44493*
44494               IF( XMAX.GT.SAFMIN ) THEN
44495                  TEMP = ONE / XMAX
44496                  DO 230 JR = 1, IEND
44497                     VR( JR, IEIG ) = TEMP*WORK( ( ISRC-1 )*N+JR )
44498  230             CONTINUE
44499               ELSE
44500                  IEND = 0
44501               END IF
44502*
44503               DO 240 JR = IEND + 1, N
44504                  VR( JR, IEIG ) = CZERO
44505  240          CONTINUE
44506*
44507            END IF
44508  250    CONTINUE
44509      END IF
44510*
44511      RETURN
44512*
44513*     End of ZTGEVC
44514*
44515      END
44516*> \brief \b ZTGEX2 swaps adjacent diagonal blocks in an upper (quasi) triangular matrix pair by an unitary equivalence transformation.
44517*
44518*  =========== DOCUMENTATION ===========
44519*
44520* Online html documentation available at
44521*            http://www.netlib.org/lapack/explore-html/
44522*
44523*> \htmlonly
44524*> Download ZTGEX2 + dependencies
44525*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztgex2.f">
44526*> [TGZ]</a>
44527*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztgex2.f">
44528*> [ZIP]</a>
44529*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztgex2.f">
44530*> [TXT]</a>
44531*> \endhtmlonly
44532*
44533*  Definition:
44534*  ===========
44535*
44536*       SUBROUTINE ZTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
44537*                          LDZ, J1, INFO )
44538*
44539*       .. Scalar Arguments ..
44540*       LOGICAL            WANTQ, WANTZ
44541*       INTEGER            INFO, J1, LDA, LDB, LDQ, LDZ, N
44542*       ..
44543*       .. Array Arguments ..
44544*       COMPLEX*16         A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
44545*      $                   Z( LDZ, * )
44546*       ..
44547*
44548*
44549*> \par Purpose:
44550*  =============
44551*>
44552*> \verbatim
44553*>
44554*> ZTGEX2 swaps adjacent diagonal 1 by 1 blocks (A11,B11) and (A22,B22)
44555*> in an upper triangular matrix pair (A, B) by an unitary equivalence
44556*> transformation.
44557*>
44558*> (A, B) must be in generalized Schur canonical form, that is, A and
44559*> B are both upper triangular.
44560*>
44561*> Optionally, the matrices Q and Z of generalized Schur vectors are
44562*> updated.
44563*>
44564*>        Q(in) * A(in) * Z(in)**H = Q(out) * A(out) * Z(out)**H
44565*>        Q(in) * B(in) * Z(in)**H = Q(out) * B(out) * Z(out)**H
44566*>
44567*> \endverbatim
44568*
44569*  Arguments:
44570*  ==========
44571*
44572*> \param[in] WANTQ
44573*> \verbatim
44574*>          WANTQ is LOGICAL
44575*>          .TRUE. : update the left transformation matrix Q;
44576*>          .FALSE.: do not update Q.
44577*> \endverbatim
44578*>
44579*> \param[in] WANTZ
44580*> \verbatim
44581*>          WANTZ is LOGICAL
44582*>          .TRUE. : update the right transformation matrix Z;
44583*>          .FALSE.: do not update Z.
44584*> \endverbatim
44585*>
44586*> \param[in] N
44587*> \verbatim
44588*>          N is INTEGER
44589*>          The order of the matrices A and B. N >= 0.
44590*> \endverbatim
44591*>
44592*> \param[in,out] A
44593*> \verbatim
44594*>          A is COMPLEX*16 array, dimensions (LDA,N)
44595*>          On entry, the matrix A in the pair (A, B).
44596*>          On exit, the updated matrix A.
44597*> \endverbatim
44598*>
44599*> \param[in] LDA
44600*> \verbatim
44601*>          LDA is INTEGER
44602*>          The leading dimension of the array A. LDA >= max(1,N).
44603*> \endverbatim
44604*>
44605*> \param[in,out] B
44606*> \verbatim
44607*>          B is COMPLEX*16 array, dimensions (LDB,N)
44608*>          On entry, the matrix B in the pair (A, B).
44609*>          On exit, the updated matrix B.
44610*> \endverbatim
44611*>
44612*> \param[in] LDB
44613*> \verbatim
44614*>          LDB is INTEGER
44615*>          The leading dimension of the array B. LDB >= max(1,N).
44616*> \endverbatim
44617*>
44618*> \param[in,out] Q
44619*> \verbatim
44620*>          Q is COMPLEX*16 array, dimension (LDQ,N)
44621*>          If WANTQ = .TRUE, on entry, the unitary matrix Q. On exit,
44622*>          the updated matrix Q.
44623*>          Not referenced if WANTQ = .FALSE..
44624*> \endverbatim
44625*>
44626*> \param[in] LDQ
44627*> \verbatim
44628*>          LDQ is INTEGER
44629*>          The leading dimension of the array Q. LDQ >= 1;
44630*>          If WANTQ = .TRUE., LDQ >= N.
44631*> \endverbatim
44632*>
44633*> \param[in,out] Z
44634*> \verbatim
44635*>          Z is COMPLEX*16 array, dimension (LDZ,N)
44636*>          If WANTZ = .TRUE, on entry, the unitary matrix Z. On exit,
44637*>          the updated matrix Z.
44638*>          Not referenced if WANTZ = .FALSE..
44639*> \endverbatim
44640*>
44641*> \param[in] LDZ
44642*> \verbatim
44643*>          LDZ is INTEGER
44644*>          The leading dimension of the array Z. LDZ >= 1;
44645*>          If WANTZ = .TRUE., LDZ >= N.
44646*> \endverbatim
44647*>
44648*> \param[in] J1
44649*> \verbatim
44650*>          J1 is INTEGER
44651*>          The index to the first block (A11, B11).
44652*> \endverbatim
44653*>
44654*> \param[out] INFO
44655*> \verbatim
44656*>          INFO is INTEGER
44657*>           =0:  Successful exit.
44658*>           =1:  The transformed matrix pair (A, B) would be too far
44659*>                from generalized Schur form; the problem is ill-
44660*>                conditioned.
44661*> \endverbatim
44662*
44663*  Authors:
44664*  ========
44665*
44666*> \author Univ. of Tennessee
44667*> \author Univ. of California Berkeley
44668*> \author Univ. of Colorado Denver
44669*> \author NAG Ltd.
44670*
44671*> \date June 2017
44672*
44673*> \ingroup complex16GEauxiliary
44674*
44675*> \par Further Details:
44676*  =====================
44677*>
44678*>  In the current code both weak and strong stability tests are
44679*>  performed. The user can omit the strong stability test by changing
44680*>  the internal logical parameter WANDS to .FALSE.. See ref. [2] for
44681*>  details.
44682*
44683*> \par Contributors:
44684*  ==================
44685*>
44686*>     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
44687*>     Umea University, S-901 87 Umea, Sweden.
44688*
44689*> \par References:
44690*  ================
44691*>
44692*>  [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
44693*>      Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
44694*>      M.S. Moonen et al (eds), Linear Algebra for Large Scale and
44695*>      Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
44696*> \n
44697*>  [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
44698*>      Eigenvalues of a Regular Matrix Pair (A, B) and Condition
44699*>      Estimation: Theory, Algorithms and Software, Report UMINF-94.04,
44700*>      Department of Computing Science, Umea University, S-901 87 Umea,
44701*>      Sweden, 1994. Also as LAPACK Working Note 87. To appear in
44702*>      Numerical Algorithms, 1996.
44703*>
44704*  =====================================================================
44705      SUBROUTINE ZTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
44706     $                   LDZ, J1, INFO )
44707*
44708*  -- LAPACK auxiliary routine (version 3.7.1) --
44709*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
44710*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
44711*     June 2017
44712*
44713*     .. Scalar Arguments ..
44714      LOGICAL            WANTQ, WANTZ
44715      INTEGER            INFO, J1, LDA, LDB, LDQ, LDZ, N
44716*     ..
44717*     .. Array Arguments ..
44718      COMPLEX*16         A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
44719     $                   Z( LDZ, * )
44720*     ..
44721*
44722*  =====================================================================
44723*
44724*     .. Parameters ..
44725      COMPLEX*16         CZERO, CONE
44726      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ),
44727     $                   CONE = ( 1.0D+0, 0.0D+0 ) )
44728      DOUBLE PRECISION   TWENTY
44729      PARAMETER          ( TWENTY = 2.0D+1 )
44730      INTEGER            LDST
44731      PARAMETER          ( LDST = 2 )
44732      LOGICAL            WANDS
44733      PARAMETER          ( WANDS = .TRUE. )
44734*     ..
44735*     .. Local Scalars ..
44736      LOGICAL            DTRONG, WEAK
44737      INTEGER            I, M
44738      DOUBLE PRECISION   CQ, CZ, EPS, SA, SB, SCALE, SMLNUM, SS, SUM,
44739     $                   THRESH, WS
44740      COMPLEX*16         CDUM, F, G, SQ, SZ
44741*     ..
44742*     .. Local Arrays ..
44743      COMPLEX*16         S( LDST, LDST ), T( LDST, LDST ), WORK( 8 )
44744*     ..
44745*     .. External Functions ..
44746      DOUBLE PRECISION   DLAMCH
44747      EXTERNAL           DLAMCH
44748*     ..
44749*     .. External Subroutines ..
44750      EXTERNAL           ZLACPY, ZLARTG, ZLASSQ, ZROT
44751*     ..
44752*     .. Intrinsic Functions ..
44753      INTRINSIC          ABS, DBLE, DCONJG, MAX, SQRT
44754*     ..
44755*     .. Executable Statements ..
44756*
44757      INFO = 0
44758*
44759*     Quick return if possible
44760*
44761      IF( N.LE.1 )
44762     $   RETURN
44763*
44764      M = LDST
44765      WEAK = .FALSE.
44766      DTRONG = .FALSE.
44767*
44768*     Make a local copy of selected block in (A, B)
44769*
44770      CALL ZLACPY( 'Full', M, M, A( J1, J1 ), LDA, S, LDST )
44771      CALL ZLACPY( 'Full', M, M, B( J1, J1 ), LDB, T, LDST )
44772*
44773*     Compute the threshold for testing the acceptance of swapping.
44774*
44775      EPS = DLAMCH( 'P' )
44776      SMLNUM = DLAMCH( 'S' ) / EPS
44777      SCALE = DBLE( CZERO )
44778      SUM = DBLE( CONE )
44779      CALL ZLACPY( 'Full', M, M, S, LDST, WORK, M )
44780      CALL ZLACPY( 'Full', M, M, T, LDST, WORK( M*M+1 ), M )
44781      CALL ZLASSQ( 2*M*M, WORK, 1, SCALE, SUM )
44782      SA = SCALE*SQRT( SUM )
44783*
44784*     THRES has been changed from
44785*        THRESH = MAX( TEN*EPS*SA, SMLNUM )
44786*     to
44787*        THRESH = MAX( TWENTY*EPS*SA, SMLNUM )
44788*     on 04/01/10.
44789*     "Bug" reported by Ondra Kamenik, confirmed by Julie Langou, fixed by
44790*     Jim Demmel and Guillaume Revy. See forum post 1783.
44791*
44792      THRESH = MAX( TWENTY*EPS*SA, SMLNUM )
44793*
44794*     Compute unitary QL and RQ that swap 1-by-1 and 1-by-1 blocks
44795*     using Givens rotations and perform the swap tentatively.
44796*
44797      F = S( 2, 2 )*T( 1, 1 ) - T( 2, 2 )*S( 1, 1 )
44798      G = S( 2, 2 )*T( 1, 2 ) - T( 2, 2 )*S( 1, 2 )
44799      SA = ABS( S( 2, 2 ) )
44800      SB = ABS( T( 2, 2 ) )
44801      CALL ZLARTG( G, F, CZ, SZ, CDUM )
44802      SZ = -SZ
44803      CALL ZROT( 2, S( 1, 1 ), 1, S( 1, 2 ), 1, CZ, DCONJG( SZ ) )
44804      CALL ZROT( 2, T( 1, 1 ), 1, T( 1, 2 ), 1, CZ, DCONJG( SZ ) )
44805      IF( SA.GE.SB ) THEN
44806         CALL ZLARTG( S( 1, 1 ), S( 2, 1 ), CQ, SQ, CDUM )
44807      ELSE
44808         CALL ZLARTG( T( 1, 1 ), T( 2, 1 ), CQ, SQ, CDUM )
44809      END IF
44810      CALL ZROT( 2, S( 1, 1 ), LDST, S( 2, 1 ), LDST, CQ, SQ )
44811      CALL ZROT( 2, T( 1, 1 ), LDST, T( 2, 1 ), LDST, CQ, SQ )
44812*
44813*     Weak stability test: |S21| + |T21| <= O(EPS F-norm((S, T)))
44814*
44815      WS = ABS( S( 2, 1 ) ) + ABS( T( 2, 1 ) )
44816      WEAK = WS.LE.THRESH
44817      IF( .NOT.WEAK )
44818     $   GO TO 20
44819*
44820      IF( WANDS ) THEN
44821*
44822*        Strong stability test:
44823*           F-norm((A-QL**H*S*QR, B-QL**H*T*QR)) <= O(EPS*F-norm((A, B)))
44824*
44825         CALL ZLACPY( 'Full', M, M, S, LDST, WORK, M )
44826         CALL ZLACPY( 'Full', M, M, T, LDST, WORK( M*M+1 ), M )
44827         CALL ZROT( 2, WORK, 1, WORK( 3 ), 1, CZ, -DCONJG( SZ ) )
44828         CALL ZROT( 2, WORK( 5 ), 1, WORK( 7 ), 1, CZ, -DCONJG( SZ ) )
44829         CALL ZROT( 2, WORK, 2, WORK( 2 ), 2, CQ, -SQ )
44830         CALL ZROT( 2, WORK( 5 ), 2, WORK( 6 ), 2, CQ, -SQ )
44831         DO 10 I = 1, 2
44832            WORK( I ) = WORK( I ) - A( J1+I-1, J1 )
44833            WORK( I+2 ) = WORK( I+2 ) - A( J1+I-1, J1+1 )
44834            WORK( I+4 ) = WORK( I+4 ) - B( J1+I-1, J1 )
44835            WORK( I+6 ) = WORK( I+6 ) - B( J1+I-1, J1+1 )
44836   10    CONTINUE
44837         SCALE = DBLE( CZERO )
44838         SUM = DBLE( CONE )
44839         CALL ZLASSQ( 2*M*M, WORK, 1, SCALE, SUM )
44840         SS = SCALE*SQRT( SUM )
44841         DTRONG = SS.LE.THRESH
44842         IF( .NOT.DTRONG )
44843     $      GO TO 20
44844      END IF
44845*
44846*     If the swap is accepted ("weakly" and "strongly"), apply the
44847*     equivalence transformations to the original matrix pair (A,B)
44848*
44849      CALL ZROT( J1+1, A( 1, J1 ), 1, A( 1, J1+1 ), 1, CZ,
44850     $           DCONJG( SZ ) )
44851      CALL ZROT( J1+1, B( 1, J1 ), 1, B( 1, J1+1 ), 1, CZ,
44852     $           DCONJG( SZ ) )
44853      CALL ZROT( N-J1+1, A( J1, J1 ), LDA, A( J1+1, J1 ), LDA, CQ, SQ )
44854      CALL ZROT( N-J1+1, B( J1, J1 ), LDB, B( J1+1, J1 ), LDB, CQ, SQ )
44855*
44856*     Set  N1 by N2 (2,1) blocks to 0
44857*
44858      A( J1+1, J1 ) = CZERO
44859      B( J1+1, J1 ) = CZERO
44860*
44861*     Accumulate transformations into Q and Z if requested.
44862*
44863      IF( WANTZ )
44864     $   CALL ZROT( N, Z( 1, J1 ), 1, Z( 1, J1+1 ), 1, CZ,
44865     $              DCONJG( SZ ) )
44866      IF( WANTQ )
44867     $   CALL ZROT( N, Q( 1, J1 ), 1, Q( 1, J1+1 ), 1, CQ,
44868     $              DCONJG( SQ ) )
44869*
44870*     Exit with INFO = 0 if swap was successfully performed.
44871*
44872      RETURN
44873*
44874*     Exit with INFO = 1 if swap was rejected.
44875*
44876   20 CONTINUE
44877      INFO = 1
44878      RETURN
44879*
44880*     End of ZTGEX2
44881*
44882      END
44883*> \brief \b ZTGEXC
44884*
44885*  =========== DOCUMENTATION ===========
44886*
44887* Online html documentation available at
44888*            http://www.netlib.org/lapack/explore-html/
44889*
44890*> \htmlonly
44891*> Download ZTGEXC + dependencies
44892*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztgexc.f">
44893*> [TGZ]</a>
44894*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztgexc.f">
44895*> [ZIP]</a>
44896*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztgexc.f">
44897*> [TXT]</a>
44898*> \endhtmlonly
44899*
44900*  Definition:
44901*  ===========
44902*
44903*       SUBROUTINE ZTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
44904*                          LDZ, IFST, ILST, INFO )
44905*
44906*       .. Scalar Arguments ..
44907*       LOGICAL            WANTQ, WANTZ
44908*       INTEGER            IFST, ILST, INFO, LDA, LDB, LDQ, LDZ, N
44909*       ..
44910*       .. Array Arguments ..
44911*       COMPLEX*16         A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
44912*      $                   Z( LDZ, * )
44913*       ..
44914*
44915*
44916*> \par Purpose:
44917*  =============
44918*>
44919*> \verbatim
44920*>
44921*> ZTGEXC reorders the generalized Schur decomposition of a complex
44922*> matrix pair (A,B), using an unitary equivalence transformation
44923*> (A, B) := Q * (A, B) * Z**H, so that the diagonal block of (A, B) with
44924*> row index IFST is moved to row ILST.
44925*>
44926*> (A, B) must be in generalized Schur canonical form, that is, A and
44927*> B are both upper triangular.
44928*>
44929*> Optionally, the matrices Q and Z of generalized Schur vectors are
44930*> updated.
44931*>
44932*>        Q(in) * A(in) * Z(in)**H = Q(out) * A(out) * Z(out)**H
44933*>        Q(in) * B(in) * Z(in)**H = Q(out) * B(out) * Z(out)**H
44934*> \endverbatim
44935*
44936*  Arguments:
44937*  ==========
44938*
44939*> \param[in] WANTQ
44940*> \verbatim
44941*>          WANTQ is LOGICAL
44942*>          .TRUE. : update the left transformation matrix Q;
44943*>          .FALSE.: do not update Q.
44944*> \endverbatim
44945*>
44946*> \param[in] WANTZ
44947*> \verbatim
44948*>          WANTZ is LOGICAL
44949*>          .TRUE. : update the right transformation matrix Z;
44950*>          .FALSE.: do not update Z.
44951*> \endverbatim
44952*>
44953*> \param[in] N
44954*> \verbatim
44955*>          N is INTEGER
44956*>          The order of the matrices A and B. N >= 0.
44957*> \endverbatim
44958*>
44959*> \param[in,out] A
44960*> \verbatim
44961*>          A is COMPLEX*16 array, dimension (LDA,N)
44962*>          On entry, the upper triangular matrix A in the pair (A, B).
44963*>          On exit, the updated matrix A.
44964*> \endverbatim
44965*>
44966*> \param[in] LDA
44967*> \verbatim
44968*>          LDA is INTEGER
44969*>          The leading dimension of the array A. LDA >= max(1,N).
44970*> \endverbatim
44971*>
44972*> \param[in,out] B
44973*> \verbatim
44974*>          B is COMPLEX*16 array, dimension (LDB,N)
44975*>          On entry, the upper triangular matrix B in the pair (A, B).
44976*>          On exit, the updated matrix B.
44977*> \endverbatim
44978*>
44979*> \param[in] LDB
44980*> \verbatim
44981*>          LDB is INTEGER
44982*>          The leading dimension of the array B. LDB >= max(1,N).
44983*> \endverbatim
44984*>
44985*> \param[in,out] Q
44986*> \verbatim
44987*>          Q is COMPLEX*16 array, dimension (LDQ,N)
44988*>          On entry, if WANTQ = .TRUE., the unitary matrix Q.
44989*>          On exit, the updated matrix Q.
44990*>          If WANTQ = .FALSE., Q is not referenced.
44991*> \endverbatim
44992*>
44993*> \param[in] LDQ
44994*> \verbatim
44995*>          LDQ is INTEGER
44996*>          The leading dimension of the array Q. LDQ >= 1;
44997*>          If WANTQ = .TRUE., LDQ >= N.
44998*> \endverbatim
44999*>
45000*> \param[in,out] Z
45001*> \verbatim
45002*>          Z is COMPLEX*16 array, dimension (LDZ,N)
45003*>          On entry, if WANTZ = .TRUE., the unitary matrix Z.
45004*>          On exit, the updated matrix Z.
45005*>          If WANTZ = .FALSE., Z is not referenced.
45006*> \endverbatim
45007*>
45008*> \param[in] LDZ
45009*> \verbatim
45010*>          LDZ is INTEGER
45011*>          The leading dimension of the array Z. LDZ >= 1;
45012*>          If WANTZ = .TRUE., LDZ >= N.
45013*> \endverbatim
45014*>
45015*> \param[in] IFST
45016*> \verbatim
45017*>          IFST is INTEGER
45018*> \endverbatim
45019*>
45020*> \param[in,out] ILST
45021*> \verbatim
45022*>          ILST is INTEGER
45023*>          Specify the reordering of the diagonal blocks of (A, B).
45024*>          The block with row index IFST is moved to row ILST, by a
45025*>          sequence of swapping between adjacent blocks.
45026*> \endverbatim
45027*>
45028*> \param[out] INFO
45029*> \verbatim
45030*>          INFO is INTEGER
45031*>           =0:  Successful exit.
45032*>           <0:  if INFO = -i, the i-th argument had an illegal value.
45033*>           =1:  The transformed matrix pair (A, B) would be too far
45034*>                from generalized Schur form; the problem is ill-
45035*>                conditioned. (A, B) may have been partially reordered,
45036*>                and ILST points to the first row of the current
45037*>                position of the block being moved.
45038*> \endverbatim
45039*
45040*  Authors:
45041*  ========
45042*
45043*> \author Univ. of Tennessee
45044*> \author Univ. of California Berkeley
45045*> \author Univ. of Colorado Denver
45046*> \author NAG Ltd.
45047*
45048*> \date June 2017
45049*
45050*> \ingroup complex16GEcomputational
45051*
45052*> \par Contributors:
45053*  ==================
45054*>
45055*>     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
45056*>     Umea University, S-901 87 Umea, Sweden.
45057*
45058*> \par References:
45059*  ================
45060*>
45061*>  [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
45062*>      Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
45063*>      M.S. Moonen et al (eds), Linear Algebra for Large Scale and
45064*>      Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
45065*> \n
45066*>  [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
45067*>      Eigenvalues of a Regular Matrix Pair (A, B) and Condition
45068*>      Estimation: Theory, Algorithms and Software, Report
45069*>      UMINF - 94.04, Department of Computing Science, Umea University,
45070*>      S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.
45071*>      To appear in Numerical Algorithms, 1996.
45072*> \n
45073*>  [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
45074*>      for Solving the Generalized Sylvester Equation and Estimating the
45075*>      Separation between Regular Matrix Pairs, Report UMINF - 93.23,
45076*>      Department of Computing Science, Umea University, S-901 87 Umea,
45077*>      Sweden, December 1993, Revised April 1994, Also as LAPACK working
45078*>      Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1,
45079*>      1996.
45080*>
45081*  =====================================================================
45082      SUBROUTINE ZTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
45083     $                   LDZ, IFST, ILST, INFO )
45084*
45085*  -- LAPACK computational routine (version 3.7.1) --
45086*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
45087*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
45088*     June 2017
45089*
45090*     .. Scalar Arguments ..
45091      LOGICAL            WANTQ, WANTZ
45092      INTEGER            IFST, ILST, INFO, LDA, LDB, LDQ, LDZ, N
45093*     ..
45094*     .. Array Arguments ..
45095      COMPLEX*16         A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
45096     $                   Z( LDZ, * )
45097*     ..
45098*
45099*  =====================================================================
45100*
45101*     .. Local Scalars ..
45102      INTEGER            HERE
45103*     ..
45104*     .. External Subroutines ..
45105      EXTERNAL           XERBLA, ZTGEX2
45106*     ..
45107*     .. Intrinsic Functions ..
45108      INTRINSIC          MAX
45109*     ..
45110*     .. Executable Statements ..
45111*
45112*     Decode and test input arguments.
45113      INFO = 0
45114      IF( N.LT.0 ) THEN
45115         INFO = -3
45116      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
45117         INFO = -5
45118      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
45119         INFO = -7
45120      ELSE IF( LDQ.LT.1 .OR. WANTQ .AND. ( LDQ.LT.MAX( 1, N ) ) ) THEN
45121         INFO = -9
45122      ELSE IF( LDZ.LT.1 .OR. WANTZ .AND. ( LDZ.LT.MAX( 1, N ) ) ) THEN
45123         INFO = -11
45124      ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN
45125         INFO = -12
45126      ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN
45127         INFO = -13
45128      END IF
45129      IF( INFO.NE.0 ) THEN
45130         CALL XERBLA( 'ZTGEXC', -INFO )
45131         RETURN
45132      END IF
45133*
45134*     Quick return if possible
45135*
45136      IF( N.LE.1 )
45137     $   RETURN
45138      IF( IFST.EQ.ILST )
45139     $   RETURN
45140*
45141      IF( IFST.LT.ILST ) THEN
45142*
45143         HERE = IFST
45144*
45145   10    CONTINUE
45146*
45147*        Swap with next one below
45148*
45149         CALL ZTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ,
45150     $                HERE, INFO )
45151         IF( INFO.NE.0 ) THEN
45152            ILST = HERE
45153            RETURN
45154         END IF
45155         HERE = HERE + 1
45156         IF( HERE.LT.ILST )
45157     $      GO TO 10
45158         HERE = HERE - 1
45159      ELSE
45160         HERE = IFST - 1
45161*
45162   20    CONTINUE
45163*
45164*        Swap with next one above
45165*
45166         CALL ZTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ,
45167     $                HERE, INFO )
45168         IF( INFO.NE.0 ) THEN
45169            ILST = HERE
45170            RETURN
45171         END IF
45172         HERE = HERE - 1
45173         IF( HERE.GE.ILST )
45174     $      GO TO 20
45175         HERE = HERE + 1
45176      END IF
45177      ILST = HERE
45178      RETURN
45179*
45180*     End of ZTGEXC
45181*
45182      END
45183*> \brief \b ZTGSEN
45184*
45185*  =========== DOCUMENTATION ===========
45186*
45187* Online html documentation available at
45188*            http://www.netlib.org/lapack/explore-html/
45189*
45190*> \htmlonly
45191*> Download ZTGSEN + dependencies
45192*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztgsen.f">
45193*> [TGZ]</a>
45194*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztgsen.f">
45195*> [ZIP]</a>
45196*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztgsen.f">
45197*> [TXT]</a>
45198*> \endhtmlonly
45199*
45200*  Definition:
45201*  ===========
45202*
45203*       SUBROUTINE ZTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB,
45204*                          ALPHA, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF,
45205*                          WORK, LWORK, IWORK, LIWORK, INFO )
45206*
45207*       .. Scalar Arguments ..
45208*       LOGICAL            WANTQ, WANTZ
45209*       INTEGER            IJOB, INFO, LDA, LDB, LDQ, LDZ, LIWORK, LWORK,
45210*      $                   M, N
45211*       DOUBLE PRECISION   PL, PR
45212*       ..
45213*       .. Array Arguments ..
45214*       LOGICAL            SELECT( * )
45215*       INTEGER            IWORK( * )
45216*       DOUBLE PRECISION   DIF( * )
45217*       COMPLEX*16         A( LDA, * ), ALPHA( * ), B( LDB, * ),
45218*      $                   BETA( * ), Q( LDQ, * ), WORK( * ), Z( LDZ, * )
45219*       ..
45220*
45221*
45222*> \par Purpose:
45223*  =============
45224*>
45225*> \verbatim
45226*>
45227*> ZTGSEN reorders the generalized Schur decomposition of a complex
45228*> matrix pair (A, B) (in terms of an unitary equivalence trans-
45229*> formation Q**H * (A, B) * Z), so that a selected cluster of eigenvalues
45230*> appears in the leading diagonal blocks of the pair (A,B). The leading
45231*> columns of Q and Z form unitary bases of the corresponding left and
45232*> right eigenspaces (deflating subspaces). (A, B) must be in
45233*> generalized Schur canonical form, that is, A and B are both upper
45234*> triangular.
45235*>
45236*> ZTGSEN also computes the generalized eigenvalues
45237*>
45238*>          w(j)= ALPHA(j) / BETA(j)
45239*>
45240*> of the reordered matrix pair (A, B).
45241*>
45242*> Optionally, the routine computes estimates of reciprocal condition
45243*> numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11),
45244*> (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s)
45245*> between the matrix pairs (A11, B11) and (A22,B22) that correspond to
45246*> the selected cluster and the eigenvalues outside the cluster, resp.,
45247*> and norms of "projections" onto left and right eigenspaces w.r.t.
45248*> the selected cluster in the (1,1)-block.
45249*>
45250*> \endverbatim
45251*
45252*  Arguments:
45253*  ==========
45254*
45255*> \param[in] IJOB
45256*> \verbatim
45257*>          IJOB is INTEGER
45258*>          Specifies whether condition numbers are required for the
45259*>          cluster of eigenvalues (PL and PR) or the deflating subspaces
45260*>          (Difu and Difl):
45261*>           =0: Only reorder w.r.t. SELECT. No extras.
45262*>           =1: Reciprocal of norms of "projections" onto left and right
45263*>               eigenspaces w.r.t. the selected cluster (PL and PR).
45264*>           =2: Upper bounds on Difu and Difl. F-norm-based estimate
45265*>               (DIF(1:2)).
45266*>           =3: Estimate of Difu and Difl. 1-norm-based estimate
45267*>               (DIF(1:2)).
45268*>               About 5 times as expensive as IJOB = 2.
45269*>           =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic
45270*>               version to get it all.
45271*>           =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above)
45272*> \endverbatim
45273*>
45274*> \param[in] WANTQ
45275*> \verbatim
45276*>          WANTQ is LOGICAL
45277*>          .TRUE. : update the left transformation matrix Q;
45278*>          .FALSE.: do not update Q.
45279*> \endverbatim
45280*>
45281*> \param[in] WANTZ
45282*> \verbatim
45283*>          WANTZ is LOGICAL
45284*>          .TRUE. : update the right transformation matrix Z;
45285*>          .FALSE.: do not update Z.
45286*> \endverbatim
45287*>
45288*> \param[in] SELECT
45289*> \verbatim
45290*>          SELECT is LOGICAL array, dimension (N)
45291*>          SELECT specifies the eigenvalues in the selected cluster. To
45292*>          select an eigenvalue w(j), SELECT(j) must be set to
45293*>          .TRUE..
45294*> \endverbatim
45295*>
45296*> \param[in] N
45297*> \verbatim
45298*>          N is INTEGER
45299*>          The order of the matrices A and B. N >= 0.
45300*> \endverbatim
45301*>
45302*> \param[in,out] A
45303*> \verbatim
45304*>          A is COMPLEX*16 array, dimension(LDA,N)
45305*>          On entry, the upper triangular matrix A, in generalized
45306*>          Schur canonical form.
45307*>          On exit, A is overwritten by the reordered matrix A.
45308*> \endverbatim
45309*>
45310*> \param[in] LDA
45311*> \verbatim
45312*>          LDA is INTEGER
45313*>          The leading dimension of the array A. LDA >= max(1,N).
45314*> \endverbatim
45315*>
45316*> \param[in,out] B
45317*> \verbatim
45318*>          B is COMPLEX*16 array, dimension(LDB,N)
45319*>          On entry, the upper triangular matrix B, in generalized
45320*>          Schur canonical form.
45321*>          On exit, B is overwritten by the reordered matrix B.
45322*> \endverbatim
45323*>
45324*> \param[in] LDB
45325*> \verbatim
45326*>          LDB is INTEGER
45327*>          The leading dimension of the array B. LDB >= max(1,N).
45328*> \endverbatim
45329*>
45330*> \param[out] ALPHA
45331*> \verbatim
45332*>          ALPHA is COMPLEX*16 array, dimension (N)
45333*> \endverbatim
45334*>
45335*> \param[out] BETA
45336*> \verbatim
45337*>          BETA is COMPLEX*16 array, dimension (N)
45338*>
45339*>          The diagonal elements of A and B, respectively,
45340*>          when the pair (A,B) has been reduced to generalized Schur
45341*>          form.  ALPHA(i)/BETA(i) i=1,...,N are the generalized
45342*>          eigenvalues.
45343*> \endverbatim
45344*>
45345*> \param[in,out] Q
45346*> \verbatim
45347*>          Q is COMPLEX*16 array, dimension (LDQ,N)
45348*>          On entry, if WANTQ = .TRUE., Q is an N-by-N matrix.
45349*>          On exit, Q has been postmultiplied by the left unitary
45350*>          transformation matrix which reorder (A, B); The leading M
45351*>          columns of Q form orthonormal bases for the specified pair of
45352*>          left eigenspaces (deflating subspaces).
45353*>          If WANTQ = .FALSE., Q is not referenced.
45354*> \endverbatim
45355*>
45356*> \param[in] LDQ
45357*> \verbatim
45358*>          LDQ is INTEGER
45359*>          The leading dimension of the array Q. LDQ >= 1.
45360*>          If WANTQ = .TRUE., LDQ >= N.
45361*> \endverbatim
45362*>
45363*> \param[in,out] Z
45364*> \verbatim
45365*>          Z is COMPLEX*16 array, dimension (LDZ,N)
45366*>          On entry, if WANTZ = .TRUE., Z is an N-by-N matrix.
45367*>          On exit, Z has been postmultiplied by the left unitary
45368*>          transformation matrix which reorder (A, B); The leading M
45369*>          columns of Z form orthonormal bases for the specified pair of
45370*>          left eigenspaces (deflating subspaces).
45371*>          If WANTZ = .FALSE., Z is not referenced.
45372*> \endverbatim
45373*>
45374*> \param[in] LDZ
45375*> \verbatim
45376*>          LDZ is INTEGER
45377*>          The leading dimension of the array Z. LDZ >= 1.
45378*>          If WANTZ = .TRUE., LDZ >= N.
45379*> \endverbatim
45380*>
45381*> \param[out] M
45382*> \verbatim
45383*>          M is INTEGER
45384*>          The dimension of the specified pair of left and right
45385*>          eigenspaces, (deflating subspaces) 0 <= M <= N.
45386*> \endverbatim
45387*>
45388*> \param[out] PL
45389*> \verbatim
45390*>          PL is DOUBLE PRECISION
45391*> \endverbatim
45392*>
45393*> \param[out] PR
45394*> \verbatim
45395*>          PR is DOUBLE PRECISION
45396*>
45397*>          If IJOB = 1, 4 or 5, PL, PR are lower bounds on the
45398*>          reciprocal  of the norm of "projections" onto left and right
45399*>          eigenspace with respect to the selected cluster.
45400*>          0 < PL, PR <= 1.
45401*>          If M = 0 or M = N, PL = PR  = 1.
45402*>          If IJOB = 0, 2 or 3 PL, PR are not referenced.
45403*> \endverbatim
45404*>
45405*> \param[out] DIF
45406*> \verbatim
45407*>          DIF is DOUBLE PRECISION array, dimension (2).
45408*>          If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl.
45409*>          If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on
45410*>          Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based
45411*>          estimates of Difu and Difl, computed using reversed
45412*>          communication with ZLACN2.
45413*>          If M = 0 or N, DIF(1:2) = F-norm([A, B]).
45414*>          If IJOB = 0 or 1, DIF is not referenced.
45415*> \endverbatim
45416*>
45417*> \param[out] WORK
45418*> \verbatim
45419*>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
45420*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
45421*> \endverbatim
45422*>
45423*> \param[in] LWORK
45424*> \verbatim
45425*>          LWORK is INTEGER
45426*>          The dimension of the array WORK. LWORK >=  1
45427*>          If IJOB = 1, 2 or 4, LWORK >=  2*M*(N-M)
45428*>          If IJOB = 3 or 5, LWORK >=  4*M*(N-M)
45429*>
45430*>          If LWORK = -1, then a workspace query is assumed; the routine
45431*>          only calculates the optimal size of the WORK array, returns
45432*>          this value as the first entry of the WORK array, and no error
45433*>          message related to LWORK is issued by XERBLA.
45434*> \endverbatim
45435*>
45436*> \param[out] IWORK
45437*> \verbatim
45438*>          IWORK is INTEGER array, dimension (MAX(1,LIWORK))
45439*>          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
45440*> \endverbatim
45441*>
45442*> \param[in] LIWORK
45443*> \verbatim
45444*>          LIWORK is INTEGER
45445*>          The dimension of the array IWORK. LIWORK >= 1.
45446*>          If IJOB = 1, 2 or 4, LIWORK >=  N+2;
45447*>          If IJOB = 3 or 5, LIWORK >= MAX(N+2, 2*M*(N-M));
45448*>
45449*>          If LIWORK = -1, then a workspace query is assumed; the
45450*>          routine only calculates the optimal size of the IWORK array,
45451*>          returns this value as the first entry of the IWORK array, and
45452*>          no error message related to LIWORK is issued by XERBLA.
45453*> \endverbatim
45454*>
45455*> \param[out] INFO
45456*> \verbatim
45457*>          INFO is INTEGER
45458*>            =0: Successful exit.
45459*>            <0: If INFO = -i, the i-th argument had an illegal value.
45460*>            =1: Reordering of (A, B) failed because the transformed
45461*>                matrix pair (A, B) would be too far from generalized
45462*>                Schur form; the problem is very ill-conditioned.
45463*>                (A, B) may have been partially reordered.
45464*>                If requested, 0 is returned in DIF(*), PL and PR.
45465*> \endverbatim
45466*
45467*  Authors:
45468*  ========
45469*
45470*> \author Univ. of Tennessee
45471*> \author Univ. of California Berkeley
45472*> \author Univ. of Colorado Denver
45473*> \author NAG Ltd.
45474*
45475*> \date June 2016
45476*
45477*> \ingroup complex16OTHERcomputational
45478*
45479*> \par Further Details:
45480*  =====================
45481*>
45482*> \verbatim
45483*>
45484*>  ZTGSEN first collects the selected eigenvalues by computing unitary
45485*>  U and W that move them to the top left corner of (A, B). In other
45486*>  words, the selected eigenvalues are the eigenvalues of (A11, B11) in
45487*>
45488*>              U**H*(A, B)*W = (A11 A12) (B11 B12) n1
45489*>                              ( 0  A22),( 0  B22) n2
45490*>                                n1  n2    n1  n2
45491*>
45492*>  where N = n1+n2 and U**H means the conjugate transpose of U. The first
45493*>  n1 columns of U and W span the specified pair of left and right
45494*>  eigenspaces (deflating subspaces) of (A, B).
45495*>
45496*>  If (A, B) has been obtained from the generalized real Schur
45497*>  decomposition of a matrix pair (C, D) = Q*(A, B)*Z**H, then the
45498*>  reordered generalized Schur form of (C, D) is given by
45499*>
45500*>           (C, D) = (Q*U)*(U**H *(A, B)*W)*(Z*W)**H,
45501*>
45502*>  and the first n1 columns of Q*U and Z*W span the corresponding
45503*>  deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.).
45504*>
45505*>  Note that if the selected eigenvalue is sufficiently ill-conditioned,
45506*>  then its value may differ significantly from its value before
45507*>  reordering.
45508*>
45509*>  The reciprocal condition numbers of the left and right eigenspaces
45510*>  spanned by the first n1 columns of U and W (or Q*U and Z*W) may
45511*>  be returned in DIF(1:2), corresponding to Difu and Difl, resp.
45512*>
45513*>  The Difu and Difl are defined as:
45514*>
45515*>       Difu[(A11, B11), (A22, B22)] = sigma-min( Zu )
45516*>  and
45517*>       Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)],
45518*>
45519*>  where sigma-min(Zu) is the smallest singular value of the
45520*>  (2*n1*n2)-by-(2*n1*n2) matrix
45521*>
45522*>       Zu = [ kron(In2, A11)  -kron(A22**H, In1) ]
45523*>            [ kron(In2, B11)  -kron(B22**H, In1) ].
45524*>
45525*>  Here, Inx is the identity matrix of size nx and A22**H is the
45526*>  conjugate transpose of A22. kron(X, Y) is the Kronecker product between
45527*>  the matrices X and Y.
45528*>
45529*>  When DIF(2) is small, small changes in (A, B) can cause large changes
45530*>  in the deflating subspace. An approximate (asymptotic) bound on the
45531*>  maximum angular error in the computed deflating subspaces is
45532*>
45533*>       EPS * norm((A, B)) / DIF(2),
45534*>
45535*>  where EPS is the machine precision.
45536*>
45537*>  The reciprocal norm of the projectors on the left and right
45538*>  eigenspaces associated with (A11, B11) may be returned in PL and PR.
45539*>  They are computed as follows. First we compute L and R so that
45540*>  P*(A, B)*Q is block diagonal, where
45541*>
45542*>       P = ( I -L ) n1           Q = ( I R ) n1
45543*>           ( 0  I ) n2    and        ( 0 I ) n2
45544*>             n1 n2                    n1 n2
45545*>
45546*>  and (L, R) is the solution to the generalized Sylvester equation
45547*>
45548*>       A11*R - L*A22 = -A12
45549*>       B11*R - L*B22 = -B12
45550*>
45551*>  Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2).
45552*>  An approximate (asymptotic) bound on the average absolute error of
45553*>  the selected eigenvalues is
45554*>
45555*>       EPS * norm((A, B)) / PL.
45556*>
45557*>  There are also global error bounds which valid for perturbations up
45558*>  to a certain restriction:  A lower bound (x) on the smallest
45559*>  F-norm(E,F) for which an eigenvalue of (A11, B11) may move and
45560*>  coalesce with an eigenvalue of (A22, B22) under perturbation (E,F),
45561*>  (i.e. (A + E, B + F), is
45562*>
45563*>   x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)).
45564*>
45565*>  An approximate bound on x can be computed from DIF(1:2), PL and PR.
45566*>
45567*>  If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed
45568*>  (L', R') and unperturbed (L, R) left and right deflating subspaces
45569*>  associated with the selected cluster in the (1,1)-blocks can be
45570*>  bounded as
45571*>
45572*>   max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2))
45573*>   max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2))
45574*>
45575*>  See LAPACK User's Guide section 4.11 or the following references
45576*>  for more information.
45577*>
45578*>  Note that if the default method for computing the Frobenius-norm-
45579*>  based estimate DIF is not wanted (see ZLATDF), then the parameter
45580*>  IDIFJB (see below) should be changed from 3 to 4 (routine ZLATDF
45581*>  (IJOB = 2 will be used)). See ZTGSYL for more details.
45582*> \endverbatim
45583*
45584*> \par Contributors:
45585*  ==================
45586*>
45587*>     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
45588*>     Umea University, S-901 87 Umea, Sweden.
45589*
45590*> \par References:
45591*  ================
45592*>
45593*>  [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
45594*>      Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
45595*>      M.S. Moonen et al (eds), Linear Algebra for Large Scale and
45596*>      Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
45597*> \n
45598*>  [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
45599*>      Eigenvalues of a Regular Matrix Pair (A, B) and Condition
45600*>      Estimation: Theory, Algorithms and Software, Report
45601*>      UMINF - 94.04, Department of Computing Science, Umea University,
45602*>      S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.
45603*>      To appear in Numerical Algorithms, 1996.
45604*> \n
45605*>  [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
45606*>      for Solving the Generalized Sylvester Equation and Estimating the
45607*>      Separation between Regular Matrix Pairs, Report UMINF - 93.23,
45608*>      Department of Computing Science, Umea University, S-901 87 Umea,
45609*>      Sweden, December 1993, Revised April 1994, Also as LAPACK working
45610*>      Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1,
45611*>      1996.
45612*>
45613*  =====================================================================
45614      SUBROUTINE ZTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB,
45615     $                   ALPHA, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF,
45616     $                   WORK, LWORK, IWORK, LIWORK, INFO )
45617*
45618*  -- LAPACK computational routine (version 3.7.1) --
45619*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
45620*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
45621*     June 2016
45622*
45623*     .. Scalar Arguments ..
45624      LOGICAL            WANTQ, WANTZ
45625      INTEGER            IJOB, INFO, LDA, LDB, LDQ, LDZ, LIWORK, LWORK,
45626     $                   M, N
45627      DOUBLE PRECISION   PL, PR
45628*     ..
45629*     .. Array Arguments ..
45630      LOGICAL            SELECT( * )
45631      INTEGER            IWORK( * )
45632      DOUBLE PRECISION   DIF( * )
45633      COMPLEX*16         A( LDA, * ), ALPHA( * ), B( LDB, * ),
45634     $                   BETA( * ), Q( LDQ, * ), WORK( * ), Z( LDZ, * )
45635*     ..
45636*
45637*  =====================================================================
45638*
45639*     .. Parameters ..
45640      INTEGER            IDIFJB
45641      PARAMETER          ( IDIFJB = 3 )
45642      DOUBLE PRECISION   ZERO, ONE
45643      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
45644*     ..
45645*     .. Local Scalars ..
45646      LOGICAL            LQUERY, SWAP, WANTD, WANTD1, WANTD2, WANTP
45647      INTEGER            I, IERR, IJB, K, KASE, KS, LIWMIN, LWMIN, MN2,
45648     $                   N1, N2
45649      DOUBLE PRECISION   DSCALE, DSUM, RDSCAL, SAFMIN
45650      COMPLEX*16         TEMP1, TEMP2
45651*     ..
45652*     .. Local Arrays ..
45653      INTEGER            ISAVE( 3 )
45654*     ..
45655*     .. External Subroutines ..
45656      EXTERNAL           XERBLA, ZLACN2, ZLACPY, ZLASSQ, ZSCAL, ZTGEXC,
45657     $                   ZTGSYL
45658*     ..
45659*     .. Intrinsic Functions ..
45660      INTRINSIC          ABS, DCMPLX, DCONJG, MAX, SQRT
45661*     ..
45662*     .. External Functions ..
45663      DOUBLE PRECISION   DLAMCH
45664      EXTERNAL           DLAMCH
45665*     ..
45666*     .. Executable Statements ..
45667*
45668*     Decode and test the input parameters
45669*
45670      INFO = 0
45671      LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
45672*
45673      IF( IJOB.LT.0 .OR. IJOB.GT.5 ) THEN
45674         INFO = -1
45675      ELSE IF( N.LT.0 ) THEN
45676         INFO = -5
45677      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
45678         INFO = -7
45679      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
45680         INFO = -9
45681      ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
45682         INFO = -13
45683      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
45684         INFO = -15
45685      END IF
45686*
45687      IF( INFO.NE.0 ) THEN
45688         CALL XERBLA( 'ZTGSEN', -INFO )
45689         RETURN
45690      END IF
45691*
45692      IERR = 0
45693*
45694      WANTP = IJOB.EQ.1 .OR. IJOB.GE.4
45695      WANTD1 = IJOB.EQ.2 .OR. IJOB.EQ.4
45696      WANTD2 = IJOB.EQ.3 .OR. IJOB.EQ.5
45697      WANTD = WANTD1 .OR. WANTD2
45698*
45699*     Set M to the dimension of the specified pair of deflating
45700*     subspaces.
45701*
45702      M = 0
45703      IF( .NOT.LQUERY .OR. IJOB.NE.0 ) THEN
45704      DO 10 K = 1, N
45705         ALPHA( K ) = A( K, K )
45706         BETA( K ) = B( K, K )
45707         IF( K.LT.N ) THEN
45708            IF( SELECT( K ) )
45709     $         M = M + 1
45710         ELSE
45711            IF( SELECT( N ) )
45712     $         M = M + 1
45713         END IF
45714   10 CONTINUE
45715      END IF
45716*
45717      IF( IJOB.EQ.1 .OR. IJOB.EQ.2 .OR. IJOB.EQ.4 ) THEN
45718         LWMIN = MAX( 1, 2*M*( N-M ) )
45719         LIWMIN = MAX( 1, N+2 )
45720      ELSE IF( IJOB.EQ.3 .OR. IJOB.EQ.5 ) THEN
45721         LWMIN = MAX( 1, 4*M*( N-M ) )
45722         LIWMIN = MAX( 1, 2*M*( N-M ), N+2 )
45723      ELSE
45724         LWMIN = 1
45725         LIWMIN = 1
45726      END IF
45727*
45728      WORK( 1 ) = LWMIN
45729      IWORK( 1 ) = LIWMIN
45730*
45731      IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
45732         INFO = -21
45733      ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
45734         INFO = -23
45735      END IF
45736*
45737      IF( INFO.NE.0 ) THEN
45738         CALL XERBLA( 'ZTGSEN', -INFO )
45739         RETURN
45740      ELSE IF( LQUERY ) THEN
45741         RETURN
45742      END IF
45743*
45744*     Quick return if possible.
45745*
45746      IF( M.EQ.N .OR. M.EQ.0 ) THEN
45747         IF( WANTP ) THEN
45748            PL = ONE
45749            PR = ONE
45750         END IF
45751         IF( WANTD ) THEN
45752            DSCALE = ZERO
45753            DSUM = ONE
45754            DO 20 I = 1, N
45755               CALL ZLASSQ( N, A( 1, I ), 1, DSCALE, DSUM )
45756               CALL ZLASSQ( N, B( 1, I ), 1, DSCALE, DSUM )
45757   20       CONTINUE
45758            DIF( 1 ) = DSCALE*SQRT( DSUM )
45759            DIF( 2 ) = DIF( 1 )
45760         END IF
45761         GO TO 70
45762      END IF
45763*
45764*     Get machine constant
45765*
45766      SAFMIN = DLAMCH( 'S' )
45767*
45768*     Collect the selected blocks at the top-left corner of (A, B).
45769*
45770      KS = 0
45771      DO 30 K = 1, N
45772         SWAP = SELECT( K )
45773         IF( SWAP ) THEN
45774            KS = KS + 1
45775*
45776*           Swap the K-th block to position KS. Compute unitary Q
45777*           and Z that will swap adjacent diagonal blocks in (A, B).
45778*
45779            IF( K.NE.KS )
45780     $         CALL ZTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
45781     $                      LDZ, K, KS, IERR )
45782*
45783            IF( IERR.GT.0 ) THEN
45784*
45785*              Swap is rejected: exit.
45786*
45787               INFO = 1
45788               IF( WANTP ) THEN
45789                  PL = ZERO
45790                  PR = ZERO
45791               END IF
45792               IF( WANTD ) THEN
45793                  DIF( 1 ) = ZERO
45794                  DIF( 2 ) = ZERO
45795               END IF
45796               GO TO 70
45797            END IF
45798         END IF
45799   30 CONTINUE
45800      IF( WANTP ) THEN
45801*
45802*        Solve generalized Sylvester equation for R and L:
45803*                   A11 * R - L * A22 = A12
45804*                   B11 * R - L * B22 = B12
45805*
45806         N1 = M
45807         N2 = N - M
45808         I = N1 + 1
45809         CALL ZLACPY( 'Full', N1, N2, A( 1, I ), LDA, WORK, N1 )
45810         CALL ZLACPY( 'Full', N1, N2, B( 1, I ), LDB, WORK( N1*N2+1 ),
45811     $                N1 )
45812         IJB = 0
45813         CALL ZTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK,
45814     $                N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ), N1,
45815     $                DSCALE, DIF( 1 ), WORK( N1*N2*2+1 ),
45816     $                LWORK-2*N1*N2, IWORK, IERR )
45817*
45818*        Estimate the reciprocal of norms of "projections" onto
45819*        left and right eigenspaces
45820*
45821         RDSCAL = ZERO
45822         DSUM = ONE
45823         CALL ZLASSQ( N1*N2, WORK, 1, RDSCAL, DSUM )
45824         PL = RDSCAL*SQRT( DSUM )
45825         IF( PL.EQ.ZERO ) THEN
45826            PL = ONE
45827         ELSE
45828            PL = DSCALE / ( SQRT( DSCALE*DSCALE / PL+PL )*SQRT( PL ) )
45829         END IF
45830         RDSCAL = ZERO
45831         DSUM = ONE
45832         CALL ZLASSQ( N1*N2, WORK( N1*N2+1 ), 1, RDSCAL, DSUM )
45833         PR = RDSCAL*SQRT( DSUM )
45834         IF( PR.EQ.ZERO ) THEN
45835            PR = ONE
45836         ELSE
45837            PR = DSCALE / ( SQRT( DSCALE*DSCALE / PR+PR )*SQRT( PR ) )
45838         END IF
45839      END IF
45840      IF( WANTD ) THEN
45841*
45842*        Compute estimates Difu and Difl.
45843*
45844         IF( WANTD1 ) THEN
45845            N1 = M
45846            N2 = N - M
45847            I = N1 + 1
45848            IJB = IDIFJB
45849*
45850*           Frobenius norm-based Difu estimate.
45851*
45852            CALL ZTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK,
45853     $                   N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ),
45854     $                   N1, DSCALE, DIF( 1 ), WORK( N1*N2*2+1 ),
45855     $                   LWORK-2*N1*N2, IWORK, IERR )
45856*
45857*           Frobenius norm-based Difl estimate.
45858*
45859            CALL ZTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA, WORK,
45860     $                   N2, B( I, I ), LDB, B, LDB, WORK( N1*N2+1 ),
45861     $                   N2, DSCALE, DIF( 2 ), WORK( N1*N2*2+1 ),
45862     $                   LWORK-2*N1*N2, IWORK, IERR )
45863         ELSE
45864*
45865*           Compute 1-norm-based estimates of Difu and Difl using
45866*           reversed communication with ZLACN2. In each step a
45867*           generalized Sylvester equation or a transposed variant
45868*           is solved.
45869*
45870            KASE = 0
45871            N1 = M
45872            N2 = N - M
45873            I = N1 + 1
45874            IJB = 0
45875            MN2 = 2*N1*N2
45876*
45877*           1-norm-based estimate of Difu.
45878*
45879   40       CONTINUE
45880            CALL ZLACN2( MN2, WORK( MN2+1 ), WORK, DIF( 1 ), KASE,
45881     $                   ISAVE )
45882            IF( KASE.NE.0 ) THEN
45883               IF( KASE.EQ.1 ) THEN
45884*
45885*                 Solve generalized Sylvester equation
45886*
45887                  CALL ZTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA,
45888     $                         WORK, N1, B, LDB, B( I, I ), LDB,
45889     $                         WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ),
45890     $                         WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK,
45891     $                         IERR )
45892               ELSE
45893*
45894*                 Solve the transposed variant.
45895*
45896                  CALL ZTGSYL( 'C', IJB, N1, N2, A, LDA, A( I, I ), LDA,
45897     $                         WORK, N1, B, LDB, B( I, I ), LDB,
45898     $                         WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ),
45899     $                         WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK,
45900     $                         IERR )
45901               END IF
45902               GO TO 40
45903            END IF
45904            DIF( 1 ) = DSCALE / DIF( 1 )
45905*
45906*           1-norm-based estimate of Difl.
45907*
45908   50       CONTINUE
45909            CALL ZLACN2( MN2, WORK( MN2+1 ), WORK, DIF( 2 ), KASE,
45910     $                   ISAVE )
45911            IF( KASE.NE.0 ) THEN
45912               IF( KASE.EQ.1 ) THEN
45913*
45914*                 Solve generalized Sylvester equation
45915*
45916                  CALL ZTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA,
45917     $                         WORK, N2, B( I, I ), LDB, B, LDB,
45918     $                         WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ),
45919     $                         WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK,
45920     $                         IERR )
45921               ELSE
45922*
45923*                 Solve the transposed variant.
45924*
45925                  CALL ZTGSYL( 'C', IJB, N2, N1, A( I, I ), LDA, A, LDA,
45926     $                         WORK, N2, B, LDB, B( I, I ), LDB,
45927     $                         WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ),
45928     $                         WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK,
45929     $                         IERR )
45930               END IF
45931               GO TO 50
45932            END IF
45933            DIF( 2 ) = DSCALE / DIF( 2 )
45934         END IF
45935      END IF
45936*
45937*     If B(K,K) is complex, make it real and positive (normalization
45938*     of the generalized Schur form) and Store the generalized
45939*     eigenvalues of reordered pair (A, B)
45940*
45941      DO 60 K = 1, N
45942         DSCALE = ABS( B( K, K ) )
45943         IF( DSCALE.GT.SAFMIN ) THEN
45944            TEMP1 = DCONJG( B( K, K ) / DSCALE )
45945            TEMP2 = B( K, K ) / DSCALE
45946            B( K, K ) = DSCALE
45947            CALL ZSCAL( N-K, TEMP1, B( K, K+1 ), LDB )
45948            CALL ZSCAL( N-K+1, TEMP1, A( K, K ), LDA )
45949            IF( WANTQ )
45950     $         CALL ZSCAL( N, TEMP2, Q( 1, K ), 1 )
45951         ELSE
45952            B( K, K ) = DCMPLX( ZERO, ZERO )
45953         END IF
45954*
45955         ALPHA( K ) = A( K, K )
45956         BETA( K ) = B( K, K )
45957*
45958   60 CONTINUE
45959*
45960   70 CONTINUE
45961*
45962      WORK( 1 ) = LWMIN
45963      IWORK( 1 ) = LIWMIN
45964*
45965      RETURN
45966*
45967*     End of ZTGSEN
45968*
45969      END
45970*> \brief \b ZTGSY2 solves the generalized Sylvester equation (unblocked algorithm).
45971*
45972*  =========== DOCUMENTATION ===========
45973*
45974* Online html documentation available at
45975*            http://www.netlib.org/lapack/explore-html/
45976*
45977*> \htmlonly
45978*> Download ZTGSY2 + dependencies
45979*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztgsy2.f">
45980*> [TGZ]</a>
45981*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztgsy2.f">
45982*> [ZIP]</a>
45983*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztgsy2.f">
45984*> [TXT]</a>
45985*> \endhtmlonly
45986*
45987*  Definition:
45988*  ===========
45989*
45990*       SUBROUTINE ZTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D,
45991*                          LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL,
45992*                          INFO )
45993*
45994*       .. Scalar Arguments ..
45995*       CHARACTER          TRANS
45996*       INTEGER            IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, M, N
45997*       DOUBLE PRECISION   RDSCAL, RDSUM, SCALE
45998*       ..
45999*       .. Array Arguments ..
46000*       COMPLEX*16         A( LDA, * ), B( LDB, * ), C( LDC, * ),
46001*      $                   D( LDD, * ), E( LDE, * ), F( LDF, * )
46002*       ..
46003*
46004*
46005*> \par Purpose:
46006*  =============
46007*>
46008*> \verbatim
46009*>
46010*> ZTGSY2 solves the generalized Sylvester equation
46011*>
46012*>             A * R - L * B = scale * C               (1)
46013*>             D * R - L * E = scale * F
46014*>
46015*> using Level 1 and 2 BLAS, where R and L are unknown M-by-N matrices,
46016*> (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M,
46017*> N-by-N and M-by-N, respectively. A, B, D and E are upper triangular
46018*> (i.e., (A,D) and (B,E) in generalized Schur form).
46019*>
46020*> The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output
46021*> scaling factor chosen to avoid overflow.
46022*>
46023*> In matrix notation solving equation (1) corresponds to solve
46024*> Zx = scale * b, where Z is defined as
46025*>
46026*>        Z = [ kron(In, A)  -kron(B**H, Im) ]             (2)
46027*>            [ kron(In, D)  -kron(E**H, Im) ],
46028*>
46029*> Ik is the identity matrix of size k and X**H is the conjuguate transpose of X.
46030*> kron(X, Y) is the Kronecker product between the matrices X and Y.
46031*>
46032*> If TRANS = 'C', y in the conjugate transposed system Z**H*y = scale*b
46033*> is solved for, which is equivalent to solve for R and L in
46034*>
46035*>             A**H * R  + D**H * L   = scale * C           (3)
46036*>             R  * B**H + L  * E**H  = scale * -F
46037*>
46038*> This case is used to compute an estimate of Dif[(A, D), (B, E)] =
46039*> = sigma_min(Z) using reverse communication with ZLACON.
46040*>
46041*> ZTGSY2 also (IJOB >= 1) contributes to the computation in ZTGSYL
46042*> of an upper bound on the separation between to matrix pairs. Then
46043*> the input (A, D), (B, E) are sub-pencils of two matrix pairs in
46044*> ZTGSYL.
46045*> \endverbatim
46046*
46047*  Arguments:
46048*  ==========
46049*
46050*> \param[in] TRANS
46051*> \verbatim
46052*>          TRANS is CHARACTER*1
46053*>          = 'N': solve the generalized Sylvester equation (1).
46054*>          = 'T': solve the 'transposed' system (3).
46055*> \endverbatim
46056*>
46057*> \param[in] IJOB
46058*> \verbatim
46059*>          IJOB is INTEGER
46060*>          Specifies what kind of functionality to be performed.
46061*>          =0: solve (1) only.
46062*>          =1: A contribution from this subsystem to a Frobenius
46063*>              norm-based estimate of the separation between two matrix
46064*>              pairs is computed. (look ahead strategy is used).
46065*>          =2: A contribution from this subsystem to a Frobenius
46066*>              norm-based estimate of the separation between two matrix
46067*>              pairs is computed. (DGECON on sub-systems is used.)
46068*>          Not referenced if TRANS = 'T'.
46069*> \endverbatim
46070*>
46071*> \param[in] M
46072*> \verbatim
46073*>          M is INTEGER
46074*>          On entry, M specifies the order of A and D, and the row
46075*>          dimension of C, F, R and L.
46076*> \endverbatim
46077*>
46078*> \param[in] N
46079*> \verbatim
46080*>          N is INTEGER
46081*>          On entry, N specifies the order of B and E, and the column
46082*>          dimension of C, F, R and L.
46083*> \endverbatim
46084*>
46085*> \param[in] A
46086*> \verbatim
46087*>          A is COMPLEX*16 array, dimension (LDA, M)
46088*>          On entry, A contains an upper triangular matrix.
46089*> \endverbatim
46090*>
46091*> \param[in] LDA
46092*> \verbatim
46093*>          LDA is INTEGER
46094*>          The leading dimension of the matrix A. LDA >= max(1, M).
46095*> \endverbatim
46096*>
46097*> \param[in] B
46098*> \verbatim
46099*>          B is COMPLEX*16 array, dimension (LDB, N)
46100*>          On entry, B contains an upper triangular matrix.
46101*> \endverbatim
46102*>
46103*> \param[in] LDB
46104*> \verbatim
46105*>          LDB is INTEGER
46106*>          The leading dimension of the matrix B. LDB >= max(1, N).
46107*> \endverbatim
46108*>
46109*> \param[in,out] C
46110*> \verbatim
46111*>          C is COMPLEX*16 array, dimension (LDC, N)
46112*>          On entry, C contains the right-hand-side of the first matrix
46113*>          equation in (1).
46114*>          On exit, if IJOB = 0, C has been overwritten by the solution
46115*>          R.
46116*> \endverbatim
46117*>
46118*> \param[in] LDC
46119*> \verbatim
46120*>          LDC is INTEGER
46121*>          The leading dimension of the matrix C. LDC >= max(1, M).
46122*> \endverbatim
46123*>
46124*> \param[in] D
46125*> \verbatim
46126*>          D is COMPLEX*16 array, dimension (LDD, M)
46127*>          On entry, D contains an upper triangular matrix.
46128*> \endverbatim
46129*>
46130*> \param[in] LDD
46131*> \verbatim
46132*>          LDD is INTEGER
46133*>          The leading dimension of the matrix D. LDD >= max(1, M).
46134*> \endverbatim
46135*>
46136*> \param[in] E
46137*> \verbatim
46138*>          E is COMPLEX*16 array, dimension (LDE, N)
46139*>          On entry, E contains an upper triangular matrix.
46140*> \endverbatim
46141*>
46142*> \param[in] LDE
46143*> \verbatim
46144*>          LDE is INTEGER
46145*>          The leading dimension of the matrix E. LDE >= max(1, N).
46146*> \endverbatim
46147*>
46148*> \param[in,out] F
46149*> \verbatim
46150*>          F is COMPLEX*16 array, dimension (LDF, N)
46151*>          On entry, F contains the right-hand-side of the second matrix
46152*>          equation in (1).
46153*>          On exit, if IJOB = 0, F has been overwritten by the solution
46154*>          L.
46155*> \endverbatim
46156*>
46157*> \param[in] LDF
46158*> \verbatim
46159*>          LDF is INTEGER
46160*>          The leading dimension of the matrix F. LDF >= max(1, M).
46161*> \endverbatim
46162*>
46163*> \param[out] SCALE
46164*> \verbatim
46165*>          SCALE is DOUBLE PRECISION
46166*>          On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions
46167*>          R and L (C and F on entry) will hold the solutions to a
46168*>          slightly perturbed system but the input matrices A, B, D and
46169*>          E have not been changed. If SCALE = 0, R and L will hold the
46170*>          solutions to the homogeneous system with C = F = 0.
46171*>          Normally, SCALE = 1.
46172*> \endverbatim
46173*>
46174*> \param[in,out] RDSUM
46175*> \verbatim
46176*>          RDSUM is DOUBLE PRECISION
46177*>          On entry, the sum of squares of computed contributions to
46178*>          the Dif-estimate under computation by ZTGSYL, where the
46179*>          scaling factor RDSCAL (see below) has been factored out.
46180*>          On exit, the corresponding sum of squares updated with the
46181*>          contributions from the current sub-system.
46182*>          If TRANS = 'T' RDSUM is not touched.
46183*>          NOTE: RDSUM only makes sense when ZTGSY2 is called by
46184*>          ZTGSYL.
46185*> \endverbatim
46186*>
46187*> \param[in,out] RDSCAL
46188*> \verbatim
46189*>          RDSCAL is DOUBLE PRECISION
46190*>          On entry, scaling factor used to prevent overflow in RDSUM.
46191*>          On exit, RDSCAL is updated w.r.t. the current contributions
46192*>          in RDSUM.
46193*>          If TRANS = 'T', RDSCAL is not touched.
46194*>          NOTE: RDSCAL only makes sense when ZTGSY2 is called by
46195*>          ZTGSYL.
46196*> \endverbatim
46197*>
46198*> \param[out] INFO
46199*> \verbatim
46200*>          INFO is INTEGER
46201*>          On exit, if INFO is set to
46202*>            =0: Successful exit
46203*>            <0: If INFO = -i, input argument number i is illegal.
46204*>            >0: The matrix pairs (A, D) and (B, E) have common or very
46205*>                close eigenvalues.
46206*> \endverbatim
46207*
46208*  Authors:
46209*  ========
46210*
46211*> \author Univ. of Tennessee
46212*> \author Univ. of California Berkeley
46213*> \author Univ. of Colorado Denver
46214*> \author NAG Ltd.
46215*
46216*> \date December 2016
46217*
46218*> \ingroup complex16SYauxiliary
46219*
46220*> \par Contributors:
46221*  ==================
46222*>
46223*>     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
46224*>     Umea University, S-901 87 Umea, Sweden.
46225*
46226*  =====================================================================
46227      SUBROUTINE ZTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D,
46228     $                   LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL,
46229     $                   INFO )
46230*
46231*  -- LAPACK auxiliary routine (version 3.7.0) --
46232*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
46233*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
46234*     December 2016
46235*
46236*     .. Scalar Arguments ..
46237      CHARACTER          TRANS
46238      INTEGER            IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, M, N
46239      DOUBLE PRECISION   RDSCAL, RDSUM, SCALE
46240*     ..
46241*     .. Array Arguments ..
46242      COMPLEX*16         A( LDA, * ), B( LDB, * ), C( LDC, * ),
46243     $                   D( LDD, * ), E( LDE, * ), F( LDF, * )
46244*     ..
46245*
46246*  =====================================================================
46247*
46248*     .. Parameters ..
46249      DOUBLE PRECISION   ZERO, ONE
46250      INTEGER            LDZ
46251      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, LDZ = 2 )
46252*     ..
46253*     .. Local Scalars ..
46254      LOGICAL            NOTRAN
46255      INTEGER            I, IERR, J, K
46256      DOUBLE PRECISION   SCALOC
46257      COMPLEX*16         ALPHA
46258*     ..
46259*     .. Local Arrays ..
46260      INTEGER            IPIV( LDZ ), JPIV( LDZ )
46261      COMPLEX*16         RHS( LDZ ), Z( LDZ, LDZ )
46262*     ..
46263*     .. External Functions ..
46264      LOGICAL            LSAME
46265      EXTERNAL           LSAME
46266*     ..
46267*     .. External Subroutines ..
46268      EXTERNAL           XERBLA, ZAXPY, ZGESC2, ZGETC2, ZLATDF, ZSCAL
46269*     ..
46270*     .. Intrinsic Functions ..
46271      INTRINSIC          DCMPLX, DCONJG, MAX
46272*     ..
46273*     .. Executable Statements ..
46274*
46275*     Decode and test input parameters
46276*
46277      INFO = 0
46278      IERR = 0
46279      NOTRAN = LSAME( TRANS, 'N' )
46280      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
46281         INFO = -1
46282      ELSE IF( NOTRAN ) THEN
46283         IF( ( IJOB.LT.0 ) .OR. ( IJOB.GT.2 ) ) THEN
46284            INFO = -2
46285         END IF
46286      END IF
46287      IF( INFO.EQ.0 ) THEN
46288         IF( M.LE.0 ) THEN
46289            INFO = -3
46290         ELSE IF( N.LE.0 ) THEN
46291            INFO = -4
46292         ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
46293            INFO = -6
46294         ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
46295            INFO = -8
46296         ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
46297            INFO = -10
46298         ELSE IF( LDD.LT.MAX( 1, M ) ) THEN
46299            INFO = -12
46300         ELSE IF( LDE.LT.MAX( 1, N ) ) THEN
46301            INFO = -14
46302         ELSE IF( LDF.LT.MAX( 1, M ) ) THEN
46303            INFO = -16
46304         END IF
46305      END IF
46306      IF( INFO.NE.0 ) THEN
46307         CALL XERBLA( 'ZTGSY2', -INFO )
46308         RETURN
46309      END IF
46310*
46311      IF( NOTRAN ) THEN
46312*
46313*        Solve (I, J) - system
46314*           A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J)
46315*           D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J)
46316*        for I = M, M - 1, ..., 1; J = 1, 2, ..., N
46317*
46318         SCALE = ONE
46319         SCALOC = ONE
46320         DO 30 J = 1, N
46321            DO 20 I = M, 1, -1
46322*
46323*              Build 2 by 2 system
46324*
46325               Z( 1, 1 ) = A( I, I )
46326               Z( 2, 1 ) = D( I, I )
46327               Z( 1, 2 ) = -B( J, J )
46328               Z( 2, 2 ) = -E( J, J )
46329*
46330*              Set up right hand side(s)
46331*
46332               RHS( 1 ) = C( I, J )
46333               RHS( 2 ) = F( I, J )
46334*
46335*              Solve Z * x = RHS
46336*
46337               CALL ZGETC2( LDZ, Z, LDZ, IPIV, JPIV, IERR )
46338               IF( IERR.GT.0 )
46339     $            INFO = IERR
46340               IF( IJOB.EQ.0 ) THEN
46341                  CALL ZGESC2( LDZ, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
46342                  IF( SCALOC.NE.ONE ) THEN
46343                     DO 10 K = 1, N
46344                        CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ),
46345     $                              C( 1, K ), 1 )
46346                        CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ),
46347     $                              F( 1, K ), 1 )
46348   10                CONTINUE
46349                     SCALE = SCALE*SCALOC
46350                  END IF
46351               ELSE
46352                  CALL ZLATDF( IJOB, LDZ, Z, LDZ, RHS, RDSUM, RDSCAL,
46353     $                         IPIV, JPIV )
46354               END IF
46355*
46356*              Unpack solution vector(s)
46357*
46358               C( I, J ) = RHS( 1 )
46359               F( I, J ) = RHS( 2 )
46360*
46361*              Substitute R(I, J) and L(I, J) into remaining equation.
46362*
46363               IF( I.GT.1 ) THEN
46364                  ALPHA = -RHS( 1 )
46365                  CALL ZAXPY( I-1, ALPHA, A( 1, I ), 1, C( 1, J ), 1 )
46366                  CALL ZAXPY( I-1, ALPHA, D( 1, I ), 1, F( 1, J ), 1 )
46367               END IF
46368               IF( J.LT.N ) THEN
46369                  CALL ZAXPY( N-J, RHS( 2 ), B( J, J+1 ), LDB,
46370     $                        C( I, J+1 ), LDC )
46371                  CALL ZAXPY( N-J, RHS( 2 ), E( J, J+1 ), LDE,
46372     $                        F( I, J+1 ), LDF )
46373               END IF
46374*
46375   20       CONTINUE
46376   30    CONTINUE
46377      ELSE
46378*
46379*        Solve transposed (I, J) - system:
46380*           A(I, I)**H * R(I, J) + D(I, I)**H * L(J, J) = C(I, J)
46381*           R(I, I) * B(J, J) + L(I, J) * E(J, J)   = -F(I, J)
46382*        for I = 1, 2, ..., M, J = N, N - 1, ..., 1
46383*
46384         SCALE = ONE
46385         SCALOC = ONE
46386         DO 80 I = 1, M
46387            DO 70 J = N, 1, -1
46388*
46389*              Build 2 by 2 system Z**H
46390*
46391               Z( 1, 1 ) = DCONJG( A( I, I ) )
46392               Z( 2, 1 ) = -DCONJG( B( J, J ) )
46393               Z( 1, 2 ) = DCONJG( D( I, I ) )
46394               Z( 2, 2 ) = -DCONJG( E( J, J ) )
46395*
46396*
46397*              Set up right hand side(s)
46398*
46399               RHS( 1 ) = C( I, J )
46400               RHS( 2 ) = F( I, J )
46401*
46402*              Solve Z**H * x = RHS
46403*
46404               CALL ZGETC2( LDZ, Z, LDZ, IPIV, JPIV, IERR )
46405               IF( IERR.GT.0 )
46406     $            INFO = IERR
46407               CALL ZGESC2( LDZ, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
46408               IF( SCALOC.NE.ONE ) THEN
46409                  DO 40 K = 1, N
46410                     CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), C( 1, K ),
46411     $                           1 )
46412                     CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), F( 1, K ),
46413     $                           1 )
46414   40             CONTINUE
46415                  SCALE = SCALE*SCALOC
46416               END IF
46417*
46418*              Unpack solution vector(s)
46419*
46420               C( I, J ) = RHS( 1 )
46421               F( I, J ) = RHS( 2 )
46422*
46423*              Substitute R(I, J) and L(I, J) into remaining equation.
46424*
46425               DO 50 K = 1, J - 1
46426                  F( I, K ) = F( I, K ) + RHS( 1 )*DCONJG( B( K, J ) ) +
46427     $                        RHS( 2 )*DCONJG( E( K, J ) )
46428   50          CONTINUE
46429               DO 60 K = I + 1, M
46430                  C( K, J ) = C( K, J ) - DCONJG( A( I, K ) )*RHS( 1 ) -
46431     $                        DCONJG( D( I, K ) )*RHS( 2 )
46432   60          CONTINUE
46433*
46434   70       CONTINUE
46435   80    CONTINUE
46436      END IF
46437      RETURN
46438*
46439*     End of ZTGSY2
46440*
46441      END
46442*> \brief \b ZTGSYL
46443*
46444*  =========== DOCUMENTATION ===========
46445*
46446* Online html documentation available at
46447*            http://www.netlib.org/lapack/explore-html/
46448*
46449*> \htmlonly
46450*> Download ZTGSYL + dependencies
46451*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztgsyl.f">
46452*> [TGZ]</a>
46453*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztgsyl.f">
46454*> [ZIP]</a>
46455*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztgsyl.f">
46456*> [TXT]</a>
46457*> \endhtmlonly
46458*
46459*  Definition:
46460*  ===========
46461*
46462*       SUBROUTINE ZTGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D,
46463*                          LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK,
46464*                          IWORK, INFO )
46465*
46466*       .. Scalar Arguments ..
46467*       CHARACTER          TRANS
46468*       INTEGER            IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF,
46469*      $                   LWORK, M, N
46470*       DOUBLE PRECISION   DIF, SCALE
46471*       ..
46472*       .. Array Arguments ..
46473*       INTEGER            IWORK( * )
46474*       COMPLEX*16         A( LDA, * ), B( LDB, * ), C( LDC, * ),
46475*      $                   D( LDD, * ), E( LDE, * ), F( LDF, * ),
46476*      $                   WORK( * )
46477*       ..
46478*
46479*
46480*> \par Purpose:
46481*  =============
46482*>
46483*> \verbatim
46484*>
46485*> ZTGSYL solves the generalized Sylvester equation:
46486*>
46487*>             A * R - L * B = scale * C            (1)
46488*>             D * R - L * E = scale * F
46489*>
46490*> where R and L are unknown m-by-n matrices, (A, D), (B, E) and
46491*> (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n,
46492*> respectively, with complex entries. A, B, D and E are upper
46493*> triangular (i.e., (A,D) and (B,E) in generalized Schur form).
46494*>
46495*> The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1
46496*> is an output scaling factor chosen to avoid overflow.
46497*>
46498*> In matrix notation (1) is equivalent to solve Zx = scale*b, where Z
46499*> is defined as
46500*>
46501*>        Z = [ kron(In, A)  -kron(B**H, Im) ]        (2)
46502*>            [ kron(In, D)  -kron(E**H, Im) ],
46503*>
46504*> Here Ix is the identity matrix of size x and X**H is the conjugate
46505*> transpose of X. Kron(X, Y) is the Kronecker product between the
46506*> matrices X and Y.
46507*>
46508*> If TRANS = 'C', y in the conjugate transposed system Z**H *y = scale*b
46509*> is solved for, which is equivalent to solve for R and L in
46510*>
46511*>             A**H * R + D**H * L = scale * C           (3)
46512*>             R * B**H + L * E**H = scale * -F
46513*>
46514*> This case (TRANS = 'C') is used to compute an one-norm-based estimate
46515*> of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D)
46516*> and (B,E), using ZLACON.
46517*>
46518*> If IJOB >= 1, ZTGSYL computes a Frobenius norm-based estimate of
46519*> Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the
46520*> reciprocal of the smallest singular value of Z.
46521*>
46522*> This is a level-3 BLAS algorithm.
46523*> \endverbatim
46524*
46525*  Arguments:
46526*  ==========
46527*
46528*> \param[in] TRANS
46529*> \verbatim
46530*>          TRANS is CHARACTER*1
46531*>          = 'N': solve the generalized sylvester equation (1).
46532*>          = 'C': solve the "conjugate transposed" system (3).
46533*> \endverbatim
46534*>
46535*> \param[in] IJOB
46536*> \verbatim
46537*>          IJOB is INTEGER
46538*>          Specifies what kind of functionality to be performed.
46539*>          =0: solve (1) only.
46540*>          =1: The functionality of 0 and 3.
46541*>          =2: The functionality of 0 and 4.
46542*>          =3: Only an estimate of Dif[(A,D), (B,E)] is computed.
46543*>              (look ahead strategy is used).
46544*>          =4: Only an estimate of Dif[(A,D), (B,E)] is computed.
46545*>              (ZGECON on sub-systems is used).
46546*>          Not referenced if TRANS = 'C'.
46547*> \endverbatim
46548*>
46549*> \param[in] M
46550*> \verbatim
46551*>          M is INTEGER
46552*>          The order of the matrices A and D, and the row dimension of
46553*>          the matrices C, F, R and L.
46554*> \endverbatim
46555*>
46556*> \param[in] N
46557*> \verbatim
46558*>          N is INTEGER
46559*>          The order of the matrices B and E, and the column dimension
46560*>          of the matrices C, F, R and L.
46561*> \endverbatim
46562*>
46563*> \param[in] A
46564*> \verbatim
46565*>          A is COMPLEX*16 array, dimension (LDA, M)
46566*>          The upper triangular matrix A.
46567*> \endverbatim
46568*>
46569*> \param[in] LDA
46570*> \verbatim
46571*>          LDA is INTEGER
46572*>          The leading dimension of the array A. LDA >= max(1, M).
46573*> \endverbatim
46574*>
46575*> \param[in] B
46576*> \verbatim
46577*>          B is COMPLEX*16 array, dimension (LDB, N)
46578*>          The upper triangular matrix B.
46579*> \endverbatim
46580*>
46581*> \param[in] LDB
46582*> \verbatim
46583*>          LDB is INTEGER
46584*>          The leading dimension of the array B. LDB >= max(1, N).
46585*> \endverbatim
46586*>
46587*> \param[in,out] C
46588*> \verbatim
46589*>          C is COMPLEX*16 array, dimension (LDC, N)
46590*>          On entry, C contains the right-hand-side of the first matrix
46591*>          equation in (1) or (3).
46592*>          On exit, if IJOB = 0, 1 or 2, C has been overwritten by
46593*>          the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R,
46594*>          the solution achieved during the computation of the
46595*>          Dif-estimate.
46596*> \endverbatim
46597*>
46598*> \param[in] LDC
46599*> \verbatim
46600*>          LDC is INTEGER
46601*>          The leading dimension of the array C. LDC >= max(1, M).
46602*> \endverbatim
46603*>
46604*> \param[in] D
46605*> \verbatim
46606*>          D is COMPLEX*16 array, dimension (LDD, M)
46607*>          The upper triangular matrix D.
46608*> \endverbatim
46609*>
46610*> \param[in] LDD
46611*> \verbatim
46612*>          LDD is INTEGER
46613*>          The leading dimension of the array D. LDD >= max(1, M).
46614*> \endverbatim
46615*>
46616*> \param[in] E
46617*> \verbatim
46618*>          E is COMPLEX*16 array, dimension (LDE, N)
46619*>          The upper triangular matrix E.
46620*> \endverbatim
46621*>
46622*> \param[in] LDE
46623*> \verbatim
46624*>          LDE is INTEGER
46625*>          The leading dimension of the array E. LDE >= max(1, N).
46626*> \endverbatim
46627*>
46628*> \param[in,out] F
46629*> \verbatim
46630*>          F is COMPLEX*16 array, dimension (LDF, N)
46631*>          On entry, F contains the right-hand-side of the second matrix
46632*>          equation in (1) or (3).
46633*>          On exit, if IJOB = 0, 1 or 2, F has been overwritten by
46634*>          the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L,
46635*>          the solution achieved during the computation of the
46636*>          Dif-estimate.
46637*> \endverbatim
46638*>
46639*> \param[in] LDF
46640*> \verbatim
46641*>          LDF is INTEGER
46642*>          The leading dimension of the array F. LDF >= max(1, M).
46643*> \endverbatim
46644*>
46645*> \param[out] DIF
46646*> \verbatim
46647*>          DIF is DOUBLE PRECISION
46648*>          On exit DIF is the reciprocal of a lower bound of the
46649*>          reciprocal of the Dif-function, i.e. DIF is an upper bound of
46650*>          Dif[(A,D), (B,E)] = sigma-min(Z), where Z as in (2).
46651*>          IF IJOB = 0 or TRANS = 'C', DIF is not referenced.
46652*> \endverbatim
46653*>
46654*> \param[out] SCALE
46655*> \verbatim
46656*>          SCALE is DOUBLE PRECISION
46657*>          On exit SCALE is the scaling factor in (1) or (3).
46658*>          If 0 < SCALE < 1, C and F hold the solutions R and L, resp.,
46659*>          to a slightly perturbed system but the input matrices A, B,
46660*>          D and E have not been changed. If SCALE = 0, R and L will
46661*>          hold the solutions to the homogenious system with C = F = 0.
46662*> \endverbatim
46663*>
46664*> \param[out] WORK
46665*> \verbatim
46666*>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
46667*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
46668*> \endverbatim
46669*>
46670*> \param[in] LWORK
46671*> \verbatim
46672*>          LWORK is INTEGER
46673*>          The dimension of the array WORK. LWORK > = 1.
46674*>          If IJOB = 1 or 2 and TRANS = 'N', LWORK >= max(1,2*M*N).
46675*>
46676*>          If LWORK = -1, then a workspace query is assumed; the routine
46677*>          only calculates the optimal size of the WORK array, returns
46678*>          this value as the first entry of the WORK array, and no error
46679*>          message related to LWORK is issued by XERBLA.
46680*> \endverbatim
46681*>
46682*> \param[out] IWORK
46683*> \verbatim
46684*>          IWORK is INTEGER array, dimension (M+N+2)
46685*> \endverbatim
46686*>
46687*> \param[out] INFO
46688*> \verbatim
46689*>          INFO is INTEGER
46690*>            =0: successful exit
46691*>            <0: If INFO = -i, the i-th argument had an illegal value.
46692*>            >0: (A, D) and (B, E) have common or very close
46693*>                eigenvalues.
46694*> \endverbatim
46695*
46696*  Authors:
46697*  ========
46698*
46699*> \author Univ. of Tennessee
46700*> \author Univ. of California Berkeley
46701*> \author Univ. of Colorado Denver
46702*> \author NAG Ltd.
46703*
46704*> \date December 2016
46705*
46706*> \ingroup complex16SYcomputational
46707*
46708*> \par Contributors:
46709*  ==================
46710*>
46711*>     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
46712*>     Umea University, S-901 87 Umea, Sweden.
46713*
46714*> \par References:
46715*  ================
46716*>
46717*>  [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
46718*>      for Solving the Generalized Sylvester Equation and Estimating the
46719*>      Separation between Regular Matrix Pairs, Report UMINF - 93.23,
46720*>      Department of Computing Science, Umea University, S-901 87 Umea,
46721*>      Sweden, December 1993, Revised April 1994, Also as LAPACK Working
46722*>      Note 75.  To appear in ACM Trans. on Math. Software, Vol 22,
46723*>      No 1, 1996.
46724*> \n
46725*>  [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester
46726*>      Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal.
46727*>      Appl., 15(4):1045-1060, 1994.
46728*> \n
46729*>  [3] B. Kagstrom and L. Westin, Generalized Schur Methods with
46730*>      Condition Estimators for Solving the Generalized Sylvester
46731*>      Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7,
46732*>      July 1989, pp 745-751.
46733*>
46734*  =====================================================================
46735      SUBROUTINE ZTGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D,
46736     $                   LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK,
46737     $                   IWORK, INFO )
46738*
46739*  -- LAPACK computational routine (version 3.7.0) --
46740*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
46741*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
46742*     December 2016
46743*
46744*     .. Scalar Arguments ..
46745      CHARACTER          TRANS
46746      INTEGER            IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF,
46747     $                   LWORK, M, N
46748      DOUBLE PRECISION   DIF, SCALE
46749*     ..
46750*     .. Array Arguments ..
46751      INTEGER            IWORK( * )
46752      COMPLEX*16         A( LDA, * ), B( LDB, * ), C( LDC, * ),
46753     $                   D( LDD, * ), E( LDE, * ), F( LDF, * ),
46754     $                   WORK( * )
46755*     ..
46756*
46757*  =====================================================================
46758*  Replaced various illegal calls to CCOPY by calls to CLASET.
46759*  Sven Hammarling, 1/5/02.
46760*
46761*     .. Parameters ..
46762      DOUBLE PRECISION   ZERO, ONE
46763      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
46764      COMPLEX*16         CZERO
46765      PARAMETER          ( CZERO = (0.0D+0, 0.0D+0) )
46766*     ..
46767*     .. Local Scalars ..
46768      LOGICAL            LQUERY, NOTRAN
46769      INTEGER            I, IE, IFUNC, IROUND, IS, ISOLVE, J, JE, JS, K,
46770     $                   LINFO, LWMIN, MB, NB, P, PQ, Q
46771      DOUBLE PRECISION   DSCALE, DSUM, SCALE2, SCALOC
46772*     ..
46773*     .. External Functions ..
46774      LOGICAL            LSAME
46775      INTEGER            ILAENV
46776      EXTERNAL           LSAME, ILAENV
46777*     ..
46778*     .. External Subroutines ..
46779      EXTERNAL           XERBLA, ZGEMM, ZLACPY, ZLASET, ZSCAL, ZTGSY2
46780*     ..
46781*     .. Intrinsic Functions ..
46782      INTRINSIC          DBLE, DCMPLX, MAX, SQRT
46783*     ..
46784*     .. Executable Statements ..
46785*
46786*     Decode and test input parameters
46787*
46788      INFO = 0
46789      NOTRAN = LSAME( TRANS, 'N' )
46790      LQUERY = ( LWORK.EQ.-1 )
46791*
46792      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
46793         INFO = -1
46794      ELSE IF( NOTRAN ) THEN
46795         IF( ( IJOB.LT.0 ) .OR. ( IJOB.GT.4 ) ) THEN
46796            INFO = -2
46797         END IF
46798      END IF
46799      IF( INFO.EQ.0 ) THEN
46800         IF( M.LE.0 ) THEN
46801            INFO = -3
46802         ELSE IF( N.LE.0 ) THEN
46803            INFO = -4
46804         ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
46805            INFO = -6
46806         ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
46807            INFO = -8
46808         ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
46809            INFO = -10
46810         ELSE IF( LDD.LT.MAX( 1, M ) ) THEN
46811            INFO = -12
46812         ELSE IF( LDE.LT.MAX( 1, N ) ) THEN
46813            INFO = -14
46814         ELSE IF( LDF.LT.MAX( 1, M ) ) THEN
46815            INFO = -16
46816         END IF
46817      END IF
46818*
46819      IF( INFO.EQ.0 ) THEN
46820         IF( NOTRAN ) THEN
46821            IF( IJOB.EQ.1 .OR. IJOB.EQ.2 ) THEN
46822               LWMIN = MAX( 1, 2*M*N )
46823            ELSE
46824               LWMIN = 1
46825            END IF
46826         ELSE
46827            LWMIN = 1
46828         END IF
46829         WORK( 1 ) = LWMIN
46830*
46831         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
46832            INFO = -20
46833         END IF
46834      END IF
46835*
46836      IF( INFO.NE.0 ) THEN
46837         CALL XERBLA( 'ZTGSYL', -INFO )
46838         RETURN
46839      ELSE IF( LQUERY ) THEN
46840         RETURN
46841      END IF
46842*
46843*     Quick return if possible
46844*
46845      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
46846         SCALE = 1
46847         IF( NOTRAN ) THEN
46848            IF( IJOB.NE.0 ) THEN
46849               DIF = 0
46850            END IF
46851         END IF
46852         RETURN
46853      END IF
46854*
46855*     Determine  optimal block sizes MB and NB
46856*
46857      MB = ILAENV( 2, 'ZTGSYL', TRANS, M, N, -1, -1 )
46858      NB = ILAENV( 5, 'ZTGSYL', TRANS, M, N, -1, -1 )
46859*
46860      ISOLVE = 1
46861      IFUNC = 0
46862      IF( NOTRAN ) THEN
46863         IF( IJOB.GE.3 ) THEN
46864            IFUNC = IJOB - 2
46865            CALL ZLASET( 'F', M, N, CZERO, CZERO, C, LDC )
46866            CALL ZLASET( 'F', M, N, CZERO, CZERO, F, LDF )
46867         ELSE IF( IJOB.GE.1 .AND. NOTRAN ) THEN
46868            ISOLVE = 2
46869         END IF
46870      END IF
46871*
46872      IF( ( MB.LE.1 .AND. NB.LE.1 ) .OR. ( MB.GE.M .AND. NB.GE.N ) )
46873     $     THEN
46874*
46875*        Use unblocked Level 2 solver
46876*
46877         DO 30 IROUND = 1, ISOLVE
46878*
46879            SCALE = ONE
46880            DSCALE = ZERO
46881            DSUM = ONE
46882            PQ = M*N
46883            CALL ZTGSY2( TRANS, IFUNC, M, N, A, LDA, B, LDB, C, LDC, D,
46884     $                   LDD, E, LDE, F, LDF, SCALE, DSUM, DSCALE,
46885     $                   INFO )
46886            IF( DSCALE.NE.ZERO ) THEN
46887               IF( IJOB.EQ.1 .OR. IJOB.EQ.3 ) THEN
46888                  DIF = SQRT( DBLE( 2*M*N ) ) / ( DSCALE*SQRT( DSUM ) )
46889               ELSE
46890                  DIF = SQRT( DBLE( PQ ) ) / ( DSCALE*SQRT( DSUM ) )
46891               END IF
46892            END IF
46893            IF( ISOLVE.EQ.2 .AND. IROUND.EQ.1 ) THEN
46894               IF( NOTRAN ) THEN
46895                  IFUNC = IJOB
46896               END IF
46897               SCALE2 = SCALE
46898               CALL ZLACPY( 'F', M, N, C, LDC, WORK, M )
46899               CALL ZLACPY( 'F', M, N, F, LDF, WORK( M*N+1 ), M )
46900               CALL ZLASET( 'F', M, N, CZERO, CZERO, C, LDC )
46901               CALL ZLASET( 'F', M, N, CZERO, CZERO, F, LDF )
46902            ELSE IF( ISOLVE.EQ.2 .AND. IROUND.EQ.2 ) THEN
46903               CALL ZLACPY( 'F', M, N, WORK, M, C, LDC )
46904               CALL ZLACPY( 'F', M, N, WORK( M*N+1 ), M, F, LDF )
46905               SCALE = SCALE2
46906            END IF
46907   30    CONTINUE
46908*
46909         RETURN
46910*
46911      END IF
46912*
46913*     Determine block structure of A
46914*
46915      P = 0
46916      I = 1
46917   40 CONTINUE
46918      IF( I.GT.M )
46919     $   GO TO 50
46920      P = P + 1
46921      IWORK( P ) = I
46922      I = I + MB
46923      IF( I.GE.M )
46924     $   GO TO 50
46925      GO TO 40
46926   50 CONTINUE
46927      IWORK( P+1 ) = M + 1
46928      IF( IWORK( P ).EQ.IWORK( P+1 ) )
46929     $   P = P - 1
46930*
46931*     Determine block structure of B
46932*
46933      Q = P + 1
46934      J = 1
46935   60 CONTINUE
46936      IF( J.GT.N )
46937     $   GO TO 70
46938*
46939      Q = Q + 1
46940      IWORK( Q ) = J
46941      J = J + NB
46942      IF( J.GE.N )
46943     $   GO TO 70
46944      GO TO 60
46945*
46946   70 CONTINUE
46947      IWORK( Q+1 ) = N + 1
46948      IF( IWORK( Q ).EQ.IWORK( Q+1 ) )
46949     $   Q = Q - 1
46950*
46951      IF( NOTRAN ) THEN
46952         DO 150 IROUND = 1, ISOLVE
46953*
46954*           Solve (I, J) - subsystem
46955*               A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J)
46956*               D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J)
46957*           for I = P, P - 1, ..., 1; J = 1, 2, ..., Q
46958*
46959            PQ = 0
46960            SCALE = ONE
46961            DSCALE = ZERO
46962            DSUM = ONE
46963            DO 130 J = P + 2, Q
46964               JS = IWORK( J )
46965               JE = IWORK( J+1 ) - 1
46966               NB = JE - JS + 1
46967               DO 120 I = P, 1, -1
46968                  IS = IWORK( I )
46969                  IE = IWORK( I+1 ) - 1
46970                  MB = IE - IS + 1
46971                  CALL ZTGSY2( TRANS, IFUNC, MB, NB, A( IS, IS ), LDA,
46972     $                         B( JS, JS ), LDB, C( IS, JS ), LDC,
46973     $                         D( IS, IS ), LDD, E( JS, JS ), LDE,
46974     $                         F( IS, JS ), LDF, SCALOC, DSUM, DSCALE,
46975     $                         LINFO )
46976                  IF( LINFO.GT.0 )
46977     $               INFO = LINFO
46978                  PQ = PQ + MB*NB
46979                  IF( SCALOC.NE.ONE ) THEN
46980                     DO 80 K = 1, JS - 1
46981                        CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ),
46982     $                              C( 1, K ), 1 )
46983                        CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ),
46984     $                              F( 1, K ), 1 )
46985   80                CONTINUE
46986                     DO 90 K = JS, JE
46987                        CALL ZSCAL( IS-1, DCMPLX( SCALOC, ZERO ),
46988     $                              C( 1, K ), 1 )
46989                        CALL ZSCAL( IS-1, DCMPLX( SCALOC, ZERO ),
46990     $                              F( 1, K ), 1 )
46991   90                CONTINUE
46992                     DO 100 K = JS, JE
46993                        CALL ZSCAL( M-IE, DCMPLX( SCALOC, ZERO ),
46994     $                              C( IE+1, K ), 1 )
46995                        CALL ZSCAL( M-IE, DCMPLX( SCALOC, ZERO ),
46996     $                              F( IE+1, K ), 1 )
46997  100                CONTINUE
46998                     DO 110 K = JE + 1, N
46999                        CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ),
47000     $                              C( 1, K ), 1 )
47001                        CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ),
47002     $                              F( 1, K ), 1 )
47003  110                CONTINUE
47004                     SCALE = SCALE*SCALOC
47005                  END IF
47006*
47007*                 Substitute R(I,J) and L(I,J) into remaining equation.
47008*
47009                  IF( I.GT.1 ) THEN
47010                     CALL ZGEMM( 'N', 'N', IS-1, NB, MB,
47011     $                           DCMPLX( -ONE, ZERO ), A( 1, IS ), LDA,
47012     $                           C( IS, JS ), LDC, DCMPLX( ONE, ZERO ),
47013     $                           C( 1, JS ), LDC )
47014                     CALL ZGEMM( 'N', 'N', IS-1, NB, MB,
47015     $                           DCMPLX( -ONE, ZERO ), D( 1, IS ), LDD,
47016     $                           C( IS, JS ), LDC, DCMPLX( ONE, ZERO ),
47017     $                           F( 1, JS ), LDF )
47018                  END IF
47019                  IF( J.LT.Q ) THEN
47020                     CALL ZGEMM( 'N', 'N', MB, N-JE, NB,
47021     $                           DCMPLX( ONE, ZERO ), F( IS, JS ), LDF,
47022     $                           B( JS, JE+1 ), LDB,
47023     $                           DCMPLX( ONE, ZERO ), C( IS, JE+1 ),
47024     $                           LDC )
47025                     CALL ZGEMM( 'N', 'N', MB, N-JE, NB,
47026     $                           DCMPLX( ONE, ZERO ), F( IS, JS ), LDF,
47027     $                           E( JS, JE+1 ), LDE,
47028     $                           DCMPLX( ONE, ZERO ), F( IS, JE+1 ),
47029     $                           LDF )
47030                  END IF
47031  120          CONTINUE
47032  130       CONTINUE
47033            IF( DSCALE.NE.ZERO ) THEN
47034               IF( IJOB.EQ.1 .OR. IJOB.EQ.3 ) THEN
47035                  DIF = SQRT( DBLE( 2*M*N ) ) / ( DSCALE*SQRT( DSUM ) )
47036               ELSE
47037                  DIF = SQRT( DBLE( PQ ) ) / ( DSCALE*SQRT( DSUM ) )
47038               END IF
47039            END IF
47040            IF( ISOLVE.EQ.2 .AND. IROUND.EQ.1 ) THEN
47041               IF( NOTRAN ) THEN
47042                  IFUNC = IJOB
47043               END IF
47044               SCALE2 = SCALE
47045               CALL ZLACPY( 'F', M, N, C, LDC, WORK, M )
47046               CALL ZLACPY( 'F', M, N, F, LDF, WORK( M*N+1 ), M )
47047               CALL ZLASET( 'F', M, N, CZERO, CZERO, C, LDC )
47048               CALL ZLASET( 'F', M, N, CZERO, CZERO, F, LDF )
47049            ELSE IF( ISOLVE.EQ.2 .AND. IROUND.EQ.2 ) THEN
47050               CALL ZLACPY( 'F', M, N, WORK, M, C, LDC )
47051               CALL ZLACPY( 'F', M, N, WORK( M*N+1 ), M, F, LDF )
47052               SCALE = SCALE2
47053            END IF
47054  150    CONTINUE
47055      ELSE
47056*
47057*        Solve transposed (I, J)-subsystem
47058*            A(I, I)**H * R(I, J) + D(I, I)**H * L(I, J) = C(I, J)
47059*            R(I, J) * B(J, J)  + L(I, J) * E(J, J) = -F(I, J)
47060*        for I = 1,2,..., P; J = Q, Q-1,..., 1
47061*
47062         SCALE = ONE
47063         DO 210 I = 1, P
47064            IS = IWORK( I )
47065            IE = IWORK( I+1 ) - 1
47066            MB = IE - IS + 1
47067            DO 200 J = Q, P + 2, -1
47068               JS = IWORK( J )
47069               JE = IWORK( J+1 ) - 1
47070               NB = JE - JS + 1
47071               CALL ZTGSY2( TRANS, IFUNC, MB, NB, A( IS, IS ), LDA,
47072     $                      B( JS, JS ), LDB, C( IS, JS ), LDC,
47073     $                      D( IS, IS ), LDD, E( JS, JS ), LDE,
47074     $                      F( IS, JS ), LDF, SCALOC, DSUM, DSCALE,
47075     $                      LINFO )
47076               IF( LINFO.GT.0 )
47077     $            INFO = LINFO
47078               IF( SCALOC.NE.ONE ) THEN
47079                  DO 160 K = 1, JS - 1
47080                     CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), C( 1, K ),
47081     $                           1 )
47082                     CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), F( 1, K ),
47083     $                           1 )
47084  160             CONTINUE
47085                  DO 170 K = JS, JE
47086                     CALL ZSCAL( IS-1, DCMPLX( SCALOC, ZERO ),
47087     $                           C( 1, K ), 1 )
47088                     CALL ZSCAL( IS-1, DCMPLX( SCALOC, ZERO ),
47089     $                           F( 1, K ), 1 )
47090  170             CONTINUE
47091                  DO 180 K = JS, JE
47092                     CALL ZSCAL( M-IE, DCMPLX( SCALOC, ZERO ),
47093     $                           C( IE+1, K ), 1 )
47094                     CALL ZSCAL( M-IE, DCMPLX( SCALOC, ZERO ),
47095     $                           F( IE+1, K ), 1 )
47096  180             CONTINUE
47097                  DO 190 K = JE + 1, N
47098                     CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), C( 1, K ),
47099     $                           1 )
47100                     CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), F( 1, K ),
47101     $                           1 )
47102  190             CONTINUE
47103                  SCALE = SCALE*SCALOC
47104               END IF
47105*
47106*              Substitute R(I,J) and L(I,J) into remaining equation.
47107*
47108               IF( J.GT.P+2 ) THEN
47109                  CALL ZGEMM( 'N', 'C', MB, JS-1, NB,
47110     $                        DCMPLX( ONE, ZERO ), C( IS, JS ), LDC,
47111     $                        B( 1, JS ), LDB, DCMPLX( ONE, ZERO ),
47112     $                        F( IS, 1 ), LDF )
47113                  CALL ZGEMM( 'N', 'C', MB, JS-1, NB,
47114     $                        DCMPLX( ONE, ZERO ), F( IS, JS ), LDF,
47115     $                        E( 1, JS ), LDE, DCMPLX( ONE, ZERO ),
47116     $                        F( IS, 1 ), LDF )
47117               END IF
47118               IF( I.LT.P ) THEN
47119                  CALL ZGEMM( 'C', 'N', M-IE, NB, MB,
47120     $                        DCMPLX( -ONE, ZERO ), A( IS, IE+1 ), LDA,
47121     $                        C( IS, JS ), LDC, DCMPLX( ONE, ZERO ),
47122     $                        C( IE+1, JS ), LDC )
47123                  CALL ZGEMM( 'C', 'N', M-IE, NB, MB,
47124     $                        DCMPLX( -ONE, ZERO ), D( IS, IE+1 ), LDD,
47125     $                        F( IS, JS ), LDF, DCMPLX( ONE, ZERO ),
47126     $                        C( IE+1, JS ), LDC )
47127               END IF
47128  200       CONTINUE
47129  210    CONTINUE
47130      END IF
47131*
47132      WORK( 1 ) = LWMIN
47133*
47134      RETURN
47135*
47136*     End of ZTGSYL
47137*
47138      END
47139*> \brief \b ZTRCON
47140*
47141*  =========== DOCUMENTATION ===========
47142*
47143* Online html documentation available at
47144*            http://www.netlib.org/lapack/explore-html/
47145*
47146*> \htmlonly
47147*> Download ZTRCON + dependencies
47148*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztrcon.f">
47149*> [TGZ]</a>
47150*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztrcon.f">
47151*> [ZIP]</a>
47152*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztrcon.f">
47153*> [TXT]</a>
47154*> \endhtmlonly
47155*
47156*  Definition:
47157*  ===========
47158*
47159*       SUBROUTINE ZTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK,
47160*                          RWORK, INFO )
47161*
47162*       .. Scalar Arguments ..
47163*       CHARACTER          DIAG, NORM, UPLO
47164*       INTEGER            INFO, LDA, N
47165*       DOUBLE PRECISION   RCOND
47166*       ..
47167*       .. Array Arguments ..
47168*       DOUBLE PRECISION   RWORK( * )
47169*       COMPLEX*16         A( LDA, * ), WORK( * )
47170*       ..
47171*
47172*
47173*> \par Purpose:
47174*  =============
47175*>
47176*> \verbatim
47177*>
47178*> ZTRCON estimates the reciprocal of the condition number of a
47179*> triangular matrix A, in either the 1-norm or the infinity-norm.
47180*>
47181*> The norm of A is computed and an estimate is obtained for
47182*> norm(inv(A)), then the reciprocal of the condition number is
47183*> computed as
47184*>    RCOND = 1 / ( norm(A) * norm(inv(A)) ).
47185*> \endverbatim
47186*
47187*  Arguments:
47188*  ==========
47189*
47190*> \param[in] NORM
47191*> \verbatim
47192*>          NORM is CHARACTER*1
47193*>          Specifies whether the 1-norm condition number or the
47194*>          infinity-norm condition number is required:
47195*>          = '1' or 'O':  1-norm;
47196*>          = 'I':         Infinity-norm.
47197*> \endverbatim
47198*>
47199*> \param[in] UPLO
47200*> \verbatim
47201*>          UPLO is CHARACTER*1
47202*>          = 'U':  A is upper triangular;
47203*>          = 'L':  A is lower triangular.
47204*> \endverbatim
47205*>
47206*> \param[in] DIAG
47207*> \verbatim
47208*>          DIAG is CHARACTER*1
47209*>          = 'N':  A is non-unit triangular;
47210*>          = 'U':  A is unit triangular.
47211*> \endverbatim
47212*>
47213*> \param[in] N
47214*> \verbatim
47215*>          N is INTEGER
47216*>          The order of the matrix A.  N >= 0.
47217*> \endverbatim
47218*>
47219*> \param[in] A
47220*> \verbatim
47221*>          A is COMPLEX*16 array, dimension (LDA,N)
47222*>          The triangular matrix A.  If UPLO = 'U', the leading N-by-N
47223*>          upper triangular part of the array A contains the upper
47224*>          triangular matrix, and the strictly lower triangular part of
47225*>          A is not referenced.  If UPLO = 'L', the leading N-by-N lower
47226*>          triangular part of the array A contains the lower triangular
47227*>          matrix, and the strictly upper triangular part of A is not
47228*>          referenced.  If DIAG = 'U', the diagonal elements of A are
47229*>          also not referenced and are assumed to be 1.
47230*> \endverbatim
47231*>
47232*> \param[in] LDA
47233*> \verbatim
47234*>          LDA is INTEGER
47235*>          The leading dimension of the array A.  LDA >= max(1,N).
47236*> \endverbatim
47237*>
47238*> \param[out] RCOND
47239*> \verbatim
47240*>          RCOND is DOUBLE PRECISION
47241*>          The reciprocal of the condition number of the matrix A,
47242*>          computed as RCOND = 1/(norm(A) * norm(inv(A))).
47243*> \endverbatim
47244*>
47245*> \param[out] WORK
47246*> \verbatim
47247*>          WORK is COMPLEX*16 array, dimension (2*N)
47248*> \endverbatim
47249*>
47250*> \param[out] RWORK
47251*> \verbatim
47252*>          RWORK is DOUBLE PRECISION array, dimension (N)
47253*> \endverbatim
47254*>
47255*> \param[out] INFO
47256*> \verbatim
47257*>          INFO is INTEGER
47258*>          = 0:  successful exit
47259*>          < 0:  if INFO = -i, the i-th argument had an illegal value
47260*> \endverbatim
47261*
47262*  Authors:
47263*  ========
47264*
47265*> \author Univ. of Tennessee
47266*> \author Univ. of California Berkeley
47267*> \author Univ. of Colorado Denver
47268*> \author NAG Ltd.
47269*
47270*> \date December 2016
47271*
47272*> \ingroup complex16OTHERcomputational
47273*
47274*  =====================================================================
47275      SUBROUTINE ZTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK,
47276     $                   RWORK, INFO )
47277*
47278*  -- LAPACK computational routine (version 3.7.0) --
47279*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
47280*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
47281*     December 2016
47282*
47283*     .. Scalar Arguments ..
47284      CHARACTER          DIAG, NORM, UPLO
47285      INTEGER            INFO, LDA, N
47286      DOUBLE PRECISION   RCOND
47287*     ..
47288*     .. Array Arguments ..
47289      DOUBLE PRECISION   RWORK( * )
47290      COMPLEX*16         A( LDA, * ), WORK( * )
47291*     ..
47292*
47293*  =====================================================================
47294*
47295*     .. Parameters ..
47296      DOUBLE PRECISION   ONE, ZERO
47297      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
47298*     ..
47299*     .. Local Scalars ..
47300      LOGICAL            NOUNIT, ONENRM, UPPER
47301      CHARACTER          NORMIN
47302      INTEGER            IX, KASE, KASE1
47303      DOUBLE PRECISION   AINVNM, ANORM, SCALE, SMLNUM, XNORM
47304      COMPLEX*16         ZDUM
47305*     ..
47306*     .. Local Arrays ..
47307      INTEGER            ISAVE( 3 )
47308*     ..
47309*     .. External Functions ..
47310      LOGICAL            LSAME
47311      INTEGER            IZAMAX
47312      DOUBLE PRECISION   DLAMCH, ZLANTR
47313      EXTERNAL           LSAME, IZAMAX, DLAMCH, ZLANTR
47314*     ..
47315*     .. External Subroutines ..
47316      EXTERNAL           XERBLA, ZDRSCL, ZLACN2, ZLATRS
47317*     ..
47318*     .. Intrinsic Functions ..
47319      INTRINSIC          ABS, DBLE, DIMAG, MAX
47320*     ..
47321*     .. Statement Functions ..
47322      DOUBLE PRECISION   CABS1
47323*     ..
47324*     .. Statement Function definitions ..
47325      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
47326*     ..
47327*     .. Executable Statements ..
47328*
47329*     Test the input parameters.
47330*
47331      INFO = 0
47332      UPPER = LSAME( UPLO, 'U' )
47333      ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
47334      NOUNIT = LSAME( DIAG, 'N' )
47335*
47336      IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
47337         INFO = -1
47338      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
47339         INFO = -2
47340      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
47341         INFO = -3
47342      ELSE IF( N.LT.0 ) THEN
47343         INFO = -4
47344      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
47345         INFO = -6
47346      END IF
47347      IF( INFO.NE.0 ) THEN
47348         CALL XERBLA( 'ZTRCON', -INFO )
47349         RETURN
47350      END IF
47351*
47352*     Quick return if possible
47353*
47354      IF( N.EQ.0 ) THEN
47355         RCOND = ONE
47356         RETURN
47357      END IF
47358*
47359      RCOND = ZERO
47360      SMLNUM = DLAMCH( 'Safe minimum' )*DBLE( MAX( 1, N ) )
47361*
47362*     Compute the norm of the triangular matrix A.
47363*
47364      ANORM = ZLANTR( NORM, UPLO, DIAG, N, N, A, LDA, RWORK )
47365*
47366*     Continue only if ANORM > 0.
47367*
47368      IF( ANORM.GT.ZERO ) THEN
47369*
47370*        Estimate the norm of the inverse of A.
47371*
47372         AINVNM = ZERO
47373         NORMIN = 'N'
47374         IF( ONENRM ) THEN
47375            KASE1 = 1
47376         ELSE
47377            KASE1 = 2
47378         END IF
47379         KASE = 0
47380   10    CONTINUE
47381         CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
47382         IF( KASE.NE.0 ) THEN
47383            IF( KASE.EQ.KASE1 ) THEN
47384*
47385*              Multiply by inv(A).
47386*
47387               CALL ZLATRS( UPLO, 'No transpose', DIAG, NORMIN, N, A,
47388     $                      LDA, WORK, SCALE, RWORK, INFO )
47389            ELSE
47390*
47391*              Multiply by inv(A**H).
47392*
47393               CALL ZLATRS( UPLO, 'Conjugate transpose', DIAG, NORMIN,
47394     $                      N, A, LDA, WORK, SCALE, RWORK, INFO )
47395            END IF
47396            NORMIN = 'Y'
47397*
47398*           Multiply by 1/SCALE if doing so will not cause overflow.
47399*
47400            IF( SCALE.NE.ONE ) THEN
47401               IX = IZAMAX( N, WORK, 1 )
47402               XNORM = CABS1( WORK( IX ) )
47403               IF( SCALE.LT.XNORM*SMLNUM .OR. SCALE.EQ.ZERO )
47404     $            GO TO 20
47405               CALL ZDRSCL( N, SCALE, WORK, 1 )
47406            END IF
47407            GO TO 10
47408         END IF
47409*
47410*        Compute the estimate of the reciprocal condition number.
47411*
47412         IF( AINVNM.NE.ZERO )
47413     $      RCOND = ( ONE / ANORM ) / AINVNM
47414      END IF
47415*
47416   20 CONTINUE
47417      RETURN
47418*
47419*     End of ZTRCON
47420*
47421      END
47422*> \brief \b ZTREVC
47423*
47424*  =========== DOCUMENTATION ===========
47425*
47426* Online html documentation available at
47427*            http://www.netlib.org/lapack/explore-html/
47428*
47429*> \htmlonly
47430*> Download ZTREVC + dependencies
47431*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztrevc.f">
47432*> [TGZ]</a>
47433*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztrevc.f">
47434*> [ZIP]</a>
47435*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztrevc.f">
47436*> [TXT]</a>
47437*> \endhtmlonly
47438*
47439*  Definition:
47440*  ===========
47441*
47442*       SUBROUTINE ZTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
47443*                          LDVR, MM, M, WORK, RWORK, INFO )
47444*
47445*       .. Scalar Arguments ..
47446*       CHARACTER          HOWMNY, SIDE
47447*       INTEGER            INFO, LDT, LDVL, LDVR, M, MM, N
47448*       ..
47449*       .. Array Arguments ..
47450*       LOGICAL            SELECT( * )
47451*       DOUBLE PRECISION   RWORK( * )
47452*       COMPLEX*16         T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
47453*      $                   WORK( * )
47454*       ..
47455*
47456*
47457*> \par Purpose:
47458*  =============
47459*>
47460*> \verbatim
47461*>
47462*> ZTREVC computes some or all of the right and/or left eigenvectors of
47463*> a complex upper triangular matrix T.
47464*> Matrices of this type are produced by the Schur factorization of
47465*> a complex general matrix:  A = Q*T*Q**H, as computed by ZHSEQR.
47466*>
47467*> The right eigenvector x and the left eigenvector y of T corresponding
47468*> to an eigenvalue w are defined by:
47469*>
47470*>              T*x = w*x,     (y**H)*T = w*(y**H)
47471*>
47472*> where y**H denotes the conjugate transpose of the vector y.
47473*> The eigenvalues are not input to this routine, but are read directly
47474*> from the diagonal of T.
47475*>
47476*> This routine returns the matrices X and/or Y of right and left
47477*> eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an
47478*> input matrix.  If Q is the unitary factor that reduces a matrix A to
47479*> Schur form T, then Q*X and Q*Y are the matrices of right and left
47480*> eigenvectors of A.
47481*> \endverbatim
47482*
47483*  Arguments:
47484*  ==========
47485*
47486*> \param[in] SIDE
47487*> \verbatim
47488*>          SIDE is CHARACTER*1
47489*>          = 'R':  compute right eigenvectors only;
47490*>          = 'L':  compute left eigenvectors only;
47491*>          = 'B':  compute both right and left eigenvectors.
47492*> \endverbatim
47493*>
47494*> \param[in] HOWMNY
47495*> \verbatim
47496*>          HOWMNY is CHARACTER*1
47497*>          = 'A':  compute all right and/or left eigenvectors;
47498*>          = 'B':  compute all right and/or left eigenvectors,
47499*>                  backtransformed using the matrices supplied in
47500*>                  VR and/or VL;
47501*>          = 'S':  compute selected right and/or left eigenvectors,
47502*>                  as indicated by the logical array SELECT.
47503*> \endverbatim
47504*>
47505*> \param[in] SELECT
47506*> \verbatim
47507*>          SELECT is LOGICAL array, dimension (N)
47508*>          If HOWMNY = 'S', SELECT specifies the eigenvectors to be
47509*>          computed.
47510*>          The eigenvector corresponding to the j-th eigenvalue is
47511*>          computed if SELECT(j) = .TRUE..
47512*>          Not referenced if HOWMNY = 'A' or 'B'.
47513*> \endverbatim
47514*>
47515*> \param[in] N
47516*> \verbatim
47517*>          N is INTEGER
47518*>          The order of the matrix T. N >= 0.
47519*> \endverbatim
47520*>
47521*> \param[in,out] T
47522*> \verbatim
47523*>          T is COMPLEX*16 array, dimension (LDT,N)
47524*>          The upper triangular matrix T.  T is modified, but restored
47525*>          on exit.
47526*> \endverbatim
47527*>
47528*> \param[in] LDT
47529*> \verbatim
47530*>          LDT is INTEGER
47531*>          The leading dimension of the array T. LDT >= max(1,N).
47532*> \endverbatim
47533*>
47534*> \param[in,out] VL
47535*> \verbatim
47536*>          VL is COMPLEX*16 array, dimension (LDVL,MM)
47537*>          On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
47538*>          contain an N-by-N matrix Q (usually the unitary matrix Q of
47539*>          Schur vectors returned by ZHSEQR).
47540*>          On exit, if SIDE = 'L' or 'B', VL contains:
47541*>          if HOWMNY = 'A', the matrix Y of left eigenvectors of T;
47542*>          if HOWMNY = 'B', the matrix Q*Y;
47543*>          if HOWMNY = 'S', the left eigenvectors of T specified by
47544*>                           SELECT, stored consecutively in the columns
47545*>                           of VL, in the same order as their
47546*>                           eigenvalues.
47547*>          Not referenced if SIDE = 'R'.
47548*> \endverbatim
47549*>
47550*> \param[in] LDVL
47551*> \verbatim
47552*>          LDVL is INTEGER
47553*>          The leading dimension of the array VL.  LDVL >= 1, and if
47554*>          SIDE = 'L' or 'B', LDVL >= N.
47555*> \endverbatim
47556*>
47557*> \param[in,out] VR
47558*> \verbatim
47559*>          VR is COMPLEX*16 array, dimension (LDVR,MM)
47560*>          On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
47561*>          contain an N-by-N matrix Q (usually the unitary matrix Q of
47562*>          Schur vectors returned by ZHSEQR).
47563*>          On exit, if SIDE = 'R' or 'B', VR contains:
47564*>          if HOWMNY = 'A', the matrix X of right eigenvectors of T;
47565*>          if HOWMNY = 'B', the matrix Q*X;
47566*>          if HOWMNY = 'S', the right eigenvectors of T specified by
47567*>                           SELECT, stored consecutively in the columns
47568*>                           of VR, in the same order as their
47569*>                           eigenvalues.
47570*>          Not referenced if SIDE = 'L'.
47571*> \endverbatim
47572*>
47573*> \param[in] LDVR
47574*> \verbatim
47575*>          LDVR is INTEGER
47576*>          The leading dimension of the array VR.  LDVR >= 1, and if
47577*>          SIDE = 'R' or 'B'; LDVR >= N.
47578*> \endverbatim
47579*>
47580*> \param[in] MM
47581*> \verbatim
47582*>          MM is INTEGER
47583*>          The number of columns in the arrays VL and/or VR. MM >= M.
47584*> \endverbatim
47585*>
47586*> \param[out] M
47587*> \verbatim
47588*>          M is INTEGER
47589*>          The number of columns in the arrays VL and/or VR actually
47590*>          used to store the eigenvectors.  If HOWMNY = 'A' or 'B', M
47591*>          is set to N.  Each selected eigenvector occupies one
47592*>          column.
47593*> \endverbatim
47594*>
47595*> \param[out] WORK
47596*> \verbatim
47597*>          WORK is COMPLEX*16 array, dimension (2*N)
47598*> \endverbatim
47599*>
47600*> \param[out] RWORK
47601*> \verbatim
47602*>          RWORK is DOUBLE PRECISION array, dimension (N)
47603*> \endverbatim
47604*>
47605*> \param[out] INFO
47606*> \verbatim
47607*>          INFO is INTEGER
47608*>          = 0:  successful exit
47609*>          < 0:  if INFO = -i, the i-th argument had an illegal value
47610*> \endverbatim
47611*
47612*  Authors:
47613*  ========
47614*
47615*> \author Univ. of Tennessee
47616*> \author Univ. of California Berkeley
47617*> \author Univ. of Colorado Denver
47618*> \author NAG Ltd.
47619*
47620*> \date November 2017
47621*
47622*> \ingroup complex16OTHERcomputational
47623*
47624*> \par Further Details:
47625*  =====================
47626*>
47627*> \verbatim
47628*>
47629*>  The algorithm used in this program is basically backward (forward)
47630*>  substitution, with scaling to make the the code robust against
47631*>  possible overflow.
47632*>
47633*>  Each eigenvector is normalized so that the element of largest
47634*>  magnitude has magnitude 1; here the magnitude of a complex number
47635*>  (x,y) is taken to be |x| + |y|.
47636*> \endverbatim
47637*>
47638*  =====================================================================
47639      SUBROUTINE ZTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
47640     $                   LDVR, MM, M, WORK, RWORK, INFO )
47641*
47642*  -- LAPACK computational routine (version 3.8.0) --
47643*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
47644*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
47645*     November 2017
47646*
47647*     .. Scalar Arguments ..
47648      CHARACTER          HOWMNY, SIDE
47649      INTEGER            INFO, LDT, LDVL, LDVR, M, MM, N
47650*     ..
47651*     .. Array Arguments ..
47652      LOGICAL            SELECT( * )
47653      DOUBLE PRECISION   RWORK( * )
47654      COMPLEX*16         T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
47655     $                   WORK( * )
47656*     ..
47657*
47658*  =====================================================================
47659*
47660*     .. Parameters ..
47661      DOUBLE PRECISION   ZERO, ONE
47662      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
47663      COMPLEX*16         CMZERO, CMONE
47664      PARAMETER          ( CMZERO = ( 0.0D+0, 0.0D+0 ),
47665     $                   CMONE = ( 1.0D+0, 0.0D+0 ) )
47666*     ..
47667*     .. Local Scalars ..
47668      LOGICAL            ALLV, BOTHV, LEFTV, OVER, RIGHTV, SOMEV
47669      INTEGER            I, II, IS, J, K, KI
47670      DOUBLE PRECISION   OVFL, REMAX, SCALE, SMIN, SMLNUM, ULP, UNFL
47671      COMPLEX*16         CDUM
47672*     ..
47673*     .. External Functions ..
47674      LOGICAL            LSAME
47675      INTEGER            IZAMAX
47676      DOUBLE PRECISION   DLAMCH, DZASUM
47677      EXTERNAL           LSAME, IZAMAX, DLAMCH, DZASUM
47678*     ..
47679*     .. External Subroutines ..
47680      EXTERNAL           XERBLA, ZCOPY, ZDSCAL, ZGEMV, ZLATRS, DLABAD
47681*     ..
47682*     .. Intrinsic Functions ..
47683      INTRINSIC          ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX
47684*     ..
47685*     .. Statement Functions ..
47686      DOUBLE PRECISION   CABS1
47687*     ..
47688*     .. Statement Function definitions ..
47689      CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
47690*     ..
47691*     .. Executable Statements ..
47692*
47693*     Decode and test the input parameters
47694*
47695      BOTHV = LSAME( SIDE, 'B' )
47696      RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV
47697      LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV
47698*
47699      ALLV = LSAME( HOWMNY, 'A' )
47700      OVER = LSAME( HOWMNY, 'B' )
47701      SOMEV = LSAME( HOWMNY, 'S' )
47702*
47703*     Set M to the number of columns required to store the selected
47704*     eigenvectors.
47705*
47706      IF( SOMEV ) THEN
47707         M = 0
47708         DO 10 J = 1, N
47709            IF( SELECT( J ) )
47710     $         M = M + 1
47711   10    CONTINUE
47712      ELSE
47713         M = N
47714      END IF
47715*
47716      INFO = 0
47717      IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
47718         INFO = -1
47719      ELSE IF( .NOT.ALLV .AND. .NOT.OVER .AND. .NOT.SOMEV ) THEN
47720         INFO = -2
47721      ELSE IF( N.LT.0 ) THEN
47722         INFO = -4
47723      ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
47724         INFO = -6
47725      ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN
47726         INFO = -8
47727      ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN
47728         INFO = -10
47729      ELSE IF( MM.LT.M ) THEN
47730         INFO = -11
47731      END IF
47732      IF( INFO.NE.0 ) THEN
47733         CALL XERBLA( 'ZTREVC', -INFO )
47734         RETURN
47735      END IF
47736*
47737*     Quick return if possible.
47738*
47739      IF( N.EQ.0 )
47740     $   RETURN
47741*
47742*     Set the constants to control overflow.
47743*
47744      UNFL = DLAMCH( 'Safe minimum' )
47745      OVFL = ONE / UNFL
47746      CALL DLABAD( UNFL, OVFL )
47747      ULP = DLAMCH( 'Precision' )
47748      SMLNUM = UNFL*( N / ULP )
47749*
47750*     Store the diagonal elements of T in working array WORK.
47751*
47752      DO 20 I = 1, N
47753         WORK( I+N ) = T( I, I )
47754   20 CONTINUE
47755*
47756*     Compute 1-norm of each column of strictly upper triangular
47757*     part of T to control overflow in triangular solver.
47758*
47759      RWORK( 1 ) = ZERO
47760      DO 30 J = 2, N
47761         RWORK( J ) = DZASUM( J-1, T( 1, J ), 1 )
47762   30 CONTINUE
47763*
47764      IF( RIGHTV ) THEN
47765*
47766*        Compute right eigenvectors.
47767*
47768         IS = M
47769         DO 80 KI = N, 1, -1
47770*
47771            IF( SOMEV ) THEN
47772               IF( .NOT.SELECT( KI ) )
47773     $            GO TO 80
47774            END IF
47775            SMIN = MAX( ULP*( CABS1( T( KI, KI ) ) ), SMLNUM )
47776*
47777            WORK( 1 ) = CMONE
47778*
47779*           Form right-hand side.
47780*
47781            DO 40 K = 1, KI - 1
47782               WORK( K ) = -T( K, KI )
47783   40       CONTINUE
47784*
47785*           Solve the triangular system:
47786*              (T(1:KI-1,1:KI-1) - T(KI,KI))*X = SCALE*WORK.
47787*
47788            DO 50 K = 1, KI - 1
47789               T( K, K ) = T( K, K ) - T( KI, KI )
47790               IF( CABS1( T( K, K ) ).LT.SMIN )
47791     $            T( K, K ) = SMIN
47792   50       CONTINUE
47793*
47794            IF( KI.GT.1 ) THEN
47795               CALL ZLATRS( 'Upper', 'No transpose', 'Non-unit', 'Y',
47796     $                      KI-1, T, LDT, WORK( 1 ), SCALE, RWORK,
47797     $                      INFO )
47798               WORK( KI ) = SCALE
47799            END IF
47800*
47801*           Copy the vector x or Q*x to VR and normalize.
47802*
47803            IF( .NOT.OVER ) THEN
47804               CALL ZCOPY( KI, WORK( 1 ), 1, VR( 1, IS ), 1 )
47805*
47806               II = IZAMAX( KI, VR( 1, IS ), 1 )
47807               REMAX = ONE / CABS1( VR( II, IS ) )
47808               CALL ZDSCAL( KI, REMAX, VR( 1, IS ), 1 )
47809*
47810               DO 60 K = KI + 1, N
47811                  VR( K, IS ) = CMZERO
47812   60          CONTINUE
47813            ELSE
47814               IF( KI.GT.1 )
47815     $            CALL ZGEMV( 'N', N, KI-1, CMONE, VR, LDVR, WORK( 1 ),
47816     $                        1, DCMPLX( SCALE ), VR( 1, KI ), 1 )
47817*
47818               II = IZAMAX( N, VR( 1, KI ), 1 )
47819               REMAX = ONE / CABS1( VR( II, KI ) )
47820               CALL ZDSCAL( N, REMAX, VR( 1, KI ), 1 )
47821            END IF
47822*
47823*           Set back the original diagonal elements of T.
47824*
47825            DO 70 K = 1, KI - 1
47826               T( K, K ) = WORK( K+N )
47827   70       CONTINUE
47828*
47829            IS = IS - 1
47830   80    CONTINUE
47831      END IF
47832*
47833      IF( LEFTV ) THEN
47834*
47835*        Compute left eigenvectors.
47836*
47837         IS = 1
47838         DO 130 KI = 1, N
47839*
47840            IF( SOMEV ) THEN
47841               IF( .NOT.SELECT( KI ) )
47842     $            GO TO 130
47843            END IF
47844            SMIN = MAX( ULP*( CABS1( T( KI, KI ) ) ), SMLNUM )
47845*
47846            WORK( N ) = CMONE
47847*
47848*           Form right-hand side.
47849*
47850            DO 90 K = KI + 1, N
47851               WORK( K ) = -DCONJG( T( KI, K ) )
47852   90       CONTINUE
47853*
47854*           Solve the triangular system:
47855*              (T(KI+1:N,KI+1:N) - T(KI,KI))**H * X = SCALE*WORK.
47856*
47857            DO 100 K = KI + 1, N
47858               T( K, K ) = T( K, K ) - T( KI, KI )
47859               IF( CABS1( T( K, K ) ).LT.SMIN )
47860     $            T( K, K ) = SMIN
47861  100       CONTINUE
47862*
47863            IF( KI.LT.N ) THEN
47864               CALL ZLATRS( 'Upper', 'Conjugate transpose', 'Non-unit',
47865     $                      'Y', N-KI, T( KI+1, KI+1 ), LDT,
47866     $                      WORK( KI+1 ), SCALE, RWORK, INFO )
47867               WORK( KI ) = SCALE
47868            END IF
47869*
47870*           Copy the vector x or Q*x to VL and normalize.
47871*
47872            IF( .NOT.OVER ) THEN
47873               CALL ZCOPY( N-KI+1, WORK( KI ), 1, VL( KI, IS ), 1 )
47874*
47875               II = IZAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1
47876               REMAX = ONE / CABS1( VL( II, IS ) )
47877               CALL ZDSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 )
47878*
47879               DO 110 K = 1, KI - 1
47880                  VL( K, IS ) = CMZERO
47881  110          CONTINUE
47882            ELSE
47883               IF( KI.LT.N )
47884     $            CALL ZGEMV( 'N', N, N-KI, CMONE, VL( 1, KI+1 ), LDVL,
47885     $                        WORK( KI+1 ), 1, DCMPLX( SCALE ),
47886     $                        VL( 1, KI ), 1 )
47887*
47888               II = IZAMAX( N, VL( 1, KI ), 1 )
47889               REMAX = ONE / CABS1( VL( II, KI ) )
47890               CALL ZDSCAL( N, REMAX, VL( 1, KI ), 1 )
47891            END IF
47892*
47893*           Set back the original diagonal elements of T.
47894*
47895            DO 120 K = KI + 1, N
47896               T( K, K ) = WORK( K+N )
47897  120       CONTINUE
47898*
47899            IS = IS + 1
47900  130    CONTINUE
47901      END IF
47902*
47903      RETURN
47904*
47905*     End of ZTREVC
47906*
47907      END
47908*> \brief \b ZTREVC3
47909*
47910*  =========== DOCUMENTATION ===========
47911*
47912* Online html documentation available at
47913*            http://www.netlib.org/lapack/explore-html/
47914*
47915*> \htmlonly
47916*> Download ZTREVC3 + dependencies
47917*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztrevc3.f">
47918*> [TGZ]</a>
47919*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztrevc3.f">
47920*> [ZIP]</a>
47921*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztrevc3.f">
47922*> [TXT]</a>
47923*> \endhtmlonly
47924*
47925*  Definition:
47926*  ===========
47927*
47928*       SUBROUTINE ZTREVC3( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
47929*      $                    LDVR, MM, M, WORK, LWORK, RWORK, LRWORK, INFO)
47930*
47931*       .. Scalar Arguments ..
47932*       CHARACTER          HOWMNY, SIDE
47933*       INTEGER            INFO, LDT, LDVL, LDVR, LWORK, M, MM, N
47934*       ..
47935*       .. Array Arguments ..
47936*       LOGICAL            SELECT( * )
47937*       DOUBLE PRECISION   RWORK( * )
47938*       COMPLEX*16         T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
47939*      $                   WORK( * )
47940*       ..
47941*
47942*
47943*> \par Purpose:
47944*  =============
47945*>
47946*> \verbatim
47947*>
47948*> ZTREVC3 computes some or all of the right and/or left eigenvectors of
47949*> a complex upper triangular matrix T.
47950*> Matrices of this type are produced by the Schur factorization of
47951*> a complex general matrix:  A = Q*T*Q**H, as computed by ZHSEQR.
47952*>
47953*> The right eigenvector x and the left eigenvector y of T corresponding
47954*> to an eigenvalue w are defined by:
47955*>
47956*>              T*x = w*x,     (y**H)*T = w*(y**H)
47957*>
47958*> where y**H denotes the conjugate transpose of the vector y.
47959*> The eigenvalues are not input to this routine, but are read directly
47960*> from the diagonal of T.
47961*>
47962*> This routine returns the matrices X and/or Y of right and left
47963*> eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an
47964*> input matrix. If Q is the unitary factor that reduces a matrix A to
47965*> Schur form T, then Q*X and Q*Y are the matrices of right and left
47966*> eigenvectors of A.
47967*>
47968*> This uses a Level 3 BLAS version of the back transformation.
47969*> \endverbatim
47970*
47971*  Arguments:
47972*  ==========
47973*
47974*> \param[in] SIDE
47975*> \verbatim
47976*>          SIDE is CHARACTER*1
47977*>          = 'R':  compute right eigenvectors only;
47978*>          = 'L':  compute left eigenvectors only;
47979*>          = 'B':  compute both right and left eigenvectors.
47980*> \endverbatim
47981*>
47982*> \param[in] HOWMNY
47983*> \verbatim
47984*>          HOWMNY is CHARACTER*1
47985*>          = 'A':  compute all right and/or left eigenvectors;
47986*>          = 'B':  compute all right and/or left eigenvectors,
47987*>                  backtransformed using the matrices supplied in
47988*>                  VR and/or VL;
47989*>          = 'S':  compute selected right and/or left eigenvectors,
47990*>                  as indicated by the logical array SELECT.
47991*> \endverbatim
47992*>
47993*> \param[in] SELECT
47994*> \verbatim
47995*>          SELECT is LOGICAL array, dimension (N)
47996*>          If HOWMNY = 'S', SELECT specifies the eigenvectors to be
47997*>          computed.
47998*>          The eigenvector corresponding to the j-th eigenvalue is
47999*>          computed if SELECT(j) = .TRUE..
48000*>          Not referenced if HOWMNY = 'A' or 'B'.
48001*> \endverbatim
48002*>
48003*> \param[in] N
48004*> \verbatim
48005*>          N is INTEGER
48006*>          The order of the matrix T. N >= 0.
48007*> \endverbatim
48008*>
48009*> \param[in,out] T
48010*> \verbatim
48011*>          T is COMPLEX*16 array, dimension (LDT,N)
48012*>          The upper triangular matrix T.  T is modified, but restored
48013*>          on exit.
48014*> \endverbatim
48015*>
48016*> \param[in] LDT
48017*> \verbatim
48018*>          LDT is INTEGER
48019*>          The leading dimension of the array T. LDT >= max(1,N).
48020*> \endverbatim
48021*>
48022*> \param[in,out] VL
48023*> \verbatim
48024*>          VL is COMPLEX*16 array, dimension (LDVL,MM)
48025*>          On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
48026*>          contain an N-by-N matrix Q (usually the unitary matrix Q of
48027*>          Schur vectors returned by ZHSEQR).
48028*>          On exit, if SIDE = 'L' or 'B', VL contains:
48029*>          if HOWMNY = 'A', the matrix Y of left eigenvectors of T;
48030*>          if HOWMNY = 'B', the matrix Q*Y;
48031*>          if HOWMNY = 'S', the left eigenvectors of T specified by
48032*>                           SELECT, stored consecutively in the columns
48033*>                           of VL, in the same order as their
48034*>                           eigenvalues.
48035*>          Not referenced if SIDE = 'R'.
48036*> \endverbatim
48037*>
48038*> \param[in] LDVL
48039*> \verbatim
48040*>          LDVL is INTEGER
48041*>          The leading dimension of the array VL.
48042*>          LDVL >= 1, and if SIDE = 'L' or 'B', LDVL >= N.
48043*> \endverbatim
48044*>
48045*> \param[in,out] VR
48046*> \verbatim
48047*>          VR is COMPLEX*16 array, dimension (LDVR,MM)
48048*>          On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
48049*>          contain an N-by-N matrix Q (usually the unitary matrix Q of
48050*>          Schur vectors returned by ZHSEQR).
48051*>          On exit, if SIDE = 'R' or 'B', VR contains:
48052*>          if HOWMNY = 'A', the matrix X of right eigenvectors of T;
48053*>          if HOWMNY = 'B', the matrix Q*X;
48054*>          if HOWMNY = 'S', the right eigenvectors of T specified by
48055*>                           SELECT, stored consecutively in the columns
48056*>                           of VR, in the same order as their
48057*>                           eigenvalues.
48058*>          Not referenced if SIDE = 'L'.
48059*> \endverbatim
48060*>
48061*> \param[in] LDVR
48062*> \verbatim
48063*>          LDVR is INTEGER
48064*>          The leading dimension of the array VR.
48065*>          LDVR >= 1, and if SIDE = 'R' or 'B', LDVR >= N.
48066*> \endverbatim
48067*>
48068*> \param[in] MM
48069*> \verbatim
48070*>          MM is INTEGER
48071*>          The number of columns in the arrays VL and/or VR. MM >= M.
48072*> \endverbatim
48073*>
48074*> \param[out] M
48075*> \verbatim
48076*>          M is INTEGER
48077*>          The number of columns in the arrays VL and/or VR actually
48078*>          used to store the eigenvectors.
48079*>          If HOWMNY = 'A' or 'B', M is set to N.
48080*>          Each selected eigenvector occupies one column.
48081*> \endverbatim
48082*>
48083*> \param[out] WORK
48084*> \verbatim
48085*>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
48086*> \endverbatim
48087*>
48088*> \param[in] LWORK
48089*> \verbatim
48090*>          LWORK is INTEGER
48091*>          The dimension of array WORK. LWORK >= max(1,2*N).
48092*>          For optimum performance, LWORK >= N + 2*N*NB, where NB is
48093*>          the optimal blocksize.
48094*>
48095*>          If LWORK = -1, then a workspace query is assumed; the routine
48096*>          only calculates the optimal size of the WORK array, returns
48097*>          this value as the first entry of the WORK array, and no error
48098*>          message related to LWORK is issued by XERBLA.
48099*> \endverbatim
48100*>
48101*> \param[out] RWORK
48102*> \verbatim
48103*>          RWORK is DOUBLE PRECISION array, dimension (LRWORK)
48104*> \endverbatim
48105*>
48106*> \param[in] LRWORK
48107*> \verbatim
48108*>          LRWORK is INTEGER
48109*>          The dimension of array RWORK. LRWORK >= max(1,N).
48110*>
48111*>          If LRWORK = -1, then a workspace query is assumed; the routine
48112*>          only calculates the optimal size of the RWORK array, returns
48113*>          this value as the first entry of the RWORK array, and no error
48114*>          message related to LRWORK is issued by XERBLA.
48115*> \endverbatim
48116*>
48117*> \param[out] INFO
48118*> \verbatim
48119*>          INFO is INTEGER
48120*>          = 0:  successful exit
48121*>          < 0:  if INFO = -i, the i-th argument had an illegal value
48122*> \endverbatim
48123*
48124*  Authors:
48125*  ========
48126*
48127*> \author Univ. of Tennessee
48128*> \author Univ. of California Berkeley
48129*> \author Univ. of Colorado Denver
48130*> \author NAG Ltd.
48131*
48132*> \date November 2017
48133*
48134*  @precisions fortran z -> c
48135*
48136*> \ingroup complex16OTHERcomputational
48137*
48138*> \par Further Details:
48139*  =====================
48140*>
48141*> \verbatim
48142*>
48143*>  The algorithm used in this program is basically backward (forward)
48144*>  substitution, with scaling to make the the code robust against
48145*>  possible overflow.
48146*>
48147*>  Each eigenvector is normalized so that the element of largest
48148*>  magnitude has magnitude 1; here the magnitude of a complex number
48149*>  (x,y) is taken to be |x| + |y|.
48150*> \endverbatim
48151*>
48152*  =====================================================================
48153      SUBROUTINE ZTREVC3( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
48154     $                    LDVR, MM, M, WORK, LWORK, RWORK, LRWORK, INFO)
48155      IMPLICIT NONE
48156*
48157*  -- LAPACK computational routine (version 3.8.0) --
48158*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
48159*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
48160*     November 2017
48161*
48162*     .. Scalar Arguments ..
48163      CHARACTER          HOWMNY, SIDE
48164      INTEGER            INFO, LDT, LDVL, LDVR, LWORK, LRWORK, M, MM, N
48165*     ..
48166*     .. Array Arguments ..
48167      LOGICAL            SELECT( * )
48168      DOUBLE PRECISION   RWORK( * )
48169      COMPLEX*16         T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
48170     $                   WORK( * )
48171*     ..
48172*
48173*  =====================================================================
48174*
48175*     .. Parameters ..
48176      DOUBLE PRECISION   ZERO, ONE
48177      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
48178      COMPLEX*16         CZERO, CONE
48179      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ),
48180     $                     CONE  = ( 1.0D+0, 0.0D+0 ) )
48181      INTEGER            NBMIN, NBMAX
48182      PARAMETER          ( NBMIN = 8, NBMAX = 128 )
48183*     ..
48184*     .. Local Scalars ..
48185      LOGICAL            ALLV, BOTHV, LEFTV, LQUERY, OVER, RIGHTV, SOMEV
48186      INTEGER            I, II, IS, J, K, KI, IV, MAXWRK, NB
48187      DOUBLE PRECISION   OVFL, REMAX, SCALE, SMIN, SMLNUM, ULP, UNFL
48188      COMPLEX*16         CDUM
48189*     ..
48190*     .. External Functions ..
48191      LOGICAL            LSAME
48192      INTEGER            ILAENV, IZAMAX
48193      DOUBLE PRECISION   DLAMCH, DZASUM
48194      EXTERNAL           LSAME, ILAENV, IZAMAX, DLAMCH, DZASUM
48195*     ..
48196*     .. External Subroutines ..
48197      EXTERNAL           XERBLA, ZCOPY, ZDSCAL, ZGEMV, ZLATRS,
48198     $                   ZGEMM, DLABAD, ZLASET, ZLACPY
48199*     ..
48200*     .. Intrinsic Functions ..
48201      INTRINSIC          ABS, DBLE, DCMPLX, CONJG, AIMAG, MAX
48202*     ..
48203*     .. Statement Functions ..
48204      DOUBLE PRECISION   CABS1
48205*     ..
48206*     .. Statement Function definitions ..
48207      CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( AIMAG( CDUM ) )
48208*     ..
48209*     .. Executable Statements ..
48210*
48211*     Decode and test the input parameters
48212*
48213      BOTHV  = LSAME( SIDE, 'B' )
48214      RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV
48215      LEFTV  = LSAME( SIDE, 'L' ) .OR. BOTHV
48216*
48217      ALLV  = LSAME( HOWMNY, 'A' )
48218      OVER  = LSAME( HOWMNY, 'B' )
48219      SOMEV = LSAME( HOWMNY, 'S' )
48220*
48221*     Set M to the number of columns required to store the selected
48222*     eigenvectors.
48223*
48224      IF( SOMEV ) THEN
48225         M = 0
48226         DO 10 J = 1, N
48227            IF( SELECT( J ) )
48228     $         M = M + 1
48229   10    CONTINUE
48230      ELSE
48231         M = N
48232      END IF
48233*
48234      INFO = 0
48235      NB = ILAENV( 1, 'ZTREVC', SIDE // HOWMNY, N, -1, -1, -1 )
48236      MAXWRK = N + 2*N*NB
48237      WORK(1) = MAXWRK
48238      RWORK(1) = N
48239      LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 )
48240      IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
48241         INFO = -1
48242      ELSE IF( .NOT.ALLV .AND. .NOT.OVER .AND. .NOT.SOMEV ) THEN
48243         INFO = -2
48244      ELSE IF( N.LT.0 ) THEN
48245         INFO = -4
48246      ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
48247         INFO = -6
48248      ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN
48249         INFO = -8
48250      ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN
48251         INFO = -10
48252      ELSE IF( MM.LT.M ) THEN
48253         INFO = -11
48254      ELSE IF( LWORK.LT.MAX( 1, 2*N ) .AND. .NOT.LQUERY ) THEN
48255         INFO = -14
48256      ELSE IF ( LRWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
48257         INFO = -16
48258      END IF
48259      IF( INFO.NE.0 ) THEN
48260         CALL XERBLA( 'ZTREVC3', -INFO )
48261         RETURN
48262      ELSE IF( LQUERY ) THEN
48263         RETURN
48264      END IF
48265*
48266*     Quick return if possible.
48267*
48268      IF( N.EQ.0 )
48269     $   RETURN
48270*
48271*     Use blocked version of back-transformation if sufficient workspace.
48272*     Zero-out the workspace to avoid potential NaN propagation.
48273*
48274      IF( OVER .AND. LWORK .GE. N + 2*N*NBMIN ) THEN
48275         NB = (LWORK - N) / (2*N)
48276         NB = MIN( NB, NBMAX )
48277         CALL ZLASET( 'F', N, 1+2*NB, CZERO, CZERO, WORK, N )
48278      ELSE
48279         NB = 1
48280      END IF
48281*
48282*     Set the constants to control overflow.
48283*
48284      UNFL = DLAMCH( 'Safe minimum' )
48285      OVFL = ONE / UNFL
48286      CALL DLABAD( UNFL, OVFL )
48287      ULP = DLAMCH( 'Precision' )
48288      SMLNUM = UNFL*( N / ULP )
48289*
48290*     Store the diagonal elements of T in working array WORK.
48291*
48292      DO 20 I = 1, N
48293         WORK( I ) = T( I, I )
48294   20 CONTINUE
48295*
48296*     Compute 1-norm of each column of strictly upper triangular
48297*     part of T to control overflow in triangular solver.
48298*
48299      RWORK( 1 ) = ZERO
48300      DO 30 J = 2, N
48301         RWORK( J ) = DZASUM( J-1, T( 1, J ), 1 )
48302   30 CONTINUE
48303*
48304      IF( RIGHTV ) THEN
48305*
48306*        ============================================================
48307*        Compute right eigenvectors.
48308*
48309*        IV is index of column in current block.
48310*        Non-blocked version always uses IV=NB=1;
48311*        blocked     version starts with IV=NB, goes down to 1.
48312*        (Note the "0-th" column is used to store the original diagonal.)
48313         IV = NB
48314         IS = M
48315         DO 80 KI = N, 1, -1
48316            IF( SOMEV ) THEN
48317               IF( .NOT.SELECT( KI ) )
48318     $            GO TO 80
48319            END IF
48320            SMIN = MAX( ULP*( CABS1( T( KI, KI ) ) ), SMLNUM )
48321*
48322*           --------------------------------------------------------
48323*           Complex right eigenvector
48324*
48325            WORK( KI + IV*N ) = CONE
48326*
48327*           Form right-hand side.
48328*
48329            DO 40 K = 1, KI - 1
48330               WORK( K + IV*N ) = -T( K, KI )
48331   40       CONTINUE
48332*
48333*           Solve upper triangular system:
48334*           [ T(1:KI-1,1:KI-1) - T(KI,KI) ]*X = SCALE*WORK.
48335*
48336            DO 50 K = 1, KI - 1
48337               T( K, K ) = T( K, K ) - T( KI, KI )
48338               IF( CABS1( T( K, K ) ).LT.SMIN )
48339     $            T( K, K ) = SMIN
48340   50       CONTINUE
48341*
48342            IF( KI.GT.1 ) THEN
48343               CALL ZLATRS( 'Upper', 'No transpose', 'Non-unit', 'Y',
48344     $                      KI-1, T, LDT, WORK( 1 + IV*N ), SCALE,
48345     $                      RWORK, INFO )
48346               WORK( KI + IV*N ) = SCALE
48347            END IF
48348*
48349*           Copy the vector x or Q*x to VR and normalize.
48350*
48351            IF( .NOT.OVER ) THEN
48352*              ------------------------------
48353*              no back-transform: copy x to VR and normalize.
48354               CALL ZCOPY( KI, WORK( 1 + IV*N ), 1, VR( 1, IS ), 1 )
48355*
48356               II = IZAMAX( KI, VR( 1, IS ), 1 )
48357               REMAX = ONE / CABS1( VR( II, IS ) )
48358               CALL ZDSCAL( KI, REMAX, VR( 1, IS ), 1 )
48359*
48360               DO 60 K = KI + 1, N
48361                  VR( K, IS ) = CZERO
48362   60          CONTINUE
48363*
48364            ELSE IF( NB.EQ.1 ) THEN
48365*              ------------------------------
48366*              version 1: back-transform each vector with GEMV, Q*x.
48367               IF( KI.GT.1 )
48368     $            CALL ZGEMV( 'N', N, KI-1, CONE, VR, LDVR,
48369     $                        WORK( 1 + IV*N ), 1, DCMPLX( SCALE ),
48370     $                        VR( 1, KI ), 1 )
48371*
48372               II = IZAMAX( N, VR( 1, KI ), 1 )
48373               REMAX = ONE / CABS1( VR( II, KI ) )
48374               CALL ZDSCAL( N, REMAX, VR( 1, KI ), 1 )
48375*
48376            ELSE
48377*              ------------------------------
48378*              version 2: back-transform block of vectors with GEMM
48379*              zero out below vector
48380               DO K = KI + 1, N
48381                  WORK( K + IV*N ) = CZERO
48382               END DO
48383*
48384*              Columns IV:NB of work are valid vectors.
48385*              When the number of vectors stored reaches NB,
48386*              or if this was last vector, do the GEMM
48387               IF( (IV.EQ.1) .OR. (KI.EQ.1) ) THEN
48388                  CALL ZGEMM( 'N', 'N', N, NB-IV+1, KI+NB-IV, CONE,
48389     $                        VR, LDVR,
48390     $                        WORK( 1 + (IV)*N    ), N,
48391     $                        CZERO,
48392     $                        WORK( 1 + (NB+IV)*N ), N )
48393*                 normalize vectors
48394                  DO K = IV, NB
48395                     II = IZAMAX( N, WORK( 1 + (NB+K)*N ), 1 )
48396                     REMAX = ONE / CABS1( WORK( II + (NB+K)*N ) )
48397                     CALL ZDSCAL( N, REMAX, WORK( 1 + (NB+K)*N ), 1 )
48398                  END DO
48399                  CALL ZLACPY( 'F', N, NB-IV+1,
48400     $                         WORK( 1 + (NB+IV)*N ), N,
48401     $                         VR( 1, KI ), LDVR )
48402                  IV = NB
48403               ELSE
48404                  IV = IV - 1
48405               END IF
48406            END IF
48407*
48408*           Restore the original diagonal elements of T.
48409*
48410            DO 70 K = 1, KI - 1
48411               T( K, K ) = WORK( K )
48412   70       CONTINUE
48413*
48414            IS = IS - 1
48415   80    CONTINUE
48416      END IF
48417*
48418      IF( LEFTV ) THEN
48419*
48420*        ============================================================
48421*        Compute left eigenvectors.
48422*
48423*        IV is index of column in current block.
48424*        Non-blocked version always uses IV=1;
48425*        blocked     version starts with IV=1, goes up to NB.
48426*        (Note the "0-th" column is used to store the original diagonal.)
48427         IV = 1
48428         IS = 1
48429         DO 130 KI = 1, N
48430*
48431            IF( SOMEV ) THEN
48432               IF( .NOT.SELECT( KI ) )
48433     $            GO TO 130
48434            END IF
48435            SMIN = MAX( ULP*( CABS1( T( KI, KI ) ) ), SMLNUM )
48436*
48437*           --------------------------------------------------------
48438*           Complex left eigenvector
48439*
48440            WORK( KI + IV*N ) = CONE
48441*
48442*           Form right-hand side.
48443*
48444            DO 90 K = KI + 1, N
48445               WORK( K + IV*N ) = -CONJG( T( KI, K ) )
48446   90       CONTINUE
48447*
48448*           Solve conjugate-transposed triangular system:
48449*           [ T(KI+1:N,KI+1:N) - T(KI,KI) ]**H * X = SCALE*WORK.
48450*
48451            DO 100 K = KI + 1, N
48452               T( K, K ) = T( K, K ) - T( KI, KI )
48453               IF( CABS1( T( K, K ) ).LT.SMIN )
48454     $            T( K, K ) = SMIN
48455  100       CONTINUE
48456*
48457            IF( KI.LT.N ) THEN
48458               CALL ZLATRS( 'Upper', 'Conjugate transpose', 'Non-unit',
48459     $                      'Y', N-KI, T( KI+1, KI+1 ), LDT,
48460     $                      WORK( KI+1 + IV*N ), SCALE, RWORK, INFO )
48461               WORK( KI + IV*N ) = SCALE
48462            END IF
48463*
48464*           Copy the vector x or Q*x to VL and normalize.
48465*
48466            IF( .NOT.OVER ) THEN
48467*              ------------------------------
48468*              no back-transform: copy x to VL and normalize.
48469               CALL ZCOPY( N-KI+1, WORK( KI + IV*N ), 1, VL(KI,IS), 1 )
48470*
48471               II = IZAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1
48472               REMAX = ONE / CABS1( VL( II, IS ) )
48473               CALL ZDSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 )
48474*
48475               DO 110 K = 1, KI - 1
48476                  VL( K, IS ) = CZERO
48477  110          CONTINUE
48478*
48479            ELSE IF( NB.EQ.1 ) THEN
48480*              ------------------------------
48481*              version 1: back-transform each vector with GEMV, Q*x.
48482               IF( KI.LT.N )
48483     $            CALL ZGEMV( 'N', N, N-KI, CONE, VL( 1, KI+1 ), LDVL,
48484     $                        WORK( KI+1 + IV*N ), 1, DCMPLX( SCALE ),
48485     $                        VL( 1, KI ), 1 )
48486*
48487               II = IZAMAX( N, VL( 1, KI ), 1 )
48488               REMAX = ONE / CABS1( VL( II, KI ) )
48489               CALL ZDSCAL( N, REMAX, VL( 1, KI ), 1 )
48490*
48491            ELSE
48492*              ------------------------------
48493*              version 2: back-transform block of vectors with GEMM
48494*              zero out above vector
48495*              could go from KI-NV+1 to KI-1
48496               DO K = 1, KI - 1
48497                  WORK( K + IV*N ) = CZERO
48498               END DO
48499*
48500*              Columns 1:IV of work are valid vectors.
48501*              When the number of vectors stored reaches NB,
48502*              or if this was last vector, do the GEMM
48503               IF( (IV.EQ.NB) .OR. (KI.EQ.N) ) THEN
48504                  CALL ZGEMM( 'N', 'N', N, IV, N-KI+IV, CONE,
48505     $                        VL( 1, KI-IV+1 ), LDVL,
48506     $                        WORK( KI-IV+1 + (1)*N ), N,
48507     $                        CZERO,
48508     $                        WORK( 1 + (NB+1)*N ), N )
48509*                 normalize vectors
48510                  DO K = 1, IV
48511                     II = IZAMAX( N, WORK( 1 + (NB+K)*N ), 1 )
48512                     REMAX = ONE / CABS1( WORK( II + (NB+K)*N ) )
48513                     CALL ZDSCAL( N, REMAX, WORK( 1 + (NB+K)*N ), 1 )
48514                  END DO
48515                  CALL ZLACPY( 'F', N, IV,
48516     $                         WORK( 1 + (NB+1)*N ), N,
48517     $                         VL( 1, KI-IV+1 ), LDVL )
48518                  IV = 1
48519               ELSE
48520                  IV = IV + 1
48521               END IF
48522            END IF
48523*
48524*           Restore the original diagonal elements of T.
48525*
48526            DO 120 K = KI + 1, N
48527               T( K, K ) = WORK( K )
48528  120       CONTINUE
48529*
48530            IS = IS + 1
48531  130    CONTINUE
48532      END IF
48533*
48534      RETURN
48535*
48536*     End of ZTREVC3
48537*
48538      END
48539*> \brief \b ZTREXC
48540*
48541*  =========== DOCUMENTATION ===========
48542*
48543* Online html documentation available at
48544*            http://www.netlib.org/lapack/explore-html/
48545*
48546*> \htmlonly
48547*> Download ZTREXC + dependencies
48548*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztrexc.f">
48549*> [TGZ]</a>
48550*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztrexc.f">
48551*> [ZIP]</a>
48552*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztrexc.f">
48553*> [TXT]</a>
48554*> \endhtmlonly
48555*
48556*  Definition:
48557*  ===========
48558*
48559*       SUBROUTINE ZTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO )
48560*
48561*       .. Scalar Arguments ..
48562*       CHARACTER          COMPQ
48563*       INTEGER            IFST, ILST, INFO, LDQ, LDT, N
48564*       ..
48565*       .. Array Arguments ..
48566*       COMPLEX*16         Q( LDQ, * ), T( LDT, * )
48567*       ..
48568*
48569*
48570*> \par Purpose:
48571*  =============
48572*>
48573*> \verbatim
48574*>
48575*> ZTREXC reorders the Schur factorization of a complex matrix
48576*> A = Q*T*Q**H, so that the diagonal element of T with row index IFST
48577*> is moved to row ILST.
48578*>
48579*> The Schur form T is reordered by a unitary similarity transformation
48580*> Z**H*T*Z, and optionally the matrix Q of Schur vectors is updated by
48581*> postmultplying it with Z.
48582*> \endverbatim
48583*
48584*  Arguments:
48585*  ==========
48586*
48587*> \param[in] COMPQ
48588*> \verbatim
48589*>          COMPQ is CHARACTER*1
48590*>          = 'V':  update the matrix Q of Schur vectors;
48591*>          = 'N':  do not update Q.
48592*> \endverbatim
48593*>
48594*> \param[in] N
48595*> \verbatim
48596*>          N is INTEGER
48597*>          The order of the matrix T. N >= 0.
48598*>          If N == 0 arguments ILST and IFST may be any value.
48599*> \endverbatim
48600*>
48601*> \param[in,out] T
48602*> \verbatim
48603*>          T is COMPLEX*16 array, dimension (LDT,N)
48604*>          On entry, the upper triangular matrix T.
48605*>          On exit, the reordered upper triangular matrix.
48606*> \endverbatim
48607*>
48608*> \param[in] LDT
48609*> \verbatim
48610*>          LDT is INTEGER
48611*>          The leading dimension of the array T. LDT >= max(1,N).
48612*> \endverbatim
48613*>
48614*> \param[in,out] Q
48615*> \verbatim
48616*>          Q is COMPLEX*16 array, dimension (LDQ,N)
48617*>          On entry, if COMPQ = 'V', the matrix Q of Schur vectors.
48618*>          On exit, if COMPQ = 'V', Q has been postmultiplied by the
48619*>          unitary transformation matrix Z which reorders T.
48620*>          If COMPQ = 'N', Q is not referenced.
48621*> \endverbatim
48622*>
48623*> \param[in] LDQ
48624*> \verbatim
48625*>          LDQ is INTEGER
48626*>          The leading dimension of the array Q.  LDQ >= 1, and if
48627*>          COMPQ = 'V', LDQ >= max(1,N).
48628*> \endverbatim
48629*>
48630*> \param[in] IFST
48631*> \verbatim
48632*>          IFST is INTEGER
48633*> \endverbatim
48634*>
48635*> \param[in] ILST
48636*> \verbatim
48637*>          ILST is INTEGER
48638*>
48639*>          Specify the reordering of the diagonal elements of T:
48640*>          The element with row index IFST is moved to row ILST by a
48641*>          sequence of transpositions between adjacent elements.
48642*>          1 <= IFST <= N; 1 <= ILST <= N.
48643*> \endverbatim
48644*>
48645*> \param[out] INFO
48646*> \verbatim
48647*>          INFO is INTEGER
48648*>          = 0:  successful exit
48649*>          < 0:  if INFO = -i, the i-th argument had an illegal value
48650*> \endverbatim
48651*
48652*  Authors:
48653*  ========
48654*
48655*> \author Univ. of Tennessee
48656*> \author Univ. of California Berkeley
48657*> \author Univ. of Colorado Denver
48658*> \author NAG Ltd.
48659*
48660*> \date December 2016
48661*
48662*> \ingroup complex16OTHERcomputational
48663*
48664*  =====================================================================
48665      SUBROUTINE ZTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO )
48666*
48667*  -- LAPACK computational routine (version 3.7.0) --
48668*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
48669*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
48670*     December 2016
48671*
48672*     .. Scalar Arguments ..
48673      CHARACTER          COMPQ
48674      INTEGER            IFST, ILST, INFO, LDQ, LDT, N
48675*     ..
48676*     .. Array Arguments ..
48677      COMPLEX*16         Q( LDQ, * ), T( LDT, * )
48678*     ..
48679*
48680*  =====================================================================
48681*
48682*     .. Local Scalars ..
48683      LOGICAL            WANTQ
48684      INTEGER            K, M1, M2, M3
48685      DOUBLE PRECISION   CS
48686      COMPLEX*16         SN, T11, T22, TEMP
48687*     ..
48688*     .. External Functions ..
48689      LOGICAL            LSAME
48690      EXTERNAL           LSAME
48691*     ..
48692*     .. External Subroutines ..
48693      EXTERNAL           XERBLA, ZLARTG, ZROT
48694*     ..
48695*     .. Intrinsic Functions ..
48696      INTRINSIC          DCONJG, MAX
48697*     ..
48698*     .. Executable Statements ..
48699*
48700*     Decode and test the input parameters.
48701*
48702      INFO = 0
48703      WANTQ = LSAME( COMPQ, 'V' )
48704      IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN
48705         INFO = -1
48706      ELSE IF( N.LT.0 ) THEN
48707         INFO = -2
48708      ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
48709         INFO = -4
48710      ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.MAX( 1, N ) ) ) THEN
48711         INFO = -6
48712      ELSE IF(( IFST.LT.1 .OR. IFST.GT.N ).AND.( N.GT.0 )) THEN
48713         INFO = -7
48714      ELSE IF(( ILST.LT.1 .OR. ILST.GT.N ).AND.( N.GT.0 )) THEN
48715         INFO = -8
48716      END IF
48717      IF( INFO.NE.0 ) THEN
48718         CALL XERBLA( 'ZTREXC', -INFO )
48719         RETURN
48720      END IF
48721*
48722*     Quick return if possible
48723*
48724      IF( N.LE.1 .OR. IFST.EQ.ILST )
48725     $   RETURN
48726*
48727      IF( IFST.LT.ILST ) THEN
48728*
48729*        Move the IFST-th diagonal element forward down the diagonal.
48730*
48731         M1 = 0
48732         M2 = -1
48733         M3 = 1
48734      ELSE
48735*
48736*        Move the IFST-th diagonal element backward up the diagonal.
48737*
48738         M1 = -1
48739         M2 = 0
48740         M3 = -1
48741      END IF
48742*
48743      DO 10 K = IFST + M1, ILST + M2, M3
48744*
48745*        Interchange the k-th and (k+1)-th diagonal elements.
48746*
48747         T11 = T( K, K )
48748         T22 = T( K+1, K+1 )
48749*
48750*        Determine the transformation to perform the interchange.
48751*
48752         CALL ZLARTG( T( K, K+1 ), T22-T11, CS, SN, TEMP )
48753*
48754*        Apply transformation to the matrix T.
48755*
48756         IF( K+2.LE.N )
48757     $      CALL ZROT( N-K-1, T( K, K+2 ), LDT, T( K+1, K+2 ), LDT, CS,
48758     $                 SN )
48759         CALL ZROT( K-1, T( 1, K ), 1, T( 1, K+1 ), 1, CS,
48760     $              DCONJG( SN ) )
48761*
48762         T( K, K ) = T22
48763         T( K+1, K+1 ) = T11
48764*
48765         IF( WANTQ ) THEN
48766*
48767*           Accumulate transformation in the matrix Q.
48768*
48769            CALL ZROT( N, Q( 1, K ), 1, Q( 1, K+1 ), 1, CS,
48770     $                 DCONJG( SN ) )
48771         END IF
48772*
48773   10 CONTINUE
48774*
48775      RETURN
48776*
48777*     End of ZTREXC
48778*
48779      END
48780*> \brief \b ZTRSEN
48781*
48782*  =========== DOCUMENTATION ===========
48783*
48784* Online html documentation available at
48785*            http://www.netlib.org/lapack/explore-html/
48786*
48787*> \htmlonly
48788*> Download ZTRSEN + dependencies
48789*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztrsen.f">
48790*> [TGZ]</a>
48791*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztrsen.f">
48792*> [ZIP]</a>
48793*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztrsen.f">
48794*> [TXT]</a>
48795*> \endhtmlonly
48796*
48797*  Definition:
48798*  ===========
48799*
48800*       SUBROUTINE ZTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, W, M, S,
48801*                          SEP, WORK, LWORK, INFO )
48802*
48803*       .. Scalar Arguments ..
48804*       CHARACTER          COMPQ, JOB
48805*       INTEGER            INFO, LDQ, LDT, LWORK, M, N
48806*       DOUBLE PRECISION   S, SEP
48807*       ..
48808*       .. Array Arguments ..
48809*       LOGICAL            SELECT( * )
48810*       COMPLEX*16         Q( LDQ, * ), T( LDT, * ), W( * ), WORK( * )
48811*       ..
48812*
48813*
48814*> \par Purpose:
48815*  =============
48816*>
48817*> \verbatim
48818*>
48819*> ZTRSEN reorders the Schur factorization of a complex matrix
48820*> A = Q*T*Q**H, so that a selected cluster of eigenvalues appears in
48821*> the leading positions on the diagonal of the upper triangular matrix
48822*> T, and the leading columns of Q form an orthonormal basis of the
48823*> corresponding right invariant subspace.
48824*>
48825*> Optionally the routine computes the reciprocal condition numbers of
48826*> the cluster of eigenvalues and/or the invariant subspace.
48827*> \endverbatim
48828*
48829*  Arguments:
48830*  ==========
48831*
48832*> \param[in] JOB
48833*> \verbatim
48834*>          JOB is CHARACTER*1
48835*>          Specifies whether condition numbers are required for the
48836*>          cluster of eigenvalues (S) or the invariant subspace (SEP):
48837*>          = 'N': none;
48838*>          = 'E': for eigenvalues only (S);
48839*>          = 'V': for invariant subspace only (SEP);
48840*>          = 'B': for both eigenvalues and invariant subspace (S and
48841*>                 SEP).
48842*> \endverbatim
48843*>
48844*> \param[in] COMPQ
48845*> \verbatim
48846*>          COMPQ is CHARACTER*1
48847*>          = 'V': update the matrix Q of Schur vectors;
48848*>          = 'N': do not update Q.
48849*> \endverbatim
48850*>
48851*> \param[in] SELECT
48852*> \verbatim
48853*>          SELECT is LOGICAL array, dimension (N)
48854*>          SELECT specifies the eigenvalues in the selected cluster. To
48855*>          select the j-th eigenvalue, SELECT(j) must be set to .TRUE..
48856*> \endverbatim
48857*>
48858*> \param[in] N
48859*> \verbatim
48860*>          N is INTEGER
48861*>          The order of the matrix T. N >= 0.
48862*> \endverbatim
48863*>
48864*> \param[in,out] T
48865*> \verbatim
48866*>          T is COMPLEX*16 array, dimension (LDT,N)
48867*>          On entry, the upper triangular matrix T.
48868*>          On exit, T is overwritten by the reordered matrix T, with the
48869*>          selected eigenvalues as the leading diagonal elements.
48870*> \endverbatim
48871*>
48872*> \param[in] LDT
48873*> \verbatim
48874*>          LDT is INTEGER
48875*>          The leading dimension of the array T. LDT >= max(1,N).
48876*> \endverbatim
48877*>
48878*> \param[in,out] Q
48879*> \verbatim
48880*>          Q is COMPLEX*16 array, dimension (LDQ,N)
48881*>          On entry, if COMPQ = 'V', the matrix Q of Schur vectors.
48882*>          On exit, if COMPQ = 'V', Q has been postmultiplied by the
48883*>          unitary transformation matrix which reorders T; the leading M
48884*>          columns of Q form an orthonormal basis for the specified
48885*>          invariant subspace.
48886*>          If COMPQ = 'N', Q is not referenced.
48887*> \endverbatim
48888*>
48889*> \param[in] LDQ
48890*> \verbatim
48891*>          LDQ is INTEGER
48892*>          The leading dimension of the array Q.
48893*>          LDQ >= 1; and if COMPQ = 'V', LDQ >= N.
48894*> \endverbatim
48895*>
48896*> \param[out] W
48897*> \verbatim
48898*>          W is COMPLEX*16 array, dimension (N)
48899*>          The reordered eigenvalues of T, in the same order as they
48900*>          appear on the diagonal of T.
48901*> \endverbatim
48902*>
48903*> \param[out] M
48904*> \verbatim
48905*>          M is INTEGER
48906*>          The dimension of the specified invariant subspace.
48907*>          0 <= M <= N.
48908*> \endverbatim
48909*>
48910*> \param[out] S
48911*> \verbatim
48912*>          S is DOUBLE PRECISION
48913*>          If JOB = 'E' or 'B', S is a lower bound on the reciprocal
48914*>          condition number for the selected cluster of eigenvalues.
48915*>          S cannot underestimate the true reciprocal condition number
48916*>          by more than a factor of sqrt(N). If M = 0 or N, S = 1.
48917*>          If JOB = 'N' or 'V', S is not referenced.
48918*> \endverbatim
48919*>
48920*> \param[out] SEP
48921*> \verbatim
48922*>          SEP is DOUBLE PRECISION
48923*>          If JOB = 'V' or 'B', SEP is the estimated reciprocal
48924*>          condition number of the specified invariant subspace. If
48925*>          M = 0 or N, SEP = norm(T).
48926*>          If JOB = 'N' or 'E', SEP is not referenced.
48927*> \endverbatim
48928*>
48929*> \param[out] WORK
48930*> \verbatim
48931*>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
48932*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
48933*> \endverbatim
48934*>
48935*> \param[in] LWORK
48936*> \verbatim
48937*>          LWORK is INTEGER
48938*>          The dimension of the array WORK.
48939*>          If JOB = 'N', LWORK >= 1;
48940*>          if JOB = 'E', LWORK = max(1,M*(N-M));
48941*>          if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)).
48942*>
48943*>          If LWORK = -1, then a workspace query is assumed; the routine
48944*>          only calculates the optimal size of the WORK array, returns
48945*>          this value as the first entry of the WORK array, and no error
48946*>          message related to LWORK is issued by XERBLA.
48947*> \endverbatim
48948*>
48949*> \param[out] INFO
48950*> \verbatim
48951*>          INFO is INTEGER
48952*>          = 0:  successful exit
48953*>          < 0:  if INFO = -i, the i-th argument had an illegal value
48954*> \endverbatim
48955*
48956*  Authors:
48957*  ========
48958*
48959*> \author Univ. of Tennessee
48960*> \author Univ. of California Berkeley
48961*> \author Univ. of Colorado Denver
48962*> \author NAG Ltd.
48963*
48964*> \date December 2016
48965*
48966*> \ingroup complex16OTHERcomputational
48967*
48968*> \par Further Details:
48969*  =====================
48970*>
48971*> \verbatim
48972*>
48973*>  ZTRSEN first collects the selected eigenvalues by computing a unitary
48974*>  transformation Z to move them to the top left corner of T. In other
48975*>  words, the selected eigenvalues are the eigenvalues of T11 in:
48976*>
48977*>          Z**H * T * Z = ( T11 T12 ) n1
48978*>                         (  0  T22 ) n2
48979*>                            n1  n2
48980*>
48981*>  where N = n1+n2. The first
48982*>  n1 columns of Z span the specified invariant subspace of T.
48983*>
48984*>  If T has been obtained from the Schur factorization of a matrix
48985*>  A = Q*T*Q**H, then the reordered Schur factorization of A is given by
48986*>  A = (Q*Z)*(Z**H*T*Z)*(Q*Z)**H, and the first n1 columns of Q*Z span the
48987*>  corresponding invariant subspace of A.
48988*>
48989*>  The reciprocal condition number of the average of the eigenvalues of
48990*>  T11 may be returned in S. S lies between 0 (very badly conditioned)
48991*>  and 1 (very well conditioned). It is computed as follows. First we
48992*>  compute R so that
48993*>
48994*>                         P = ( I  R ) n1
48995*>                             ( 0  0 ) n2
48996*>                               n1 n2
48997*>
48998*>  is the projector on the invariant subspace associated with T11.
48999*>  R is the solution of the Sylvester equation:
49000*>
49001*>                        T11*R - R*T22 = T12.
49002*>
49003*>  Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote
49004*>  the two-norm of M. Then S is computed as the lower bound
49005*>
49006*>                      (1 + F-norm(R)**2)**(-1/2)
49007*>
49008*>  on the reciprocal of 2-norm(P), the true reciprocal condition number.
49009*>  S cannot underestimate 1 / 2-norm(P) by more than a factor of
49010*>  sqrt(N).
49011*>
49012*>  An approximate error bound for the computed average of the
49013*>  eigenvalues of T11 is
49014*>
49015*>                         EPS * norm(T) / S
49016*>
49017*>  where EPS is the machine precision.
49018*>
49019*>  The reciprocal condition number of the right invariant subspace
49020*>  spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP.
49021*>  SEP is defined as the separation of T11 and T22:
49022*>
49023*>                     sep( T11, T22 ) = sigma-min( C )
49024*>
49025*>  where sigma-min(C) is the smallest singular value of the
49026*>  n1*n2-by-n1*n2 matrix
49027*>
49028*>     C  = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) )
49029*>
49030*>  I(m) is an m by m identity matrix, and kprod denotes the Kronecker
49031*>  product. We estimate sigma-min(C) by the reciprocal of an estimate of
49032*>  the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C)
49033*>  cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2).
49034*>
49035*>  When SEP is small, small changes in T can cause large changes in
49036*>  the invariant subspace. An approximate bound on the maximum angular
49037*>  error in the computed right invariant subspace is
49038*>
49039*>                      EPS * norm(T) / SEP
49040*> \endverbatim
49041*>
49042*  =====================================================================
49043      SUBROUTINE ZTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, W, M, S,
49044     $                   SEP, WORK, LWORK, INFO )
49045*
49046*  -- LAPACK computational routine (version 3.7.0) --
49047*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
49048*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
49049*     December 2016
49050*
49051*     .. Scalar Arguments ..
49052      CHARACTER          COMPQ, JOB
49053      INTEGER            INFO, LDQ, LDT, LWORK, M, N
49054      DOUBLE PRECISION   S, SEP
49055*     ..
49056*     .. Array Arguments ..
49057      LOGICAL            SELECT( * )
49058      COMPLEX*16         Q( LDQ, * ), T( LDT, * ), W( * ), WORK( * )
49059*     ..
49060*
49061*  =====================================================================
49062*
49063*     .. Parameters ..
49064      DOUBLE PRECISION   ZERO, ONE
49065      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
49066*     ..
49067*     .. Local Scalars ..
49068      LOGICAL            LQUERY, WANTBH, WANTQ, WANTS, WANTSP
49069      INTEGER            IERR, K, KASE, KS, LWMIN, N1, N2, NN
49070      DOUBLE PRECISION   EST, RNORM, SCALE
49071*     ..
49072*     .. Local Arrays ..
49073      INTEGER            ISAVE( 3 )
49074      DOUBLE PRECISION   RWORK( 1 )
49075*     ..
49076*     .. External Functions ..
49077      LOGICAL            LSAME
49078      DOUBLE PRECISION   ZLANGE
49079      EXTERNAL           LSAME, ZLANGE
49080*     ..
49081*     .. External Subroutines ..
49082      EXTERNAL           XERBLA, ZLACN2, ZLACPY, ZTREXC, ZTRSYL
49083*     ..
49084*     .. Intrinsic Functions ..
49085      INTRINSIC          MAX, SQRT
49086*     ..
49087*     .. Executable Statements ..
49088*
49089*     Decode and test the input parameters.
49090*
49091      WANTBH = LSAME( JOB, 'B' )
49092      WANTS = LSAME( JOB, 'E' ) .OR. WANTBH
49093      WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH
49094      WANTQ = LSAME( COMPQ, 'V' )
49095*
49096*     Set M to the number of selected eigenvalues.
49097*
49098      M = 0
49099      DO 10 K = 1, N
49100         IF( SELECT( K ) )
49101     $      M = M + 1
49102   10 CONTINUE
49103*
49104      N1 = M
49105      N2 = N - M
49106      NN = N1*N2
49107*
49108      INFO = 0
49109      LQUERY = ( LWORK.EQ.-1 )
49110*
49111      IF( WANTSP ) THEN
49112         LWMIN = MAX( 1, 2*NN )
49113      ELSE IF( LSAME( JOB, 'N' ) ) THEN
49114         LWMIN = 1
49115      ELSE IF( LSAME( JOB, 'E' ) ) THEN
49116         LWMIN = MAX( 1, NN )
49117      END IF
49118*
49119      IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.WANTS .AND. .NOT.WANTSP )
49120     $     THEN
49121         INFO = -1
49122      ELSE IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN
49123         INFO = -2
49124      ELSE IF( N.LT.0 ) THEN
49125         INFO = -4
49126      ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
49127         INFO = -6
49128      ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
49129         INFO = -8
49130      ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
49131         INFO = -14
49132      END IF
49133*
49134      IF( INFO.EQ.0 ) THEN
49135         WORK( 1 ) = LWMIN
49136      END IF
49137*
49138      IF( INFO.NE.0 ) THEN
49139         CALL XERBLA( 'ZTRSEN', -INFO )
49140         RETURN
49141      ELSE IF( LQUERY ) THEN
49142         RETURN
49143      END IF
49144*
49145*     Quick return if possible
49146*
49147      IF( M.EQ.N .OR. M.EQ.0 ) THEN
49148         IF( WANTS )
49149     $      S = ONE
49150         IF( WANTSP )
49151     $      SEP = ZLANGE( '1', N, N, T, LDT, RWORK )
49152         GO TO 40
49153      END IF
49154*
49155*     Collect the selected eigenvalues at the top left corner of T.
49156*
49157      KS = 0
49158      DO 20 K = 1, N
49159         IF( SELECT( K ) ) THEN
49160            KS = KS + 1
49161*
49162*           Swap the K-th eigenvalue to position KS.
49163*
49164            IF( K.NE.KS )
49165     $         CALL ZTREXC( COMPQ, N, T, LDT, Q, LDQ, K, KS, IERR )
49166         END IF
49167   20 CONTINUE
49168*
49169      IF( WANTS ) THEN
49170*
49171*        Solve the Sylvester equation for R:
49172*
49173*           T11*R - R*T22 = scale*T12
49174*
49175         CALL ZLACPY( 'F', N1, N2, T( 1, N1+1 ), LDT, WORK, N1 )
49176         CALL ZTRSYL( 'N', 'N', -1, N1, N2, T, LDT, T( N1+1, N1+1 ),
49177     $                LDT, WORK, N1, SCALE, IERR )
49178*
49179*        Estimate the reciprocal of the condition number of the cluster
49180*        of eigenvalues.
49181*
49182         RNORM = ZLANGE( 'F', N1, N2, WORK, N1, RWORK )
49183         IF( RNORM.EQ.ZERO ) THEN
49184            S = ONE
49185         ELSE
49186            S = SCALE / ( SQRT( SCALE*SCALE / RNORM+RNORM )*
49187     $          SQRT( RNORM ) )
49188         END IF
49189      END IF
49190*
49191      IF( WANTSP ) THEN
49192*
49193*        Estimate sep(T11,T22).
49194*
49195         EST = ZERO
49196         KASE = 0
49197   30    CONTINUE
49198         CALL ZLACN2( NN, WORK( NN+1 ), WORK, EST, KASE, ISAVE )
49199         IF( KASE.NE.0 ) THEN
49200            IF( KASE.EQ.1 ) THEN
49201*
49202*              Solve T11*R - R*T22 = scale*X.
49203*
49204               CALL ZTRSYL( 'N', 'N', -1, N1, N2, T, LDT,
49205     $                      T( N1+1, N1+1 ), LDT, WORK, N1, SCALE,
49206     $                      IERR )
49207            ELSE
49208*
49209*              Solve T11**H*R - R*T22**H = scale*X.
49210*
49211               CALL ZTRSYL( 'C', 'C', -1, N1, N2, T, LDT,
49212     $                      T( N1+1, N1+1 ), LDT, WORK, N1, SCALE,
49213     $                      IERR )
49214            END IF
49215            GO TO 30
49216         END IF
49217*
49218         SEP = SCALE / EST
49219      END IF
49220*
49221   40 CONTINUE
49222*
49223*     Copy reordered eigenvalues to W.
49224*
49225      DO 50 K = 1, N
49226         W( K ) = T( K, K )
49227   50 CONTINUE
49228*
49229      WORK( 1 ) = LWMIN
49230*
49231      RETURN
49232*
49233*     End of ZTRSEN
49234*
49235      END
49236*> \brief \b ZTRSYL
49237*
49238*  =========== DOCUMENTATION ===========
49239*
49240* Online html documentation available at
49241*            http://www.netlib.org/lapack/explore-html/
49242*
49243*> \htmlonly
49244*> Download ZTRSYL + dependencies
49245*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztrsyl.f">
49246*> [TGZ]</a>
49247*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztrsyl.f">
49248*> [ZIP]</a>
49249*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztrsyl.f">
49250*> [TXT]</a>
49251*> \endhtmlonly
49252*
49253*  Definition:
49254*  ===========
49255*
49256*       SUBROUTINE ZTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C,
49257*                          LDC, SCALE, INFO )
49258*
49259*       .. Scalar Arguments ..
49260*       CHARACTER          TRANA, TRANB
49261*       INTEGER            INFO, ISGN, LDA, LDB, LDC, M, N
49262*       DOUBLE PRECISION   SCALE
49263*       ..
49264*       .. Array Arguments ..
49265*       COMPLEX*16         A( LDA, * ), B( LDB, * ), C( LDC, * )
49266*       ..
49267*
49268*
49269*> \par Purpose:
49270*  =============
49271*>
49272*> \verbatim
49273*>
49274*> ZTRSYL solves the complex Sylvester matrix equation:
49275*>
49276*>    op(A)*X + X*op(B) = scale*C or
49277*>    op(A)*X - X*op(B) = scale*C,
49278*>
49279*> where op(A) = A or A**H, and A and B are both upper triangular. A is
49280*> M-by-M and B is N-by-N; the right hand side C and the solution X are
49281*> M-by-N; and scale is an output scale factor, set <= 1 to avoid
49282*> overflow in X.
49283*> \endverbatim
49284*
49285*  Arguments:
49286*  ==========
49287*
49288*> \param[in] TRANA
49289*> \verbatim
49290*>          TRANA is CHARACTER*1
49291*>          Specifies the option op(A):
49292*>          = 'N': op(A) = A    (No transpose)
49293*>          = 'C': op(A) = A**H (Conjugate transpose)
49294*> \endverbatim
49295*>
49296*> \param[in] TRANB
49297*> \verbatim
49298*>          TRANB is CHARACTER*1
49299*>          Specifies the option op(B):
49300*>          = 'N': op(B) = B    (No transpose)
49301*>          = 'C': op(B) = B**H (Conjugate transpose)
49302*> \endverbatim
49303*>
49304*> \param[in] ISGN
49305*> \verbatim
49306*>          ISGN is INTEGER
49307*>          Specifies the sign in the equation:
49308*>          = +1: solve op(A)*X + X*op(B) = scale*C
49309*>          = -1: solve op(A)*X - X*op(B) = scale*C
49310*> \endverbatim
49311*>
49312*> \param[in] M
49313*> \verbatim
49314*>          M is INTEGER
49315*>          The order of the matrix A, and the number of rows in the
49316*>          matrices X and C. M >= 0.
49317*> \endverbatim
49318*>
49319*> \param[in] N
49320*> \verbatim
49321*>          N is INTEGER
49322*>          The order of the matrix B, and the number of columns in the
49323*>          matrices X and C. N >= 0.
49324*> \endverbatim
49325*>
49326*> \param[in] A
49327*> \verbatim
49328*>          A is COMPLEX*16 array, dimension (LDA,M)
49329*>          The upper triangular matrix A.
49330*> \endverbatim
49331*>
49332*> \param[in] LDA
49333*> \verbatim
49334*>          LDA is INTEGER
49335*>          The leading dimension of the array A. LDA >= max(1,M).
49336*> \endverbatim
49337*>
49338*> \param[in] B
49339*> \verbatim
49340*>          B is COMPLEX*16 array, dimension (LDB,N)
49341*>          The upper triangular matrix B.
49342*> \endverbatim
49343*>
49344*> \param[in] LDB
49345*> \verbatim
49346*>          LDB is INTEGER
49347*>          The leading dimension of the array B. LDB >= max(1,N).
49348*> \endverbatim
49349*>
49350*> \param[in,out] C
49351*> \verbatim
49352*>          C is COMPLEX*16 array, dimension (LDC,N)
49353*>          On entry, the M-by-N right hand side matrix C.
49354*>          On exit, C is overwritten by the solution matrix X.
49355*> \endverbatim
49356*>
49357*> \param[in] LDC
49358*> \verbatim
49359*>          LDC is INTEGER
49360*>          The leading dimension of the array C. LDC >= max(1,M)
49361*> \endverbatim
49362*>
49363*> \param[out] SCALE
49364*> \verbatim
49365*>          SCALE is DOUBLE PRECISION
49366*>          The scale factor, scale, set <= 1 to avoid overflow in X.
49367*> \endverbatim
49368*>
49369*> \param[out] INFO
49370*> \verbatim
49371*>          INFO is INTEGER
49372*>          = 0: successful exit
49373*>          < 0: if INFO = -i, the i-th argument had an illegal value
49374*>          = 1: A and B have common or very close eigenvalues; perturbed
49375*>               values were used to solve the equation (but the matrices
49376*>               A and B are unchanged).
49377*> \endverbatim
49378*
49379*  Authors:
49380*  ========
49381*
49382*> \author Univ. of Tennessee
49383*> \author Univ. of California Berkeley
49384*> \author Univ. of Colorado Denver
49385*> \author NAG Ltd.
49386*
49387*> \date December 2016
49388*
49389*> \ingroup complex16SYcomputational
49390*
49391*  =====================================================================
49392      SUBROUTINE ZTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C,
49393     $                   LDC, SCALE, INFO )
49394*
49395*  -- LAPACK computational routine (version 3.7.0) --
49396*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
49397*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
49398*     December 2016
49399*
49400*     .. Scalar Arguments ..
49401      CHARACTER          TRANA, TRANB
49402      INTEGER            INFO, ISGN, LDA, LDB, LDC, M, N
49403      DOUBLE PRECISION   SCALE
49404*     ..
49405*     .. Array Arguments ..
49406      COMPLEX*16         A( LDA, * ), B( LDB, * ), C( LDC, * )
49407*     ..
49408*
49409*  =====================================================================
49410*
49411*     .. Parameters ..
49412      DOUBLE PRECISION   ONE
49413      PARAMETER          ( ONE = 1.0D+0 )
49414*     ..
49415*     .. Local Scalars ..
49416      LOGICAL            NOTRNA, NOTRNB
49417      INTEGER            J, K, L
49418      DOUBLE PRECISION   BIGNUM, DA11, DB, EPS, SCALOC, SGN, SMIN,
49419     $                   SMLNUM
49420      COMPLEX*16         A11, SUML, SUMR, VEC, X11
49421*     ..
49422*     .. Local Arrays ..
49423      DOUBLE PRECISION   DUM( 1 )
49424*     ..
49425*     .. External Functions ..
49426      LOGICAL            LSAME
49427      DOUBLE PRECISION   DLAMCH, ZLANGE
49428      COMPLEX*16         ZDOTC, ZDOTU, ZLADIV
49429      EXTERNAL           LSAME, DLAMCH, ZLANGE, ZDOTC, ZDOTU, ZLADIV
49430*     ..
49431*     .. External Subroutines ..
49432      EXTERNAL           DLABAD, XERBLA, ZDSCAL
49433*     ..
49434*     .. Intrinsic Functions ..
49435      INTRINSIC          ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN
49436*     ..
49437*     .. Executable Statements ..
49438*
49439*     Decode and Test input parameters
49440*
49441      NOTRNA = LSAME( TRANA, 'N' )
49442      NOTRNB = LSAME( TRANB, 'N' )
49443*
49444      INFO = 0
49445      IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'C' ) ) THEN
49446         INFO = -1
49447      ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'C' ) ) THEN
49448         INFO = -2
49449      ELSE IF( ISGN.NE.1 .AND. ISGN.NE.-1 ) THEN
49450         INFO = -3
49451      ELSE IF( M.LT.0 ) THEN
49452         INFO = -4
49453      ELSE IF( N.LT.0 ) THEN
49454         INFO = -5
49455      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
49456         INFO = -7
49457      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
49458         INFO = -9
49459      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
49460         INFO = -11
49461      END IF
49462      IF( INFO.NE.0 ) THEN
49463         CALL XERBLA( 'ZTRSYL', -INFO )
49464         RETURN
49465      END IF
49466*
49467*     Quick return if possible
49468*
49469      SCALE = ONE
49470      IF( M.EQ.0 .OR. N.EQ.0 )
49471     $   RETURN
49472*
49473*     Set constants to control overflow
49474*
49475      EPS = DLAMCH( 'P' )
49476      SMLNUM = DLAMCH( 'S' )
49477      BIGNUM = ONE / SMLNUM
49478      CALL DLABAD( SMLNUM, BIGNUM )
49479      SMLNUM = SMLNUM*DBLE( M*N ) / EPS
49480      BIGNUM = ONE / SMLNUM
49481      SMIN = MAX( SMLNUM, EPS*ZLANGE( 'M', M, M, A, LDA, DUM ),
49482     $       EPS*ZLANGE( 'M', N, N, B, LDB, DUM ) )
49483      SGN = ISGN
49484*
49485      IF( NOTRNA .AND. NOTRNB ) THEN
49486*
49487*        Solve    A*X + ISGN*X*B = scale*C.
49488*
49489*        The (K,L)th block of X is determined starting from
49490*        bottom-left corner column by column by
49491*
49492*            A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
49493*
49494*        Where
49495*                    M                        L-1
49496*          R(K,L) = SUM [A(K,I)*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)].
49497*                  I=K+1                      J=1
49498*
49499         DO 30 L = 1, N
49500            DO 20 K = M, 1, -1
49501*
49502               SUML = ZDOTU( M-K, A( K, MIN( K+1, M ) ), LDA,
49503     $                C( MIN( K+1, M ), L ), 1 )
49504               SUMR = ZDOTU( L-1, C( K, 1 ), LDC, B( 1, L ), 1 )
49505               VEC = C( K, L ) - ( SUML+SGN*SUMR )
49506*
49507               SCALOC = ONE
49508               A11 = A( K, K ) + SGN*B( L, L )
49509               DA11 = ABS( DBLE( A11 ) ) + ABS( DIMAG( A11 ) )
49510               IF( DA11.LE.SMIN ) THEN
49511                  A11 = SMIN
49512                  DA11 = SMIN
49513                  INFO = 1
49514               END IF
49515               DB = ABS( DBLE( VEC ) ) + ABS( DIMAG( VEC ) )
49516               IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
49517                  IF( DB.GT.BIGNUM*DA11 )
49518     $               SCALOC = ONE / DB
49519               END IF
49520               X11 = ZLADIV( VEC*DCMPLX( SCALOC ), A11 )
49521*
49522               IF( SCALOC.NE.ONE ) THEN
49523                  DO 10 J = 1, N
49524                     CALL ZDSCAL( M, SCALOC, C( 1, J ), 1 )
49525   10             CONTINUE
49526                  SCALE = SCALE*SCALOC
49527               END IF
49528               C( K, L ) = X11
49529*
49530   20       CONTINUE
49531   30    CONTINUE
49532*
49533      ELSE IF( .NOT.NOTRNA .AND. NOTRNB ) THEN
49534*
49535*        Solve    A**H *X + ISGN*X*B = scale*C.
49536*
49537*        The (K,L)th block of X is determined starting from
49538*        upper-left corner column by column by
49539*
49540*            A**H(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
49541*
49542*        Where
49543*                   K-1                           L-1
49544*          R(K,L) = SUM [A**H(I,K)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)]
49545*                   I=1                           J=1
49546*
49547         DO 60 L = 1, N
49548            DO 50 K = 1, M
49549*
49550               SUML = ZDOTC( K-1, A( 1, K ), 1, C( 1, L ), 1 )
49551               SUMR = ZDOTU( L-1, C( K, 1 ), LDC, B( 1, L ), 1 )
49552               VEC = C( K, L ) - ( SUML+SGN*SUMR )
49553*
49554               SCALOC = ONE
49555               A11 = DCONJG( A( K, K ) ) + SGN*B( L, L )
49556               DA11 = ABS( DBLE( A11 ) ) + ABS( DIMAG( A11 ) )
49557               IF( DA11.LE.SMIN ) THEN
49558                  A11 = SMIN
49559                  DA11 = SMIN
49560                  INFO = 1
49561               END IF
49562               DB = ABS( DBLE( VEC ) ) + ABS( DIMAG( VEC ) )
49563               IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
49564                  IF( DB.GT.BIGNUM*DA11 )
49565     $               SCALOC = ONE / DB
49566               END IF
49567*
49568               X11 = ZLADIV( VEC*DCMPLX( SCALOC ), A11 )
49569*
49570               IF( SCALOC.NE.ONE ) THEN
49571                  DO 40 J = 1, N
49572                     CALL ZDSCAL( M, SCALOC, C( 1, J ), 1 )
49573   40             CONTINUE
49574                  SCALE = SCALE*SCALOC
49575               END IF
49576               C( K, L ) = X11
49577*
49578   50       CONTINUE
49579   60    CONTINUE
49580*
49581      ELSE IF( .NOT.NOTRNA .AND. .NOT.NOTRNB ) THEN
49582*
49583*        Solve    A**H*X + ISGN*X*B**H = C.
49584*
49585*        The (K,L)th block of X is determined starting from
49586*        upper-right corner column by column by
49587*
49588*            A**H(K,K)*X(K,L) + ISGN*X(K,L)*B**H(L,L) = C(K,L) - R(K,L)
49589*
49590*        Where
49591*                    K-1
49592*           R(K,L) = SUM [A**H(I,K)*X(I,L)] +
49593*                    I=1
49594*                           N
49595*                     ISGN*SUM [X(K,J)*B**H(L,J)].
49596*                          J=L+1
49597*
49598         DO 90 L = N, 1, -1
49599            DO 80 K = 1, M
49600*
49601               SUML = ZDOTC( K-1, A( 1, K ), 1, C( 1, L ), 1 )
49602               SUMR = ZDOTC( N-L, C( K, MIN( L+1, N ) ), LDC,
49603     $                B( L, MIN( L+1, N ) ), LDB )
49604               VEC = C( K, L ) - ( SUML+SGN*DCONJG( SUMR ) )
49605*
49606               SCALOC = ONE
49607               A11 = DCONJG( A( K, K )+SGN*B( L, L ) )
49608               DA11 = ABS( DBLE( A11 ) ) + ABS( DIMAG( A11 ) )
49609               IF( DA11.LE.SMIN ) THEN
49610                  A11 = SMIN
49611                  DA11 = SMIN
49612                  INFO = 1
49613               END IF
49614               DB = ABS( DBLE( VEC ) ) + ABS( DIMAG( VEC ) )
49615               IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
49616                  IF( DB.GT.BIGNUM*DA11 )
49617     $               SCALOC = ONE / DB
49618               END IF
49619*
49620               X11 = ZLADIV( VEC*DCMPLX( SCALOC ), A11 )
49621*
49622               IF( SCALOC.NE.ONE ) THEN
49623                  DO 70 J = 1, N
49624                     CALL ZDSCAL( M, SCALOC, C( 1, J ), 1 )
49625   70             CONTINUE
49626                  SCALE = SCALE*SCALOC
49627               END IF
49628               C( K, L ) = X11
49629*
49630   80       CONTINUE
49631   90    CONTINUE
49632*
49633      ELSE IF( NOTRNA .AND. .NOT.NOTRNB ) THEN
49634*
49635*        Solve    A*X + ISGN*X*B**H = C.
49636*
49637*        The (K,L)th block of X is determined starting from
49638*        bottom-left corner column by column by
49639*
49640*           A(K,K)*X(K,L) + ISGN*X(K,L)*B**H(L,L) = C(K,L) - R(K,L)
49641*
49642*        Where
49643*                    M                          N
49644*          R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B**H(L,J)]
49645*                  I=K+1                      J=L+1
49646*
49647         DO 120 L = N, 1, -1
49648            DO 110 K = M, 1, -1
49649*
49650               SUML = ZDOTU( M-K, A( K, MIN( K+1, M ) ), LDA,
49651     $                C( MIN( K+1, M ), L ), 1 )
49652               SUMR = ZDOTC( N-L, C( K, MIN( L+1, N ) ), LDC,
49653     $                B( L, MIN( L+1, N ) ), LDB )
49654               VEC = C( K, L ) - ( SUML+SGN*DCONJG( SUMR ) )
49655*
49656               SCALOC = ONE
49657               A11 = A( K, K ) + SGN*DCONJG( B( L, L ) )
49658               DA11 = ABS( DBLE( A11 ) ) + ABS( DIMAG( A11 ) )
49659               IF( DA11.LE.SMIN ) THEN
49660                  A11 = SMIN
49661                  DA11 = SMIN
49662                  INFO = 1
49663               END IF
49664               DB = ABS( DBLE( VEC ) ) + ABS( DIMAG( VEC ) )
49665               IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
49666                  IF( DB.GT.BIGNUM*DA11 )
49667     $               SCALOC = ONE / DB
49668               END IF
49669*
49670               X11 = ZLADIV( VEC*DCMPLX( SCALOC ), A11 )
49671*
49672               IF( SCALOC.NE.ONE ) THEN
49673                  DO 100 J = 1, N
49674                     CALL ZDSCAL( M, SCALOC, C( 1, J ), 1 )
49675  100             CONTINUE
49676                  SCALE = SCALE*SCALOC
49677               END IF
49678               C( K, L ) = X11
49679*
49680  110       CONTINUE
49681  120    CONTINUE
49682*
49683      END IF
49684*
49685      RETURN
49686*
49687*     End of ZTRSYL
49688*
49689      END
49690*> \brief \b ZTRTI2 computes the inverse of a triangular matrix (unblocked algorithm).
49691*
49692*  =========== DOCUMENTATION ===========
49693*
49694* Online html documentation available at
49695*            http://www.netlib.org/lapack/explore-html/
49696*
49697*> \htmlonly
49698*> Download ZTRTI2 + dependencies
49699*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztrti2.f">
49700*> [TGZ]</a>
49701*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztrti2.f">
49702*> [ZIP]</a>
49703*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztrti2.f">
49704*> [TXT]</a>
49705*> \endhtmlonly
49706*
49707*  Definition:
49708*  ===========
49709*
49710*       SUBROUTINE ZTRTI2( UPLO, DIAG, N, A, LDA, INFO )
49711*
49712*       .. Scalar Arguments ..
49713*       CHARACTER          DIAG, UPLO
49714*       INTEGER            INFO, LDA, N
49715*       ..
49716*       .. Array Arguments ..
49717*       COMPLEX*16         A( LDA, * )
49718*       ..
49719*
49720*
49721*> \par Purpose:
49722*  =============
49723*>
49724*> \verbatim
49725*>
49726*> ZTRTI2 computes the inverse of a complex upper or lower triangular
49727*> matrix.
49728*>
49729*> This is the Level 2 BLAS version of the algorithm.
49730*> \endverbatim
49731*
49732*  Arguments:
49733*  ==========
49734*
49735*> \param[in] UPLO
49736*> \verbatim
49737*>          UPLO is CHARACTER*1
49738*>          Specifies whether the matrix A is upper or lower triangular.
49739*>          = 'U':  Upper triangular
49740*>          = 'L':  Lower triangular
49741*> \endverbatim
49742*>
49743*> \param[in] DIAG
49744*> \verbatim
49745*>          DIAG is CHARACTER*1
49746*>          Specifies whether or not the matrix A is unit triangular.
49747*>          = 'N':  Non-unit triangular
49748*>          = 'U':  Unit triangular
49749*> \endverbatim
49750*>
49751*> \param[in] N
49752*> \verbatim
49753*>          N is INTEGER
49754*>          The order of the matrix A.  N >= 0.
49755*> \endverbatim
49756*>
49757*> \param[in,out] A
49758*> \verbatim
49759*>          A is COMPLEX*16 array, dimension (LDA,N)
49760*>          On entry, the triangular matrix A.  If UPLO = 'U', the
49761*>          leading n by n upper triangular part of the array A contains
49762*>          the upper triangular matrix, and the strictly lower
49763*>          triangular part of A is not referenced.  If UPLO = 'L', the
49764*>          leading n by n lower triangular part of the array A contains
49765*>          the lower triangular matrix, and the strictly upper
49766*>          triangular part of A is not referenced.  If DIAG = 'U', the
49767*>          diagonal elements of A are also not referenced and are
49768*>          assumed to be 1.
49769*>
49770*>          On exit, the (triangular) inverse of the original matrix, in
49771*>          the same storage format.
49772*> \endverbatim
49773*>
49774*> \param[in] LDA
49775*> \verbatim
49776*>          LDA is INTEGER
49777*>          The leading dimension of the array A.  LDA >= max(1,N).
49778*> \endverbatim
49779*>
49780*> \param[out] INFO
49781*> \verbatim
49782*>          INFO is INTEGER
49783*>          = 0: successful exit
49784*>          < 0: if INFO = -k, the k-th argument had an illegal value
49785*> \endverbatim
49786*
49787*  Authors:
49788*  ========
49789*
49790*> \author Univ. of Tennessee
49791*> \author Univ. of California Berkeley
49792*> \author Univ. of Colorado Denver
49793*> \author NAG Ltd.
49794*
49795*> \date December 2016
49796*
49797*> \ingroup complex16OTHERcomputational
49798*
49799*  =====================================================================
49800      SUBROUTINE ZTRTI2( UPLO, DIAG, N, A, LDA, INFO )
49801*
49802*  -- LAPACK computational routine (version 3.7.0) --
49803*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
49804*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
49805*     December 2016
49806*
49807*     .. Scalar Arguments ..
49808      CHARACTER          DIAG, UPLO
49809      INTEGER            INFO, LDA, N
49810*     ..
49811*     .. Array Arguments ..
49812      COMPLEX*16         A( LDA, * )
49813*     ..
49814*
49815*  =====================================================================
49816*
49817*     .. Parameters ..
49818      COMPLEX*16         ONE
49819      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
49820*     ..
49821*     .. Local Scalars ..
49822      LOGICAL            NOUNIT, UPPER
49823      INTEGER            J
49824      COMPLEX*16         AJJ
49825*     ..
49826*     .. External Functions ..
49827      LOGICAL            LSAME
49828      EXTERNAL           LSAME
49829*     ..
49830*     .. External Subroutines ..
49831      EXTERNAL           XERBLA, ZSCAL, ZTRMV
49832*     ..
49833*     .. Intrinsic Functions ..
49834      INTRINSIC          MAX
49835*     ..
49836*     .. Executable Statements ..
49837*
49838*     Test the input parameters.
49839*
49840      INFO = 0
49841      UPPER = LSAME( UPLO, 'U' )
49842      NOUNIT = LSAME( DIAG, 'N' )
49843      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
49844         INFO = -1
49845      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
49846         INFO = -2
49847      ELSE IF( N.LT.0 ) THEN
49848         INFO = -3
49849      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
49850         INFO = -5
49851      END IF
49852      IF( INFO.NE.0 ) THEN
49853         CALL XERBLA( 'ZTRTI2', -INFO )
49854         RETURN
49855      END IF
49856*
49857      IF( UPPER ) THEN
49858*
49859*        Compute inverse of upper triangular matrix.
49860*
49861         DO 10 J = 1, N
49862            IF( NOUNIT ) THEN
49863               A( J, J ) = ONE / A( J, J )
49864               AJJ = -A( J, J )
49865            ELSE
49866               AJJ = -ONE
49867            END IF
49868*
49869*           Compute elements 1:j-1 of j-th column.
49870*
49871            CALL ZTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA,
49872     $                  A( 1, J ), 1 )
49873            CALL ZSCAL( J-1, AJJ, A( 1, J ), 1 )
49874   10    CONTINUE
49875      ELSE
49876*
49877*        Compute inverse of lower triangular matrix.
49878*
49879         DO 20 J = N, 1, -1
49880            IF( NOUNIT ) THEN
49881               A( J, J ) = ONE / A( J, J )
49882               AJJ = -A( J, J )
49883            ELSE
49884               AJJ = -ONE
49885            END IF
49886            IF( J.LT.N ) THEN
49887*
49888*              Compute elements j+1:n of j-th column.
49889*
49890               CALL ZTRMV( 'Lower', 'No transpose', DIAG, N-J,
49891     $                     A( J+1, J+1 ), LDA, A( J+1, J ), 1 )
49892               CALL ZSCAL( N-J, AJJ, A( J+1, J ), 1 )
49893            END IF
49894   20    CONTINUE
49895      END IF
49896*
49897      RETURN
49898*
49899*     End of ZTRTI2
49900*
49901      END
49902*> \brief \b ZTRTRI
49903*
49904*  =========== DOCUMENTATION ===========
49905*
49906* Online html documentation available at
49907*            http://www.netlib.org/lapack/explore-html/
49908*
49909*> \htmlonly
49910*> Download ZTRTRI + dependencies
49911*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztrtri.f">
49912*> [TGZ]</a>
49913*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztrtri.f">
49914*> [ZIP]</a>
49915*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztrtri.f">
49916*> [TXT]</a>
49917*> \endhtmlonly
49918*
49919*  Definition:
49920*  ===========
49921*
49922*       SUBROUTINE ZTRTRI( UPLO, DIAG, N, A, LDA, INFO )
49923*
49924*       .. Scalar Arguments ..
49925*       CHARACTER          DIAG, UPLO
49926*       INTEGER            INFO, LDA, N
49927*       ..
49928*       .. Array Arguments ..
49929*       COMPLEX*16         A( LDA, * )
49930*       ..
49931*
49932*
49933*> \par Purpose:
49934*  =============
49935*>
49936*> \verbatim
49937*>
49938*> ZTRTRI computes the inverse of a complex upper or lower triangular
49939*> matrix A.
49940*>
49941*> This is the Level 3 BLAS version of the algorithm.
49942*> \endverbatim
49943*
49944*  Arguments:
49945*  ==========
49946*
49947*> \param[in] UPLO
49948*> \verbatim
49949*>          UPLO is CHARACTER*1
49950*>          = 'U':  A is upper triangular;
49951*>          = 'L':  A is lower triangular.
49952*> \endverbatim
49953*>
49954*> \param[in] DIAG
49955*> \verbatim
49956*>          DIAG is CHARACTER*1
49957*>          = 'N':  A is non-unit triangular;
49958*>          = 'U':  A is unit triangular.
49959*> \endverbatim
49960*>
49961*> \param[in] N
49962*> \verbatim
49963*>          N is INTEGER
49964*>          The order of the matrix A.  N >= 0.
49965*> \endverbatim
49966*>
49967*> \param[in,out] A
49968*> \verbatim
49969*>          A is COMPLEX*16 array, dimension (LDA,N)
49970*>          On entry, the triangular matrix A.  If UPLO = 'U', the
49971*>          leading N-by-N upper triangular part of the array A contains
49972*>          the upper triangular matrix, and the strictly lower
49973*>          triangular part of A is not referenced.  If UPLO = 'L', the
49974*>          leading N-by-N lower triangular part of the array A contains
49975*>          the lower triangular matrix, and the strictly upper
49976*>          triangular part of A is not referenced.  If DIAG = 'U', the
49977*>          diagonal elements of A are also not referenced and are
49978*>          assumed to be 1.
49979*>          On exit, the (triangular) inverse of the original matrix, in
49980*>          the same storage format.
49981*> \endverbatim
49982*>
49983*> \param[in] LDA
49984*> \verbatim
49985*>          LDA is INTEGER
49986*>          The leading dimension of the array A.  LDA >= max(1,N).
49987*> \endverbatim
49988*>
49989*> \param[out] INFO
49990*> \verbatim
49991*>          INFO is INTEGER
49992*>          = 0: successful exit
49993*>          < 0: if INFO = -i, the i-th argument had an illegal value
49994*>          > 0: if INFO = i, A(i,i) is exactly zero.  The triangular
49995*>               matrix is singular and its inverse can not be computed.
49996*> \endverbatim
49997*
49998*  Authors:
49999*  ========
50000*
50001*> \author Univ. of Tennessee
50002*> \author Univ. of California Berkeley
50003*> \author Univ. of Colorado Denver
50004*> \author NAG Ltd.
50005*
50006*> \date December 2016
50007*
50008*> \ingroup complex16OTHERcomputational
50009*
50010*  =====================================================================
50011      SUBROUTINE ZTRTRI( UPLO, DIAG, N, A, LDA, INFO )
50012*
50013*  -- LAPACK computational routine (version 3.7.0) --
50014*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
50015*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
50016*     December 2016
50017*
50018*     .. Scalar Arguments ..
50019      CHARACTER          DIAG, UPLO
50020      INTEGER            INFO, LDA, N
50021*     ..
50022*     .. Array Arguments ..
50023      COMPLEX*16         A( LDA, * )
50024*     ..
50025*
50026*  =====================================================================
50027*
50028*     .. Parameters ..
50029      COMPLEX*16         ONE, ZERO
50030      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),
50031     $                   ZERO = ( 0.0D+0, 0.0D+0 ) )
50032*     ..
50033*     .. Local Scalars ..
50034      LOGICAL            NOUNIT, UPPER
50035      INTEGER            J, JB, NB, NN
50036*     ..
50037*     .. External Functions ..
50038      LOGICAL            LSAME
50039      INTEGER            ILAENV
50040      EXTERNAL           LSAME, ILAENV
50041*     ..
50042*     .. External Subroutines ..
50043      EXTERNAL           XERBLA, ZTRMM, ZTRSM, ZTRTI2
50044*     ..
50045*     .. Intrinsic Functions ..
50046      INTRINSIC          MAX, MIN
50047*     ..
50048*     .. Executable Statements ..
50049*
50050*     Test the input parameters.
50051*
50052      INFO = 0
50053      UPPER = LSAME( UPLO, 'U' )
50054      NOUNIT = LSAME( DIAG, 'N' )
50055      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
50056         INFO = -1
50057      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
50058         INFO = -2
50059      ELSE IF( N.LT.0 ) THEN
50060         INFO = -3
50061      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
50062         INFO = -5
50063      END IF
50064      IF( INFO.NE.0 ) THEN
50065         CALL XERBLA( 'ZTRTRI', -INFO )
50066         RETURN
50067      END IF
50068*
50069*     Quick return if possible
50070*
50071      IF( N.EQ.0 )
50072     $   RETURN
50073*
50074*     Check for singularity if non-unit.
50075*
50076      IF( NOUNIT ) THEN
50077         DO 10 INFO = 1, N
50078            IF( A( INFO, INFO ).EQ.ZERO )
50079     $         RETURN
50080   10    CONTINUE
50081         INFO = 0
50082      END IF
50083*
50084*     Determine the block size for this environment.
50085*
50086      NB = ILAENV( 1, 'ZTRTRI', UPLO // DIAG, N, -1, -1, -1 )
50087      IF( NB.LE.1 .OR. NB.GE.N ) THEN
50088*
50089*        Use unblocked code
50090*
50091         CALL ZTRTI2( UPLO, DIAG, N, A, LDA, INFO )
50092      ELSE
50093*
50094*        Use blocked code
50095*
50096         IF( UPPER ) THEN
50097*
50098*           Compute inverse of upper triangular matrix
50099*
50100            DO 20 J = 1, N, NB
50101               JB = MIN( NB, N-J+1 )
50102*
50103*              Compute rows 1:j-1 of current block column
50104*
50105               CALL ZTRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1,
50106     $                     JB, ONE, A, LDA, A( 1, J ), LDA )
50107               CALL ZTRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1,
50108     $                     JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA )
50109*
50110*              Compute inverse of current diagonal block
50111*
50112               CALL ZTRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO )
50113   20       CONTINUE
50114         ELSE
50115*
50116*           Compute inverse of lower triangular matrix
50117*
50118            NN = ( ( N-1 ) / NB )*NB + 1
50119            DO 30 J = NN, 1, -NB
50120               JB = MIN( NB, N-J+1 )
50121               IF( J+JB.LE.N ) THEN
50122*
50123*                 Compute rows j+jb:n of current block column
50124*
50125                  CALL ZTRMM( 'Left', 'Lower', 'No transpose', DIAG,
50126     $                        N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA,
50127     $                        A( J+JB, J ), LDA )
50128                  CALL ZTRSM( 'Right', 'Lower', 'No transpose', DIAG,
50129     $                        N-J-JB+1, JB, -ONE, A( J, J ), LDA,
50130     $                        A( J+JB, J ), LDA )
50131               END IF
50132*
50133*              Compute inverse of current diagonal block
50134*
50135               CALL ZTRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO )
50136   30       CONTINUE
50137         END IF
50138      END IF
50139*
50140      RETURN
50141*
50142*     End of ZTRTRI
50143*
50144      END
50145*> \brief \b ZTRTRS
50146*
50147*  =========== DOCUMENTATION ===========
50148*
50149* Online html documentation available at
50150*            http://www.netlib.org/lapack/explore-html/
50151*
50152*> \htmlonly
50153*> Download ZTRTRS + dependencies
50154*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztrtrs.f">
50155*> [TGZ]</a>
50156*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztrtrs.f">
50157*> [ZIP]</a>
50158*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztrtrs.f">
50159*> [TXT]</a>
50160*> \endhtmlonly
50161*
50162*  Definition:
50163*  ===========
50164*
50165*       SUBROUTINE ZTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB,
50166*                          INFO )
50167*
50168*       .. Scalar Arguments ..
50169*       CHARACTER          DIAG, TRANS, UPLO
50170*       INTEGER            INFO, LDA, LDB, N, NRHS
50171*       ..
50172*       .. Array Arguments ..
50173*       COMPLEX*16         A( LDA, * ), B( LDB, * )
50174*       ..
50175*
50176*
50177*> \par Purpose:
50178*  =============
50179*>
50180*> \verbatim
50181*>
50182*> ZTRTRS solves a triangular system of the form
50183*>
50184*>    A * X = B,  A**T * X = B,  or  A**H * X = B,
50185*>
50186*> where A is a triangular matrix of order N, and B is an N-by-NRHS
50187*> matrix.  A check is made to verify that A is nonsingular.
50188*> \endverbatim
50189*
50190*  Arguments:
50191*  ==========
50192*
50193*> \param[in] UPLO
50194*> \verbatim
50195*>          UPLO is CHARACTER*1
50196*>          = 'U':  A is upper triangular;
50197*>          = 'L':  A is lower triangular.
50198*> \endverbatim
50199*>
50200*> \param[in] TRANS
50201*> \verbatim
50202*>          TRANS is CHARACTER*1
50203*>          Specifies the form of the system of equations:
50204*>          = 'N':  A * X = B     (No transpose)
50205*>          = 'T':  A**T * X = B  (Transpose)
50206*>          = 'C':  A**H * X = B  (Conjugate transpose)
50207*> \endverbatim
50208*>
50209*> \param[in] DIAG
50210*> \verbatim
50211*>          DIAG is CHARACTER*1
50212*>          = 'N':  A is non-unit triangular;
50213*>          = 'U':  A is unit triangular.
50214*> \endverbatim
50215*>
50216*> \param[in] N
50217*> \verbatim
50218*>          N is INTEGER
50219*>          The order of the matrix A.  N >= 0.
50220*> \endverbatim
50221*>
50222*> \param[in] NRHS
50223*> \verbatim
50224*>          NRHS is INTEGER
50225*>          The number of right hand sides, i.e., the number of columns
50226*>          of the matrix B.  NRHS >= 0.
50227*> \endverbatim
50228*>
50229*> \param[in] A
50230*> \verbatim
50231*>          A is COMPLEX*16 array, dimension (LDA,N)
50232*>          The triangular matrix A.  If UPLO = 'U', the leading N-by-N
50233*>          upper triangular part of the array A contains the upper
50234*>          triangular matrix, and the strictly lower triangular part of
50235*>          A is not referenced.  If UPLO = 'L', the leading N-by-N lower
50236*>          triangular part of the array A contains the lower triangular
50237*>          matrix, and the strictly upper triangular part of A is not
50238*>          referenced.  If DIAG = 'U', the diagonal elements of A are
50239*>          also not referenced and are assumed to be 1.
50240*> \endverbatim
50241*>
50242*> \param[in] LDA
50243*> \verbatim
50244*>          LDA is INTEGER
50245*>          The leading dimension of the array A.  LDA >= max(1,N).
50246*> \endverbatim
50247*>
50248*> \param[in,out] B
50249*> \verbatim
50250*>          B is COMPLEX*16 array, dimension (LDB,NRHS)
50251*>          On entry, the right hand side matrix B.
50252*>          On exit, if INFO = 0, the solution matrix X.
50253*> \endverbatim
50254*>
50255*> \param[in] LDB
50256*> \verbatim
50257*>          LDB is INTEGER
50258*>          The leading dimension of the array B.  LDB >= max(1,N).
50259*> \endverbatim
50260*>
50261*> \param[out] INFO
50262*> \verbatim
50263*>          INFO is INTEGER
50264*>          = 0:  successful exit
50265*>          < 0: if INFO = -i, the i-th argument had an illegal value
50266*>          > 0: if INFO = i, the i-th diagonal element of A is zero,
50267*>               indicating that the matrix is singular and the solutions
50268*>               X have not been computed.
50269*> \endverbatim
50270*
50271*  Authors:
50272*  ========
50273*
50274*> \author Univ. of Tennessee
50275*> \author Univ. of California Berkeley
50276*> \author Univ. of Colorado Denver
50277*> \author NAG Ltd.
50278*
50279*> \date December 2016
50280*
50281*> \ingroup complex16OTHERcomputational
50282*
50283*  =====================================================================
50284      SUBROUTINE ZTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB,
50285     $                   INFO )
50286*
50287*  -- LAPACK computational routine (version 3.7.0) --
50288*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
50289*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
50290*     December 2016
50291*
50292*     .. Scalar Arguments ..
50293      CHARACTER          DIAG, TRANS, UPLO
50294      INTEGER            INFO, LDA, LDB, N, NRHS
50295*     ..
50296*     .. Array Arguments ..
50297      COMPLEX*16         A( LDA, * ), B( LDB, * )
50298*     ..
50299*
50300*  =====================================================================
50301*
50302*     .. Parameters ..
50303      COMPLEX*16         ZERO, ONE
50304      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ),
50305     $                   ONE = ( 1.0D+0, 0.0D+0 ) )
50306*     ..
50307*     .. Local Scalars ..
50308      LOGICAL            NOUNIT
50309*     ..
50310*     .. External Functions ..
50311      LOGICAL            LSAME
50312      EXTERNAL           LSAME
50313*     ..
50314*     .. External Subroutines ..
50315      EXTERNAL           XERBLA, ZTRSM
50316*     ..
50317*     .. Intrinsic Functions ..
50318      INTRINSIC          MAX
50319*     ..
50320*     .. Executable Statements ..
50321*
50322*     Test the input parameters.
50323*
50324      INFO = 0
50325      NOUNIT = LSAME( DIAG, 'N' )
50326      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
50327         INFO = -1
50328      ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.
50329     $         LSAME( TRANS, 'T' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
50330         INFO = -2
50331      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
50332         INFO = -3
50333      ELSE IF( N.LT.0 ) THEN
50334         INFO = -4
50335      ELSE IF( NRHS.LT.0 ) THEN
50336         INFO = -5
50337      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
50338         INFO = -7
50339      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
50340         INFO = -9
50341      END IF
50342      IF( INFO.NE.0 ) THEN
50343         CALL XERBLA( 'ZTRTRS', -INFO )
50344         RETURN
50345      END IF
50346*
50347*     Quick return if possible
50348*
50349      IF( N.EQ.0 )
50350     $   RETURN
50351*
50352*     Check for singularity.
50353*
50354      IF( NOUNIT ) THEN
50355         DO 10 INFO = 1, N
50356            IF( A( INFO, INFO ).EQ.ZERO )
50357     $         RETURN
50358   10    CONTINUE
50359      END IF
50360      INFO = 0
50361*
50362*     Solve A * x = b,  A**T * x = b,  or  A**H * x = b.
50363*
50364      CALL ZTRSM( 'Left', UPLO, TRANS, DIAG, N, NRHS, ONE, A, LDA, B,
50365     $            LDB )
50366*
50367      RETURN
50368*
50369*     End of ZTRTRS
50370*
50371      END
50372*> \brief \b ZUNG2L generates all or part of the unitary matrix Q from a QL factorization determined by cgeqlf (unblocked algorithm).
50373*
50374*  =========== DOCUMENTATION ===========
50375*
50376* Online html documentation available at
50377*            http://www.netlib.org/lapack/explore-html/
50378*
50379*> \htmlonly
50380*> Download ZUNG2L + dependencies
50381*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zung2l.f">
50382*> [TGZ]</a>
50383*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zung2l.f">
50384*> [ZIP]</a>
50385*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zung2l.f">
50386*> [TXT]</a>
50387*> \endhtmlonly
50388*
50389*  Definition:
50390*  ===========
50391*
50392*       SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO )
50393*
50394*       .. Scalar Arguments ..
50395*       INTEGER            INFO, K, LDA, M, N
50396*       ..
50397*       .. Array Arguments ..
50398*       COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
50399*       ..
50400*
50401*
50402*> \par Purpose:
50403*  =============
50404*>
50405*> \verbatim
50406*>
50407*> ZUNG2L generates an m by n complex matrix Q with orthonormal columns,
50408*> which is defined as the last n columns of a product of k elementary
50409*> reflectors of order m
50410*>
50411*>       Q  =  H(k) . . . H(2) H(1)
50412*>
50413*> as returned by ZGEQLF.
50414*> \endverbatim
50415*
50416*  Arguments:
50417*  ==========
50418*
50419*> \param[in] M
50420*> \verbatim
50421*>          M is INTEGER
50422*>          The number of rows of the matrix Q. M >= 0.
50423*> \endverbatim
50424*>
50425*> \param[in] N
50426*> \verbatim
50427*>          N is INTEGER
50428*>          The number of columns of the matrix Q. M >= N >= 0.
50429*> \endverbatim
50430*>
50431*> \param[in] K
50432*> \verbatim
50433*>          K is INTEGER
50434*>          The number of elementary reflectors whose product defines the
50435*>          matrix Q. N >= K >= 0.
50436*> \endverbatim
50437*>
50438*> \param[in,out] A
50439*> \verbatim
50440*>          A is COMPLEX*16 array, dimension (LDA,N)
50441*>          On entry, the (n-k+i)-th column must contain the vector which
50442*>          defines the elementary reflector H(i), for i = 1,2,...,k, as
50443*>          returned by ZGEQLF in the last k columns of its array
50444*>          argument A.
50445*>          On exit, the m-by-n matrix Q.
50446*> \endverbatim
50447*>
50448*> \param[in] LDA
50449*> \verbatim
50450*>          LDA is INTEGER
50451*>          The first dimension of the array A. LDA >= max(1,M).
50452*> \endverbatim
50453*>
50454*> \param[in] TAU
50455*> \verbatim
50456*>          TAU is COMPLEX*16 array, dimension (K)
50457*>          TAU(i) must contain the scalar factor of the elementary
50458*>          reflector H(i), as returned by ZGEQLF.
50459*> \endverbatim
50460*>
50461*> \param[out] WORK
50462*> \verbatim
50463*>          WORK is COMPLEX*16 array, dimension (N)
50464*> \endverbatim
50465*>
50466*> \param[out] INFO
50467*> \verbatim
50468*>          INFO is INTEGER
50469*>          = 0: successful exit
50470*>          < 0: if INFO = -i, the i-th argument has an illegal value
50471*> \endverbatim
50472*
50473*  Authors:
50474*  ========
50475*
50476*> \author Univ. of Tennessee
50477*> \author Univ. of California Berkeley
50478*> \author Univ. of Colorado Denver
50479*> \author NAG Ltd.
50480*
50481*> \date December 2016
50482*
50483*> \ingroup complex16OTHERcomputational
50484*
50485*  =====================================================================
50486      SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO )
50487*
50488*  -- LAPACK computational routine (version 3.7.0) --
50489*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
50490*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
50491*     December 2016
50492*
50493*     .. Scalar Arguments ..
50494      INTEGER            INFO, K, LDA, M, N
50495*     ..
50496*     .. Array Arguments ..
50497      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
50498*     ..
50499*
50500*  =====================================================================
50501*
50502*     .. Parameters ..
50503      COMPLEX*16         ONE, ZERO
50504      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),
50505     $                   ZERO = ( 0.0D+0, 0.0D+0 ) )
50506*     ..
50507*     .. Local Scalars ..
50508      INTEGER            I, II, J, L
50509*     ..
50510*     .. External Subroutines ..
50511      EXTERNAL           XERBLA, ZLARF, ZSCAL
50512*     ..
50513*     .. Intrinsic Functions ..
50514      INTRINSIC          MAX
50515*     ..
50516*     .. Executable Statements ..
50517*
50518*     Test the input arguments
50519*
50520      INFO = 0
50521      IF( M.LT.0 ) THEN
50522         INFO = -1
50523      ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
50524         INFO = -2
50525      ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
50526         INFO = -3
50527      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
50528         INFO = -5
50529      END IF
50530      IF( INFO.NE.0 ) THEN
50531         CALL XERBLA( 'ZUNG2L', -INFO )
50532         RETURN
50533      END IF
50534*
50535*     Quick return if possible
50536*
50537      IF( N.LE.0 )
50538     $   RETURN
50539*
50540*     Initialise columns 1:n-k to columns of the unit matrix
50541*
50542      DO 20 J = 1, N - K
50543         DO 10 L = 1, M
50544            A( L, J ) = ZERO
50545   10    CONTINUE
50546         A( M-N+J, J ) = ONE
50547   20 CONTINUE
50548*
50549      DO 40 I = 1, K
50550         II = N - K + I
50551*
50552*        Apply H(i) to A(1:m-k+i,1:n-k+i) from the left
50553*
50554         A( M-N+II, II ) = ONE
50555         CALL ZLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A,
50556     $               LDA, WORK )
50557         CALL ZSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 )
50558         A( M-N+II, II ) = ONE - TAU( I )
50559*
50560*        Set A(m-k+i+1:m,n-k+i) to zero
50561*
50562         DO 30 L = M - N + II + 1, M
50563            A( L, II ) = ZERO
50564   30    CONTINUE
50565   40 CONTINUE
50566      RETURN
50567*
50568*     End of ZUNG2L
50569*
50570      END
50571*> \brief \b ZUNG2R
50572*
50573*  =========== DOCUMENTATION ===========
50574*
50575* Online html documentation available at
50576*            http://www.netlib.org/lapack/explore-html/
50577*
50578*> \htmlonly
50579*> Download ZUNG2R + dependencies
50580*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zung2r.f">
50581*> [TGZ]</a>
50582*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zung2r.f">
50583*> [ZIP]</a>
50584*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zung2r.f">
50585*> [TXT]</a>
50586*> \endhtmlonly
50587*
50588*  Definition:
50589*  ===========
50590*
50591*       SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO )
50592*
50593*       .. Scalar Arguments ..
50594*       INTEGER            INFO, K, LDA, M, N
50595*       ..
50596*       .. Array Arguments ..
50597*       COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
50598*       ..
50599*
50600*
50601*> \par Purpose:
50602*  =============
50603*>
50604*> \verbatim
50605*>
50606*> ZUNG2R generates an m by n complex matrix Q with orthonormal columns,
50607*> which is defined as the first n columns of a product of k elementary
50608*> reflectors of order m
50609*>
50610*>       Q  =  H(1) H(2) . . . H(k)
50611*>
50612*> as returned by ZGEQRF.
50613*> \endverbatim
50614*
50615*  Arguments:
50616*  ==========
50617*
50618*> \param[in] M
50619*> \verbatim
50620*>          M is INTEGER
50621*>          The number of rows of the matrix Q. M >= 0.
50622*> \endverbatim
50623*>
50624*> \param[in] N
50625*> \verbatim
50626*>          N is INTEGER
50627*>          The number of columns of the matrix Q. M >= N >= 0.
50628*> \endverbatim
50629*>
50630*> \param[in] K
50631*> \verbatim
50632*>          K is INTEGER
50633*>          The number of elementary reflectors whose product defines the
50634*>          matrix Q. N >= K >= 0.
50635*> \endverbatim
50636*>
50637*> \param[in,out] A
50638*> \verbatim
50639*>          A is COMPLEX*16 array, dimension (LDA,N)
50640*>          On entry, the i-th column must contain the vector which
50641*>          defines the elementary reflector H(i), for i = 1,2,...,k, as
50642*>          returned by ZGEQRF in the first k columns of its array
50643*>          argument A.
50644*>          On exit, the m by n matrix Q.
50645*> \endverbatim
50646*>
50647*> \param[in] LDA
50648*> \verbatim
50649*>          LDA is INTEGER
50650*>          The first dimension of the array A. LDA >= max(1,M).
50651*> \endverbatim
50652*>
50653*> \param[in] TAU
50654*> \verbatim
50655*>          TAU is COMPLEX*16 array, dimension (K)
50656*>          TAU(i) must contain the scalar factor of the elementary
50657*>          reflector H(i), as returned by ZGEQRF.
50658*> \endverbatim
50659*>
50660*> \param[out] WORK
50661*> \verbatim
50662*>          WORK is COMPLEX*16 array, dimension (N)
50663*> \endverbatim
50664*>
50665*> \param[out] INFO
50666*> \verbatim
50667*>          INFO is INTEGER
50668*>          = 0: successful exit
50669*>          < 0: if INFO = -i, the i-th argument has an illegal value
50670*> \endverbatim
50671*
50672*  Authors:
50673*  ========
50674*
50675*> \author Univ. of Tennessee
50676*> \author Univ. of California Berkeley
50677*> \author Univ. of Colorado Denver
50678*> \author NAG Ltd.
50679*
50680*> \date December 2016
50681*
50682*> \ingroup complex16OTHERcomputational
50683*
50684*  =====================================================================
50685      SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO )
50686*
50687*  -- LAPACK computational routine (version 3.7.0) --
50688*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
50689*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
50690*     December 2016
50691*
50692*     .. Scalar Arguments ..
50693      INTEGER            INFO, K, LDA, M, N
50694*     ..
50695*     .. Array Arguments ..
50696      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
50697*     ..
50698*
50699*  =====================================================================
50700*
50701*     .. Parameters ..
50702      COMPLEX*16         ONE, ZERO
50703      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),
50704     $                   ZERO = ( 0.0D+0, 0.0D+0 ) )
50705*     ..
50706*     .. Local Scalars ..
50707      INTEGER            I, J, L
50708*     ..
50709*     .. External Subroutines ..
50710      EXTERNAL           XERBLA, ZLARF, ZSCAL
50711*     ..
50712*     .. Intrinsic Functions ..
50713      INTRINSIC          MAX
50714*     ..
50715*     .. Executable Statements ..
50716*
50717*     Test the input arguments
50718*
50719      INFO = 0
50720      IF( M.LT.0 ) THEN
50721         INFO = -1
50722      ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
50723         INFO = -2
50724      ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
50725         INFO = -3
50726      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
50727         INFO = -5
50728      END IF
50729      IF( INFO.NE.0 ) THEN
50730         CALL XERBLA( 'ZUNG2R', -INFO )
50731         RETURN
50732      END IF
50733*
50734*     Quick return if possible
50735*
50736      IF( N.LE.0 )
50737     $   RETURN
50738*
50739*     Initialise columns k+1:n to columns of the unit matrix
50740*
50741      DO 20 J = K + 1, N
50742         DO 10 L = 1, M
50743            A( L, J ) = ZERO
50744   10    CONTINUE
50745         A( J, J ) = ONE
50746   20 CONTINUE
50747*
50748      DO 40 I = K, 1, -1
50749*
50750*        Apply H(i) to A(i:m,i:n) from the left
50751*
50752         IF( I.LT.N ) THEN
50753            A( I, I ) = ONE
50754            CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
50755     $                  A( I, I+1 ), LDA, WORK )
50756         END IF
50757         IF( I.LT.M )
50758     $      CALL ZSCAL( M-I, -TAU( I ), A( I+1, I ), 1 )
50759         A( I, I ) = ONE - TAU( I )
50760*
50761*        Set A(1:i-1,i) to zero
50762*
50763         DO 30 L = 1, I - 1
50764            A( L, I ) = ZERO
50765   30    CONTINUE
50766   40 CONTINUE
50767      RETURN
50768*
50769*     End of ZUNG2R
50770*
50771      END
50772*> \brief \b ZUNGBR
50773*
50774*  =========== DOCUMENTATION ===========
50775*
50776* Online html documentation available at
50777*            http://www.netlib.org/lapack/explore-html/
50778*
50779*> \htmlonly
50780*> Download ZUNGBR + dependencies
50781*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zungbr.f">
50782*> [TGZ]</a>
50783*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zungbr.f">
50784*> [ZIP]</a>
50785*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zungbr.f">
50786*> [TXT]</a>
50787*> \endhtmlonly
50788*
50789*  Definition:
50790*  ===========
50791*
50792*       SUBROUTINE ZUNGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
50793*
50794*       .. Scalar Arguments ..
50795*       CHARACTER          VECT
50796*       INTEGER            INFO, K, LDA, LWORK, M, N
50797*       ..
50798*       .. Array Arguments ..
50799*       COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
50800*       ..
50801*
50802*
50803*> \par Purpose:
50804*  =============
50805*>
50806*> \verbatim
50807*>
50808*> ZUNGBR generates one of the complex unitary matrices Q or P**H
50809*> determined by ZGEBRD when reducing a complex matrix A to bidiagonal
50810*> form: A = Q * B * P**H.  Q and P**H are defined as products of
50811*> elementary reflectors H(i) or G(i) respectively.
50812*>
50813*> If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q
50814*> is of order M:
50815*> if m >= k, Q = H(1) H(2) . . . H(k) and ZUNGBR returns the first n
50816*> columns of Q, where m >= n >= k;
50817*> if m < k, Q = H(1) H(2) . . . H(m-1) and ZUNGBR returns Q as an
50818*> M-by-M matrix.
50819*>
50820*> If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**H
50821*> is of order N:
50822*> if k < n, P**H = G(k) . . . G(2) G(1) and ZUNGBR returns the first m
50823*> rows of P**H, where n >= m >= k;
50824*> if k >= n, P**H = G(n-1) . . . G(2) G(1) and ZUNGBR returns P**H as
50825*> an N-by-N matrix.
50826*> \endverbatim
50827*
50828*  Arguments:
50829*  ==========
50830*
50831*> \param[in] VECT
50832*> \verbatim
50833*>          VECT is CHARACTER*1
50834*>          Specifies whether the matrix Q or the matrix P**H is
50835*>          required, as defined in the transformation applied by ZGEBRD:
50836*>          = 'Q':  generate Q;
50837*>          = 'P':  generate P**H.
50838*> \endverbatim
50839*>
50840*> \param[in] M
50841*> \verbatim
50842*>          M is INTEGER
50843*>          The number of rows of the matrix Q or P**H to be returned.
50844*>          M >= 0.
50845*> \endverbatim
50846*>
50847*> \param[in] N
50848*> \verbatim
50849*>          N is INTEGER
50850*>          The number of columns of the matrix Q or P**H to be returned.
50851*>          N >= 0.
50852*>          If VECT = 'Q', M >= N >= min(M,K);
50853*>          if VECT = 'P', N >= M >= min(N,K).
50854*> \endverbatim
50855*>
50856*> \param[in] K
50857*> \verbatim
50858*>          K is INTEGER
50859*>          If VECT = 'Q', the number of columns in the original M-by-K
50860*>          matrix reduced by ZGEBRD.
50861*>          If VECT = 'P', the number of rows in the original K-by-N
50862*>          matrix reduced by ZGEBRD.
50863*>          K >= 0.
50864*> \endverbatim
50865*>
50866*> \param[in,out] A
50867*> \verbatim
50868*>          A is COMPLEX*16 array, dimension (LDA,N)
50869*>          On entry, the vectors which define the elementary reflectors,
50870*>          as returned by ZGEBRD.
50871*>          On exit, the M-by-N matrix Q or P**H.
50872*> \endverbatim
50873*>
50874*> \param[in] LDA
50875*> \verbatim
50876*>          LDA is INTEGER
50877*>          The leading dimension of the array A. LDA >= M.
50878*> \endverbatim
50879*>
50880*> \param[in] TAU
50881*> \verbatim
50882*>          TAU is COMPLEX*16 array, dimension
50883*>                                (min(M,K)) if VECT = 'Q'
50884*>                                (min(N,K)) if VECT = 'P'
50885*>          TAU(i) must contain the scalar factor of the elementary
50886*>          reflector H(i) or G(i), which determines Q or P**H, as
50887*>          returned by ZGEBRD in its array argument TAUQ or TAUP.
50888*> \endverbatim
50889*>
50890*> \param[out] WORK
50891*> \verbatim
50892*>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
50893*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
50894*> \endverbatim
50895*>
50896*> \param[in] LWORK
50897*> \verbatim
50898*>          LWORK is INTEGER
50899*>          The dimension of the array WORK. LWORK >= max(1,min(M,N)).
50900*>          For optimum performance LWORK >= min(M,N)*NB, where NB
50901*>          is the optimal blocksize.
50902*>
50903*>          If LWORK = -1, then a workspace query is assumed; the routine
50904*>          only calculates the optimal size of the WORK array, returns
50905*>          this value as the first entry of the WORK array, and no error
50906*>          message related to LWORK is issued by XERBLA.
50907*> \endverbatim
50908*>
50909*> \param[out] INFO
50910*> \verbatim
50911*>          INFO is INTEGER
50912*>          = 0:  successful exit
50913*>          < 0:  if INFO = -i, the i-th argument had an illegal value
50914*> \endverbatim
50915*
50916*  Authors:
50917*  ========
50918*
50919*> \author Univ. of Tennessee
50920*> \author Univ. of California Berkeley
50921*> \author Univ. of Colorado Denver
50922*> \author NAG Ltd.
50923*
50924*> \date April 2012
50925*
50926*> \ingroup complex16GBcomputational
50927*
50928*  =====================================================================
50929      SUBROUTINE ZUNGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
50930*
50931*  -- LAPACK computational routine (version 3.7.0) --
50932*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
50933*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
50934*     April 2012
50935*
50936*     .. Scalar Arguments ..
50937      CHARACTER          VECT
50938      INTEGER            INFO, K, LDA, LWORK, M, N
50939*     ..
50940*     .. Array Arguments ..
50941      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
50942*     ..
50943*
50944*  =====================================================================
50945*
50946*     .. Parameters ..
50947      COMPLEX*16         ZERO, ONE
50948      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ),
50949     $                   ONE = ( 1.0D+0, 0.0D+0 ) )
50950*     ..
50951*     .. Local Scalars ..
50952      LOGICAL            LQUERY, WANTQ
50953      INTEGER            I, IINFO, J, LWKOPT, MN
50954*     ..
50955*     .. External Functions ..
50956      LOGICAL            LSAME
50957      EXTERNAL           LSAME
50958*     ..
50959*     .. External Subroutines ..
50960      EXTERNAL           XERBLA, ZUNGLQ, ZUNGQR
50961*     ..
50962*     .. Intrinsic Functions ..
50963      INTRINSIC          MAX, MIN
50964*     ..
50965*     .. Executable Statements ..
50966*
50967*     Test the input arguments
50968*
50969      INFO = 0
50970      WANTQ = LSAME( VECT, 'Q' )
50971      MN = MIN( M, N )
50972      LQUERY = ( LWORK.EQ.-1 )
50973      IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN
50974         INFO = -1
50975      ELSE IF( M.LT.0 ) THEN
50976         INFO = -2
50977      ELSE IF( N.LT.0 .OR. ( WANTQ .AND. ( N.GT.M .OR. N.LT.MIN( M,
50978     $         K ) ) ) .OR. ( .NOT.WANTQ .AND. ( M.GT.N .OR. M.LT.
50979     $         MIN( N, K ) ) ) ) THEN
50980         INFO = -3
50981      ELSE IF( K.LT.0 ) THEN
50982         INFO = -4
50983      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
50984         INFO = -6
50985      ELSE IF( LWORK.LT.MAX( 1, MN ) .AND. .NOT.LQUERY ) THEN
50986         INFO = -9
50987      END IF
50988*
50989      IF( INFO.EQ.0 ) THEN
50990         WORK( 1 ) = 1
50991         IF( WANTQ ) THEN
50992            IF( M.GE.K ) THEN
50993               CALL ZUNGQR( M, N, K, A, LDA, TAU, WORK, -1, IINFO )
50994            ELSE
50995               IF( M.GT.1 ) THEN
50996                  CALL ZUNGQR( M-1, M-1, M-1, A( 2, 2 ), LDA, TAU, WORK,
50997     $                         -1, IINFO )
50998               END IF
50999            END IF
51000         ELSE
51001            IF( K.LT.N ) THEN
51002               CALL ZUNGLQ( M, N, K, A, LDA, TAU, WORK, -1, IINFO )
51003            ELSE
51004               IF( N.GT.1 ) THEN
51005                  CALL ZUNGLQ( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK,
51006     $                         -1, IINFO )
51007               END IF
51008            END IF
51009         END IF
51010         LWKOPT = WORK( 1 )
51011         LWKOPT = MAX (LWKOPT, MN)
51012      END IF
51013*
51014      IF( INFO.NE.0 ) THEN
51015         CALL XERBLA( 'ZUNGBR', -INFO )
51016         RETURN
51017      ELSE IF( LQUERY ) THEN
51018         WORK( 1 ) = LWKOPT
51019         RETURN
51020      END IF
51021*
51022*     Quick return if possible
51023*
51024      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
51025         WORK( 1 ) = 1
51026         RETURN
51027      END IF
51028*
51029      IF( WANTQ ) THEN
51030*
51031*        Form Q, determined by a call to ZGEBRD to reduce an m-by-k
51032*        matrix
51033*
51034         IF( M.GE.K ) THEN
51035*
51036*           If m >= k, assume m >= n >= k
51037*
51038            CALL ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO )
51039*
51040         ELSE
51041*
51042*           If m < k, assume m = n
51043*
51044*           Shift the vectors which define the elementary reflectors one
51045*           column to the right, and set the first row and column of Q
51046*           to those of the unit matrix
51047*
51048            DO 20 J = M, 2, -1
51049               A( 1, J ) = ZERO
51050               DO 10 I = J + 1, M
51051                  A( I, J ) = A( I, J-1 )
51052   10          CONTINUE
51053   20       CONTINUE
51054            A( 1, 1 ) = ONE
51055            DO 30 I = 2, M
51056               A( I, 1 ) = ZERO
51057   30       CONTINUE
51058            IF( M.GT.1 ) THEN
51059*
51060*              Form Q(2:m,2:m)
51061*
51062               CALL ZUNGQR( M-1, M-1, M-1, A( 2, 2 ), LDA, TAU, WORK,
51063     $                      LWORK, IINFO )
51064            END IF
51065         END IF
51066      ELSE
51067*
51068*        Form P**H, determined by a call to ZGEBRD to reduce a k-by-n
51069*        matrix
51070*
51071         IF( K.LT.N ) THEN
51072*
51073*           If k < n, assume k <= m <= n
51074*
51075            CALL ZUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO )
51076*
51077         ELSE
51078*
51079*           If k >= n, assume m = n
51080*
51081*           Shift the vectors which define the elementary reflectors one
51082*           row downward, and set the first row and column of P**H to
51083*           those of the unit matrix
51084*
51085            A( 1, 1 ) = ONE
51086            DO 40 I = 2, N
51087               A( I, 1 ) = ZERO
51088   40       CONTINUE
51089            DO 60 J = 2, N
51090               DO 50 I = J - 1, 2, -1
51091                  A( I, J ) = A( I-1, J )
51092   50          CONTINUE
51093               A( 1, J ) = ZERO
51094   60       CONTINUE
51095            IF( N.GT.1 ) THEN
51096*
51097*              Form P**H(2:n,2:n)
51098*
51099               CALL ZUNGLQ( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK,
51100     $                      LWORK, IINFO )
51101            END IF
51102         END IF
51103      END IF
51104      WORK( 1 ) = LWKOPT
51105      RETURN
51106*
51107*     End of ZUNGBR
51108*
51109      END
51110*> \brief \b ZUNGHR
51111*
51112*  =========== DOCUMENTATION ===========
51113*
51114* Online html documentation available at
51115*            http://www.netlib.org/lapack/explore-html/
51116*
51117*> \htmlonly
51118*> Download ZUNGHR + dependencies
51119*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zunghr.f">
51120*> [TGZ]</a>
51121*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zunghr.f">
51122*> [ZIP]</a>
51123*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zunghr.f">
51124*> [TXT]</a>
51125*> \endhtmlonly
51126*
51127*  Definition:
51128*  ===========
51129*
51130*       SUBROUTINE ZUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
51131*
51132*       .. Scalar Arguments ..
51133*       INTEGER            IHI, ILO, INFO, LDA, LWORK, N
51134*       ..
51135*       .. Array Arguments ..
51136*       COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
51137*       ..
51138*
51139*
51140*> \par Purpose:
51141*  =============
51142*>
51143*> \verbatim
51144*>
51145*> ZUNGHR generates a complex unitary matrix Q which is defined as the
51146*> product of IHI-ILO elementary reflectors of order N, as returned by
51147*> ZGEHRD:
51148*>
51149*> Q = H(ilo) H(ilo+1) . . . H(ihi-1).
51150*> \endverbatim
51151*
51152*  Arguments:
51153*  ==========
51154*
51155*> \param[in] N
51156*> \verbatim
51157*>          N is INTEGER
51158*>          The order of the matrix Q. N >= 0.
51159*> \endverbatim
51160*>
51161*> \param[in] ILO
51162*> \verbatim
51163*>          ILO is INTEGER
51164*> \endverbatim
51165*>
51166*> \param[in] IHI
51167*> \verbatim
51168*>          IHI is INTEGER
51169*>
51170*>          ILO and IHI must have the same values as in the previous call
51171*>          of ZGEHRD. Q is equal to the unit matrix except in the
51172*>          submatrix Q(ilo+1:ihi,ilo+1:ihi).
51173*>          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
51174*> \endverbatim
51175*>
51176*> \param[in,out] A
51177*> \verbatim
51178*>          A is COMPLEX*16 array, dimension (LDA,N)
51179*>          On entry, the vectors which define the elementary reflectors,
51180*>          as returned by ZGEHRD.
51181*>          On exit, the N-by-N unitary matrix Q.
51182*> \endverbatim
51183*>
51184*> \param[in] LDA
51185*> \verbatim
51186*>          LDA is INTEGER
51187*>          The leading dimension of the array A. LDA >= max(1,N).
51188*> \endverbatim
51189*>
51190*> \param[in] TAU
51191*> \verbatim
51192*>          TAU is COMPLEX*16 array, dimension (N-1)
51193*>          TAU(i) must contain the scalar factor of the elementary
51194*>          reflector H(i), as returned by ZGEHRD.
51195*> \endverbatim
51196*>
51197*> \param[out] WORK
51198*> \verbatim
51199*>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
51200*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
51201*> \endverbatim
51202*>
51203*> \param[in] LWORK
51204*> \verbatim
51205*>          LWORK is INTEGER
51206*>          The dimension of the array WORK. LWORK >= IHI-ILO.
51207*>          For optimum performance LWORK >= (IHI-ILO)*NB, where NB is
51208*>          the optimal blocksize.
51209*>
51210*>          If LWORK = -1, then a workspace query is assumed; the routine
51211*>          only calculates the optimal size of the WORK array, returns
51212*>          this value as the first entry of the WORK array, and no error
51213*>          message related to LWORK is issued by XERBLA.
51214*> \endverbatim
51215*>
51216*> \param[out] INFO
51217*> \verbatim
51218*>          INFO is INTEGER
51219*>          = 0:  successful exit
51220*>          < 0:  if INFO = -i, the i-th argument had an illegal value
51221*> \endverbatim
51222*
51223*  Authors:
51224*  ========
51225*
51226*> \author Univ. of Tennessee
51227*> \author Univ. of California Berkeley
51228*> \author Univ. of Colorado Denver
51229*> \author NAG Ltd.
51230*
51231*> \date December 2016
51232*
51233*> \ingroup complex16OTHERcomputational
51234*
51235*  =====================================================================
51236      SUBROUTINE ZUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
51237*
51238*  -- LAPACK computational routine (version 3.7.0) --
51239*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
51240*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
51241*     December 2016
51242*
51243*     .. Scalar Arguments ..
51244      INTEGER            IHI, ILO, INFO, LDA, LWORK, N
51245*     ..
51246*     .. Array Arguments ..
51247      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
51248*     ..
51249*
51250*  =====================================================================
51251*
51252*     .. Parameters ..
51253      COMPLEX*16         ZERO, ONE
51254      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ),
51255     $                   ONE = ( 1.0D+0, 0.0D+0 ) )
51256*     ..
51257*     .. Local Scalars ..
51258      LOGICAL            LQUERY
51259      INTEGER            I, IINFO, J, LWKOPT, NB, NH
51260*     ..
51261*     .. External Subroutines ..
51262      EXTERNAL           XERBLA, ZUNGQR
51263*     ..
51264*     .. External Functions ..
51265      INTEGER            ILAENV
51266      EXTERNAL           ILAENV
51267*     ..
51268*     .. Intrinsic Functions ..
51269      INTRINSIC          MAX, MIN
51270*     ..
51271*     .. Executable Statements ..
51272*
51273*     Test the input arguments
51274*
51275      INFO = 0
51276      NH = IHI - ILO
51277      LQUERY = ( LWORK.EQ.-1 )
51278      IF( N.LT.0 ) THEN
51279         INFO = -1
51280      ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
51281         INFO = -2
51282      ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
51283         INFO = -3
51284      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
51285         INFO = -5
51286      ELSE IF( LWORK.LT.MAX( 1, NH ) .AND. .NOT.LQUERY ) THEN
51287         INFO = -8
51288      END IF
51289*
51290      IF( INFO.EQ.0 ) THEN
51291         NB = ILAENV( 1, 'ZUNGQR', ' ', NH, NH, NH, -1 )
51292         LWKOPT = MAX( 1, NH )*NB
51293         WORK( 1 ) = LWKOPT
51294      END IF
51295*
51296      IF( INFO.NE.0 ) THEN
51297         CALL XERBLA( 'ZUNGHR', -INFO )
51298         RETURN
51299      ELSE IF( LQUERY ) THEN
51300         RETURN
51301      END IF
51302*
51303*     Quick return if possible
51304*
51305      IF( N.EQ.0 ) THEN
51306         WORK( 1 ) = 1
51307         RETURN
51308      END IF
51309*
51310*     Shift the vectors which define the elementary reflectors one
51311*     column to the right, and set the first ilo and the last n-ihi
51312*     rows and columns to those of the unit matrix
51313*
51314      DO 40 J = IHI, ILO + 1, -1
51315         DO 10 I = 1, J - 1
51316            A( I, J ) = ZERO
51317   10    CONTINUE
51318         DO 20 I = J + 1, IHI
51319            A( I, J ) = A( I, J-1 )
51320   20    CONTINUE
51321         DO 30 I = IHI + 1, N
51322            A( I, J ) = ZERO
51323   30    CONTINUE
51324   40 CONTINUE
51325      DO 60 J = 1, ILO
51326         DO 50 I = 1, N
51327            A( I, J ) = ZERO
51328   50    CONTINUE
51329         A( J, J ) = ONE
51330   60 CONTINUE
51331      DO 80 J = IHI + 1, N
51332         DO 70 I = 1, N
51333            A( I, J ) = ZERO
51334   70    CONTINUE
51335         A( J, J ) = ONE
51336   80 CONTINUE
51337*
51338      IF( NH.GT.0 ) THEN
51339*
51340*        Generate Q(ilo+1:ihi,ilo+1:ihi)
51341*
51342         CALL ZUNGQR( NH, NH, NH, A( ILO+1, ILO+1 ), LDA, TAU( ILO ),
51343     $                WORK, LWORK, IINFO )
51344      END IF
51345      WORK( 1 ) = LWKOPT
51346      RETURN
51347*
51348*     End of ZUNGHR
51349*
51350      END
51351*> \brief \b ZUNGL2 generates all or part of the unitary matrix Q from an LQ factorization determined by cgelqf (unblocked algorithm).
51352*
51353*  =========== DOCUMENTATION ===========
51354*
51355* Online html documentation available at
51356*            http://www.netlib.org/lapack/explore-html/
51357*
51358*> \htmlonly
51359*> Download ZUNGL2 + dependencies
51360*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zungl2.f">
51361*> [TGZ]</a>
51362*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zungl2.f">
51363*> [ZIP]</a>
51364*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zungl2.f">
51365*> [TXT]</a>
51366*> \endhtmlonly
51367*
51368*  Definition:
51369*  ===========
51370*
51371*       SUBROUTINE ZUNGL2( M, N, K, A, LDA, TAU, WORK, INFO )
51372*
51373*       .. Scalar Arguments ..
51374*       INTEGER            INFO, K, LDA, M, N
51375*       ..
51376*       .. Array Arguments ..
51377*       COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
51378*       ..
51379*
51380*
51381*> \par Purpose:
51382*  =============
51383*>
51384*> \verbatim
51385*>
51386*> ZUNGL2 generates an m-by-n complex matrix Q with orthonormal rows,
51387*> which is defined as the first m rows of a product of k elementary
51388*> reflectors of order n
51389*>
51390*>       Q  =  H(k)**H . . . H(2)**H H(1)**H
51391*>
51392*> as returned by ZGELQF.
51393*> \endverbatim
51394*
51395*  Arguments:
51396*  ==========
51397*
51398*> \param[in] M
51399*> \verbatim
51400*>          M is INTEGER
51401*>          The number of rows of the matrix Q. M >= 0.
51402*> \endverbatim
51403*>
51404*> \param[in] N
51405*> \verbatim
51406*>          N is INTEGER
51407*>          The number of columns of the matrix Q. N >= M.
51408*> \endverbatim
51409*>
51410*> \param[in] K
51411*> \verbatim
51412*>          K is INTEGER
51413*>          The number of elementary reflectors whose product defines the
51414*>          matrix Q. M >= K >= 0.
51415*> \endverbatim
51416*>
51417*> \param[in,out] A
51418*> \verbatim
51419*>          A is COMPLEX*16 array, dimension (LDA,N)
51420*>          On entry, the i-th row must contain the vector which defines
51421*>          the elementary reflector H(i), for i = 1,2,...,k, as returned
51422*>          by ZGELQF in the first k rows of its array argument A.
51423*>          On exit, the m by n matrix Q.
51424*> \endverbatim
51425*>
51426*> \param[in] LDA
51427*> \verbatim
51428*>          LDA is INTEGER
51429*>          The first dimension of the array A. LDA >= max(1,M).
51430*> \endverbatim
51431*>
51432*> \param[in] TAU
51433*> \verbatim
51434*>          TAU is COMPLEX*16 array, dimension (K)
51435*>          TAU(i) must contain the scalar factor of the elementary
51436*>          reflector H(i), as returned by ZGELQF.
51437*> \endverbatim
51438*>
51439*> \param[out] WORK
51440*> \verbatim
51441*>          WORK is COMPLEX*16 array, dimension (M)
51442*> \endverbatim
51443*>
51444*> \param[out] INFO
51445*> \verbatim
51446*>          INFO is INTEGER
51447*>          = 0: successful exit
51448*>          < 0: if INFO = -i, the i-th argument has an illegal value
51449*> \endverbatim
51450*
51451*  Authors:
51452*  ========
51453*
51454*> \author Univ. of Tennessee
51455*> \author Univ. of California Berkeley
51456*> \author Univ. of Colorado Denver
51457*> \author NAG Ltd.
51458*
51459*> \date December 2016
51460*
51461*> \ingroup complex16OTHERcomputational
51462*
51463*  =====================================================================
51464      SUBROUTINE ZUNGL2( M, N, K, A, LDA, TAU, WORK, INFO )
51465*
51466*  -- LAPACK computational routine (version 3.7.0) --
51467*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
51468*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
51469*     December 2016
51470*
51471*     .. Scalar Arguments ..
51472      INTEGER            INFO, K, LDA, M, N
51473*     ..
51474*     .. Array Arguments ..
51475      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
51476*     ..
51477*
51478*  =====================================================================
51479*
51480*     .. Parameters ..
51481      COMPLEX*16         ONE, ZERO
51482      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),
51483     $                   ZERO = ( 0.0D+0, 0.0D+0 ) )
51484*     ..
51485*     .. Local Scalars ..
51486      INTEGER            I, J, L
51487*     ..
51488*     .. External Subroutines ..
51489      EXTERNAL           XERBLA, ZLACGV, ZLARF, ZSCAL
51490*     ..
51491*     .. Intrinsic Functions ..
51492      INTRINSIC          DCONJG, MAX
51493*     ..
51494*     .. Executable Statements ..
51495*
51496*     Test the input arguments
51497*
51498      INFO = 0
51499      IF( M.LT.0 ) THEN
51500         INFO = -1
51501      ELSE IF( N.LT.M ) THEN
51502         INFO = -2
51503      ELSE IF( K.LT.0 .OR. K.GT.M ) THEN
51504         INFO = -3
51505      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
51506         INFO = -5
51507      END IF
51508      IF( INFO.NE.0 ) THEN
51509         CALL XERBLA( 'ZUNGL2', -INFO )
51510         RETURN
51511      END IF
51512*
51513*     Quick return if possible
51514*
51515      IF( M.LE.0 )
51516     $   RETURN
51517*
51518      IF( K.LT.M ) THEN
51519*
51520*        Initialise rows k+1:m to rows of the unit matrix
51521*
51522         DO 20 J = 1, N
51523            DO 10 L = K + 1, M
51524               A( L, J ) = ZERO
51525   10       CONTINUE
51526            IF( J.GT.K .AND. J.LE.M )
51527     $         A( J, J ) = ONE
51528   20    CONTINUE
51529      END IF
51530*
51531      DO 40 I = K, 1, -1
51532*
51533*        Apply H(i)**H to A(i:m,i:n) from the right
51534*
51535         IF( I.LT.N ) THEN
51536            CALL ZLACGV( N-I, A( I, I+1 ), LDA )
51537            IF( I.LT.M ) THEN
51538               A( I, I ) = ONE
51539               CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
51540     $                     DCONJG( TAU( I ) ), A( I+1, I ), LDA, WORK )
51541            END IF
51542            CALL ZSCAL( N-I, -TAU( I ), A( I, I+1 ), LDA )
51543            CALL ZLACGV( N-I, A( I, I+1 ), LDA )
51544         END IF
51545         A( I, I ) = ONE - DCONJG( TAU( I ) )
51546*
51547*        Set A(i,1:i-1) to zero
51548*
51549         DO 30 L = 1, I - 1
51550            A( I, L ) = ZERO
51551   30    CONTINUE
51552   40 CONTINUE
51553      RETURN
51554*
51555*     End of ZUNGL2
51556*
51557      END
51558*> \brief \b ZUNGLQ
51559*
51560*  =========== DOCUMENTATION ===========
51561*
51562* Online html documentation available at
51563*            http://www.netlib.org/lapack/explore-html/
51564*
51565*> \htmlonly
51566*> Download ZUNGLQ + dependencies
51567*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zunglq.f">
51568*> [TGZ]</a>
51569*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zunglq.f">
51570*> [ZIP]</a>
51571*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zunglq.f">
51572*> [TXT]</a>
51573*> \endhtmlonly
51574*
51575*  Definition:
51576*  ===========
51577*
51578*       SUBROUTINE ZUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
51579*
51580*       .. Scalar Arguments ..
51581*       INTEGER            INFO, K, LDA, LWORK, M, N
51582*       ..
51583*       .. Array Arguments ..
51584*       COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
51585*       ..
51586*
51587*
51588*> \par Purpose:
51589*  =============
51590*>
51591*> \verbatim
51592*>
51593*> ZUNGLQ generates an M-by-N complex matrix Q with orthonormal rows,
51594*> which is defined as the first M rows of a product of K elementary
51595*> reflectors of order N
51596*>
51597*>       Q  =  H(k)**H . . . H(2)**H H(1)**H
51598*>
51599*> as returned by ZGELQF.
51600*> \endverbatim
51601*
51602*  Arguments:
51603*  ==========
51604*
51605*> \param[in] M
51606*> \verbatim
51607*>          M is INTEGER
51608*>          The number of rows of the matrix Q. M >= 0.
51609*> \endverbatim
51610*>
51611*> \param[in] N
51612*> \verbatim
51613*>          N is INTEGER
51614*>          The number of columns of the matrix Q. N >= M.
51615*> \endverbatim
51616*>
51617*> \param[in] K
51618*> \verbatim
51619*>          K is INTEGER
51620*>          The number of elementary reflectors whose product defines the
51621*>          matrix Q. M >= K >= 0.
51622*> \endverbatim
51623*>
51624*> \param[in,out] A
51625*> \verbatim
51626*>          A is COMPLEX*16 array, dimension (LDA,N)
51627*>          On entry, the i-th row must contain the vector which defines
51628*>          the elementary reflector H(i), for i = 1,2,...,k, as returned
51629*>          by ZGELQF in the first k rows of its array argument A.
51630*>          On exit, the M-by-N matrix Q.
51631*> \endverbatim
51632*>
51633*> \param[in] LDA
51634*> \verbatim
51635*>          LDA is INTEGER
51636*>          The first dimension of the array A. LDA >= max(1,M).
51637*> \endverbatim
51638*>
51639*> \param[in] TAU
51640*> \verbatim
51641*>          TAU is COMPLEX*16 array, dimension (K)
51642*>          TAU(i) must contain the scalar factor of the elementary
51643*>          reflector H(i), as returned by ZGELQF.
51644*> \endverbatim
51645*>
51646*> \param[out] WORK
51647*> \verbatim
51648*>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
51649*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
51650*> \endverbatim
51651*>
51652*> \param[in] LWORK
51653*> \verbatim
51654*>          LWORK is INTEGER
51655*>          The dimension of the array WORK. LWORK >= max(1,M).
51656*>          For optimum performance LWORK >= M*NB, where NB is
51657*>          the optimal blocksize.
51658*>
51659*>          If LWORK = -1, then a workspace query is assumed; the routine
51660*>          only calculates the optimal size of the WORK array, returns
51661*>          this value as the first entry of the WORK array, and no error
51662*>          message related to LWORK is issued by XERBLA.
51663*> \endverbatim
51664*>
51665*> \param[out] INFO
51666*> \verbatim
51667*>          INFO is INTEGER
51668*>          = 0:  successful exit;
51669*>          < 0:  if INFO = -i, the i-th argument has an illegal value
51670*> \endverbatim
51671*
51672*  Authors:
51673*  ========
51674*
51675*> \author Univ. of Tennessee
51676*> \author Univ. of California Berkeley
51677*> \author Univ. of Colorado Denver
51678*> \author NAG Ltd.
51679*
51680*> \date December 2016
51681*
51682*> \ingroup complex16OTHERcomputational
51683*
51684*  =====================================================================
51685      SUBROUTINE ZUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
51686*
51687*  -- LAPACK computational routine (version 3.7.0) --
51688*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
51689*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
51690*     December 2016
51691*
51692*     .. Scalar Arguments ..
51693      INTEGER            INFO, K, LDA, LWORK, M, N
51694*     ..
51695*     .. Array Arguments ..
51696      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
51697*     ..
51698*
51699*  =====================================================================
51700*
51701*     .. Parameters ..
51702      COMPLEX*16         ZERO
51703      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ) )
51704*     ..
51705*     .. Local Scalars ..
51706      LOGICAL            LQUERY
51707      INTEGER            I, IB, IINFO, IWS, J, KI, KK, L, LDWORK,
51708     $                   LWKOPT, NB, NBMIN, NX
51709*     ..
51710*     .. External Subroutines ..
51711      EXTERNAL           XERBLA, ZLARFB, ZLARFT, ZUNGL2
51712*     ..
51713*     .. Intrinsic Functions ..
51714      INTRINSIC          MAX, MIN
51715*     ..
51716*     .. External Functions ..
51717      INTEGER            ILAENV
51718      EXTERNAL           ILAENV
51719*     ..
51720*     .. Executable Statements ..
51721*
51722*     Test the input arguments
51723*
51724      INFO = 0
51725      NB = ILAENV( 1, 'ZUNGLQ', ' ', M, N, K, -1 )
51726      LWKOPT = MAX( 1, M )*NB
51727      WORK( 1 ) = LWKOPT
51728      LQUERY = ( LWORK.EQ.-1 )
51729      IF( M.LT.0 ) THEN
51730         INFO = -1
51731      ELSE IF( N.LT.M ) THEN
51732         INFO = -2
51733      ELSE IF( K.LT.0 .OR. K.GT.M ) THEN
51734         INFO = -3
51735      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
51736         INFO = -5
51737      ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
51738         INFO = -8
51739      END IF
51740      IF( INFO.NE.0 ) THEN
51741         CALL XERBLA( 'ZUNGLQ', -INFO )
51742         RETURN
51743      ELSE IF( LQUERY ) THEN
51744         RETURN
51745      END IF
51746*
51747*     Quick return if possible
51748*
51749      IF( M.LE.0 ) THEN
51750         WORK( 1 ) = 1
51751         RETURN
51752      END IF
51753*
51754      NBMIN = 2
51755      NX = 0
51756      IWS = M
51757      IF( NB.GT.1 .AND. NB.LT.K ) THEN
51758*
51759*        Determine when to cross over from blocked to unblocked code.
51760*
51761         NX = MAX( 0, ILAENV( 3, 'ZUNGLQ', ' ', M, N, K, -1 ) )
51762         IF( NX.LT.K ) THEN
51763*
51764*           Determine if workspace is large enough for blocked code.
51765*
51766            LDWORK = M
51767            IWS = LDWORK*NB
51768            IF( LWORK.LT.IWS ) THEN
51769*
51770*              Not enough workspace to use optimal NB:  reduce NB and
51771*              determine the minimum value of NB.
51772*
51773               NB = LWORK / LDWORK
51774               NBMIN = MAX( 2, ILAENV( 2, 'ZUNGLQ', ' ', M, N, K, -1 ) )
51775            END IF
51776         END IF
51777      END IF
51778*
51779      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
51780*
51781*        Use blocked code after the last block.
51782*        The first kk rows are handled by the block method.
51783*
51784         KI = ( ( K-NX-1 ) / NB )*NB
51785         KK = MIN( K, KI+NB )
51786*
51787*        Set A(kk+1:m,1:kk) to zero.
51788*
51789         DO 20 J = 1, KK
51790            DO 10 I = KK + 1, M
51791               A( I, J ) = ZERO
51792   10       CONTINUE
51793   20    CONTINUE
51794      ELSE
51795         KK = 0
51796      END IF
51797*
51798*     Use unblocked code for the last or only block.
51799*
51800      IF( KK.LT.M )
51801     $   CALL ZUNGL2( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA,
51802     $                TAU( KK+1 ), WORK, IINFO )
51803*
51804      IF( KK.GT.0 ) THEN
51805*
51806*        Use blocked code
51807*
51808         DO 50 I = KI + 1, 1, -NB
51809            IB = MIN( NB, K-I+1 )
51810            IF( I+IB.LE.M ) THEN
51811*
51812*              Form the triangular factor of the block reflector
51813*              H = H(i) H(i+1) . . . H(i+ib-1)
51814*
51815               CALL ZLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ),
51816     $                      LDA, TAU( I ), WORK, LDWORK )
51817*
51818*              Apply H**H to A(i+ib:m,i:n) from the right
51819*
51820               CALL ZLARFB( 'Right', 'Conjugate transpose', 'Forward',
51821     $                      'Rowwise', M-I-IB+1, N-I+1, IB, A( I, I ),
51822     $                      LDA, WORK, LDWORK, A( I+IB, I ), LDA,
51823     $                      WORK( IB+1 ), LDWORK )
51824            END IF
51825*
51826*           Apply H**H to columns i:n of current block
51827*
51828            CALL ZUNGL2( IB, N-I+1, IB, A( I, I ), LDA, TAU( I ), WORK,
51829     $                   IINFO )
51830*
51831*           Set columns 1:i-1 of current block to zero
51832*
51833            DO 40 J = 1, I - 1
51834               DO 30 L = I, I + IB - 1
51835                  A( L, J ) = ZERO
51836   30          CONTINUE
51837   40       CONTINUE
51838   50    CONTINUE
51839      END IF
51840*
51841      WORK( 1 ) = IWS
51842      RETURN
51843*
51844*     End of ZUNGLQ
51845*
51846      END
51847*> \brief \b ZUNGQL
51848*
51849*  =========== DOCUMENTATION ===========
51850*
51851* Online html documentation available at
51852*            http://www.netlib.org/lapack/explore-html/
51853*
51854*> \htmlonly
51855*> Download ZUNGQL + dependencies
51856*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zungql.f">
51857*> [TGZ]</a>
51858*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zungql.f">
51859*> [ZIP]</a>
51860*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zungql.f">
51861*> [TXT]</a>
51862*> \endhtmlonly
51863*
51864*  Definition:
51865*  ===========
51866*
51867*       SUBROUTINE ZUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
51868*
51869*       .. Scalar Arguments ..
51870*       INTEGER            INFO, K, LDA, LWORK, M, N
51871*       ..
51872*       .. Array Arguments ..
51873*       COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
51874*       ..
51875*
51876*
51877*> \par Purpose:
51878*  =============
51879*>
51880*> \verbatim
51881*>
51882*> ZUNGQL generates an M-by-N complex matrix Q with orthonormal columns,
51883*> which is defined as the last N columns of a product of K elementary
51884*> reflectors of order M
51885*>
51886*>       Q  =  H(k) . . . H(2) H(1)
51887*>
51888*> as returned by ZGEQLF.
51889*> \endverbatim
51890*
51891*  Arguments:
51892*  ==========
51893*
51894*> \param[in] M
51895*> \verbatim
51896*>          M is INTEGER
51897*>          The number of rows of the matrix Q. M >= 0.
51898*> \endverbatim
51899*>
51900*> \param[in] N
51901*> \verbatim
51902*>          N is INTEGER
51903*>          The number of columns of the matrix Q. M >= N >= 0.
51904*> \endverbatim
51905*>
51906*> \param[in] K
51907*> \verbatim
51908*>          K is INTEGER
51909*>          The number of elementary reflectors whose product defines the
51910*>          matrix Q. N >= K >= 0.
51911*> \endverbatim
51912*>
51913*> \param[in,out] A
51914*> \verbatim
51915*>          A is COMPLEX*16 array, dimension (LDA,N)
51916*>          On entry, the (n-k+i)-th column must contain the vector which
51917*>          defines the elementary reflector H(i), for i = 1,2,...,k, as
51918*>          returned by ZGEQLF in the last k columns of its array
51919*>          argument A.
51920*>          On exit, the M-by-N matrix Q.
51921*> \endverbatim
51922*>
51923*> \param[in] LDA
51924*> \verbatim
51925*>          LDA is INTEGER
51926*>          The first dimension of the array A. LDA >= max(1,M).
51927*> \endverbatim
51928*>
51929*> \param[in] TAU
51930*> \verbatim
51931*>          TAU is COMPLEX*16 array, dimension (K)
51932*>          TAU(i) must contain the scalar factor of the elementary
51933*>          reflector H(i), as returned by ZGEQLF.
51934*> \endverbatim
51935*>
51936*> \param[out] WORK
51937*> \verbatim
51938*>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
51939*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
51940*> \endverbatim
51941*>
51942*> \param[in] LWORK
51943*> \verbatim
51944*>          LWORK is INTEGER
51945*>          The dimension of the array WORK. LWORK >= max(1,N).
51946*>          For optimum performance LWORK >= N*NB, where NB is the
51947*>          optimal blocksize.
51948*>
51949*>          If LWORK = -1, then a workspace query is assumed; the routine
51950*>          only calculates the optimal size of the WORK array, returns
51951*>          this value as the first entry of the WORK array, and no error
51952*>          message related to LWORK is issued by XERBLA.
51953*> \endverbatim
51954*>
51955*> \param[out] INFO
51956*> \verbatim
51957*>          INFO is INTEGER
51958*>          = 0:  successful exit
51959*>          < 0:  if INFO = -i, the i-th argument has an illegal value
51960*> \endverbatim
51961*
51962*  Authors:
51963*  ========
51964*
51965*> \author Univ. of Tennessee
51966*> \author Univ. of California Berkeley
51967*> \author Univ. of Colorado Denver
51968*> \author NAG Ltd.
51969*
51970*> \date December 2016
51971*
51972*> \ingroup complex16OTHERcomputational
51973*
51974*  =====================================================================
51975      SUBROUTINE ZUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
51976*
51977*  -- LAPACK computational routine (version 3.7.0) --
51978*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
51979*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
51980*     December 2016
51981*
51982*     .. Scalar Arguments ..
51983      INTEGER            INFO, K, LDA, LWORK, M, N
51984*     ..
51985*     .. Array Arguments ..
51986      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
51987*     ..
51988*
51989*  =====================================================================
51990*
51991*     .. Parameters ..
51992      COMPLEX*16         ZERO
51993      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ) )
51994*     ..
51995*     .. Local Scalars ..
51996      LOGICAL            LQUERY
51997      INTEGER            I, IB, IINFO, IWS, J, KK, L, LDWORK, LWKOPT,
51998     $                   NB, NBMIN, NX
51999*     ..
52000*     .. External Subroutines ..
52001      EXTERNAL           XERBLA, ZLARFB, ZLARFT, ZUNG2L
52002*     ..
52003*     .. Intrinsic Functions ..
52004      INTRINSIC          MAX, MIN
52005*     ..
52006*     .. External Functions ..
52007      INTEGER            ILAENV
52008      EXTERNAL           ILAENV
52009*     ..
52010*     .. Executable Statements ..
52011*
52012*     Test the input arguments
52013*
52014      INFO = 0
52015      LQUERY = ( LWORK.EQ.-1 )
52016      IF( M.LT.0 ) THEN
52017         INFO = -1
52018      ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
52019         INFO = -2
52020      ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
52021         INFO = -3
52022      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
52023         INFO = -5
52024      END IF
52025*
52026      IF( INFO.EQ.0 ) THEN
52027         IF( N.EQ.0 ) THEN
52028            LWKOPT = 1
52029         ELSE
52030            NB = ILAENV( 1, 'ZUNGQL', ' ', M, N, K, -1 )
52031            LWKOPT = N*NB
52032         END IF
52033         WORK( 1 ) = LWKOPT
52034*
52035         IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
52036            INFO = -8
52037         END IF
52038      END IF
52039*
52040      IF( INFO.NE.0 ) THEN
52041         CALL XERBLA( 'ZUNGQL', -INFO )
52042         RETURN
52043      ELSE IF( LQUERY ) THEN
52044         RETURN
52045      END IF
52046*
52047*     Quick return if possible
52048*
52049      IF( N.LE.0 ) THEN
52050         RETURN
52051      END IF
52052*
52053      NBMIN = 2
52054      NX = 0
52055      IWS = N
52056      IF( NB.GT.1 .AND. NB.LT.K ) THEN
52057*
52058*        Determine when to cross over from blocked to unblocked code.
52059*
52060         NX = MAX( 0, ILAENV( 3, 'ZUNGQL', ' ', M, N, K, -1 ) )
52061         IF( NX.LT.K ) THEN
52062*
52063*           Determine if workspace is large enough for blocked code.
52064*
52065            LDWORK = N
52066            IWS = LDWORK*NB
52067            IF( LWORK.LT.IWS ) THEN
52068*
52069*              Not enough workspace to use optimal NB:  reduce NB and
52070*              determine the minimum value of NB.
52071*
52072               NB = LWORK / LDWORK
52073               NBMIN = MAX( 2, ILAENV( 2, 'ZUNGQL', ' ', M, N, K, -1 ) )
52074            END IF
52075         END IF
52076      END IF
52077*
52078      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
52079*
52080*        Use blocked code after the first block.
52081*        The last kk columns are handled by the block method.
52082*
52083         KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB )
52084*
52085*        Set A(m-kk+1:m,1:n-kk) to zero.
52086*
52087         DO 20 J = 1, N - KK
52088            DO 10 I = M - KK + 1, M
52089               A( I, J ) = ZERO
52090   10       CONTINUE
52091   20    CONTINUE
52092      ELSE
52093         KK = 0
52094      END IF
52095*
52096*     Use unblocked code for the first or only block.
52097*
52098      CALL ZUNG2L( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO )
52099*
52100      IF( KK.GT.0 ) THEN
52101*
52102*        Use blocked code
52103*
52104         DO 50 I = K - KK + 1, K, NB
52105            IB = MIN( NB, K-I+1 )
52106            IF( N-K+I.GT.1 ) THEN
52107*
52108*              Form the triangular factor of the block reflector
52109*              H = H(i+ib-1) . . . H(i+1) H(i)
52110*
52111               CALL ZLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB,
52112     $                      A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK )
52113*
52114*              Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left
52115*
52116               CALL ZLARFB( 'Left', 'No transpose', 'Backward',
52117     $                      'Columnwise', M-K+I+IB-1, N-K+I-1, IB,
52118     $                      A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA,
52119     $                      WORK( IB+1 ), LDWORK )
52120            END IF
52121*
52122*           Apply H to rows 1:m-k+i+ib-1 of current block
52123*
52124            CALL ZUNG2L( M-K+I+IB-1, IB, IB, A( 1, N-K+I ), LDA,
52125     $                   TAU( I ), WORK, IINFO )
52126*
52127*           Set rows m-k+i+ib:m of current block to zero
52128*
52129            DO 40 J = N - K + I, N - K + I + IB - 1
52130               DO 30 L = M - K + I + IB, M
52131                  A( L, J ) = ZERO
52132   30          CONTINUE
52133   40       CONTINUE
52134   50    CONTINUE
52135      END IF
52136*
52137      WORK( 1 ) = IWS
52138      RETURN
52139*
52140*     End of ZUNGQL
52141*
52142      END
52143*> \brief \b ZUNGQR
52144*
52145*  =========== DOCUMENTATION ===========
52146*
52147* Online html documentation available at
52148*            http://www.netlib.org/lapack/explore-html/
52149*
52150*> \htmlonly
52151*> Download ZUNGQR + dependencies
52152*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zungqr.f">
52153*> [TGZ]</a>
52154*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zungqr.f">
52155*> [ZIP]</a>
52156*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zungqr.f">
52157*> [TXT]</a>
52158*> \endhtmlonly
52159*
52160*  Definition:
52161*  ===========
52162*
52163*       SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
52164*
52165*       .. Scalar Arguments ..
52166*       INTEGER            INFO, K, LDA, LWORK, M, N
52167*       ..
52168*       .. Array Arguments ..
52169*       COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
52170*       ..
52171*
52172*
52173*> \par Purpose:
52174*  =============
52175*>
52176*> \verbatim
52177*>
52178*> ZUNGQR generates an M-by-N complex matrix Q with orthonormal columns,
52179*> which is defined as the first N columns of a product of K elementary
52180*> reflectors of order M
52181*>
52182*>       Q  =  H(1) H(2) . . . H(k)
52183*>
52184*> as returned by ZGEQRF.
52185*> \endverbatim
52186*
52187*  Arguments:
52188*  ==========
52189*
52190*> \param[in] M
52191*> \verbatim
52192*>          M is INTEGER
52193*>          The number of rows of the matrix Q. M >= 0.
52194*> \endverbatim
52195*>
52196*> \param[in] N
52197*> \verbatim
52198*>          N is INTEGER
52199*>          The number of columns of the matrix Q. M >= N >= 0.
52200*> \endverbatim
52201*>
52202*> \param[in] K
52203*> \verbatim
52204*>          K is INTEGER
52205*>          The number of elementary reflectors whose product defines the
52206*>          matrix Q. N >= K >= 0.
52207*> \endverbatim
52208*>
52209*> \param[in,out] A
52210*> \verbatim
52211*>          A is COMPLEX*16 array, dimension (LDA,N)
52212*>          On entry, the i-th column must contain the vector which
52213*>          defines the elementary reflector H(i), for i = 1,2,...,k, as
52214*>          returned by ZGEQRF in the first k columns of its array
52215*>          argument A.
52216*>          On exit, the M-by-N matrix Q.
52217*> \endverbatim
52218*>
52219*> \param[in] LDA
52220*> \verbatim
52221*>          LDA is INTEGER
52222*>          The first dimension of the array A. LDA >= max(1,M).
52223*> \endverbatim
52224*>
52225*> \param[in] TAU
52226*> \verbatim
52227*>          TAU is COMPLEX*16 array, dimension (K)
52228*>          TAU(i) must contain the scalar factor of the elementary
52229*>          reflector H(i), as returned by ZGEQRF.
52230*> \endverbatim
52231*>
52232*> \param[out] WORK
52233*> \verbatim
52234*>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
52235*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
52236*> \endverbatim
52237*>
52238*> \param[in] LWORK
52239*> \verbatim
52240*>          LWORK is INTEGER
52241*>          The dimension of the array WORK. LWORK >= max(1,N).
52242*>          For optimum performance LWORK >= N*NB, where NB is the
52243*>          optimal blocksize.
52244*>
52245*>          If LWORK = -1, then a workspace query is assumed; the routine
52246*>          only calculates the optimal size of the WORK array, returns
52247*>          this value as the first entry of the WORK array, and no error
52248*>          message related to LWORK is issued by XERBLA.
52249*> \endverbatim
52250*>
52251*> \param[out] INFO
52252*> \verbatim
52253*>          INFO is INTEGER
52254*>          = 0:  successful exit
52255*>          < 0:  if INFO = -i, the i-th argument has an illegal value
52256*> \endverbatim
52257*
52258*  Authors:
52259*  ========
52260*
52261*> \author Univ. of Tennessee
52262*> \author Univ. of California Berkeley
52263*> \author Univ. of Colorado Denver
52264*> \author NAG Ltd.
52265*
52266*> \date December 2016
52267*
52268*> \ingroup complex16OTHERcomputational
52269*
52270*  =====================================================================
52271      SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
52272*
52273*  -- LAPACK computational routine (version 3.7.0) --
52274*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
52275*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
52276*     December 2016
52277*
52278*     .. Scalar Arguments ..
52279      INTEGER            INFO, K, LDA, LWORK, M, N
52280*     ..
52281*     .. Array Arguments ..
52282      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
52283*     ..
52284*
52285*  =====================================================================
52286*
52287*     .. Parameters ..
52288      COMPLEX*16         ZERO
52289      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ) )
52290*     ..
52291*     .. Local Scalars ..
52292      LOGICAL            LQUERY
52293      INTEGER            I, IB, IINFO, IWS, J, KI, KK, L, LDWORK,
52294     $                   LWKOPT, NB, NBMIN, NX
52295*     ..
52296*     .. External Subroutines ..
52297      EXTERNAL           XERBLA, ZLARFB, ZLARFT, ZUNG2R
52298*     ..
52299*     .. Intrinsic Functions ..
52300      INTRINSIC          MAX, MIN
52301*     ..
52302*     .. External Functions ..
52303      INTEGER            ILAENV
52304      EXTERNAL           ILAENV
52305*     ..
52306*     .. Executable Statements ..
52307*
52308*     Test the input arguments
52309*
52310      INFO = 0
52311      NB = ILAENV( 1, 'ZUNGQR', ' ', M, N, K, -1 )
52312      LWKOPT = MAX( 1, N )*NB
52313      WORK( 1 ) = LWKOPT
52314      LQUERY = ( LWORK.EQ.-1 )
52315      IF( M.LT.0 ) THEN
52316         INFO = -1
52317      ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
52318         INFO = -2
52319      ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
52320         INFO = -3
52321      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
52322         INFO = -5
52323      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
52324         INFO = -8
52325      END IF
52326      IF( INFO.NE.0 ) THEN
52327         CALL XERBLA( 'ZUNGQR', -INFO )
52328         RETURN
52329      ELSE IF( LQUERY ) THEN
52330         RETURN
52331      END IF
52332*
52333*     Quick return if possible
52334*
52335      IF( N.LE.0 ) THEN
52336         WORK( 1 ) = 1
52337         RETURN
52338      END IF
52339*
52340      NBMIN = 2
52341      NX = 0
52342      IWS = N
52343      IF( NB.GT.1 .AND. NB.LT.K ) THEN
52344*
52345*        Determine when to cross over from blocked to unblocked code.
52346*
52347         NX = MAX( 0, ILAENV( 3, 'ZUNGQR', ' ', M, N, K, -1 ) )
52348         IF( NX.LT.K ) THEN
52349*
52350*           Determine if workspace is large enough for blocked code.
52351*
52352            LDWORK = N
52353            IWS = LDWORK*NB
52354            IF( LWORK.LT.IWS ) THEN
52355*
52356*              Not enough workspace to use optimal NB:  reduce NB and
52357*              determine the minimum value of NB.
52358*
52359               NB = LWORK / LDWORK
52360               NBMIN = MAX( 2, ILAENV( 2, 'ZUNGQR', ' ', M, N, K, -1 ) )
52361            END IF
52362         END IF
52363      END IF
52364*
52365      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
52366*
52367*        Use blocked code after the last block.
52368*        The first kk columns are handled by the block method.
52369*
52370         KI = ( ( K-NX-1 ) / NB )*NB
52371         KK = MIN( K, KI+NB )
52372*
52373*        Set A(1:kk,kk+1:n) to zero.
52374*
52375         DO 20 J = KK + 1, N
52376            DO 10 I = 1, KK
52377               A( I, J ) = ZERO
52378   10       CONTINUE
52379   20    CONTINUE
52380      ELSE
52381         KK = 0
52382      END IF
52383*
52384*     Use unblocked code for the last or only block.
52385*
52386      IF( KK.LT.N )
52387     $   CALL ZUNG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA,
52388     $                TAU( KK+1 ), WORK, IINFO )
52389*
52390      IF( KK.GT.0 ) THEN
52391*
52392*        Use blocked code
52393*
52394         DO 50 I = KI + 1, 1, -NB
52395            IB = MIN( NB, K-I+1 )
52396            IF( I+IB.LE.N ) THEN
52397*
52398*              Form the triangular factor of the block reflector
52399*              H = H(i) H(i+1) . . . H(i+ib-1)
52400*
52401               CALL ZLARFT( 'Forward', 'Columnwise', M-I+1, IB,
52402     $                      A( I, I ), LDA, TAU( I ), WORK, LDWORK )
52403*
52404*              Apply H to A(i:m,i+ib:n) from the left
52405*
52406               CALL ZLARFB( 'Left', 'No transpose', 'Forward',
52407     $                      'Columnwise', M-I+1, N-I-IB+1, IB,
52408     $                      A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ),
52409     $                      LDA, WORK( IB+1 ), LDWORK )
52410            END IF
52411*
52412*           Apply H to rows i:m of current block
52413*
52414            CALL ZUNG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK,
52415     $                   IINFO )
52416*
52417*           Set rows 1:i-1 of current block to zero
52418*
52419            DO 40 J = I, I + IB - 1
52420               DO 30 L = 1, I - 1
52421                  A( L, J ) = ZERO
52422   30          CONTINUE
52423   40       CONTINUE
52424   50    CONTINUE
52425      END IF
52426*
52427      WORK( 1 ) = IWS
52428      RETURN
52429*
52430*     End of ZUNGQR
52431*
52432      END
52433*> \brief \b ZUNGR2 generates all or part of the unitary matrix Q from an RQ factorization determined by cgerqf (unblocked algorithm).
52434*
52435*  =========== DOCUMENTATION ===========
52436*
52437* Online html documentation available at
52438*            http://www.netlib.org/lapack/explore-html/
52439*
52440*> \htmlonly
52441*> Download ZUNGR2 + dependencies
52442*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zungr2.f">
52443*> [TGZ]</a>
52444*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zungr2.f">
52445*> [ZIP]</a>
52446*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zungr2.f">
52447*> [TXT]</a>
52448*> \endhtmlonly
52449*
52450*  Definition:
52451*  ===========
52452*
52453*       SUBROUTINE ZUNGR2( M, N, K, A, LDA, TAU, WORK, INFO )
52454*
52455*       .. Scalar Arguments ..
52456*       INTEGER            INFO, K, LDA, M, N
52457*       ..
52458*       .. Array Arguments ..
52459*       COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
52460*       ..
52461*
52462*
52463*> \par Purpose:
52464*  =============
52465*>
52466*> \verbatim
52467*>
52468*> ZUNGR2 generates an m by n complex matrix Q with orthonormal rows,
52469*> which is defined as the last m rows of a product of k elementary
52470*> reflectors of order n
52471*>
52472*>       Q  =  H(1)**H H(2)**H . . . H(k)**H
52473*>
52474*> as returned by ZGERQF.
52475*> \endverbatim
52476*
52477*  Arguments:
52478*  ==========
52479*
52480*> \param[in] M
52481*> \verbatim
52482*>          M is INTEGER
52483*>          The number of rows of the matrix Q. M >= 0.
52484*> \endverbatim
52485*>
52486*> \param[in] N
52487*> \verbatim
52488*>          N is INTEGER
52489*>          The number of columns of the matrix Q. N >= M.
52490*> \endverbatim
52491*>
52492*> \param[in] K
52493*> \verbatim
52494*>          K is INTEGER
52495*>          The number of elementary reflectors whose product defines the
52496*>          matrix Q. M >= K >= 0.
52497*> \endverbatim
52498*>
52499*> \param[in,out] A
52500*> \verbatim
52501*>          A is COMPLEX*16 array, dimension (LDA,N)
52502*>          On entry, the (m-k+i)-th row must contain the vector which
52503*>          defines the elementary reflector H(i), for i = 1,2,...,k, as
52504*>          returned by ZGERQF in the last k rows of its array argument
52505*>          A.
52506*>          On exit, the m-by-n matrix Q.
52507*> \endverbatim
52508*>
52509*> \param[in] LDA
52510*> \verbatim
52511*>          LDA is INTEGER
52512*>          The first dimension of the array A. LDA >= max(1,M).
52513*> \endverbatim
52514*>
52515*> \param[in] TAU
52516*> \verbatim
52517*>          TAU is COMPLEX*16 array, dimension (K)
52518*>          TAU(i) must contain the scalar factor of the elementary
52519*>          reflector H(i), as returned by ZGERQF.
52520*> \endverbatim
52521*>
52522*> \param[out] WORK
52523*> \verbatim
52524*>          WORK is COMPLEX*16 array, dimension (M)
52525*> \endverbatim
52526*>
52527*> \param[out] INFO
52528*> \verbatim
52529*>          INFO is INTEGER
52530*>          = 0: successful exit
52531*>          < 0: if INFO = -i, the i-th argument has an illegal value
52532*> \endverbatim
52533*
52534*  Authors:
52535*  ========
52536*
52537*> \author Univ. of Tennessee
52538*> \author Univ. of California Berkeley
52539*> \author Univ. of Colorado Denver
52540*> \author NAG Ltd.
52541*
52542*> \date December 2016
52543*
52544*> \ingroup complex16OTHERcomputational
52545*
52546*  =====================================================================
52547      SUBROUTINE ZUNGR2( M, N, K, A, LDA, TAU, WORK, INFO )
52548*
52549*  -- LAPACK computational routine (version 3.7.0) --
52550*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
52551*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
52552*     December 2016
52553*
52554*     .. Scalar Arguments ..
52555      INTEGER            INFO, K, LDA, M, N
52556*     ..
52557*     .. Array Arguments ..
52558      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
52559*     ..
52560*
52561*  =====================================================================
52562*
52563*     .. Parameters ..
52564      COMPLEX*16         ONE, ZERO
52565      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),
52566     $                   ZERO = ( 0.0D+0, 0.0D+0 ) )
52567*     ..
52568*     .. Local Scalars ..
52569      INTEGER            I, II, J, L
52570*     ..
52571*     .. External Subroutines ..
52572      EXTERNAL           XERBLA, ZLACGV, ZLARF, ZSCAL
52573*     ..
52574*     .. Intrinsic Functions ..
52575      INTRINSIC          DCONJG, MAX
52576*     ..
52577*     .. Executable Statements ..
52578*
52579*     Test the input arguments
52580*
52581      INFO = 0
52582      IF( M.LT.0 ) THEN
52583         INFO = -1
52584      ELSE IF( N.LT.M ) THEN
52585         INFO = -2
52586      ELSE IF( K.LT.0 .OR. K.GT.M ) THEN
52587         INFO = -3
52588      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
52589         INFO = -5
52590      END IF
52591      IF( INFO.NE.0 ) THEN
52592         CALL XERBLA( 'ZUNGR2', -INFO )
52593         RETURN
52594      END IF
52595*
52596*     Quick return if possible
52597*
52598      IF( M.LE.0 )
52599     $   RETURN
52600*
52601      IF( K.LT.M ) THEN
52602*
52603*        Initialise rows 1:m-k to rows of the unit matrix
52604*
52605         DO 20 J = 1, N
52606            DO 10 L = 1, M - K
52607               A( L, J ) = ZERO
52608   10       CONTINUE
52609            IF( J.GT.N-M .AND. J.LE.N-K )
52610     $         A( M-N+J, J ) = ONE
52611   20    CONTINUE
52612      END IF
52613*
52614      DO 40 I = 1, K
52615         II = M - K + I
52616*
52617*        Apply H(i)**H to A(1:m-k+i,1:n-k+i) from the right
52618*
52619         CALL ZLACGV( N-M+II-1, A( II, 1 ), LDA )
52620         A( II, N-M+II ) = ONE
52621         CALL ZLARF( 'Right', II-1, N-M+II, A( II, 1 ), LDA,
52622     $               DCONJG( TAU( I ) ), A, LDA, WORK )
52623         CALL ZSCAL( N-M+II-1, -TAU( I ), A( II, 1 ), LDA )
52624         CALL ZLACGV( N-M+II-1, A( II, 1 ), LDA )
52625         A( II, N-M+II ) = ONE - DCONJG( TAU( I ) )
52626*
52627*        Set A(m-k+i,n-k+i+1:n) to zero
52628*
52629         DO 30 L = N - M + II + 1, N
52630            A( II, L ) = ZERO
52631   30    CONTINUE
52632   40 CONTINUE
52633      RETURN
52634*
52635*     End of ZUNGR2
52636*
52637      END
52638*> \brief \b ZUNGRQ
52639*
52640*  =========== DOCUMENTATION ===========
52641*
52642* Online html documentation available at
52643*            http://www.netlib.org/lapack/explore-html/
52644*
52645*> \htmlonly
52646*> Download ZUNGRQ + dependencies
52647*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zungrq.f">
52648*> [TGZ]</a>
52649*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zungrq.f">
52650*> [ZIP]</a>
52651*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zungrq.f">
52652*> [TXT]</a>
52653*> \endhtmlonly
52654*
52655*  Definition:
52656*  ===========
52657*
52658*       SUBROUTINE ZUNGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
52659*
52660*       .. Scalar Arguments ..
52661*       INTEGER            INFO, K, LDA, LWORK, M, N
52662*       ..
52663*       .. Array Arguments ..
52664*       COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
52665*       ..
52666*
52667*
52668*> \par Purpose:
52669*  =============
52670*>
52671*> \verbatim
52672*>
52673*> ZUNGRQ generates an M-by-N complex matrix Q with orthonormal rows,
52674*> which is defined as the last M rows of a product of K elementary
52675*> reflectors of order N
52676*>
52677*>       Q  =  H(1)**H H(2)**H . . . H(k)**H
52678*>
52679*> as returned by ZGERQF.
52680*> \endverbatim
52681*
52682*  Arguments:
52683*  ==========
52684*
52685*> \param[in] M
52686*> \verbatim
52687*>          M is INTEGER
52688*>          The number of rows of the matrix Q. M >= 0.
52689*> \endverbatim
52690*>
52691*> \param[in] N
52692*> \verbatim
52693*>          N is INTEGER
52694*>          The number of columns of the matrix Q. N >= M.
52695*> \endverbatim
52696*>
52697*> \param[in] K
52698*> \verbatim
52699*>          K is INTEGER
52700*>          The number of elementary reflectors whose product defines the
52701*>          matrix Q. M >= K >= 0.
52702*> \endverbatim
52703*>
52704*> \param[in,out] A
52705*> \verbatim
52706*>          A is COMPLEX*16 array, dimension (LDA,N)
52707*>          On entry, the (m-k+i)-th row must contain the vector which
52708*>          defines the elementary reflector H(i), for i = 1,2,...,k, as
52709*>          returned by ZGERQF in the last k rows of its array argument
52710*>          A.
52711*>          On exit, the M-by-N matrix Q.
52712*> \endverbatim
52713*>
52714*> \param[in] LDA
52715*> \verbatim
52716*>          LDA is INTEGER
52717*>          The first dimension of the array A. LDA >= max(1,M).
52718*> \endverbatim
52719*>
52720*> \param[in] TAU
52721*> \verbatim
52722*>          TAU is COMPLEX*16 array, dimension (K)
52723*>          TAU(i) must contain the scalar factor of the elementary
52724*>          reflector H(i), as returned by ZGERQF.
52725*> \endverbatim
52726*>
52727*> \param[out] WORK
52728*> \verbatim
52729*>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
52730*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
52731*> \endverbatim
52732*>
52733*> \param[in] LWORK
52734*> \verbatim
52735*>          LWORK is INTEGER
52736*>          The dimension of the array WORK. LWORK >= max(1,M).
52737*>          For optimum performance LWORK >= M*NB, where NB is the
52738*>          optimal blocksize.
52739*>
52740*>          If LWORK = -1, then a workspace query is assumed; the routine
52741*>          only calculates the optimal size of the WORK array, returns
52742*>          this value as the first entry of the WORK array, and no error
52743*>          message related to LWORK is issued by XERBLA.
52744*> \endverbatim
52745*>
52746*> \param[out] INFO
52747*> \verbatim
52748*>          INFO is INTEGER
52749*>          = 0:  successful exit
52750*>          < 0:  if INFO = -i, the i-th argument has an illegal value
52751*> \endverbatim
52752*
52753*  Authors:
52754*  ========
52755*
52756*> \author Univ. of Tennessee
52757*> \author Univ. of California Berkeley
52758*> \author Univ. of Colorado Denver
52759*> \author NAG Ltd.
52760*
52761*> \date December 2016
52762*
52763*> \ingroup complex16OTHERcomputational
52764*
52765*  =====================================================================
52766      SUBROUTINE ZUNGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
52767*
52768*  -- LAPACK computational routine (version 3.7.0) --
52769*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
52770*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
52771*     December 2016
52772*
52773*     .. Scalar Arguments ..
52774      INTEGER            INFO, K, LDA, LWORK, M, N
52775*     ..
52776*     .. Array Arguments ..
52777      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
52778*     ..
52779*
52780*  =====================================================================
52781*
52782*     .. Parameters ..
52783      COMPLEX*16         ZERO
52784      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ) )
52785*     ..
52786*     .. Local Scalars ..
52787      LOGICAL            LQUERY
52788      INTEGER            I, IB, II, IINFO, IWS, J, KK, L, LDWORK,
52789     $                   LWKOPT, NB, NBMIN, NX
52790*     ..
52791*     .. External Subroutines ..
52792      EXTERNAL           XERBLA, ZLARFB, ZLARFT, ZUNGR2
52793*     ..
52794*     .. Intrinsic Functions ..
52795      INTRINSIC          MAX, MIN
52796*     ..
52797*     .. External Functions ..
52798      INTEGER            ILAENV
52799      EXTERNAL           ILAENV
52800*     ..
52801*     .. Executable Statements ..
52802*
52803*     Test the input arguments
52804*
52805      INFO = 0
52806      LQUERY = ( LWORK.EQ.-1 )
52807      IF( M.LT.0 ) THEN
52808         INFO = -1
52809      ELSE IF( N.LT.M ) THEN
52810         INFO = -2
52811      ELSE IF( K.LT.0 .OR. K.GT.M ) THEN
52812         INFO = -3
52813      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
52814         INFO = -5
52815      END IF
52816*
52817      IF( INFO.EQ.0 ) THEN
52818         IF( M.LE.0 ) THEN
52819            LWKOPT = 1
52820         ELSE
52821            NB = ILAENV( 1, 'ZUNGRQ', ' ', M, N, K, -1 )
52822            LWKOPT = M*NB
52823         END IF
52824         WORK( 1 ) = LWKOPT
52825*
52826         IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
52827            INFO = -8
52828         END IF
52829      END IF
52830*
52831      IF( INFO.NE.0 ) THEN
52832         CALL XERBLA( 'ZUNGRQ', -INFO )
52833         RETURN
52834      ELSE IF( LQUERY ) THEN
52835         RETURN
52836      END IF
52837*
52838*     Quick return if possible
52839*
52840      IF( M.LE.0 ) THEN
52841         RETURN
52842      END IF
52843*
52844      NBMIN = 2
52845      NX = 0
52846      IWS = M
52847      IF( NB.GT.1 .AND. NB.LT.K ) THEN
52848*
52849*        Determine when to cross over from blocked to unblocked code.
52850*
52851         NX = MAX( 0, ILAENV( 3, 'ZUNGRQ', ' ', M, N, K, -1 ) )
52852         IF( NX.LT.K ) THEN
52853*
52854*           Determine if workspace is large enough for blocked code.
52855*
52856            LDWORK = M
52857            IWS = LDWORK*NB
52858            IF( LWORK.LT.IWS ) THEN
52859*
52860*              Not enough workspace to use optimal NB:  reduce NB and
52861*              determine the minimum value of NB.
52862*
52863               NB = LWORK / LDWORK
52864               NBMIN = MAX( 2, ILAENV( 2, 'ZUNGRQ', ' ', M, N, K, -1 ) )
52865            END IF
52866         END IF
52867      END IF
52868*
52869      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
52870*
52871*        Use blocked code after the first block.
52872*        The last kk rows are handled by the block method.
52873*
52874         KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB )
52875*
52876*        Set A(1:m-kk,n-kk+1:n) to zero.
52877*
52878         DO 20 J = N - KK + 1, N
52879            DO 10 I = 1, M - KK
52880               A( I, J ) = ZERO
52881   10       CONTINUE
52882   20    CONTINUE
52883      ELSE
52884         KK = 0
52885      END IF
52886*
52887*     Use unblocked code for the first or only block.
52888*
52889      CALL ZUNGR2( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO )
52890*
52891      IF( KK.GT.0 ) THEN
52892*
52893*        Use blocked code
52894*
52895         DO 50 I = K - KK + 1, K, NB
52896            IB = MIN( NB, K-I+1 )
52897            II = M - K + I
52898            IF( II.GT.1 ) THEN
52899*
52900*              Form the triangular factor of the block reflector
52901*              H = H(i+ib-1) . . . H(i+1) H(i)
52902*
52903               CALL ZLARFT( 'Backward', 'Rowwise', N-K+I+IB-1, IB,
52904     $                      A( II, 1 ), LDA, TAU( I ), WORK, LDWORK )
52905*
52906*              Apply H**H to A(1:m-k+i-1,1:n-k+i+ib-1) from the right
52907*
52908               CALL ZLARFB( 'Right', 'Conjugate transpose', 'Backward',
52909     $                      'Rowwise', II-1, N-K+I+IB-1, IB, A( II, 1 ),
52910     $                      LDA, WORK, LDWORK, A, LDA, WORK( IB+1 ),
52911     $                      LDWORK )
52912            END IF
52913*
52914*           Apply H**H to columns 1:n-k+i+ib-1 of current block
52915*
52916            CALL ZUNGR2( IB, N-K+I+IB-1, IB, A( II, 1 ), LDA, TAU( I ),
52917     $                   WORK, IINFO )
52918*
52919*           Set columns n-k+i+ib:n of current block to zero
52920*
52921            DO 40 L = N - K + I + IB, N
52922               DO 30 J = II, II + IB - 1
52923                  A( J, L ) = ZERO
52924   30          CONTINUE
52925   40       CONTINUE
52926   50    CONTINUE
52927      END IF
52928*
52929      WORK( 1 ) = IWS
52930      RETURN
52931*
52932*     End of ZUNGRQ
52933*
52934      END
52935*> \brief \b ZUNGTR
52936*
52937*  =========== DOCUMENTATION ===========
52938*
52939* Online html documentation available at
52940*            http://www.netlib.org/lapack/explore-html/
52941*
52942*> \htmlonly
52943*> Download ZUNGTR + dependencies
52944*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zungtr.f">
52945*> [TGZ]</a>
52946*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zungtr.f">
52947*> [ZIP]</a>
52948*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zungtr.f">
52949*> [TXT]</a>
52950*> \endhtmlonly
52951*
52952*  Definition:
52953*  ===========
52954*
52955*       SUBROUTINE ZUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )
52956*
52957*       .. Scalar Arguments ..
52958*       CHARACTER          UPLO
52959*       INTEGER            INFO, LDA, LWORK, N
52960*       ..
52961*       .. Array Arguments ..
52962*       COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
52963*       ..
52964*
52965*
52966*> \par Purpose:
52967*  =============
52968*>
52969*> \verbatim
52970*>
52971*> ZUNGTR generates a complex unitary matrix Q which is defined as the
52972*> product of n-1 elementary reflectors of order N, as returned by
52973*> ZHETRD:
52974*>
52975*> if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
52976*>
52977*> if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
52978*> \endverbatim
52979*
52980*  Arguments:
52981*  ==========
52982*
52983*> \param[in] UPLO
52984*> \verbatim
52985*>          UPLO is CHARACTER*1
52986*>          = 'U': Upper triangle of A contains elementary reflectors
52987*>                 from ZHETRD;
52988*>          = 'L': Lower triangle of A contains elementary reflectors
52989*>                 from ZHETRD.
52990*> \endverbatim
52991*>
52992*> \param[in] N
52993*> \verbatim
52994*>          N is INTEGER
52995*>          The order of the matrix Q. N >= 0.
52996*> \endverbatim
52997*>
52998*> \param[in,out] A
52999*> \verbatim
53000*>          A is COMPLEX*16 array, dimension (LDA,N)
53001*>          On entry, the vectors which define the elementary reflectors,
53002*>          as returned by ZHETRD.
53003*>          On exit, the N-by-N unitary matrix Q.
53004*> \endverbatim
53005*>
53006*> \param[in] LDA
53007*> \verbatim
53008*>          LDA is INTEGER
53009*>          The leading dimension of the array A. LDA >= N.
53010*> \endverbatim
53011*>
53012*> \param[in] TAU
53013*> \verbatim
53014*>          TAU is COMPLEX*16 array, dimension (N-1)
53015*>          TAU(i) must contain the scalar factor of the elementary
53016*>          reflector H(i), as returned by ZHETRD.
53017*> \endverbatim
53018*>
53019*> \param[out] WORK
53020*> \verbatim
53021*>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
53022*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
53023*> \endverbatim
53024*>
53025*> \param[in] LWORK
53026*> \verbatim
53027*>          LWORK is INTEGER
53028*>          The dimension of the array WORK. LWORK >= N-1.
53029*>          For optimum performance LWORK >= (N-1)*NB, where NB is
53030*>          the optimal blocksize.
53031*>
53032*>          If LWORK = -1, then a workspace query is assumed; the routine
53033*>          only calculates the optimal size of the WORK array, returns
53034*>          this value as the first entry of the WORK array, and no error
53035*>          message related to LWORK is issued by XERBLA.
53036*> \endverbatim
53037*>
53038*> \param[out] INFO
53039*> \verbatim
53040*>          INFO is INTEGER
53041*>          = 0:  successful exit
53042*>          < 0:  if INFO = -i, the i-th argument had an illegal value
53043*> \endverbatim
53044*
53045*  Authors:
53046*  ========
53047*
53048*> \author Univ. of Tennessee
53049*> \author Univ. of California Berkeley
53050*> \author Univ. of Colorado Denver
53051*> \author NAG Ltd.
53052*
53053*> \date December 2016
53054*
53055*> \ingroup complex16OTHERcomputational
53056*
53057*  =====================================================================
53058      SUBROUTINE ZUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )
53059*
53060*  -- LAPACK computational routine (version 3.7.0) --
53061*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
53062*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
53063*     December 2016
53064*
53065*     .. Scalar Arguments ..
53066      CHARACTER          UPLO
53067      INTEGER            INFO, LDA, LWORK, N
53068*     ..
53069*     .. Array Arguments ..
53070      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
53071*     ..
53072*
53073*  =====================================================================
53074*
53075*     .. Parameters ..
53076      COMPLEX*16         ZERO, ONE
53077      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ),
53078     $                   ONE = ( 1.0D+0, 0.0D+0 ) )
53079*     ..
53080*     .. Local Scalars ..
53081      LOGICAL            LQUERY, UPPER
53082      INTEGER            I, IINFO, J, LWKOPT, NB
53083*     ..
53084*     .. External Functions ..
53085      LOGICAL            LSAME
53086      INTEGER            ILAENV
53087      EXTERNAL           LSAME, ILAENV
53088*     ..
53089*     .. External Subroutines ..
53090      EXTERNAL           XERBLA, ZUNGQL, ZUNGQR
53091*     ..
53092*     .. Intrinsic Functions ..
53093      INTRINSIC          MAX
53094*     ..
53095*     .. Executable Statements ..
53096*
53097*     Test the input arguments
53098*
53099      INFO = 0
53100      LQUERY = ( LWORK.EQ.-1 )
53101      UPPER = LSAME( UPLO, 'U' )
53102      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
53103         INFO = -1
53104      ELSE IF( N.LT.0 ) THEN
53105         INFO = -2
53106      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
53107         INFO = -4
53108      ELSE IF( LWORK.LT.MAX( 1, N-1 ) .AND. .NOT.LQUERY ) THEN
53109         INFO = -7
53110      END IF
53111*
53112      IF( INFO.EQ.0 ) THEN
53113         IF( UPPER ) THEN
53114            NB = ILAENV( 1, 'ZUNGQL', ' ', N-1, N-1, N-1, -1 )
53115         ELSE
53116            NB = ILAENV( 1, 'ZUNGQR', ' ', N-1, N-1, N-1, -1 )
53117         END IF
53118         LWKOPT = MAX( 1, N-1 )*NB
53119         WORK( 1 ) = LWKOPT
53120      END IF
53121*
53122      IF( INFO.NE.0 ) THEN
53123         CALL XERBLA( 'ZUNGTR', -INFO )
53124         RETURN
53125      ELSE IF( LQUERY ) THEN
53126         RETURN
53127      END IF
53128*
53129*     Quick return if possible
53130*
53131      IF( N.EQ.0 ) THEN
53132         WORK( 1 ) = 1
53133         RETURN
53134      END IF
53135*
53136      IF( UPPER ) THEN
53137*
53138*        Q was determined by a call to ZHETRD with UPLO = 'U'
53139*
53140*        Shift the vectors which define the elementary reflectors one
53141*        column to the left, and set the last row and column of Q to
53142*        those of the unit matrix
53143*
53144         DO 20 J = 1, N - 1
53145            DO 10 I = 1, J - 1
53146               A( I, J ) = A( I, J+1 )
53147   10       CONTINUE
53148            A( N, J ) = ZERO
53149   20    CONTINUE
53150         DO 30 I = 1, N - 1
53151            A( I, N ) = ZERO
53152   30    CONTINUE
53153         A( N, N ) = ONE
53154*
53155*        Generate Q(1:n-1,1:n-1)
53156*
53157         CALL ZUNGQL( N-1, N-1, N-1, A, LDA, TAU, WORK, LWORK, IINFO )
53158*
53159      ELSE
53160*
53161*        Q was determined by a call to ZHETRD with UPLO = 'L'.
53162*
53163*        Shift the vectors which define the elementary reflectors one
53164*        column to the right, and set the first row and column of Q to
53165*        those of the unit matrix
53166*
53167         DO 50 J = N, 2, -1
53168            A( 1, J ) = ZERO
53169            DO 40 I = J + 1, N
53170               A( I, J ) = A( I, J-1 )
53171   40       CONTINUE
53172   50    CONTINUE
53173         A( 1, 1 ) = ONE
53174         DO 60 I = 2, N
53175            A( I, 1 ) = ZERO
53176   60    CONTINUE
53177         IF( N.GT.1 ) THEN
53178*
53179*           Generate Q(2:n,2:n)
53180*
53181            CALL ZUNGQR( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK,
53182     $                   LWORK, IINFO )
53183         END IF
53184      END IF
53185      WORK( 1 ) = LWKOPT
53186      RETURN
53187*
53188*     End of ZUNGTR
53189*
53190      END
53191*> \brief \b ZUNM2L multiplies a general matrix by the unitary matrix from a QL factorization determined by cgeqlf (unblocked algorithm).
53192*
53193*  =========== DOCUMENTATION ===========
53194*
53195* Online html documentation available at
53196*            http://www.netlib.org/lapack/explore-html/
53197*
53198*> \htmlonly
53199*> Download ZUNM2L + dependencies
53200*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zunm2l.f">
53201*> [TGZ]</a>
53202*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zunm2l.f">
53203*> [ZIP]</a>
53204*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zunm2l.f">
53205*> [TXT]</a>
53206*> \endhtmlonly
53207*
53208*  Definition:
53209*  ===========
53210*
53211*       SUBROUTINE ZUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
53212*                          WORK, INFO )
53213*
53214*       .. Scalar Arguments ..
53215*       CHARACTER          SIDE, TRANS
53216*       INTEGER            INFO, K, LDA, LDC, M, N
53217*       ..
53218*       .. Array Arguments ..
53219*       COMPLEX*16         A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
53220*       ..
53221*
53222*
53223*> \par Purpose:
53224*  =============
53225*>
53226*> \verbatim
53227*>
53228*> ZUNM2L overwrites the general complex m-by-n matrix C with
53229*>
53230*>       Q * C  if SIDE = 'L' and TRANS = 'N', or
53231*>
53232*>       Q**H* C  if SIDE = 'L' and TRANS = 'C', or
53233*>
53234*>       C * Q  if SIDE = 'R' and TRANS = 'N', or
53235*>
53236*>       C * Q**H if SIDE = 'R' and TRANS = 'C',
53237*>
53238*> where Q is a complex unitary matrix defined as the product of k
53239*> elementary reflectors
53240*>
53241*>       Q = H(k) . . . H(2) H(1)
53242*>
53243*> as returned by ZGEQLF. Q is of order m if SIDE = 'L' and of order n
53244*> if SIDE = 'R'.
53245*> \endverbatim
53246*
53247*  Arguments:
53248*  ==========
53249*
53250*> \param[in] SIDE
53251*> \verbatim
53252*>          SIDE is CHARACTER*1
53253*>          = 'L': apply Q or Q**H from the Left
53254*>          = 'R': apply Q or Q**H from the Right
53255*> \endverbatim
53256*>
53257*> \param[in] TRANS
53258*> \verbatim
53259*>          TRANS is CHARACTER*1
53260*>          = 'N': apply Q  (No transpose)
53261*>          = 'C': apply Q**H (Conjugate transpose)
53262*> \endverbatim
53263*>
53264*> \param[in] M
53265*> \verbatim
53266*>          M is INTEGER
53267*>          The number of rows of the matrix C. M >= 0.
53268*> \endverbatim
53269*>
53270*> \param[in] N
53271*> \verbatim
53272*>          N is INTEGER
53273*>          The number of columns of the matrix C. N >= 0.
53274*> \endverbatim
53275*>
53276*> \param[in] K
53277*> \verbatim
53278*>          K is INTEGER
53279*>          The number of elementary reflectors whose product defines
53280*>          the matrix Q.
53281*>          If SIDE = 'L', M >= K >= 0;
53282*>          if SIDE = 'R', N >= K >= 0.
53283*> \endverbatim
53284*>
53285*> \param[in] A
53286*> \verbatim
53287*>          A is COMPLEX*16 array, dimension (LDA,K)
53288*>          The i-th column must contain the vector which defines the
53289*>          elementary reflector H(i), for i = 1,2,...,k, as returned by
53290*>          ZGEQLF in the last k columns of its array argument A.
53291*>          A is modified by the routine but restored on exit.
53292*> \endverbatim
53293*>
53294*> \param[in] LDA
53295*> \verbatim
53296*>          LDA is INTEGER
53297*>          The leading dimension of the array A.
53298*>          If SIDE = 'L', LDA >= max(1,M);
53299*>          if SIDE = 'R', LDA >= max(1,N).
53300*> \endverbatim
53301*>
53302*> \param[in] TAU
53303*> \verbatim
53304*>          TAU is COMPLEX*16 array, dimension (K)
53305*>          TAU(i) must contain the scalar factor of the elementary
53306*>          reflector H(i), as returned by ZGEQLF.
53307*> \endverbatim
53308*>
53309*> \param[in,out] C
53310*> \verbatim
53311*>          C is COMPLEX*16 array, dimension (LDC,N)
53312*>          On entry, the m-by-n matrix C.
53313*>          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
53314*> \endverbatim
53315*>
53316*> \param[in] LDC
53317*> \verbatim
53318*>          LDC is INTEGER
53319*>          The leading dimension of the array C. LDC >= max(1,M).
53320*> \endverbatim
53321*>
53322*> \param[out] WORK
53323*> \verbatim
53324*>          WORK is COMPLEX*16 array, dimension
53325*>                                   (N) if SIDE = 'L',
53326*>                                   (M) if SIDE = 'R'
53327*> \endverbatim
53328*>
53329*> \param[out] INFO
53330*> \verbatim
53331*>          INFO is INTEGER
53332*>          = 0: successful exit
53333*>          < 0: if INFO = -i, the i-th argument had an illegal value
53334*> \endverbatim
53335*
53336*  Authors:
53337*  ========
53338*
53339*> \author Univ. of Tennessee
53340*> \author Univ. of California Berkeley
53341*> \author Univ. of Colorado Denver
53342*> \author NAG Ltd.
53343*
53344*> \date December 2016
53345*
53346*> \ingroup complex16OTHERcomputational
53347*
53348*  =====================================================================
53349      SUBROUTINE ZUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
53350     $                   WORK, INFO )
53351*
53352*  -- LAPACK computational routine (version 3.7.0) --
53353*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
53354*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
53355*     December 2016
53356*
53357*     .. Scalar Arguments ..
53358      CHARACTER          SIDE, TRANS
53359      INTEGER            INFO, K, LDA, LDC, M, N
53360*     ..
53361*     .. Array Arguments ..
53362      COMPLEX*16         A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
53363*     ..
53364*
53365*  =====================================================================
53366*
53367*     .. Parameters ..
53368      COMPLEX*16         ONE
53369      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
53370*     ..
53371*     .. Local Scalars ..
53372      LOGICAL            LEFT, NOTRAN
53373      INTEGER            I, I1, I2, I3, MI, NI, NQ
53374      COMPLEX*16         AII, TAUI
53375*     ..
53376*     .. External Functions ..
53377      LOGICAL            LSAME
53378      EXTERNAL           LSAME
53379*     ..
53380*     .. External Subroutines ..
53381      EXTERNAL           XERBLA, ZLARF
53382*     ..
53383*     .. Intrinsic Functions ..
53384      INTRINSIC          DCONJG, MAX
53385*     ..
53386*     .. Executable Statements ..
53387*
53388*     Test the input arguments
53389*
53390      INFO = 0
53391      LEFT = LSAME( SIDE, 'L' )
53392      NOTRAN = LSAME( TRANS, 'N' )
53393*
53394*     NQ is the order of Q
53395*
53396      IF( LEFT ) THEN
53397         NQ = M
53398      ELSE
53399         NQ = N
53400      END IF
53401      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
53402         INFO = -1
53403      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
53404         INFO = -2
53405      ELSE IF( M.LT.0 ) THEN
53406         INFO = -3
53407      ELSE IF( N.LT.0 ) THEN
53408         INFO = -4
53409      ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
53410         INFO = -5
53411      ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
53412         INFO = -7
53413      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
53414         INFO = -10
53415      END IF
53416      IF( INFO.NE.0 ) THEN
53417         CALL XERBLA( 'ZUNM2L', -INFO )
53418         RETURN
53419      END IF
53420*
53421*     Quick return if possible
53422*
53423      IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
53424     $   RETURN
53425*
53426      IF( ( LEFT .AND. NOTRAN .OR. .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN
53427         I1 = 1
53428         I2 = K
53429         I3 = 1
53430      ELSE
53431         I1 = K
53432         I2 = 1
53433         I3 = -1
53434      END IF
53435*
53436      IF( LEFT ) THEN
53437         NI = N
53438      ELSE
53439         MI = M
53440      END IF
53441*
53442      DO 10 I = I1, I2, I3
53443         IF( LEFT ) THEN
53444*
53445*           H(i) or H(i)**H is applied to C(1:m-k+i,1:n)
53446*
53447            MI = M - K + I
53448         ELSE
53449*
53450*           H(i) or H(i)**H is applied to C(1:m,1:n-k+i)
53451*
53452            NI = N - K + I
53453         END IF
53454*
53455*        Apply H(i) or H(i)**H
53456*
53457         IF( NOTRAN ) THEN
53458            TAUI = TAU( I )
53459         ELSE
53460            TAUI = DCONJG( TAU( I ) )
53461         END IF
53462         AII = A( NQ-K+I, I )
53463         A( NQ-K+I, I ) = ONE
53464         CALL ZLARF( SIDE, MI, NI, A( 1, I ), 1, TAUI, C, LDC, WORK )
53465         A( NQ-K+I, I ) = AII
53466   10 CONTINUE
53467      RETURN
53468*
53469*     End of ZUNM2L
53470*
53471      END
53472*> \brief \b ZUNM2R multiplies a general matrix by the unitary matrix from a QR factorization determined by cgeqrf (unblocked algorithm).
53473*
53474*  =========== DOCUMENTATION ===========
53475*
53476* Online html documentation available at
53477*            http://www.netlib.org/lapack/explore-html/
53478*
53479*> \htmlonly
53480*> Download ZUNM2R + dependencies
53481*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zunm2r.f">
53482*> [TGZ]</a>
53483*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zunm2r.f">
53484*> [ZIP]</a>
53485*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zunm2r.f">
53486*> [TXT]</a>
53487*> \endhtmlonly
53488*
53489*  Definition:
53490*  ===========
53491*
53492*       SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
53493*                          WORK, INFO )
53494*
53495*       .. Scalar Arguments ..
53496*       CHARACTER          SIDE, TRANS
53497*       INTEGER            INFO, K, LDA, LDC, M, N
53498*       ..
53499*       .. Array Arguments ..
53500*       COMPLEX*16         A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
53501*       ..
53502*
53503*
53504*> \par Purpose:
53505*  =============
53506*>
53507*> \verbatim
53508*>
53509*> ZUNM2R overwrites the general complex m-by-n matrix C with
53510*>
53511*>       Q * C  if SIDE = 'L' and TRANS = 'N', or
53512*>
53513*>       Q**H* C  if SIDE = 'L' and TRANS = 'C', or
53514*>
53515*>       C * Q  if SIDE = 'R' and TRANS = 'N', or
53516*>
53517*>       C * Q**H if SIDE = 'R' and TRANS = 'C',
53518*>
53519*> where Q is a complex unitary matrix defined as the product of k
53520*> elementary reflectors
53521*>
53522*>       Q = H(1) H(2) . . . H(k)
53523*>
53524*> as returned by ZGEQRF. Q is of order m if SIDE = 'L' and of order n
53525*> if SIDE = 'R'.
53526*> \endverbatim
53527*
53528*  Arguments:
53529*  ==========
53530*
53531*> \param[in] SIDE
53532*> \verbatim
53533*>          SIDE is CHARACTER*1
53534*>          = 'L': apply Q or Q**H from the Left
53535*>          = 'R': apply Q or Q**H from the Right
53536*> \endverbatim
53537*>
53538*> \param[in] TRANS
53539*> \verbatim
53540*>          TRANS is CHARACTER*1
53541*>          = 'N': apply Q  (No transpose)
53542*>          = 'C': apply Q**H (Conjugate transpose)
53543*> \endverbatim
53544*>
53545*> \param[in] M
53546*> \verbatim
53547*>          M is INTEGER
53548*>          The number of rows of the matrix C. M >= 0.
53549*> \endverbatim
53550*>
53551*> \param[in] N
53552*> \verbatim
53553*>          N is INTEGER
53554*>          The number of columns of the matrix C. N >= 0.
53555*> \endverbatim
53556*>
53557*> \param[in] K
53558*> \verbatim
53559*>          K is INTEGER
53560*>          The number of elementary reflectors whose product defines
53561*>          the matrix Q.
53562*>          If SIDE = 'L', M >= K >= 0;
53563*>          if SIDE = 'R', N >= K >= 0.
53564*> \endverbatim
53565*>
53566*> \param[in] A
53567*> \verbatim
53568*>          A is COMPLEX*16 array, dimension (LDA,K)
53569*>          The i-th column must contain the vector which defines the
53570*>          elementary reflector H(i), for i = 1,2,...,k, as returned by
53571*>          ZGEQRF in the first k columns of its array argument A.
53572*>          A is modified by the routine but restored on exit.
53573*> \endverbatim
53574*>
53575*> \param[in] LDA
53576*> \verbatim
53577*>          LDA is INTEGER
53578*>          The leading dimension of the array A.
53579*>          If SIDE = 'L', LDA >= max(1,M);
53580*>          if SIDE = 'R', LDA >= max(1,N).
53581*> \endverbatim
53582*>
53583*> \param[in] TAU
53584*> \verbatim
53585*>          TAU is COMPLEX*16 array, dimension (K)
53586*>          TAU(i) must contain the scalar factor of the elementary
53587*>          reflector H(i), as returned by ZGEQRF.
53588*> \endverbatim
53589*>
53590*> \param[in,out] C
53591*> \verbatim
53592*>          C is COMPLEX*16 array, dimension (LDC,N)
53593*>          On entry, the m-by-n matrix C.
53594*>          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
53595*> \endverbatim
53596*>
53597*> \param[in] LDC
53598*> \verbatim
53599*>          LDC is INTEGER
53600*>          The leading dimension of the array C. LDC >= max(1,M).
53601*> \endverbatim
53602*>
53603*> \param[out] WORK
53604*> \verbatim
53605*>          WORK is COMPLEX*16 array, dimension
53606*>                                   (N) if SIDE = 'L',
53607*>                                   (M) if SIDE = 'R'
53608*> \endverbatim
53609*>
53610*> \param[out] INFO
53611*> \verbatim
53612*>          INFO is INTEGER
53613*>          = 0: successful exit
53614*>          < 0: if INFO = -i, the i-th argument had an illegal value
53615*> \endverbatim
53616*
53617*  Authors:
53618*  ========
53619*
53620*> \author Univ. of Tennessee
53621*> \author Univ. of California Berkeley
53622*> \author Univ. of Colorado Denver
53623*> \author NAG Ltd.
53624*
53625*> \date December 2016
53626*
53627*> \ingroup complex16OTHERcomputational
53628*
53629*  =====================================================================
53630      SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
53631     $                   WORK, INFO )
53632*
53633*  -- LAPACK computational routine (version 3.7.0) --
53634*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
53635*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
53636*     December 2016
53637*
53638*     .. Scalar Arguments ..
53639      CHARACTER          SIDE, TRANS
53640      INTEGER            INFO, K, LDA, LDC, M, N
53641*     ..
53642*     .. Array Arguments ..
53643      COMPLEX*16         A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
53644*     ..
53645*
53646*  =====================================================================
53647*
53648*     .. Parameters ..
53649      COMPLEX*16         ONE
53650      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
53651*     ..
53652*     .. Local Scalars ..
53653      LOGICAL            LEFT, NOTRAN
53654      INTEGER            I, I1, I2, I3, IC, JC, MI, NI, NQ
53655      COMPLEX*16         AII, TAUI
53656*     ..
53657*     .. External Functions ..
53658      LOGICAL            LSAME
53659      EXTERNAL           LSAME
53660*     ..
53661*     .. External Subroutines ..
53662      EXTERNAL           XERBLA, ZLARF
53663*     ..
53664*     .. Intrinsic Functions ..
53665      INTRINSIC          DCONJG, MAX
53666*     ..
53667*     .. Executable Statements ..
53668*
53669*     Test the input arguments
53670*
53671      INFO = 0
53672      LEFT = LSAME( SIDE, 'L' )
53673      NOTRAN = LSAME( TRANS, 'N' )
53674*
53675*     NQ is the order of Q
53676*
53677      IF( LEFT ) THEN
53678         NQ = M
53679      ELSE
53680         NQ = N
53681      END IF
53682      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
53683         INFO = -1
53684      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
53685         INFO = -2
53686      ELSE IF( M.LT.0 ) THEN
53687         INFO = -3
53688      ELSE IF( N.LT.0 ) THEN
53689         INFO = -4
53690      ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
53691         INFO = -5
53692      ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
53693         INFO = -7
53694      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
53695         INFO = -10
53696      END IF
53697      IF( INFO.NE.0 ) THEN
53698         CALL XERBLA( 'ZUNM2R', -INFO )
53699         RETURN
53700      END IF
53701*
53702*     Quick return if possible
53703*
53704      IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
53705     $   RETURN
53706*
53707      IF( ( LEFT .AND. .NOT.NOTRAN .OR. .NOT.LEFT .AND. NOTRAN ) ) THEN
53708         I1 = 1
53709         I2 = K
53710         I3 = 1
53711      ELSE
53712         I1 = K
53713         I2 = 1
53714         I3 = -1
53715      END IF
53716*
53717      IF( LEFT ) THEN
53718         NI = N
53719         JC = 1
53720      ELSE
53721         MI = M
53722         IC = 1
53723      END IF
53724*
53725      DO 10 I = I1, I2, I3
53726         IF( LEFT ) THEN
53727*
53728*           H(i) or H(i)**H is applied to C(i:m,1:n)
53729*
53730            MI = M - I + 1
53731            IC = I
53732         ELSE
53733*
53734*           H(i) or H(i)**H is applied to C(1:m,i:n)
53735*
53736            NI = N - I + 1
53737            JC = I
53738         END IF
53739*
53740*        Apply H(i) or H(i)**H
53741*
53742         IF( NOTRAN ) THEN
53743            TAUI = TAU( I )
53744         ELSE
53745            TAUI = DCONJG( TAU( I ) )
53746         END IF
53747         AII = A( I, I )
53748         A( I, I ) = ONE
53749         CALL ZLARF( SIDE, MI, NI, A( I, I ), 1, TAUI, C( IC, JC ), LDC,
53750     $               WORK )
53751         A( I, I ) = AII
53752   10 CONTINUE
53753      RETURN
53754*
53755*     End of ZUNM2R
53756*
53757      END
53758*> \brief \b ZUNMBR
53759*
53760*  =========== DOCUMENTATION ===========
53761*
53762* Online html documentation available at
53763*            http://www.netlib.org/lapack/explore-html/
53764*
53765*> \htmlonly
53766*> Download ZUNMBR + dependencies
53767*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zunmbr.f">
53768*> [TGZ]</a>
53769*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zunmbr.f">
53770*> [ZIP]</a>
53771*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zunmbr.f">
53772*> [TXT]</a>
53773*> \endhtmlonly
53774*
53775*  Definition:
53776*  ===========
53777*
53778*       SUBROUTINE ZUNMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C,
53779*                          LDC, WORK, LWORK, INFO )
53780*
53781*       .. Scalar Arguments ..
53782*       CHARACTER          SIDE, TRANS, VECT
53783*       INTEGER            INFO, K, LDA, LDC, LWORK, M, N
53784*       ..
53785*       .. Array Arguments ..
53786*       COMPLEX*16         A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
53787*       ..
53788*
53789*
53790*> \par Purpose:
53791*  =============
53792*>
53793*> \verbatim
53794*>
53795*> If VECT = 'Q', ZUNMBR overwrites the general complex M-by-N matrix C
53796*> with
53797*>                 SIDE = 'L'     SIDE = 'R'
53798*> TRANS = 'N':      Q * C          C * Q
53799*> TRANS = 'C':      Q**H * C       C * Q**H
53800*>
53801*> If VECT = 'P', ZUNMBR overwrites the general complex M-by-N matrix C
53802*> with
53803*>                 SIDE = 'L'     SIDE = 'R'
53804*> TRANS = 'N':      P * C          C * P
53805*> TRANS = 'C':      P**H * C       C * P**H
53806*>
53807*> Here Q and P**H are the unitary matrices determined by ZGEBRD when
53808*> reducing a complex matrix A to bidiagonal form: A = Q * B * P**H. Q
53809*> and P**H are defined as products of elementary reflectors H(i) and
53810*> G(i) respectively.
53811*>
53812*> Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the
53813*> order of the unitary matrix Q or P**H that is applied.
53814*>
53815*> If VECT = 'Q', A is assumed to have been an NQ-by-K matrix:
53816*> if nq >= k, Q = H(1) H(2) . . . H(k);
53817*> if nq < k, Q = H(1) H(2) . . . H(nq-1).
53818*>
53819*> If VECT = 'P', A is assumed to have been a K-by-NQ matrix:
53820*> if k < nq, P = G(1) G(2) . . . G(k);
53821*> if k >= nq, P = G(1) G(2) . . . G(nq-1).
53822*> \endverbatim
53823*
53824*  Arguments:
53825*  ==========
53826*
53827*> \param[in] VECT
53828*> \verbatim
53829*>          VECT is CHARACTER*1
53830*>          = 'Q': apply Q or Q**H;
53831*>          = 'P': apply P or P**H.
53832*> \endverbatim
53833*>
53834*> \param[in] SIDE
53835*> \verbatim
53836*>          SIDE is CHARACTER*1
53837*>          = 'L': apply Q, Q**H, P or P**H from the Left;
53838*>          = 'R': apply Q, Q**H, P or P**H from the Right.
53839*> \endverbatim
53840*>
53841*> \param[in] TRANS
53842*> \verbatim
53843*>          TRANS is CHARACTER*1
53844*>          = 'N':  No transpose, apply Q or P;
53845*>          = 'C':  Conjugate transpose, apply Q**H or P**H.
53846*> \endverbatim
53847*>
53848*> \param[in] M
53849*> \verbatim
53850*>          M is INTEGER
53851*>          The number of rows of the matrix C. M >= 0.
53852*> \endverbatim
53853*>
53854*> \param[in] N
53855*> \verbatim
53856*>          N is INTEGER
53857*>          The number of columns of the matrix C. N >= 0.
53858*> \endverbatim
53859*>
53860*> \param[in] K
53861*> \verbatim
53862*>          K is INTEGER
53863*>          If VECT = 'Q', the number of columns in the original
53864*>          matrix reduced by ZGEBRD.
53865*>          If VECT = 'P', the number of rows in the original
53866*>          matrix reduced by ZGEBRD.
53867*>          K >= 0.
53868*> \endverbatim
53869*>
53870*> \param[in] A
53871*> \verbatim
53872*>          A is COMPLEX*16 array, dimension
53873*>                                (LDA,min(nq,K)) if VECT = 'Q'
53874*>                                (LDA,nq)        if VECT = 'P'
53875*>          The vectors which define the elementary reflectors H(i) and
53876*>          G(i), whose products determine the matrices Q and P, as
53877*>          returned by ZGEBRD.
53878*> \endverbatim
53879*>
53880*> \param[in] LDA
53881*> \verbatim
53882*>          LDA is INTEGER
53883*>          The leading dimension of the array A.
53884*>          If VECT = 'Q', LDA >= max(1,nq);
53885*>          if VECT = 'P', LDA >= max(1,min(nq,K)).
53886*> \endverbatim
53887*>
53888*> \param[in] TAU
53889*> \verbatim
53890*>          TAU is COMPLEX*16 array, dimension (min(nq,K))
53891*>          TAU(i) must contain the scalar factor of the elementary
53892*>          reflector H(i) or G(i) which determines Q or P, as returned
53893*>          by ZGEBRD in the array argument TAUQ or TAUP.
53894*> \endverbatim
53895*>
53896*> \param[in,out] C
53897*> \verbatim
53898*>          C is COMPLEX*16 array, dimension (LDC,N)
53899*>          On entry, the M-by-N matrix C.
53900*>          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q
53901*>          or P*C or P**H*C or C*P or C*P**H.
53902*> \endverbatim
53903*>
53904*> \param[in] LDC
53905*> \verbatim
53906*>          LDC is INTEGER
53907*>          The leading dimension of the array C. LDC >= max(1,M).
53908*> \endverbatim
53909*>
53910*> \param[out] WORK
53911*> \verbatim
53912*>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
53913*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
53914*> \endverbatim
53915*>
53916*> \param[in] LWORK
53917*> \verbatim
53918*>          LWORK is INTEGER
53919*>          The dimension of the array WORK.
53920*>          If SIDE = 'L', LWORK >= max(1,N);
53921*>          if SIDE = 'R', LWORK >= max(1,M);
53922*>          if N = 0 or M = 0, LWORK >= 1.
53923*>          For optimum performance LWORK >= max(1,N*NB) if SIDE = 'L',
53924*>          and LWORK >= max(1,M*NB) if SIDE = 'R', where NB is the
53925*>          optimal blocksize. (NB = 0 if M = 0 or N = 0.)
53926*>
53927*>          If LWORK = -1, then a workspace query is assumed; the routine
53928*>          only calculates the optimal size of the WORK array, returns
53929*>          this value as the first entry of the WORK array, and no error
53930*>          message related to LWORK is issued by XERBLA.
53931*> \endverbatim
53932*>
53933*> \param[out] INFO
53934*> \verbatim
53935*>          INFO is INTEGER
53936*>          = 0:  successful exit
53937*>          < 0:  if INFO = -i, the i-th argument had an illegal value
53938*> \endverbatim
53939*
53940*  Authors:
53941*  ========
53942*
53943*> \author Univ. of Tennessee
53944*> \author Univ. of California Berkeley
53945*> \author Univ. of Colorado Denver
53946*> \author NAG Ltd.
53947*
53948*> \date December 2016
53949*
53950*> \ingroup complex16OTHERcomputational
53951*
53952*  =====================================================================
53953      SUBROUTINE ZUNMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C,
53954     $                   LDC, WORK, LWORK, INFO )
53955*
53956*  -- LAPACK computational routine (version 3.7.0) --
53957*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
53958*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
53959*     December 2016
53960*
53961*     .. Scalar Arguments ..
53962      CHARACTER          SIDE, TRANS, VECT
53963      INTEGER            INFO, K, LDA, LDC, LWORK, M, N
53964*     ..
53965*     .. Array Arguments ..
53966      COMPLEX*16         A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
53967*     ..
53968*
53969*  =====================================================================
53970*
53971*     .. Local Scalars ..
53972      LOGICAL            APPLYQ, LEFT, LQUERY, NOTRAN
53973      CHARACTER          TRANST
53974      INTEGER            I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW
53975*     ..
53976*     .. External Functions ..
53977      LOGICAL            LSAME
53978      INTEGER            ILAENV
53979      EXTERNAL           LSAME, ILAENV
53980*     ..
53981*     .. External Subroutines ..
53982      EXTERNAL           XERBLA, ZUNMLQ, ZUNMQR
53983*     ..
53984*     .. Intrinsic Functions ..
53985      INTRINSIC          MAX, MIN
53986*     ..
53987*     .. Executable Statements ..
53988*
53989*     Test the input arguments
53990*
53991      INFO = 0
53992      APPLYQ = LSAME( VECT, 'Q' )
53993      LEFT = LSAME( SIDE, 'L' )
53994      NOTRAN = LSAME( TRANS, 'N' )
53995      LQUERY = ( LWORK.EQ.-1 )
53996*
53997*     NQ is the order of Q or P and NW is the minimum dimension of WORK
53998*
53999      IF( LEFT ) THEN
54000         NQ = M
54001         NW = N
54002      ELSE
54003         NQ = N
54004         NW = M
54005      END IF
54006      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
54007         NW = 0
54008      END IF
54009      IF( .NOT.APPLYQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN
54010         INFO = -1
54011      ELSE IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
54012         INFO = -2
54013      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
54014         INFO = -3
54015      ELSE IF( M.LT.0 ) THEN
54016         INFO = -4
54017      ELSE IF( N.LT.0 ) THEN
54018         INFO = -5
54019      ELSE IF( K.LT.0 ) THEN
54020         INFO = -6
54021      ELSE IF( ( APPLYQ .AND. LDA.LT.MAX( 1, NQ ) ) .OR.
54022     $         ( .NOT.APPLYQ .AND. LDA.LT.MAX( 1, MIN( NQ, K ) ) ) )
54023     $          THEN
54024         INFO = -8
54025      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
54026         INFO = -11
54027      ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
54028         INFO = -13
54029      END IF
54030*
54031      IF( INFO.EQ.0 ) THEN
54032         IF( NW.GT.0 ) THEN
54033            IF( APPLYQ ) THEN
54034               IF( LEFT ) THEN
54035                  NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M-1, N, M-1,
54036     $                 -1 )
54037               ELSE
54038                  NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, N-1, N-1,
54039     $                 -1 )
54040               END IF
54041            ELSE
54042               IF( LEFT ) THEN
54043                  NB = ILAENV( 1, 'ZUNMLQ', SIDE // TRANS, M-1, N, M-1,
54044     $                 -1 )
54045               ELSE
54046                  NB = ILAENV( 1, 'ZUNMLQ', SIDE // TRANS, M, N-1, N-1,
54047     $                 -1 )
54048               END IF
54049            END IF
54050            LWKOPT = MAX( 1, NW*NB )
54051         ELSE
54052            LWKOPT = 1
54053         END IF
54054         WORK( 1 ) = LWKOPT
54055      END IF
54056*
54057      IF( INFO.NE.0 ) THEN
54058         CALL XERBLA( 'ZUNMBR', -INFO )
54059         RETURN
54060      ELSE IF( LQUERY ) THEN
54061         RETURN
54062      END IF
54063*
54064*     Quick return if possible
54065*
54066      IF( M.EQ.0 .OR. N.EQ.0 )
54067     $   RETURN
54068*
54069      IF( APPLYQ ) THEN
54070*
54071*        Apply Q
54072*
54073         IF( NQ.GE.K ) THEN
54074*
54075*           Q was determined by a call to ZGEBRD with nq >= k
54076*
54077            CALL ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
54078     $                   WORK, LWORK, IINFO )
54079         ELSE IF( NQ.GT.1 ) THEN
54080*
54081*           Q was determined by a call to ZGEBRD with nq < k
54082*
54083            IF( LEFT ) THEN
54084               MI = M - 1
54085               NI = N
54086               I1 = 2
54087               I2 = 1
54088            ELSE
54089               MI = M
54090               NI = N - 1
54091               I1 = 1
54092               I2 = 2
54093            END IF
54094            CALL ZUNMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU,
54095     $                   C( I1, I2 ), LDC, WORK, LWORK, IINFO )
54096         END IF
54097      ELSE
54098*
54099*        Apply P
54100*
54101         IF( NOTRAN ) THEN
54102            TRANST = 'C'
54103         ELSE
54104            TRANST = 'N'
54105         END IF
54106         IF( NQ.GT.K ) THEN
54107*
54108*           P was determined by a call to ZGEBRD with nq > k
54109*
54110            CALL ZUNMLQ( SIDE, TRANST, M, N, K, A, LDA, TAU, C, LDC,
54111     $                   WORK, LWORK, IINFO )
54112         ELSE IF( NQ.GT.1 ) THEN
54113*
54114*           P was determined by a call to ZGEBRD with nq <= k
54115*
54116            IF( LEFT ) THEN
54117               MI = M - 1
54118               NI = N
54119               I1 = 2
54120               I2 = 1
54121            ELSE
54122               MI = M
54123               NI = N - 1
54124               I1 = 1
54125               I2 = 2
54126            END IF
54127            CALL ZUNMLQ( SIDE, TRANST, MI, NI, NQ-1, A( 1, 2 ), LDA,
54128     $                   TAU, C( I1, I2 ), LDC, WORK, LWORK, IINFO )
54129         END IF
54130      END IF
54131      WORK( 1 ) = LWKOPT
54132      RETURN
54133*
54134*     End of ZUNMBR
54135*
54136      END
54137*> \brief \b ZUNMHR
54138*
54139*  =========== DOCUMENTATION ===========
54140*
54141* Online html documentation available at
54142*            http://www.netlib.org/lapack/explore-html/
54143*
54144*> \htmlonly
54145*> Download ZUNMHR + dependencies
54146*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zunmhr.f">
54147*> [TGZ]</a>
54148*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zunmhr.f">
54149*> [ZIP]</a>
54150*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zunmhr.f">
54151*> [TXT]</a>
54152*> \endhtmlonly
54153*
54154*  Definition:
54155*  ===========
54156*
54157*       SUBROUTINE ZUNMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C,
54158*                          LDC, WORK, LWORK, INFO )
54159*
54160*       .. Scalar Arguments ..
54161*       CHARACTER          SIDE, TRANS
54162*       INTEGER            IHI, ILO, INFO, LDA, LDC, LWORK, M, N
54163*       ..
54164*       .. Array Arguments ..
54165*       COMPLEX*16         A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
54166*       ..
54167*
54168*
54169*> \par Purpose:
54170*  =============
54171*>
54172*> \verbatim
54173*>
54174*> ZUNMHR overwrites the general complex M-by-N matrix C with
54175*>
54176*>                 SIDE = 'L'     SIDE = 'R'
54177*> TRANS = 'N':      Q * C          C * Q
54178*> TRANS = 'C':      Q**H * C       C * Q**H
54179*>
54180*> where Q is a complex unitary matrix of order nq, with nq = m if
54181*> SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
54182*> IHI-ILO elementary reflectors, as returned by ZGEHRD:
54183*>
54184*> Q = H(ilo) H(ilo+1) . . . H(ihi-1).
54185*> \endverbatim
54186*
54187*  Arguments:
54188*  ==========
54189*
54190*> \param[in] SIDE
54191*> \verbatim
54192*>          SIDE is CHARACTER*1
54193*>          = 'L': apply Q or Q**H from the Left;
54194*>          = 'R': apply Q or Q**H from the Right.
54195*> \endverbatim
54196*>
54197*> \param[in] TRANS
54198*> \verbatim
54199*>          TRANS is CHARACTER*1
54200*>          = 'N': apply Q  (No transpose)
54201*>          = 'C': apply Q**H (Conjugate transpose)
54202*> \endverbatim
54203*>
54204*> \param[in] M
54205*> \verbatim
54206*>          M is INTEGER
54207*>          The number of rows of the matrix C. M >= 0.
54208*> \endverbatim
54209*>
54210*> \param[in] N
54211*> \verbatim
54212*>          N is INTEGER
54213*>          The number of columns of the matrix C. N >= 0.
54214*> \endverbatim
54215*>
54216*> \param[in] ILO
54217*> \verbatim
54218*>          ILO is INTEGER
54219*> \endverbatim
54220*>
54221*> \param[in] IHI
54222*> \verbatim
54223*>          IHI is INTEGER
54224*>
54225*>          ILO and IHI must have the same values as in the previous call
54226*>          of ZGEHRD. Q is equal to the unit matrix except in the
54227*>          submatrix Q(ilo+1:ihi,ilo+1:ihi).
54228*>          If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and
54229*>          ILO = 1 and IHI = 0, if M = 0;
54230*>          if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and
54231*>          ILO = 1 and IHI = 0, if N = 0.
54232*> \endverbatim
54233*>
54234*> \param[in] A
54235*> \verbatim
54236*>          A is COMPLEX*16 array, dimension
54237*>                               (LDA,M) if SIDE = 'L'
54238*>                               (LDA,N) if SIDE = 'R'
54239*>          The vectors which define the elementary reflectors, as
54240*>          returned by ZGEHRD.
54241*> \endverbatim
54242*>
54243*> \param[in] LDA
54244*> \verbatim
54245*>          LDA is INTEGER
54246*>          The leading dimension of the array A.
54247*>          LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.
54248*> \endverbatim
54249*>
54250*> \param[in] TAU
54251*> \verbatim
54252*>          TAU is COMPLEX*16 array, dimension
54253*>                               (M-1) if SIDE = 'L'
54254*>                               (N-1) if SIDE = 'R'
54255*>          TAU(i) must contain the scalar factor of the elementary
54256*>          reflector H(i), as returned by ZGEHRD.
54257*> \endverbatim
54258*>
54259*> \param[in,out] C
54260*> \verbatim
54261*>          C is COMPLEX*16 array, dimension (LDC,N)
54262*>          On entry, the M-by-N matrix C.
54263*>          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
54264*> \endverbatim
54265*>
54266*> \param[in] LDC
54267*> \verbatim
54268*>          LDC is INTEGER
54269*>          The leading dimension of the array C. LDC >= max(1,M).
54270*> \endverbatim
54271*>
54272*> \param[out] WORK
54273*> \verbatim
54274*>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
54275*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
54276*> \endverbatim
54277*>
54278*> \param[in] LWORK
54279*> \verbatim
54280*>          LWORK is INTEGER
54281*>          The dimension of the array WORK.
54282*>          If SIDE = 'L', LWORK >= max(1,N);
54283*>          if SIDE = 'R', LWORK >= max(1,M).
54284*>          For optimum performance LWORK >= N*NB if SIDE = 'L', and
54285*>          LWORK >= M*NB if SIDE = 'R', where NB is the optimal
54286*>          blocksize.
54287*>
54288*>          If LWORK = -1, then a workspace query is assumed; the routine
54289*>          only calculates the optimal size of the WORK array, returns
54290*>          this value as the first entry of the WORK array, and no error
54291*>          message related to LWORK is issued by XERBLA.
54292*> \endverbatim
54293*>
54294*> \param[out] INFO
54295*> \verbatim
54296*>          INFO is INTEGER
54297*>          = 0:  successful exit
54298*>          < 0:  if INFO = -i, the i-th argument had an illegal value
54299*> \endverbatim
54300*
54301*  Authors:
54302*  ========
54303*
54304*> \author Univ. of Tennessee
54305*> \author Univ. of California Berkeley
54306*> \author Univ. of Colorado Denver
54307*> \author NAG Ltd.
54308*
54309*> \date December 2016
54310*
54311*> \ingroup complex16OTHERcomputational
54312*
54313*  =====================================================================
54314      SUBROUTINE ZUNMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C,
54315     $                   LDC, WORK, LWORK, INFO )
54316*
54317*  -- LAPACK computational routine (version 3.7.0) --
54318*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
54319*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
54320*     December 2016
54321*
54322*     .. Scalar Arguments ..
54323      CHARACTER          SIDE, TRANS
54324      INTEGER            IHI, ILO, INFO, LDA, LDC, LWORK, M, N
54325*     ..
54326*     .. Array Arguments ..
54327      COMPLEX*16         A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
54328*     ..
54329*
54330*  =====================================================================
54331*
54332*     .. Local Scalars ..
54333      LOGICAL            LEFT, LQUERY
54334      INTEGER            I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW
54335*     ..
54336*     .. External Functions ..
54337      LOGICAL            LSAME
54338      INTEGER            ILAENV
54339      EXTERNAL           LSAME, ILAENV
54340*     ..
54341*     .. External Subroutines ..
54342      EXTERNAL           XERBLA, ZUNMQR
54343*     ..
54344*     .. Intrinsic Functions ..
54345      INTRINSIC          MAX, MIN
54346*     ..
54347*     .. Executable Statements ..
54348*
54349*     Test the input arguments
54350*
54351      INFO = 0
54352      NH = IHI - ILO
54353      LEFT = LSAME( SIDE, 'L' )
54354      LQUERY = ( LWORK.EQ.-1 )
54355*
54356*     NQ is the order of Q and NW is the minimum dimension of WORK
54357*
54358      IF( LEFT ) THEN
54359         NQ = M
54360         NW = N
54361      ELSE
54362         NQ = N
54363         NW = M
54364      END IF
54365      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
54366         INFO = -1
54367      ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'C' ) )
54368     $          THEN
54369         INFO = -2
54370      ELSE IF( M.LT.0 ) THEN
54371         INFO = -3
54372      ELSE IF( N.LT.0 ) THEN
54373         INFO = -4
54374      ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, NQ ) ) THEN
54375         INFO = -5
54376      ELSE IF( IHI.LT.MIN( ILO, NQ ) .OR. IHI.GT.NQ ) THEN
54377         INFO = -6
54378      ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
54379         INFO = -8
54380      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
54381         INFO = -11
54382      ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
54383         INFO = -13
54384      END IF
54385*
54386      IF( INFO.EQ.0 ) THEN
54387         IF( LEFT ) THEN
54388            NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, NH, N, NH, -1 )
54389         ELSE
54390            NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, NH, NH, -1 )
54391         END IF
54392         LWKOPT = MAX( 1, NW )*NB
54393         WORK( 1 ) = LWKOPT
54394      END IF
54395*
54396      IF( INFO.NE.0 ) THEN
54397         CALL XERBLA( 'ZUNMHR', -INFO )
54398         RETURN
54399      ELSE IF( LQUERY ) THEN
54400         RETURN
54401      END IF
54402*
54403*     Quick return if possible
54404*
54405      IF( M.EQ.0 .OR. N.EQ.0 .OR. NH.EQ.0 ) THEN
54406         WORK( 1 ) = 1
54407         RETURN
54408      END IF
54409*
54410      IF( LEFT ) THEN
54411         MI = NH
54412         NI = N
54413         I1 = ILO + 1
54414         I2 = 1
54415      ELSE
54416         MI = M
54417         NI = NH
54418         I1 = 1
54419         I2 = ILO + 1
54420      END IF
54421*
54422      CALL ZUNMQR( SIDE, TRANS, MI, NI, NH, A( ILO+1, ILO ), LDA,
54423     $             TAU( ILO ), C( I1, I2 ), LDC, WORK, LWORK, IINFO )
54424*
54425      WORK( 1 ) = LWKOPT
54426      RETURN
54427*
54428*     End of ZUNMHR
54429*
54430      END
54431*> \brief \b ZUNML2 multiplies a general matrix by the unitary matrix from a LQ factorization determined by cgelqf (unblocked algorithm).
54432*
54433*  =========== DOCUMENTATION ===========
54434*
54435* Online html documentation available at
54436*            http://www.netlib.org/lapack/explore-html/
54437*
54438*> \htmlonly
54439*> Download ZUNML2 + dependencies
54440*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zunml2.f">
54441*> [TGZ]</a>
54442*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zunml2.f">
54443*> [ZIP]</a>
54444*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zunml2.f">
54445*> [TXT]</a>
54446*> \endhtmlonly
54447*
54448*  Definition:
54449*  ===========
54450*
54451*       SUBROUTINE ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
54452*                          WORK, INFO )
54453*
54454*       .. Scalar Arguments ..
54455*       CHARACTER          SIDE, TRANS
54456*       INTEGER            INFO, K, LDA, LDC, M, N
54457*       ..
54458*       .. Array Arguments ..
54459*       COMPLEX*16         A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
54460*       ..
54461*
54462*
54463*> \par Purpose:
54464*  =============
54465*>
54466*> \verbatim
54467*>
54468*> ZUNML2 overwrites the general complex m-by-n matrix C with
54469*>
54470*>       Q * C  if SIDE = 'L' and TRANS = 'N', or
54471*>
54472*>       Q**H* C  if SIDE = 'L' and TRANS = 'C', or
54473*>
54474*>       C * Q  if SIDE = 'R' and TRANS = 'N', or
54475*>
54476*>       C * Q**H if SIDE = 'R' and TRANS = 'C',
54477*>
54478*> where Q is a complex unitary matrix defined as the product of k
54479*> elementary reflectors
54480*>
54481*>       Q = H(k)**H . . . H(2)**H H(1)**H
54482*>
54483*> as returned by ZGELQF. Q is of order m if SIDE = 'L' and of order n
54484*> if SIDE = 'R'.
54485*> \endverbatim
54486*
54487*  Arguments:
54488*  ==========
54489*
54490*> \param[in] SIDE
54491*> \verbatim
54492*>          SIDE is CHARACTER*1
54493*>          = 'L': apply Q or Q**H from the Left
54494*>          = 'R': apply Q or Q**H from the Right
54495*> \endverbatim
54496*>
54497*> \param[in] TRANS
54498*> \verbatim
54499*>          TRANS is CHARACTER*1
54500*>          = 'N': apply Q  (No transpose)
54501*>          = 'C': apply Q**H (Conjugate transpose)
54502*> \endverbatim
54503*>
54504*> \param[in] M
54505*> \verbatim
54506*>          M is INTEGER
54507*>          The number of rows of the matrix C. M >= 0.
54508*> \endverbatim
54509*>
54510*> \param[in] N
54511*> \verbatim
54512*>          N is INTEGER
54513*>          The number of columns of the matrix C. N >= 0.
54514*> \endverbatim
54515*>
54516*> \param[in] K
54517*> \verbatim
54518*>          K is INTEGER
54519*>          The number of elementary reflectors whose product defines
54520*>          the matrix Q.
54521*>          If SIDE = 'L', M >= K >= 0;
54522*>          if SIDE = 'R', N >= K >= 0.
54523*> \endverbatim
54524*>
54525*> \param[in] A
54526*> \verbatim
54527*>          A is COMPLEX*16 array, dimension
54528*>                               (LDA,M) if SIDE = 'L',
54529*>                               (LDA,N) if SIDE = 'R'
54530*>          The i-th row must contain the vector which defines the
54531*>          elementary reflector H(i), for i = 1,2,...,k, as returned by
54532*>          ZGELQF in the first k rows of its array argument A.
54533*>          A is modified by the routine but restored on exit.
54534*> \endverbatim
54535*>
54536*> \param[in] LDA
54537*> \verbatim
54538*>          LDA is INTEGER
54539*>          The leading dimension of the array A. LDA >= max(1,K).
54540*> \endverbatim
54541*>
54542*> \param[in] TAU
54543*> \verbatim
54544*>          TAU is COMPLEX*16 array, dimension (K)
54545*>          TAU(i) must contain the scalar factor of the elementary
54546*>          reflector H(i), as returned by ZGELQF.
54547*> \endverbatim
54548*>
54549*> \param[in,out] C
54550*> \verbatim
54551*>          C is COMPLEX*16 array, dimension (LDC,N)
54552*>          On entry, the m-by-n matrix C.
54553*>          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
54554*> \endverbatim
54555*>
54556*> \param[in] LDC
54557*> \verbatim
54558*>          LDC is INTEGER
54559*>          The leading dimension of the array C. LDC >= max(1,M).
54560*> \endverbatim
54561*>
54562*> \param[out] WORK
54563*> \verbatim
54564*>          WORK is COMPLEX*16 array, dimension
54565*>                                   (N) if SIDE = 'L',
54566*>                                   (M) if SIDE = 'R'
54567*> \endverbatim
54568*>
54569*> \param[out] INFO
54570*> \verbatim
54571*>          INFO is INTEGER
54572*>          = 0: successful exit
54573*>          < 0: if INFO = -i, the i-th argument had an illegal value
54574*> \endverbatim
54575*
54576*  Authors:
54577*  ========
54578*
54579*> \author Univ. of Tennessee
54580*> \author Univ. of California Berkeley
54581*> \author Univ. of Colorado Denver
54582*> \author NAG Ltd.
54583*
54584*> \date December 2016
54585*
54586*> \ingroup complex16OTHERcomputational
54587*
54588*  =====================================================================
54589      SUBROUTINE ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
54590     $                   WORK, INFO )
54591*
54592*  -- LAPACK computational routine (version 3.7.0) --
54593*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
54594*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
54595*     December 2016
54596*
54597*     .. Scalar Arguments ..
54598      CHARACTER          SIDE, TRANS
54599      INTEGER            INFO, K, LDA, LDC, M, N
54600*     ..
54601*     .. Array Arguments ..
54602      COMPLEX*16         A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
54603*     ..
54604*
54605*  =====================================================================
54606*
54607*     .. Parameters ..
54608      COMPLEX*16         ONE
54609      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
54610*     ..
54611*     .. Local Scalars ..
54612      LOGICAL            LEFT, NOTRAN
54613      INTEGER            I, I1, I2, I3, IC, JC, MI, NI, NQ
54614      COMPLEX*16         AII, TAUI
54615*     ..
54616*     .. External Functions ..
54617      LOGICAL            LSAME
54618      EXTERNAL           LSAME
54619*     ..
54620*     .. External Subroutines ..
54621      EXTERNAL           XERBLA, ZLACGV, ZLARF
54622*     ..
54623*     .. Intrinsic Functions ..
54624      INTRINSIC          DCONJG, MAX
54625*     ..
54626*     .. Executable Statements ..
54627*
54628*     Test the input arguments
54629*
54630      INFO = 0
54631      LEFT = LSAME( SIDE, 'L' )
54632      NOTRAN = LSAME( TRANS, 'N' )
54633*
54634*     NQ is the order of Q
54635*
54636      IF( LEFT ) THEN
54637         NQ = M
54638      ELSE
54639         NQ = N
54640      END IF
54641      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
54642         INFO = -1
54643      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
54644         INFO = -2
54645      ELSE IF( M.LT.0 ) THEN
54646         INFO = -3
54647      ELSE IF( N.LT.0 ) THEN
54648         INFO = -4
54649      ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
54650         INFO = -5
54651      ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
54652         INFO = -7
54653      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
54654         INFO = -10
54655      END IF
54656      IF( INFO.NE.0 ) THEN
54657         CALL XERBLA( 'ZUNML2', -INFO )
54658         RETURN
54659      END IF
54660*
54661*     Quick return if possible
54662*
54663      IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
54664     $   RETURN
54665*
54666      IF( ( LEFT .AND. NOTRAN .OR. .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN
54667         I1 = 1
54668         I2 = K
54669         I3 = 1
54670      ELSE
54671         I1 = K
54672         I2 = 1
54673         I3 = -1
54674      END IF
54675*
54676      IF( LEFT ) THEN
54677         NI = N
54678         JC = 1
54679      ELSE
54680         MI = M
54681         IC = 1
54682      END IF
54683*
54684      DO 10 I = I1, I2, I3
54685         IF( LEFT ) THEN
54686*
54687*           H(i) or H(i)**H is applied to C(i:m,1:n)
54688*
54689            MI = M - I + 1
54690            IC = I
54691         ELSE
54692*
54693*           H(i) or H(i)**H is applied to C(1:m,i:n)
54694*
54695            NI = N - I + 1
54696            JC = I
54697         END IF
54698*
54699*        Apply H(i) or H(i)**H
54700*
54701         IF( NOTRAN ) THEN
54702            TAUI = DCONJG( TAU( I ) )
54703         ELSE
54704            TAUI = TAU( I )
54705         END IF
54706         IF( I.LT.NQ )
54707     $      CALL ZLACGV( NQ-I, A( I, I+1 ), LDA )
54708         AII = A( I, I )
54709         A( I, I ) = ONE
54710         CALL ZLARF( SIDE, MI, NI, A( I, I ), LDA, TAUI, C( IC, JC ),
54711     $               LDC, WORK )
54712         A( I, I ) = AII
54713         IF( I.LT.NQ )
54714     $      CALL ZLACGV( NQ-I, A( I, I+1 ), LDA )
54715   10 CONTINUE
54716      RETURN
54717*
54718*     End of ZUNML2
54719*
54720      END
54721*> \brief \b ZUNMLQ
54722*
54723*  =========== DOCUMENTATION ===========
54724*
54725* Online html documentation available at
54726*            http://www.netlib.org/lapack/explore-html/
54727*
54728*> \htmlonly
54729*> Download ZUNMLQ + dependencies
54730*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zunmlq.f">
54731*> [TGZ]</a>
54732*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zunmlq.f">
54733*> [ZIP]</a>
54734*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zunmlq.f">
54735*> [TXT]</a>
54736*> \endhtmlonly
54737*
54738*  Definition:
54739*  ===========
54740*
54741*       SUBROUTINE ZUNMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
54742*                          WORK, LWORK, INFO )
54743*
54744*       .. Scalar Arguments ..
54745*       CHARACTER          SIDE, TRANS
54746*       INTEGER            INFO, K, LDA, LDC, LWORK, M, N
54747*       ..
54748*       .. Array Arguments ..
54749*       COMPLEX*16         A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
54750*       ..
54751*
54752*
54753*> \par Purpose:
54754*  =============
54755*>
54756*> \verbatim
54757*>
54758*> ZUNMLQ overwrites the general complex M-by-N matrix C with
54759*>
54760*>                 SIDE = 'L'     SIDE = 'R'
54761*> TRANS = 'N':      Q * C          C * Q
54762*> TRANS = 'C':      Q**H * C       C * Q**H
54763*>
54764*> where Q is a complex unitary matrix defined as the product of k
54765*> elementary reflectors
54766*>
54767*>       Q = H(k)**H . . . H(2)**H H(1)**H
54768*>
54769*> as returned by ZGELQF. Q is of order M if SIDE = 'L' and of order N
54770*> if SIDE = 'R'.
54771*> \endverbatim
54772*
54773*  Arguments:
54774*  ==========
54775*
54776*> \param[in] SIDE
54777*> \verbatim
54778*>          SIDE is CHARACTER*1
54779*>          = 'L': apply Q or Q**H from the Left;
54780*>          = 'R': apply Q or Q**H from the Right.
54781*> \endverbatim
54782*>
54783*> \param[in] TRANS
54784*> \verbatim
54785*>          TRANS is CHARACTER*1
54786*>          = 'N':  No transpose, apply Q;
54787*>          = 'C':  Conjugate transpose, apply Q**H.
54788*> \endverbatim
54789*>
54790*> \param[in] M
54791*> \verbatim
54792*>          M is INTEGER
54793*>          The number of rows of the matrix C. M >= 0.
54794*> \endverbatim
54795*>
54796*> \param[in] N
54797*> \verbatim
54798*>          N is INTEGER
54799*>          The number of columns of the matrix C. N >= 0.
54800*> \endverbatim
54801*>
54802*> \param[in] K
54803*> \verbatim
54804*>          K is INTEGER
54805*>          The number of elementary reflectors whose product defines
54806*>          the matrix Q.
54807*>          If SIDE = 'L', M >= K >= 0;
54808*>          if SIDE = 'R', N >= K >= 0.
54809*> \endverbatim
54810*>
54811*> \param[in] A
54812*> \verbatim
54813*>          A is COMPLEX*16 array, dimension
54814*>                               (LDA,M) if SIDE = 'L',
54815*>                               (LDA,N) if SIDE = 'R'
54816*>          The i-th row must contain the vector which defines the
54817*>          elementary reflector H(i), for i = 1,2,...,k, as returned by
54818*>          ZGELQF in the first k rows of its array argument A.
54819*> \endverbatim
54820*>
54821*> \param[in] LDA
54822*> \verbatim
54823*>          LDA is INTEGER
54824*>          The leading dimension of the array A. LDA >= max(1,K).
54825*> \endverbatim
54826*>
54827*> \param[in] TAU
54828*> \verbatim
54829*>          TAU is COMPLEX*16 array, dimension (K)
54830*>          TAU(i) must contain the scalar factor of the elementary
54831*>          reflector H(i), as returned by ZGELQF.
54832*> \endverbatim
54833*>
54834*> \param[in,out] C
54835*> \verbatim
54836*>          C is COMPLEX*16 array, dimension (LDC,N)
54837*>          On entry, the M-by-N matrix C.
54838*>          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
54839*> \endverbatim
54840*>
54841*> \param[in] LDC
54842*> \verbatim
54843*>          LDC is INTEGER
54844*>          The leading dimension of the array C. LDC >= max(1,M).
54845*> \endverbatim
54846*>
54847*> \param[out] WORK
54848*> \verbatim
54849*>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
54850*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
54851*> \endverbatim
54852*>
54853*> \param[in] LWORK
54854*> \verbatim
54855*>          LWORK is INTEGER
54856*>          The dimension of the array WORK.
54857*>          If SIDE = 'L', LWORK >= max(1,N);
54858*>          if SIDE = 'R', LWORK >= max(1,M).
54859*>          For good performance, LWORK should generally be larger.
54860*>
54861*>          If LWORK = -1, then a workspace query is assumed; the routine
54862*>          only calculates the optimal size of the WORK array, returns
54863*>          this value as the first entry of the WORK array, and no error
54864*>          message related to LWORK is issued by XERBLA.
54865*> \endverbatim
54866*>
54867*> \param[out] INFO
54868*> \verbatim
54869*>          INFO is INTEGER
54870*>          = 0:  successful exit
54871*>          < 0:  if INFO = -i, the i-th argument had an illegal value
54872*> \endverbatim
54873*
54874*  Authors:
54875*  ========
54876*
54877*> \author Univ. of Tennessee
54878*> \author Univ. of California Berkeley
54879*> \author Univ. of Colorado Denver
54880*> \author NAG Ltd.
54881*
54882*> \date December 2016
54883*
54884*> \ingroup complex16OTHERcomputational
54885*
54886*  =====================================================================
54887      SUBROUTINE ZUNMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
54888     $                   WORK, LWORK, INFO )
54889*
54890*  -- LAPACK computational routine (version 3.7.0) --
54891*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
54892*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
54893*     December 2016
54894*
54895*     .. Scalar Arguments ..
54896      CHARACTER          SIDE, TRANS
54897      INTEGER            INFO, K, LDA, LDC, LWORK, M, N
54898*     ..
54899*     .. Array Arguments ..
54900      COMPLEX*16         A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
54901*     ..
54902*
54903*  =====================================================================
54904*
54905*     .. Parameters ..
54906      INTEGER            NBMAX, LDT, TSIZE
54907      PARAMETER          ( NBMAX = 64, LDT = NBMAX+1,
54908     $                     TSIZE = LDT*NBMAX )
54909*     ..
54910*     .. Local Scalars ..
54911      LOGICAL            LEFT, LQUERY, NOTRAN
54912      CHARACTER          TRANST
54913      INTEGER            I, I1, I2, I3, IB, IC, IINFO, IWT, JC, LDWORK,
54914     $                   LWKOPT, MI, NB, NBMIN, NI, NQ, NW
54915*     ..
54916*     .. External Functions ..
54917      LOGICAL            LSAME
54918      INTEGER            ILAENV
54919      EXTERNAL           LSAME, ILAENV
54920*     ..
54921*     .. External Subroutines ..
54922      EXTERNAL           XERBLA, ZLARFB, ZLARFT, ZUNML2
54923*     ..
54924*     .. Intrinsic Functions ..
54925      INTRINSIC          MAX, MIN
54926*     ..
54927*     .. Executable Statements ..
54928*
54929*     Test the input arguments
54930*
54931      INFO = 0
54932      LEFT = LSAME( SIDE, 'L' )
54933      NOTRAN = LSAME( TRANS, 'N' )
54934      LQUERY = ( LWORK.EQ.-1 )
54935*
54936*     NQ is the order of Q and NW is the minimum dimension of WORK
54937*
54938      IF( LEFT ) THEN
54939         NQ = M
54940         NW = N
54941      ELSE
54942         NQ = N
54943         NW = M
54944      END IF
54945      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
54946         INFO = -1
54947      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
54948         INFO = -2
54949      ELSE IF( M.LT.0 ) THEN
54950         INFO = -3
54951      ELSE IF( N.LT.0 ) THEN
54952         INFO = -4
54953      ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
54954         INFO = -5
54955      ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
54956         INFO = -7
54957      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
54958         INFO = -10
54959      ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
54960         INFO = -12
54961      END IF
54962*
54963      IF( INFO.EQ.0 ) THEN
54964*
54965*        Compute the workspace requirements
54966*
54967         NB = MIN( NBMAX, ILAENV( 1, 'ZUNMLQ', SIDE // TRANS, M, N, K,
54968     $        -1 ) )
54969         LWKOPT = MAX( 1, NW )*NB + TSIZE
54970         WORK( 1 ) = LWKOPT
54971      END IF
54972*
54973      IF( INFO.NE.0 ) THEN
54974         CALL XERBLA( 'ZUNMLQ', -INFO )
54975         RETURN
54976      ELSE IF( LQUERY ) THEN
54977         RETURN
54978      END IF
54979*
54980*     Quick return if possible
54981*
54982      IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN
54983         WORK( 1 ) = 1
54984         RETURN
54985      END IF
54986*
54987      NBMIN = 2
54988      LDWORK = NW
54989      IF( NB.GT.1 .AND. NB.LT.K ) THEN
54990         IF( LWORK.LT.NW*NB+TSIZE ) THEN
54991            NB = (LWORK-TSIZE) / LDWORK
54992            NBMIN = MAX( 2, ILAENV( 2, 'ZUNMLQ', SIDE // TRANS, M, N, K,
54993     $              -1 ) )
54994         END IF
54995      END IF
54996*
54997      IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
54998*
54999*        Use unblocked code
55000*
55001         CALL ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK,
55002     $                IINFO )
55003      ELSE
55004*
55005*        Use blocked code
55006*
55007         IWT = 1 + NW*NB
55008         IF( ( LEFT .AND. NOTRAN ) .OR.
55009     $       ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN
55010            I1 = 1
55011            I2 = K
55012            I3 = NB
55013         ELSE
55014            I1 = ( ( K-1 ) / NB )*NB + 1
55015            I2 = 1
55016            I3 = -NB
55017         END IF
55018*
55019         IF( LEFT ) THEN
55020            NI = N
55021            JC = 1
55022         ELSE
55023            MI = M
55024            IC = 1
55025         END IF
55026*
55027         IF( NOTRAN ) THEN
55028            TRANST = 'C'
55029         ELSE
55030            TRANST = 'N'
55031         END IF
55032*
55033         DO 10 I = I1, I2, I3
55034            IB = MIN( NB, K-I+1 )
55035*
55036*           Form the triangular factor of the block reflector
55037*           H = H(i) H(i+1) . . . H(i+ib-1)
55038*
55039            CALL ZLARFT( 'Forward', 'Rowwise', NQ-I+1, IB, A( I, I ),
55040     $                   LDA, TAU( I ), WORK( IWT ), LDT )
55041            IF( LEFT ) THEN
55042*
55043*              H or H**H is applied to C(i:m,1:n)
55044*
55045               MI = M - I + 1
55046               IC = I
55047            ELSE
55048*
55049*              H or H**H is applied to C(1:m,i:n)
55050*
55051               NI = N - I + 1
55052               JC = I
55053            END IF
55054*
55055*           Apply H or H**H
55056*
55057            CALL ZLARFB( SIDE, TRANST, 'Forward', 'Rowwise', MI, NI, IB,
55058     $                   A( I, I ), LDA, WORK( IWT ), LDT,
55059     $                   C( IC, JC ), LDC, WORK, LDWORK )
55060   10    CONTINUE
55061      END IF
55062      WORK( 1 ) = LWKOPT
55063      RETURN
55064*
55065*     End of ZUNMLQ
55066*
55067      END
55068*> \brief \b ZUNMQL
55069*
55070*  =========== DOCUMENTATION ===========
55071*
55072* Online html documentation available at
55073*            http://www.netlib.org/lapack/explore-html/
55074*
55075*> \htmlonly
55076*> Download ZUNMQL + dependencies
55077*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zunmql.f">
55078*> [TGZ]</a>
55079*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zunmql.f">
55080*> [ZIP]</a>
55081*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zunmql.f">
55082*> [TXT]</a>
55083*> \endhtmlonly
55084*
55085*  Definition:
55086*  ===========
55087*
55088*       SUBROUTINE ZUNMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
55089*                          WORK, LWORK, INFO )
55090*
55091*       .. Scalar Arguments ..
55092*       CHARACTER          SIDE, TRANS
55093*       INTEGER            INFO, K, LDA, LDC, LWORK, M, N
55094*       ..
55095*       .. Array Arguments ..
55096*       COMPLEX*16         A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
55097*       ..
55098*
55099*
55100*> \par Purpose:
55101*  =============
55102*>
55103*> \verbatim
55104*>
55105*> ZUNMQL overwrites the general complex M-by-N matrix C with
55106*>
55107*>                 SIDE = 'L'     SIDE = 'R'
55108*> TRANS = 'N':      Q * C          C * Q
55109*> TRANS = 'C':      Q**H * C       C * Q**H
55110*>
55111*> where Q is a complex unitary matrix defined as the product of k
55112*> elementary reflectors
55113*>
55114*>       Q = H(k) . . . H(2) H(1)
55115*>
55116*> as returned by ZGEQLF. Q is of order M if SIDE = 'L' and of order N
55117*> if SIDE = 'R'.
55118*> \endverbatim
55119*
55120*  Arguments:
55121*  ==========
55122*
55123*> \param[in] SIDE
55124*> \verbatim
55125*>          SIDE is CHARACTER*1
55126*>          = 'L': apply Q or Q**H from the Left;
55127*>          = 'R': apply Q or Q**H from the Right.
55128*> \endverbatim
55129*>
55130*> \param[in] TRANS
55131*> \verbatim
55132*>          TRANS is CHARACTER*1
55133*>          = 'N':  No transpose, apply Q;
55134*>          = 'C':  Transpose, apply Q**H.
55135*> \endverbatim
55136*>
55137*> \param[in] M
55138*> \verbatim
55139*>          M is INTEGER
55140*>          The number of rows of the matrix C. M >= 0.
55141*> \endverbatim
55142*>
55143*> \param[in] N
55144*> \verbatim
55145*>          N is INTEGER
55146*>          The number of columns of the matrix C. N >= 0.
55147*> \endverbatim
55148*>
55149*> \param[in] K
55150*> \verbatim
55151*>          K is INTEGER
55152*>          The number of elementary reflectors whose product defines
55153*>          the matrix Q.
55154*>          If SIDE = 'L', M >= K >= 0;
55155*>          if SIDE = 'R', N >= K >= 0.
55156*> \endverbatim
55157*>
55158*> \param[in] A
55159*> \verbatim
55160*>          A is COMPLEX*16 array, dimension (LDA,K)
55161*>          The i-th column must contain the vector which defines the
55162*>          elementary reflector H(i), for i = 1,2,...,k, as returned by
55163*>          ZGEQLF in the last k columns of its array argument A.
55164*> \endverbatim
55165*>
55166*> \param[in] LDA
55167*> \verbatim
55168*>          LDA is INTEGER
55169*>          The leading dimension of the array A.
55170*>          If SIDE = 'L', LDA >= max(1,M);
55171*>          if SIDE = 'R', LDA >= max(1,N).
55172*> \endverbatim
55173*>
55174*> \param[in] TAU
55175*> \verbatim
55176*>          TAU is COMPLEX*16 array, dimension (K)
55177*>          TAU(i) must contain the scalar factor of the elementary
55178*>          reflector H(i), as returned by ZGEQLF.
55179*> \endverbatim
55180*>
55181*> \param[in,out] C
55182*> \verbatim
55183*>          C is COMPLEX*16 array, dimension (LDC,N)
55184*>          On entry, the M-by-N matrix C.
55185*>          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
55186*> \endverbatim
55187*>
55188*> \param[in] LDC
55189*> \verbatim
55190*>          LDC is INTEGER
55191*>          The leading dimension of the array C. LDC >= max(1,M).
55192*> \endverbatim
55193*>
55194*> \param[out] WORK
55195*> \verbatim
55196*>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
55197*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
55198*> \endverbatim
55199*>
55200*> \param[in] LWORK
55201*> \verbatim
55202*>          LWORK is INTEGER
55203*>          The dimension of the array WORK.
55204*>          If SIDE = 'L', LWORK >= max(1,N);
55205*>          if SIDE = 'R', LWORK >= max(1,M).
55206*>          For good performance, LWORK should genreally be larger.
55207*>
55208*>          If LWORK = -1, then a workspace query is assumed; the routine
55209*>          only calculates the optimal size of the WORK array, returns
55210*>          this value as the first entry of the WORK array, and no error
55211*>          message related to LWORK is issued by XERBLA.
55212*> \endverbatim
55213*>
55214*> \param[out] INFO
55215*> \verbatim
55216*>          INFO is INTEGER
55217*>          = 0:  successful exit
55218*>          < 0:  if INFO = -i, the i-th argument had an illegal value
55219*> \endverbatim
55220*
55221*  Authors:
55222*  ========
55223*
55224*> \author Univ. of Tennessee
55225*> \author Univ. of California Berkeley
55226*> \author Univ. of Colorado Denver
55227*> \author NAG Ltd.
55228*
55229*> \date December 2016
55230*
55231*> \ingroup complex16OTHERcomputational
55232*
55233*  =====================================================================
55234      SUBROUTINE ZUNMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
55235     $                   WORK, LWORK, INFO )
55236*
55237*  -- LAPACK computational routine (version 3.7.0) --
55238*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
55239*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
55240*     December 2016
55241*
55242*     .. Scalar Arguments ..
55243      CHARACTER          SIDE, TRANS
55244      INTEGER            INFO, K, LDA, LDC, LWORK, M, N
55245*     ..
55246*     .. Array Arguments ..
55247      COMPLEX*16         A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
55248*     ..
55249*
55250*  =====================================================================
55251*
55252*     .. Parameters ..
55253      INTEGER            NBMAX, LDT, TSIZE
55254      PARAMETER          ( NBMAX = 64, LDT = NBMAX+1,
55255     $                     TSIZE = LDT*NBMAX )
55256*     ..
55257*     .. Local Scalars ..
55258      LOGICAL            LEFT, LQUERY, NOTRAN
55259      INTEGER            I, I1, I2, I3, IB, IINFO, IWT, LDWORK, LWKOPT,
55260     $                   MI, NB, NBMIN, NI, NQ, NW
55261*     ..
55262*     .. External Functions ..
55263      LOGICAL            LSAME
55264      INTEGER            ILAENV
55265      EXTERNAL           LSAME, ILAENV
55266*     ..
55267*     .. External Subroutines ..
55268      EXTERNAL           XERBLA, ZLARFB, ZLARFT, ZUNM2L
55269*     ..
55270*     .. Intrinsic Functions ..
55271      INTRINSIC          MAX, MIN
55272*     ..
55273*     .. Executable Statements ..
55274*
55275*     Test the input arguments
55276*
55277      INFO = 0
55278      LEFT = LSAME( SIDE, 'L' )
55279      NOTRAN = LSAME( TRANS, 'N' )
55280      LQUERY = ( LWORK.EQ.-1 )
55281*
55282*     NQ is the order of Q and NW is the minimum dimension of WORK
55283*
55284      IF( LEFT ) THEN
55285         NQ = M
55286         NW = MAX( 1, N )
55287      ELSE
55288         NQ = N
55289         NW = MAX( 1, M )
55290      END IF
55291      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
55292         INFO = -1
55293      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
55294         INFO = -2
55295      ELSE IF( M.LT.0 ) THEN
55296         INFO = -3
55297      ELSE IF( N.LT.0 ) THEN
55298         INFO = -4
55299      ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
55300         INFO = -5
55301      ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
55302         INFO = -7
55303      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
55304         INFO = -10
55305      ELSE IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN
55306         INFO = -12
55307      END IF
55308*
55309      IF( INFO.EQ.0 ) THEN
55310*
55311*        Compute the workspace requirements
55312*
55313         IF( M.EQ.0 .OR. N.EQ.0 ) THEN
55314            LWKOPT = 1
55315         ELSE
55316            NB = MIN( NBMAX, ILAENV( 1, 'ZUNMQL', SIDE // TRANS, M, N,
55317     $                               K, -1 ) )
55318            LWKOPT = NW*NB + TSIZE
55319         END IF
55320         WORK( 1 ) = LWKOPT
55321      END IF
55322*
55323      IF( INFO.NE.0 ) THEN
55324         CALL XERBLA( 'ZUNMQL', -INFO )
55325         RETURN
55326      ELSE IF( LQUERY ) THEN
55327         RETURN
55328      END IF
55329*
55330*     Quick return if possible
55331*
55332      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
55333         RETURN
55334      END IF
55335*
55336      NBMIN = 2
55337      LDWORK = NW
55338      IF( NB.GT.1 .AND. NB.LT.K ) THEN
55339         IF( LWORK.LT.NW*NB+TSIZE ) THEN
55340            NB = (LWORK-TSIZE) / LDWORK
55341            NBMIN = MAX( 2, ILAENV( 2, 'ZUNMQL', SIDE // TRANS, M, N, K,
55342     $              -1 ) )
55343         END IF
55344      END IF
55345*
55346      IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
55347*
55348*        Use unblocked code
55349*
55350         CALL ZUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK,
55351     $                IINFO )
55352      ELSE
55353*
55354*        Use blocked code
55355*
55356         IWT = 1 + NW*NB
55357         IF( ( LEFT .AND. NOTRAN ) .OR.
55358     $       ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN
55359            I1 = 1
55360            I2 = K
55361            I3 = NB
55362         ELSE
55363            I1 = ( ( K-1 ) / NB )*NB + 1
55364            I2 = 1
55365            I3 = -NB
55366         END IF
55367*
55368         IF( LEFT ) THEN
55369            NI = N
55370         ELSE
55371            MI = M
55372         END IF
55373*
55374         DO 10 I = I1, I2, I3
55375            IB = MIN( NB, K-I+1 )
55376*
55377*           Form the triangular factor of the block reflector
55378*           H = H(i+ib-1) . . . H(i+1) H(i)
55379*
55380            CALL ZLARFT( 'Backward', 'Columnwise', NQ-K+I+IB-1, IB,
55381     $                   A( 1, I ), LDA, TAU( I ), WORK( IWT ), LDT )
55382            IF( LEFT ) THEN
55383*
55384*              H or H**H is applied to C(1:m-k+i+ib-1,1:n)
55385*
55386               MI = M - K + I + IB - 1
55387            ELSE
55388*
55389*              H or H**H is applied to C(1:m,1:n-k+i+ib-1)
55390*
55391               NI = N - K + I + IB - 1
55392            END IF
55393*
55394*           Apply H or H**H
55395*
55396            CALL ZLARFB( SIDE, TRANS, 'Backward', 'Columnwise', MI, NI,
55397     $                   IB, A( 1, I ), LDA, WORK( IWT ), LDT, C, LDC,
55398     $                   WORK, LDWORK )
55399   10    CONTINUE
55400      END IF
55401      WORK( 1 ) = LWKOPT
55402      RETURN
55403*
55404*     End of ZUNMQL
55405*
55406      END
55407*> \brief \b ZUNMQR
55408*
55409*  =========== DOCUMENTATION ===========
55410*
55411* Online html documentation available at
55412*            http://www.netlib.org/lapack/explore-html/
55413*
55414*> \htmlonly
55415*> Download ZUNMQR + dependencies
55416*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zunmqr.f">
55417*> [TGZ]</a>
55418*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zunmqr.f">
55419*> [ZIP]</a>
55420*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zunmqr.f">
55421*> [TXT]</a>
55422*> \endhtmlonly
55423*
55424*  Definition:
55425*  ===========
55426*
55427*       SUBROUTINE ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
55428*                          WORK, LWORK, INFO )
55429*
55430*       .. Scalar Arguments ..
55431*       CHARACTER          SIDE, TRANS
55432*       INTEGER            INFO, K, LDA, LDC, LWORK, M, N
55433*       ..
55434*       .. Array Arguments ..
55435*       COMPLEX*16         A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
55436*       ..
55437*
55438*
55439*> \par Purpose:
55440*  =============
55441*>
55442*> \verbatim
55443*>
55444*> ZUNMQR overwrites the general complex M-by-N matrix C with
55445*>
55446*>                 SIDE = 'L'     SIDE = 'R'
55447*> TRANS = 'N':      Q * C          C * Q
55448*> TRANS = 'C':      Q**H * C       C * Q**H
55449*>
55450*> where Q is a complex unitary matrix defined as the product of k
55451*> elementary reflectors
55452*>
55453*>       Q = H(1) H(2) . . . H(k)
55454*>
55455*> as returned by ZGEQRF. Q is of order M if SIDE = 'L' and of order N
55456*> if SIDE = 'R'.
55457*> \endverbatim
55458*
55459*  Arguments:
55460*  ==========
55461*
55462*> \param[in] SIDE
55463*> \verbatim
55464*>          SIDE is CHARACTER*1
55465*>          = 'L': apply Q or Q**H from the Left;
55466*>          = 'R': apply Q or Q**H from the Right.
55467*> \endverbatim
55468*>
55469*> \param[in] TRANS
55470*> \verbatim
55471*>          TRANS is CHARACTER*1
55472*>          = 'N':  No transpose, apply Q;
55473*>          = 'C':  Conjugate transpose, apply Q**H.
55474*> \endverbatim
55475*>
55476*> \param[in] M
55477*> \verbatim
55478*>          M is INTEGER
55479*>          The number of rows of the matrix C. M >= 0.
55480*> \endverbatim
55481*>
55482*> \param[in] N
55483*> \verbatim
55484*>          N is INTEGER
55485*>          The number of columns of the matrix C. N >= 0.
55486*> \endverbatim
55487*>
55488*> \param[in] K
55489*> \verbatim
55490*>          K is INTEGER
55491*>          The number of elementary reflectors whose product defines
55492*>          the matrix Q.
55493*>          If SIDE = 'L', M >= K >= 0;
55494*>          if SIDE = 'R', N >= K >= 0.
55495*> \endverbatim
55496*>
55497*> \param[in] A
55498*> \verbatim
55499*>          A is COMPLEX*16 array, dimension (LDA,K)
55500*>          The i-th column must contain the vector which defines the
55501*>          elementary reflector H(i), for i = 1,2,...,k, as returned by
55502*>          ZGEQRF in the first k columns of its array argument A.
55503*> \endverbatim
55504*>
55505*> \param[in] LDA
55506*> \verbatim
55507*>          LDA is INTEGER
55508*>          The leading dimension of the array A.
55509*>          If SIDE = 'L', LDA >= max(1,M);
55510*>          if SIDE = 'R', LDA >= max(1,N).
55511*> \endverbatim
55512*>
55513*> \param[in] TAU
55514*> \verbatim
55515*>          TAU is COMPLEX*16 array, dimension (K)
55516*>          TAU(i) must contain the scalar factor of the elementary
55517*>          reflector H(i), as returned by ZGEQRF.
55518*> \endverbatim
55519*>
55520*> \param[in,out] C
55521*> \verbatim
55522*>          C is COMPLEX*16 array, dimension (LDC,N)
55523*>          On entry, the M-by-N matrix C.
55524*>          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
55525*> \endverbatim
55526*>
55527*> \param[in] LDC
55528*> \verbatim
55529*>          LDC is INTEGER
55530*>          The leading dimension of the array C. LDC >= max(1,M).
55531*> \endverbatim
55532*>
55533*> \param[out] WORK
55534*> \verbatim
55535*>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
55536*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
55537*> \endverbatim
55538*>
55539*> \param[in] LWORK
55540*> \verbatim
55541*>          LWORK is INTEGER
55542*>          The dimension of the array WORK.
55543*>          If SIDE = 'L', LWORK >= max(1,N);
55544*>          if SIDE = 'R', LWORK >= max(1,M).
55545*>          For good performance, LWORK should generally be larger.
55546*>
55547*>          If LWORK = -1, then a workspace query is assumed; the routine
55548*>          only calculates the optimal size of the WORK array, returns
55549*>          this value as the first entry of the WORK array, and no error
55550*>          message related to LWORK is issued by XERBLA.
55551*> \endverbatim
55552*>
55553*> \param[out] INFO
55554*> \verbatim
55555*>          INFO is INTEGER
55556*>          = 0:  successful exit
55557*>          < 0:  if INFO = -i, the i-th argument had an illegal value
55558*> \endverbatim
55559*
55560*  Authors:
55561*  ========
55562*
55563*> \author Univ. of Tennessee
55564*> \author Univ. of California Berkeley
55565*> \author Univ. of Colorado Denver
55566*> \author NAG Ltd.
55567*
55568*> \date December 2016
55569*
55570*> \ingroup complex16OTHERcomputational
55571*
55572*  =====================================================================
55573      SUBROUTINE ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
55574     $                   WORK, LWORK, INFO )
55575*
55576*  -- LAPACK computational routine (version 3.7.0) --
55577*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
55578*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
55579*     December 2016
55580*
55581*     .. Scalar Arguments ..
55582      CHARACTER          SIDE, TRANS
55583      INTEGER            INFO, K, LDA, LDC, LWORK, M, N
55584*     ..
55585*     .. Array Arguments ..
55586      COMPLEX*16         A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
55587*     ..
55588*
55589*  =====================================================================
55590*
55591*     .. Parameters ..
55592      INTEGER            NBMAX, LDT, TSIZE
55593      PARAMETER          ( NBMAX = 64, LDT = NBMAX+1,
55594     $                     TSIZE = LDT*NBMAX )
55595*     ..
55596*     .. Local Scalars ..
55597      LOGICAL            LEFT, LQUERY, NOTRAN
55598      INTEGER            I, I1, I2, I3, IB, IC, IINFO, IWT, JC, LDWORK,
55599     $                   LWKOPT, MI, NB, NBMIN, NI, NQ, NW
55600*     ..
55601*     .. External Functions ..
55602      LOGICAL            LSAME
55603      INTEGER            ILAENV
55604      EXTERNAL           LSAME, ILAENV
55605*     ..
55606*     .. External Subroutines ..
55607      EXTERNAL           XERBLA, ZLARFB, ZLARFT, ZUNM2R
55608*     ..
55609*     .. Intrinsic Functions ..
55610      INTRINSIC          MAX, MIN
55611*     ..
55612*     .. Executable Statements ..
55613*
55614*     Test the input arguments
55615*
55616      INFO = 0
55617      LEFT = LSAME( SIDE, 'L' )
55618      NOTRAN = LSAME( TRANS, 'N' )
55619      LQUERY = ( LWORK.EQ.-1 )
55620*
55621*     NQ is the order of Q and NW is the minimum dimension of WORK
55622*
55623      IF( LEFT ) THEN
55624         NQ = M
55625         NW = N
55626      ELSE
55627         NQ = N
55628         NW = M
55629      END IF
55630      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
55631         INFO = -1
55632      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
55633         INFO = -2
55634      ELSE IF( M.LT.0 ) THEN
55635         INFO = -3
55636      ELSE IF( N.LT.0 ) THEN
55637         INFO = -4
55638      ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
55639         INFO = -5
55640      ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
55641         INFO = -7
55642      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
55643         INFO = -10
55644      ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
55645         INFO = -12
55646      END IF
55647*
55648      IF( INFO.EQ.0 ) THEN
55649*
55650*        Compute the workspace requirements
55651*
55652         NB = MIN( NBMAX, ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, N, K,
55653     $        -1 ) )
55654         LWKOPT = MAX( 1, NW )*NB + TSIZE
55655         WORK( 1 ) = LWKOPT
55656      END IF
55657*
55658      IF( INFO.NE.0 ) THEN
55659         CALL XERBLA( 'ZUNMQR', -INFO )
55660         RETURN
55661      ELSE IF( LQUERY ) THEN
55662         RETURN
55663      END IF
55664*
55665*     Quick return if possible
55666*
55667      IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN
55668         WORK( 1 ) = 1
55669         RETURN
55670      END IF
55671*
55672      NBMIN = 2
55673      LDWORK = NW
55674      IF( NB.GT.1 .AND. NB.LT.K ) THEN
55675         IF( LWORK.LT.NW*NB+TSIZE ) THEN
55676            NB = (LWORK-TSIZE) / LDWORK
55677            NBMIN = MAX( 2, ILAENV( 2, 'ZUNMQR', SIDE // TRANS, M, N, K,
55678     $              -1 ) )
55679         END IF
55680      END IF
55681*
55682      IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
55683*
55684*        Use unblocked code
55685*
55686         CALL ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK,
55687     $                IINFO )
55688      ELSE
55689*
55690*        Use blocked code
55691*
55692         IWT = 1 + NW*NB
55693         IF( ( LEFT .AND. .NOT.NOTRAN ) .OR.
55694     $       ( .NOT.LEFT .AND. NOTRAN ) ) THEN
55695            I1 = 1
55696            I2 = K
55697            I3 = NB
55698         ELSE
55699            I1 = ( ( K-1 ) / NB )*NB + 1
55700            I2 = 1
55701            I3 = -NB
55702         END IF
55703*
55704         IF( LEFT ) THEN
55705            NI = N
55706            JC = 1
55707         ELSE
55708            MI = M
55709            IC = 1
55710         END IF
55711*
55712         DO 10 I = I1, I2, I3
55713            IB = MIN( NB, K-I+1 )
55714*
55715*           Form the triangular factor of the block reflector
55716*           H = H(i) H(i+1) . . . H(i+ib-1)
55717*
55718            CALL ZLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ),
55719     $                   LDA, TAU( I ), WORK( IWT ), LDT )
55720            IF( LEFT ) THEN
55721*
55722*              H or H**H is applied to C(i:m,1:n)
55723*
55724               MI = M - I + 1
55725               IC = I
55726            ELSE
55727*
55728*              H or H**H is applied to C(1:m,i:n)
55729*
55730               NI = N - I + 1
55731               JC = I
55732            END IF
55733*
55734*           Apply H or H**H
55735*
55736            CALL ZLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI,
55737     $                   IB, A( I, I ), LDA, WORK( IWT ), LDT,
55738     $                   C( IC, JC ), LDC, WORK, LDWORK )
55739   10    CONTINUE
55740      END IF
55741      WORK( 1 ) = LWKOPT
55742      RETURN
55743*
55744*     End of ZUNMQR
55745*
55746      END
55747*> \brief \b ZUNMTR
55748*
55749*  =========== DOCUMENTATION ===========
55750*
55751* Online html documentation available at
55752*            http://www.netlib.org/lapack/explore-html/
55753*
55754*> \htmlonly
55755*> Download ZUNMTR + dependencies
55756*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zunmtr.f">
55757*> [TGZ]</a>
55758*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zunmtr.f">
55759*> [ZIP]</a>
55760*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zunmtr.f">
55761*> [TXT]</a>
55762*> \endhtmlonly
55763*
55764*  Definition:
55765*  ===========
55766*
55767*       SUBROUTINE ZUNMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC,
55768*                          WORK, LWORK, INFO )
55769*
55770*       .. Scalar Arguments ..
55771*       CHARACTER          SIDE, TRANS, UPLO
55772*       INTEGER            INFO, LDA, LDC, LWORK, M, N
55773*       ..
55774*       .. Array Arguments ..
55775*       COMPLEX*16         A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
55776*       ..
55777*
55778*
55779*> \par Purpose:
55780*  =============
55781*>
55782*> \verbatim
55783*>
55784*> ZUNMTR overwrites the general complex M-by-N matrix C with
55785*>
55786*>                 SIDE = 'L'     SIDE = 'R'
55787*> TRANS = 'N':      Q * C          C * Q
55788*> TRANS = 'C':      Q**H * C       C * Q**H
55789*>
55790*> where Q is a complex unitary matrix of order nq, with nq = m if
55791*> SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
55792*> nq-1 elementary reflectors, as returned by ZHETRD:
55793*>
55794*> if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
55795*>
55796*> if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
55797*> \endverbatim
55798*
55799*  Arguments:
55800*  ==========
55801*
55802*> \param[in] SIDE
55803*> \verbatim
55804*>          SIDE is CHARACTER*1
55805*>          = 'L': apply Q or Q**H from the Left;
55806*>          = 'R': apply Q or Q**H from the Right.
55807*> \endverbatim
55808*>
55809*> \param[in] UPLO
55810*> \verbatim
55811*>          UPLO is CHARACTER*1
55812*>          = 'U': Upper triangle of A contains elementary reflectors
55813*>                 from ZHETRD;
55814*>          = 'L': Lower triangle of A contains elementary reflectors
55815*>                 from ZHETRD.
55816*> \endverbatim
55817*>
55818*> \param[in] TRANS
55819*> \verbatim
55820*>          TRANS is CHARACTER*1
55821*>          = 'N':  No transpose, apply Q;
55822*>          = 'C':  Conjugate transpose, apply Q**H.
55823*> \endverbatim
55824*>
55825*> \param[in] M
55826*> \verbatim
55827*>          M is INTEGER
55828*>          The number of rows of the matrix C. M >= 0.
55829*> \endverbatim
55830*>
55831*> \param[in] N
55832*> \verbatim
55833*>          N is INTEGER
55834*>          The number of columns of the matrix C. N >= 0.
55835*> \endverbatim
55836*>
55837*> \param[in] A
55838*> \verbatim
55839*>          A is COMPLEX*16 array, dimension
55840*>                               (LDA,M) if SIDE = 'L'
55841*>                               (LDA,N) if SIDE = 'R'
55842*>          The vectors which define the elementary reflectors, as
55843*>          returned by ZHETRD.
55844*> \endverbatim
55845*>
55846*> \param[in] LDA
55847*> \verbatim
55848*>          LDA is INTEGER
55849*>          The leading dimension of the array A.
55850*>          LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.
55851*> \endverbatim
55852*>
55853*> \param[in] TAU
55854*> \verbatim
55855*>          TAU is COMPLEX*16 array, dimension
55856*>                               (M-1) if SIDE = 'L'
55857*>                               (N-1) if SIDE = 'R'
55858*>          TAU(i) must contain the scalar factor of the elementary
55859*>          reflector H(i), as returned by ZHETRD.
55860*> \endverbatim
55861*>
55862*> \param[in,out] C
55863*> \verbatim
55864*>          C is COMPLEX*16 array, dimension (LDC,N)
55865*>          On entry, the M-by-N matrix C.
55866*>          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
55867*> \endverbatim
55868*>
55869*> \param[in] LDC
55870*> \verbatim
55871*>          LDC is INTEGER
55872*>          The leading dimension of the array C. LDC >= max(1,M).
55873*> \endverbatim
55874*>
55875*> \param[out] WORK
55876*> \verbatim
55877*>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
55878*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
55879*> \endverbatim
55880*>
55881*> \param[in] LWORK
55882*> \verbatim
55883*>          LWORK is INTEGER
55884*>          The dimension of the array WORK.
55885*>          If SIDE = 'L', LWORK >= max(1,N);
55886*>          if SIDE = 'R', LWORK >= max(1,M).
55887*>          For optimum performance LWORK >= N*NB if SIDE = 'L', and
55888*>          LWORK >=M*NB if SIDE = 'R', where NB is the optimal
55889*>          blocksize.
55890*>
55891*>          If LWORK = -1, then a workspace query is assumed; the routine
55892*>          only calculates the optimal size of the WORK array, returns
55893*>          this value as the first entry of the WORK array, and no error
55894*>          message related to LWORK is issued by XERBLA.
55895*> \endverbatim
55896*>
55897*> \param[out] INFO
55898*> \verbatim
55899*>          INFO is INTEGER
55900*>          = 0:  successful exit
55901*>          < 0:  if INFO = -i, the i-th argument had an illegal value
55902*> \endverbatim
55903*
55904*  Authors:
55905*  ========
55906*
55907*> \author Univ. of Tennessee
55908*> \author Univ. of California Berkeley
55909*> \author Univ. of Colorado Denver
55910*> \author NAG Ltd.
55911*
55912*> \date December 2016
55913*
55914*> \ingroup complex16OTHERcomputational
55915*
55916*  =====================================================================
55917      SUBROUTINE ZUNMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC,
55918     $                   WORK, LWORK, INFO )
55919*
55920*  -- LAPACK computational routine (version 3.7.0) --
55921*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
55922*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
55923*     December 2016
55924*
55925*     .. Scalar Arguments ..
55926      CHARACTER          SIDE, TRANS, UPLO
55927      INTEGER            INFO, LDA, LDC, LWORK, M, N
55928*     ..
55929*     .. Array Arguments ..
55930      COMPLEX*16         A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
55931*     ..
55932*
55933*  =====================================================================
55934*
55935*     .. Local Scalars ..
55936      LOGICAL            LEFT, LQUERY, UPPER
55937      INTEGER            I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW
55938*     ..
55939*     .. External Functions ..
55940      LOGICAL            LSAME
55941      INTEGER            ILAENV
55942      EXTERNAL           LSAME, ILAENV
55943*     ..
55944*     .. External Subroutines ..
55945      EXTERNAL           XERBLA, ZUNMQL, ZUNMQR
55946*     ..
55947*     .. Intrinsic Functions ..
55948      INTRINSIC          MAX
55949*     ..
55950*     .. Executable Statements ..
55951*
55952*     Test the input arguments
55953*
55954      INFO = 0
55955      LEFT = LSAME( SIDE, 'L' )
55956      UPPER = LSAME( UPLO, 'U' )
55957      LQUERY = ( LWORK.EQ.-1 )
55958*
55959*     NQ is the order of Q and NW is the minimum dimension of WORK
55960*
55961      IF( LEFT ) THEN
55962         NQ = M
55963         NW = N
55964      ELSE
55965         NQ = N
55966         NW = M
55967      END IF
55968      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
55969         INFO = -1
55970      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
55971         INFO = -2
55972      ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'C' ) )
55973     $          THEN
55974         INFO = -3
55975      ELSE IF( M.LT.0 ) THEN
55976         INFO = -4
55977      ELSE IF( N.LT.0 ) THEN
55978         INFO = -5
55979      ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
55980         INFO = -7
55981      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
55982         INFO = -10
55983      ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
55984         INFO = -12
55985      END IF
55986*
55987      IF( INFO.EQ.0 ) THEN
55988         IF( UPPER ) THEN
55989            IF( LEFT ) THEN
55990               NB = ILAENV( 1, 'ZUNMQL', SIDE // TRANS, M-1, N, M-1,
55991     $              -1 )
55992            ELSE
55993               NB = ILAENV( 1, 'ZUNMQL', SIDE // TRANS, M, N-1, N-1,
55994     $              -1 )
55995            END IF
55996         ELSE
55997            IF( LEFT ) THEN
55998               NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M-1, N, M-1,
55999     $              -1 )
56000            ELSE
56001               NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, N-1, N-1,
56002     $              -1 )
56003            END IF
56004         END IF
56005         LWKOPT = MAX( 1, NW )*NB
56006         WORK( 1 ) = LWKOPT
56007      END IF
56008*
56009      IF( INFO.NE.0 ) THEN
56010         CALL XERBLA( 'ZUNMTR', -INFO )
56011         RETURN
56012      ELSE IF( LQUERY ) THEN
56013         RETURN
56014      END IF
56015*
56016*     Quick return if possible
56017*
56018      IF( M.EQ.0 .OR. N.EQ.0 .OR. NQ.EQ.1 ) THEN
56019         WORK( 1 ) = 1
56020         RETURN
56021      END IF
56022*
56023      IF( LEFT ) THEN
56024         MI = M - 1
56025         NI = N
56026      ELSE
56027         MI = M
56028         NI = N - 1
56029      END IF
56030*
56031      IF( UPPER ) THEN
56032*
56033*        Q was determined by a call to ZHETRD with UPLO = 'U'
56034*
56035         CALL ZUNMQL( SIDE, TRANS, MI, NI, NQ-1, A( 1, 2 ), LDA, TAU, C,
56036     $                LDC, WORK, LWORK, IINFO )
56037      ELSE
56038*
56039*        Q was determined by a call to ZHETRD with UPLO = 'L'
56040*
56041         IF( LEFT ) THEN
56042            I1 = 2
56043            I2 = 1
56044         ELSE
56045            I1 = 1
56046            I2 = 2
56047         END IF
56048         CALL ZUNMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU,
56049     $                C( I1, I2 ), LDC, WORK, LWORK, IINFO )
56050      END IF
56051      WORK( 1 ) = LWKOPT
56052      RETURN
56053*
56054*     End of ZUNMTR
56055*
56056      END
56057