1*> \brief \b DLQT04
2*
3*  =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6*            http://www.netlib.org/lapack/explore-html/
7*
8*  Definition:
9*  ===========
10*
11*       SUBROUTINE CLQT04(M,N,NB,RESULT)
12*
13*       .. Scalar Arguments ..
14*       INTEGER M, N, NB
15*       .. Return values ..
16*       REAL RESULT(6)
17*
18*
19*> \par Purpose:
20*  =============
21*>
22*> \verbatim
23*>
24*> CLQT04 tests CGELQT and CGEMLQT.
25*> \endverbatim
26*
27*  Arguments:
28*  ==========
29*
30*> \param[in] M
31*> \verbatim
32*>          M is INTEGER
33*>          Number of rows in test matrix.
34*> \endverbatim
35*>
36*> \param[in] N
37*> \verbatim
38*>          N is INTEGER
39*>          Number of columns in test matrix.
40*> \endverbatim
41*>
42*> \param[in] NB
43*> \verbatim
44*>          NB is INTEGER
45*>          Block size of test matrix.  NB <= Min(M,N).
46*> \endverbatim
47*>
48*> \param[out] RESULT
49*> \verbatim
50*>          RESULT is DOUBLE PRECISION array, dimension (6)
51*>          Results of each of the six tests below.
52*>
53*>          RESULT(1) = | A - L Q |
54*>          RESULT(2) = | I - Q Q^H |
55*>          RESULT(3) = | Q C - Q C |
56*>          RESULT(4) = | Q^H C - Q^H C |
57*>          RESULT(5) = | C Q - C Q |
58*>          RESULT(6) = | C Q^H - C Q^H |
59*> \endverbatim
60*
61*  Authors:
62*  ========
63*
64*> \author Univ. of Tennessee
65*> \author Univ. of California Berkeley
66*> \author Univ. of Colorado Denver
67*> \author NAG Ltd.
68*
69*> \date April 2012
70*
71*> \ingroup double_lin
72*
73*  =====================================================================
74      SUBROUTINE CLQT04(M,N,NB,RESULT)
75      IMPLICIT NONE
76*
77*  -- LAPACK test routine (version 3.7.0) --
78*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
79*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
80*     April 2012
81*
82*     .. Scalar Arguments ..
83      INTEGER M, N, NB
84*     .. Return values ..
85      REAL RESULT(6)
86*
87*  =====================================================================
88*
89*     ..
90*     .. Local allocatable arrays
91      COMPLEX, ALLOCATABLE :: AF(:,:), Q(:,:),
92     $  L(:,:), RWORK(:), WORK( : ), T(:,:),
93     $  CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:)
94*
95*     .. Parameters ..
96      REAL       ZERO
97      COMPLEX    ONE, CZERO
98      PARAMETER( ZERO = 0.0)
99      PARAMETER( ONE = (1.0,0.0), CZERO=(0.0,0.0) )
100*     ..
101*     .. Local Scalars ..
102      INTEGER INFO, J, K, LL, LWORK, LDT
103      REAL    ANORM, EPS, RESID, CNORM, DNORM
104*     ..
105*     .. Local Arrays ..
106      INTEGER            ISEED( 4 )
107*     ..
108*     .. External Functions ..
109      REAL     SLAMCH
110      REAL     CLANGE, CLANSY
111      LOGICAL  LSAME
112      EXTERNAL SLAMCH, CLANGE, CLANSY, LSAME
113*     ..
114*     .. Intrinsic Functions ..
115      INTRINSIC  MAX, MIN
116*     ..
117*     .. Data statements ..
118      DATA ISEED / 1988, 1989, 1990, 1991 /
119*
120      EPS = SLAMCH( 'Epsilon' )
121      K = MIN(M,N)
122      LL = MAX(M,N)
123      LWORK = MAX(2,LL)*MAX(2,LL)*NB
124*
125*     Dynamically allocate local arrays
126*
127      ALLOCATE ( A(M,N), AF(M,N), Q(N,N), L(LL,N), RWORK(LL),
128     $           WORK(LWORK), T(NB,N), C(M,N), CF(M,N),
129     $           D(N,M), DF(N,M) )
130*
131*     Put random numbers into A and copy to AF
132*
133      LDT=NB
134      DO J=1,N
135         CALL CLARNV( 2, ISEED, M, A( 1, J ) )
136      END DO
137      CALL CLACPY( 'Full', M, N, A, M, AF, M )
138*
139*     Factor the matrix A in the array AF.
140*
141      CALL CGELQT( M, N, NB, AF, M, T, LDT, WORK, INFO )
142*
143*     Generate the n-by-n matrix Q
144*
145      CALL CLASET( 'Full', N, N, CZERO, ONE, Q, N )
146      CALL CGEMLQT( 'R', 'N', N, N, K, NB, AF, M, T, LDT, Q, N,
147     $              WORK, INFO )
148*
149*     Copy L
150*
151      CALL CLASET( 'Full', LL, N, CZERO, CZERO, L, LL )
152      CALL CLACPY( 'Lower', M, N, AF, M, L, LL )
153*
154*     Compute |L - A*Q'| / |A| and store in RESULT(1)
155*
156      CALL CGEMM( 'N', 'C', M, N, N, -ONE, A, M, Q, N, ONE, L, LL )
157      ANORM = CLANGE( '1', M, N, A, M, RWORK )
158      RESID = CLANGE( '1', M, N, L, LL, RWORK )
159      IF( ANORM.GT.ZERO ) THEN
160         RESULT( 1 ) = RESID / (EPS*MAX(1,M)*ANORM)
161      ELSE
162         RESULT( 1 ) = ZERO
163      END IF
164*
165*     Compute |I - Q'*Q| and store in RESULT(2)
166*
167      CALL CLASET( 'Full', N, N, CZERO, ONE, L, LL )
168      CALL CHERK( 'U', 'C', N, N, REAL(-ONE), Q, N, REAL(ONE), L, LL)
169      RESID = CLANSY( '1', 'Upper', N, L, LL, RWORK )
170      RESULT( 2 ) = RESID / (EPS*MAX(1,N))
171*
172*     Generate random m-by-n matrix C and a copy CF
173*
174      DO J=1,M
175         CALL CLARNV( 2, ISEED, N, D( 1, J ) )
176      END DO
177      DNORM = CLANGE( '1', N, M, D, N, RWORK)
178      CALL CLACPY( 'Full', N, M, D, N, DF, N )
179*
180*     Apply Q to C as Q*C
181*
182      CALL CGEMLQT( 'L', 'N', N, M, K, NB, AF, M, T, NB, DF, N,
183     $             WORK, INFO)
184*
185*     Compute |Q*D - Q*D| / |D|
186*
187      CALL CGEMM( 'N', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N )
188      RESID = CLANGE( '1', N, M, DF, N, RWORK )
189      IF( DNORM.GT.ZERO ) THEN
190         RESULT( 3 ) = RESID / (EPS*MAX(1,M)*DNORM)
191      ELSE
192         RESULT( 3 ) = ZERO
193      END IF
194*
195*     Copy D into DF again
196*
197      CALL CLACPY( 'Full', N, M, D, N, DF, N )
198*
199*     Apply Q to D as QT*D
200*
201      CALL CGEMLQT( 'L', 'C', N, M, K, NB, AF, M, T, NB, DF, N,
202     $             WORK, INFO)
203*
204*     Compute |QT*D - QT*D| / |D|
205*
206      CALL CGEMM( 'C', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N )
207      RESID = CLANGE( '1', N, M, DF, N, RWORK )
208      IF( DNORM.GT.ZERO ) THEN
209         RESULT( 4 ) = RESID / (EPS*MAX(1,M)*DNORM)
210      ELSE
211         RESULT( 4 ) = ZERO
212      END IF
213*
214*     Generate random n-by-m matrix D and a copy DF
215*
216      DO J=1,N
217         CALL CLARNV( 2, ISEED, M, C( 1, J ) )
218      END DO
219      CNORM = CLANGE( '1', M, N, C, M, RWORK)
220      CALL CLACPY( 'Full', M, N, C, M, CF, M )
221*
222*     Apply Q to C as C*Q
223*
224      CALL CGEMLQT( 'R', 'N', M, N, K, NB, AF, M, T, NB, CF, M,
225     $             WORK, INFO)
226*
227*     Compute |C*Q - C*Q| / |C|
228*
229      CALL CGEMM( 'N', 'N', M, N, N, -ONE, C, M, Q, N, ONE, CF, M )
230      RESID = CLANGE( '1', N, M, DF, N, RWORK )
231      IF( CNORM.GT.ZERO ) THEN
232         RESULT( 5 ) = RESID / (EPS*MAX(1,M)*DNORM)
233      ELSE
234         RESULT( 5 ) = ZERO
235      END IF
236*
237*     Copy C into CF again
238*
239      CALL CLACPY( 'Full', M, N, C, M, CF, M )
240*
241*     Apply Q to D as D*QT
242*
243      CALL CGEMLQT( 'R', 'C', M, N, K, NB, AF, M, T, NB, CF, M,
244     $             WORK, INFO)
245*
246*     Compute |C*QT - C*QT| / |C|
247*
248      CALL CGEMM( 'N', 'C', M, N, N, -ONE, C, M, Q, N, ONE, CF, M )
249      RESID = CLANGE( '1', M, N, CF, M, RWORK )
250      IF( CNORM.GT.ZERO ) THEN
251         RESULT( 6 ) = RESID / (EPS*MAX(1,M)*DNORM)
252      ELSE
253         RESULT( 6 ) = ZERO
254      END IF
255*
256*     Deallocate all arrays
257*
258      DEALLOCATE ( A, AF, Q, L, RWORK, WORK, T, C, D, CF, DF)
259*
260      RETURN
261      END
262
263