1*> \brief \b CUNHR_COL02
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 CUNHR_COL02( M, N, MB1, NB1, NB2, RESULT )
12*
13*       .. Scalar Arguments ..
14*       INTEGER           M, N, MB1, NB1, NB2
15*       .. Return values ..
16*       REAL              RESULT(6)
17*
18*
19*> \par Purpose:
20*  =============
21*>
22*> \verbatim
23*>
24*> CUNHR_COL02 tests CUNGTSQR_ROW and CUNHR_COL inside CGETSQRHRT
25*> (which calls CLATSQR, CUNGTSQR_ROW and CUNHR_COL) using CGEMQRT.
26*> Therefore, CLATSQR (part of CGEQR), CGEMQRT (part of CGEMQR)
27*> have to be tested before this test.
28*>
29*> \endverbatim
30*
31*  Arguments:
32*  ==========
33*
34*> \param[in] M
35*> \verbatim
36*>          M is INTEGER
37*>          Number of rows in test matrix.
38*> \endverbatim
39*> \param[in] N
40*> \verbatim
41*>          N is INTEGER
42*>          Number of columns in test matrix.
43*> \endverbatim
44*> \param[in] MB1
45*> \verbatim
46*>          MB1 is INTEGER
47*>          Number of row in row block in an input test matrix.
48*> \endverbatim
49*>
50*> \param[in] NB1
51*> \verbatim
52*>          NB1 is INTEGER
53*>          Number of columns in column block an input test matrix.
54*> \endverbatim
55*>
56*> \param[in] NB2
57*> \verbatim
58*>          NB2 is INTEGER
59*>          Number of columns in column block in an output test matrix.
60*> \endverbatim
61*>
62*> \param[out] RESULT
63*> \verbatim
64*>          RESULT is REAL array, dimension (6)
65*>          Results of each of the six tests below.
66*>
67*>            A is a m-by-n test input matrix to be factored.
68*>            so that A = Q_gr * ( R )
69*>                               ( 0 ),
70*>
71*>            Q_qr is an implicit m-by-m unitary Q matrix, the result
72*>            of factorization in blocked WY-representation,
73*>            stored in CGEQRT output format.
74*>
75*>            R is a n-by-n upper-triangular matrix,
76*>
77*>            0 is a (m-n)-by-n zero matrix,
78*>
79*>            Q is an explicit m-by-m unitary matrix Q = Q_gr * I
80*>
81*>            C is an m-by-n random matrix,
82*>
83*>            D is an n-by-m random matrix.
84*>
85*>          The six tests are:
86*>
87*>          RESULT(1) = |R - (Q**H) * A| / ( eps * m * |A| )
88*>            is equivalent to test for | A - Q * R | / (eps * m * |A|),
89*>
90*>          RESULT(2) = |I - (Q**H) * Q| / ( eps * m ),
91*>
92*>          RESULT(3) = | Q_qr * C - Q * C | / (eps * m * |C|),
93*>
94*>          RESULT(4) = | (Q_gr**H) * C - (Q**H) * C | / (eps * m * |C|)
95*>
96*>          RESULT(5) = | D * Q_qr - D * Q | / (eps * m * |D|)
97*>
98*>          RESULT(6) = | D * (Q_qr**H) - D * (Q**H) | / (eps * m * |D|),
99*>
100*>          where:
101*>            Q_qr * C, (Q_gr**H) * C, D * Q_qr, D * (Q_qr**H) are
102*>            computed using CGEMQRT,
103*>
104*>            Q * C, (Q**H) * C, D * Q, D * (Q**H)  are
105*>            computed using CGEMM.
106*> \endverbatim
107*
108*  Authors:
109*  ========
110*
111*> \author Univ. of Tennessee
112*> \author Univ. of California Berkeley
113*> \author Univ. of Colorado Denver
114*> \author NAG Ltd.
115*
116*> \ingroup complex_lin
117*
118*  =====================================================================
119      SUBROUTINE CUNHR_COL02( M, N, MB1, NB1, NB2, RESULT )
120      IMPLICIT NONE
121*
122*  -- LAPACK test routine --
123*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
124*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
125*
126*     .. Scalar Arguments ..
127      INTEGER           M, N, MB1, NB1, NB2
128*     .. Return values ..
129      REAL              RESULT(6)
130*
131*  =====================================================================
132*
133*     ..
134*     .. Local allocatable arrays
135      COMPLEX         , ALLOCATABLE ::  A(:,:), AF(:,:), Q(:,:), R(:,:),
136     $                   WORK( : ), T1(:,:), T2(:,:), DIAG(:),
137     $                   C(:,:), CF(:,:), D(:,:), DF(:,:)
138      REAL            , ALLOCATABLE :: RWORK(:)
139*
140*     .. Parameters ..
141      REAL               ZERO
142      PARAMETER          ( ZERO = 0.0E+0 )
143      COMPLEX            CONE, CZERO
144      PARAMETER          ( CONE = ( 1.0E+0, 0.0E+0 ),
145     $                     CZERO = ( 0.0E+0, 0.0E+0 ) )
146*     ..
147*     .. Local Scalars ..
148      LOGICAL            TESTZEROS
149      INTEGER            INFO, J, K, L, LWORK, NB2_UB, NRB
150      REAL               ANORM, EPS, RESID, CNORM, DNORM
151*     ..
152*     .. Local Arrays ..
153      INTEGER            ISEED( 4 )
154      COMPLEX            WORKQUERY( 1 )
155*     ..
156*     .. External Functions ..
157      REAL               SLAMCH, CLANGE, CLANSY
158      EXTERNAL           SLAMCH, CLANGE, CLANSY
159*     ..
160*     .. External Subroutines ..
161      EXTERNAL           CLACPY, CLARNV, CLASET, CGETSQRHRT,
162     $                   CSCAL, CGEMM, CGEMQRT, CHERK
163*     ..
164*     .. Intrinsic Functions ..
165      INTRINSIC          CEILING, REAL, MAX, MIN
166*     ..
167*     .. Scalars in Common ..
168      CHARACTER(LEN=32)  SRNAMT
169*     ..
170*     .. Common blocks ..
171      COMMON             / SRMNAMC / SRNAMT
172*     ..
173*     .. Data statements ..
174      DATA ISEED / 1988, 1989, 1990, 1991 /
175*
176*     TEST MATRICES WITH HALF OF MATRIX BEING ZEROS
177*
178      TESTZEROS = .FALSE.
179*
180      EPS = SLAMCH( 'Epsilon' )
181      K = MIN( M, N )
182      L = MAX( M, N, 1)
183*
184*     Dynamically allocate local arrays
185*
186      ALLOCATE ( A(M,N), AF(M,N), Q(L,L), R(M,L), RWORK(L),
187     $           C(M,N), CF(M,N),
188     $           D(N,M), DF(N,M) )
189*
190*     Put random numbers into A and copy to AF
191*
192      DO J = 1, N
193         CALL CLARNV( 2, ISEED, M, A( 1, J ) )
194      END DO
195      IF( TESTZEROS ) THEN
196         IF( M.GE.4 ) THEN
197            DO J = 1, N
198               CALL CLARNV( 2, ISEED, M/2, A( M/4, J ) )
199            END DO
200         END IF
201      END IF
202      CALL CLACPY( 'Full', M, N, A, M, AF, M )
203*
204*     Number of row blocks in CLATSQR
205*
206      NRB = MAX( 1, CEILING( REAL( M - N ) / REAL( MB1 - N ) ) )
207*
208      ALLOCATE ( T1( NB1, N * NRB ) )
209      ALLOCATE ( T2( NB2, N ) )
210      ALLOCATE ( DIAG( N ) )
211*
212*     Begin determine LWORK for the array WORK and allocate memory.
213*
214*     CGEMQRT requires NB2 to be bounded by N.
215*
216      NB2_UB = MIN( NB2, N)
217*
218*
219      CALL CGETSQRHRT( M, N, MB1, NB1, NB2, AF, M, T2, NB2,
220     $                 WORKQUERY, -1, INFO )
221*
222      LWORK = INT( WORKQUERY( 1 ) )
223*
224*     In CGEMQRT, WORK is N*NB2_UB if SIDE = 'L',
225*                or  M*NB2_UB if SIDE = 'R'.
226*
227      LWORK = MAX( LWORK, NB2_UB * N, NB2_UB * M )
228*
229      ALLOCATE ( WORK( LWORK ) )
230*
231*     End allocate memory for WORK.
232*
233*
234*     Begin Householder reconstruction routines
235*
236*     Factor the matrix A in the array AF.
237*
238      SRNAMT = 'CGETSQRHRT'
239      CALL CGETSQRHRT( M, N, MB1, NB1, NB2, AF, M, T2, NB2,
240     $                 WORK, LWORK, INFO )
241*
242*     End Householder reconstruction routines.
243*
244*
245*     Generate the m-by-m matrix Q
246*
247      CALL CLASET( 'Full', M, M, CZERO, CONE, Q, M )
248*
249      SRNAMT = 'CGEMQRT'
250      CALL CGEMQRT( 'L', 'N', M, M, K, NB2_UB, AF, M, T2, NB2, Q, M,
251     $              WORK, INFO )
252*
253*     Copy R
254*
255      CALL CLASET( 'Full', M, N, CZERO, CZERO, R, M )
256*
257      CALL CLACPY( 'Upper', M, N, AF, M, R, M )
258*
259*     TEST 1
260*     Compute |R - (Q**T)*A| / ( eps * m * |A| ) and store in RESULT(1)
261*
262      CALL CGEMM( 'C', 'N', M, N, M, -CONE, Q, M, A, M, CONE, R, M )
263*
264      ANORM = CLANGE( '1', M, N, A, M, RWORK )
265      RESID = CLANGE( '1', M, N, R, M, RWORK )
266      IF( ANORM.GT.ZERO ) THEN
267         RESULT( 1 ) = RESID / ( EPS * MAX( 1, M ) * ANORM )
268      ELSE
269         RESULT( 1 ) = ZERO
270      END IF
271*
272*     TEST 2
273*     Compute |I - (Q**T)*Q| / ( eps * m ) and store in RESULT(2)
274*
275      CALL CLASET( 'Full', M, M, CZERO, CONE, R, M )
276      CALL CHERK( 'U', 'C', M, M, -CONE, Q, M, CONE, R, M )
277      RESID = CLANSY( '1', 'Upper', M, R, M, RWORK )
278      RESULT( 2 ) = RESID / ( EPS * MAX( 1, M ) )
279*
280*     Generate random m-by-n matrix C
281*
282      DO J = 1, N
283         CALL CLARNV( 2, ISEED, M, C( 1, J ) )
284      END DO
285      CNORM = CLANGE( '1', M, N, C, M, RWORK )
286      CALL CLACPY( 'Full', M, N, C, M, CF, M )
287*
288*     Apply Q to C as Q*C = CF
289*
290      SRNAMT = 'CGEMQRT'
291      CALL CGEMQRT( 'L', 'N', M, N, K, NB2_UB, AF, M, T2, NB2, CF, M,
292     $               WORK, INFO )
293*
294*     TEST 3
295*     Compute |CF - Q*C| / ( eps *  m * |C| )
296*
297      CALL CGEMM( 'N', 'N', M, N, M, -CONE, Q, M, C, M, CONE, CF, M )
298      RESID = CLANGE( '1', M, N, CF, M, RWORK )
299      IF( CNORM.GT.ZERO ) THEN
300         RESULT( 3 ) = RESID / ( EPS * MAX( 1, M ) * CNORM )
301      ELSE
302         RESULT( 3 ) = ZERO
303      END IF
304*
305*     Copy C into CF again
306*
307      CALL CLACPY( 'Full', M, N, C, M, CF, M )
308*
309*     Apply Q to C as (Q**T)*C = CF
310*
311      SRNAMT = 'CGEMQRT'
312      CALL CGEMQRT( 'L', 'C', M, N, K, NB2_UB, AF, M, T2, NB2, CF, M,
313     $               WORK, INFO )
314*
315*     TEST 4
316*     Compute |CF - (Q**T)*C| / ( eps * m * |C|)
317*
318      CALL CGEMM( 'C', 'N', M, N, M, -CONE, Q, M, C, M, CONE, CF, M )
319      RESID = CLANGE( '1', M, N, CF, M, RWORK )
320      IF( CNORM.GT.ZERO ) THEN
321         RESULT( 4 ) = RESID / ( EPS * MAX( 1, M ) * CNORM )
322      ELSE
323         RESULT( 4 ) = ZERO
324      END IF
325*
326*     Generate random n-by-m matrix D and a copy DF
327*
328      DO J = 1, M
329         CALL CLARNV( 2, ISEED, N, D( 1, J ) )
330      END DO
331      DNORM = CLANGE( '1', N, M, D, N, RWORK )
332      CALL CLACPY( 'Full', N, M, D, N, DF, N )
333*
334*     Apply Q to D as D*Q = DF
335*
336      SRNAMT = 'CGEMQRT'
337      CALL CGEMQRT( 'R', 'N', N, M, K, NB2_UB, AF, M, T2, NB2, DF, N,
338     $               WORK, INFO )
339*
340*     TEST 5
341*     Compute |DF - D*Q| / ( eps * m * |D| )
342*
343      CALL CGEMM( 'N', 'N', N, M, M, -CONE, D, N, Q, M, CONE, DF, N )
344      RESID = CLANGE( '1', N, M, DF, N, RWORK )
345      IF( DNORM.GT.ZERO ) THEN
346         RESULT( 5 ) = RESID / ( EPS * MAX( 1, M ) * DNORM )
347      ELSE
348         RESULT( 5 ) = ZERO
349      END IF
350*
351*     Copy D into DF again
352*
353      CALL CLACPY( 'Full', N, M, D, N, DF, N )
354*
355*     Apply Q to D as D*QT = DF
356*
357      SRNAMT = 'CGEMQRT'
358      CALL CGEMQRT( 'R', 'C', N, M, K, NB2_UB, AF, M, T2, NB2, DF, N,
359     $               WORK, INFO )
360*
361*     TEST 6
362*     Compute |DF - D*(Q**T)| / ( eps * m * |D| )
363*
364      CALL CGEMM( 'N', 'C', N, M, M, -CONE, D, N, Q, M, CONE, DF, N )
365      RESID = CLANGE( '1', N, M, DF, N, RWORK )
366      IF( DNORM.GT.ZERO ) THEN
367         RESULT( 6 ) = RESID / ( EPS * MAX( 1, M ) * DNORM )
368      ELSE
369         RESULT( 6 ) = ZERO
370      END IF
371*
372*     Deallocate all arrays
373*
374      DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T1, T2, DIAG,
375     $             C, D, CF, DF )
376*
377      RETURN
378*
379*     End of CUNHR_COL02
380*
381      END
382