1*> \brief \b CQRT12
2*
3*  =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6*            http://www.netlib.org/lapack/explore-html/
7*
8*  Definition:
9*  ===========
10*
11*       REAL             FUNCTION CQRT12( M, N, A, LDA, S, WORK, LWORK,
12*                        RWORK )
13*
14*       .. Scalar Arguments ..
15*       INTEGER            LDA, LWORK, M, N
16*       ..
17*       .. Array Arguments ..
18*       REAL               RWORK( * ), S( * )
19*       COMPLEX            A( LDA, * ), WORK( LWORK )
20*       ..
21*
22*
23*> \par Purpose:
24*  =============
25*>
26*> \verbatim
27*>
28*> CQRT12 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 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 REAL 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 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 REAL array, dimension (4*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 complex_lin
95*
96*  =====================================================================
97      REAL             FUNCTION CQRT12( 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      REAL               RWORK( * ), S( * )
110      COMPLEX            A( LDA, * ), WORK( LWORK )
111*     ..
112*
113*  =====================================================================
114*
115*     .. Parameters ..
116      REAL               ZERO, ONE
117      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
118*     ..
119*     .. Local Scalars ..
120      INTEGER            I, INFO, ISCL, J, MN
121      REAL               ANRM, BIGNUM, NRMSVL, SMLNUM
122*     ..
123*     .. Local Arrays ..
124      REAL               DUMMY( 1 )
125*     ..
126*     .. External Functions ..
127      REAL               CLANGE, SASUM, SLAMCH, SNRM2
128      EXTERNAL           CLANGE, SASUM, SLAMCH, SNRM2
129*     ..
130*     .. External Subroutines ..
131      EXTERNAL           CGEBD2, CLASCL, CLASET, SAXPY, SBDSQR, SLABAD,
132     $                   SLASCL, XERBLA
133*     ..
134*     .. Intrinsic Functions ..
135      INTRINSIC          CMPLX, MAX, MIN, REAL
136*     ..
137*     .. Executable Statements ..
138*
139      CQRT12 = 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( 'CQRT12', 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 = SNRM2( MN, S, 1 )
155*
156*     Copy upper triangle of A into work
157*
158      CALL CLASET( 'Full', M, N, CMPLX( ZERO ), CMPLX( ZERO ), WORK, M )
159      DO 20 J = 1, N
160         DO 10 I = 1, MIN( J, M )
161            WORK( ( J-1 )*M+I ) = A( I, J )
162   10    CONTINUE
163   20 CONTINUE
164*
165*     Get machine parameters
166*
167      SMLNUM = SLAMCH( 'S' ) / SLAMCH( 'P' )
168      BIGNUM = ONE / SMLNUM
169      CALL SLABAD( SMLNUM, BIGNUM )
170*
171*     Scale work if max entry outside range [SMLNUM,BIGNUM]
172*
173      ANRM = CLANGE( 'M', M, N, WORK, M, DUMMY )
174      ISCL = 0
175      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
176*
177*        Scale matrix norm up to SMLNUM
178*
179         CALL CLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, WORK, M, INFO )
180         ISCL = 1
181      ELSE IF( ANRM.GT.BIGNUM ) THEN
182*
183*        Scale matrix norm down to BIGNUM
184*
185         CALL CLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, WORK, M, INFO )
186         ISCL = 1
187      END IF
188*
189      IF( ANRM.NE.ZERO ) THEN
190*
191*        Compute SVD of work
192*
193         CALL CGEBD2( M, N, WORK, M, RWORK( 1 ), RWORK( MN+1 ),
194     $                WORK( M*N+1 ), WORK( M*N+MN+1 ),
195     $                WORK( M*N+2*MN+1 ), INFO )
196         CALL SBDSQR( 'Upper', MN, 0, 0, 0, RWORK( 1 ), RWORK( MN+1 ),
197     $                DUMMY, MN, DUMMY, 1, DUMMY, MN, RWORK( 2*MN+1 ),
198     $                INFO )
199*
200         IF( ISCL.EQ.1 ) THEN
201            IF( ANRM.GT.BIGNUM ) THEN
202               CALL SLASCL( 'G', 0, 0, BIGNUM, ANRM, MN, 1, RWORK( 1 ),
203     $                      MN, INFO )
204            END IF
205            IF( ANRM.LT.SMLNUM ) THEN
206               CALL SLASCL( 'G', 0, 0, SMLNUM, ANRM, MN, 1, RWORK( 1 ),
207     $                      MN, INFO )
208            END IF
209         END IF
210*
211      ELSE
212*
213         DO 30 I = 1, MN
214            RWORK( I ) = ZERO
215   30    CONTINUE
216      END IF
217*
218*     Compare s and singular values of work
219*
220      CALL SAXPY( MN, -ONE, S, 1, RWORK( 1 ), 1 )
221      CQRT12 = SASUM( MN, RWORK( 1 ), 1 ) /
222     $         ( SLAMCH( 'Epsilon' )*REAL( MAX( M, N ) ) )
223      IF( NRMSVL.NE.ZERO )
224     $   CQRT12 = CQRT12 / NRMSVL
225*
226      RETURN
227*
228*     End of CQRT12
229*
230      END
231