1*> \brief \b ZQRT12
2*
3*  =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6*            http://www.netlib.org/lapack/explore-html/
7*
8*  Definition:
9*  ===========
10*
11*       DOUBLE PRECISION FUNCTION ZQRT12( M, N, A, LDA, S, WORK, LWORK,
12*                        RWORK )
13*
14*       .. Scalar Arguments ..
15*       INTEGER            LDA, LWORK, M, N
16*       ..
17*       .. Array Arguments ..
18*       DOUBLE PRECISION   RWORK( * ), S( * )
19*       COMPLEX*16         A( LDA, * ), WORK( LWORK )
20*       ..
21*
22*
23*> \par Purpose:
24*  =============
25*>
26*> \verbatim
27*>
28*> ZQRT12 computes the singular values `svlues' of the upper trapezoid
29*> of A(1:M,1:N) and returns the ratio
30*>
31*>      || s - svlues||/(||svlues||*eps*max(M,N))
32*> \endverbatim
33*
34*  Arguments:
35*  ==========
36*
37*> \param[in] M
38*> \verbatim
39*>          M is INTEGER
40*>          The number of rows of the matrix A.
41*> \endverbatim
42*>
43*> \param[in] N
44*> \verbatim
45*>          N is INTEGER
46*>          The number of columns of the matrix A.
47*> \endverbatim
48*>
49*> \param[in] A
50*> \verbatim
51*>          A is COMPLEX*16 array, dimension (LDA,N)
52*>          The M-by-N matrix A. Only the upper trapezoid is referenced.
53*> \endverbatim
54*>
55*> \param[in] LDA
56*> \verbatim
57*>          LDA is INTEGER
58*>          The leading dimension of the array A.
59*> \endverbatim
60*>
61*> \param[in] S
62*> \verbatim
63*>          S is DOUBLE PRECISION array, dimension (min(M,N))
64*>          The singular values of the matrix A.
65*> \endverbatim
66*>
67*> \param[out] WORK
68*> \verbatim
69*>          WORK is COMPLEX*16 array, dimension (LWORK)
70*> \endverbatim
71*>
72*> \param[in] LWORK
73*> \verbatim
74*>          LWORK is INTEGER
75*>          The length of the array WORK. LWORK >= M*N + 2*min(M,N) +
76*>          max(M,N).
77*> \endverbatim
78*>
79*> \param[out] RWORK
80*> \verbatim
81*>          RWORK is DOUBLE PRECISION array, dimension (2*min(M,N))
82*> \endverbatim
83*
84*  Authors:
85*  ========
86*
87*> \author Univ. of Tennessee
88*> \author Univ. of California Berkeley
89*> \author Univ. of Colorado Denver
90*> \author NAG Ltd.
91*
92*> \date November 2011
93*
94*> \ingroup complex16_lin
95*
96*  =====================================================================
97      DOUBLE PRECISION FUNCTION ZQRT12( M, N, A, LDA, S, WORK, LWORK,
98     $                 RWORK )
99*
100*  -- LAPACK test routine (version 3.4.0) --
101*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
102*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
103*     November 2011
104*
105*     .. Scalar Arguments ..
106      INTEGER            LDA, LWORK, M, N
107*     ..
108*     .. Array Arguments ..
109      DOUBLE PRECISION   RWORK( * ), S( * )
110      COMPLEX*16         A( LDA, * ), WORK( LWORK )
111*     ..
112*
113*  =====================================================================
114*
115*     .. Parameters ..
116      DOUBLE PRECISION   ZERO, ONE
117      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
118*     ..
119*     .. Local Scalars ..
120      INTEGER            I, INFO, ISCL, J, MN
121      DOUBLE PRECISION   ANRM, BIGNUM, NRMSVL, SMLNUM
122*     ..
123*     .. Local Arrays ..
124      DOUBLE PRECISION   DUMMY( 1 )
125*     ..
126*     .. External Functions ..
127      DOUBLE PRECISION   DASUM, DLAMCH, DNRM2, ZLANGE
128      EXTERNAL           DASUM, DLAMCH, DNRM2, ZLANGE
129*     ..
130*     .. External Subroutines ..
131      EXTERNAL           DAXPY, DBDSQR, DLABAD, DLASCL, XERBLA, ZGEBD2,
132     $                   ZLASCL, ZLASET
133*     ..
134*     .. Intrinsic Functions ..
135      INTRINSIC          DBLE, DCMPLX, MAX, MIN
136*     ..
137*     .. Executable Statements ..
138*
139      ZQRT12 = ZERO
140*
141*     Test that enough workspace is supplied
142*
143      IF( LWORK.LT.M*N+2*MIN( M, N )+MAX( M, N ) ) THEN
144         CALL XERBLA( 'ZQRT12', 7 )
145         RETURN
146      END IF
147*
148*     Quick return if possible
149*
150      MN = MIN( M, N )
151      IF( MN.LE.ZERO )
152     $   RETURN
153*
154      NRMSVL = DNRM2( MN, S, 1 )
155*
156*     Copy upper triangle of A into work
157*
158      CALL ZLASET( 'Full', M, N, DCMPLX( ZERO ), DCMPLX( ZERO ), WORK,
159     $             M )
160      DO 20 J = 1, N
161         DO 10 I = 1, MIN( J, M )
162            WORK( ( J-1 )*M+I ) = A( I, J )
163   10    CONTINUE
164   20 CONTINUE
165*
166*     Get machine parameters
167*
168      SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' )
169      BIGNUM = ONE / SMLNUM
170      CALL DLABAD( SMLNUM, BIGNUM )
171*
172*     Scale work if max entry outside range [SMLNUM,BIGNUM]
173*
174      ANRM = ZLANGE( 'M', M, N, WORK, M, DUMMY )
175      ISCL = 0
176      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
177*
178*        Scale matrix norm up to SMLNUM
179*
180         CALL ZLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, WORK, M, INFO )
181         ISCL = 1
182      ELSE IF( ANRM.GT.BIGNUM ) THEN
183*
184*        Scale matrix norm down to BIGNUM
185*
186         CALL ZLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, WORK, M, INFO )
187         ISCL = 1
188      END IF
189*
190      IF( ANRM.NE.ZERO ) THEN
191*
192*        Compute SVD of work
193*
194         CALL ZGEBD2( M, N, WORK, M, RWORK( 1 ), RWORK( MN+1 ),
195     $                WORK( M*N+1 ), WORK( M*N+MN+1 ),
196     $                WORK( M*N+2*MN+1 ), INFO )
197         CALL DBDSQR( 'Upper', MN, 0, 0, 0, RWORK( 1 ), RWORK( MN+1 ),
198     $                DUMMY, MN, DUMMY, 1, DUMMY, MN, RWORK( 2*MN+1 ),
199     $                INFO )
200*
201         IF( ISCL.EQ.1 ) THEN
202            IF( ANRM.GT.BIGNUM ) THEN
203               CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MN, 1, RWORK( 1 ),
204     $                      MN, INFO )
205            END IF
206            IF( ANRM.LT.SMLNUM ) THEN
207               CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MN, 1, RWORK( 1 ),
208     $                      MN, INFO )
209            END IF
210         END IF
211*
212      ELSE
213*
214         DO 30 I = 1, MN
215            RWORK( I ) = ZERO
216   30    CONTINUE
217      END IF
218*
219*     Compare s and singular values of work
220*
221      CALL DAXPY( MN, -ONE, S, 1, RWORK( 1 ), 1 )
222      ZQRT12 = DASUM( MN, RWORK( 1 ), 1 ) /
223     $         ( DLAMCH( 'Epsilon' )*DBLE( MAX( M, N ) ) )
224      IF( NRMSVL.NE.ZERO )
225     $   ZQRT12 = ZQRT12 / NRMSVL
226*
227      RETURN
228*
229*     End of ZQRT12
230*
231      END
232