LAPACK  3.7.0
LAPACK: Linear Algebra PACKage
subroutine ztsqr01 ( character  TSSW,
integer  M,
integer  N,
integer  MB,
integer  NB,
double precision, dimension(6)  RESULT 
)

ZTSQR01

Purpose: 
 ZTSQR01 tests ZGEQR , ZGELQ, ZGEMLQ and ZGEMQR.
Parameters
[in]TSSW
          TSSW is CHARACTER
          'TS' for testing tall skinny QR
               and anything else for testing short wide LQ
[in]M
          M is INTEGER
          Number of rows in test matrix.
[in]N
          N is INTEGER
          Number of columns in test matrix.
[in]MB
          MB is INTEGER
          Number of row in row block in test matrix.
[in]NB
          NB is INTEGER
          Number of columns in column block test matrix.
[out]RESULT
          RESULT is DOUBLE PRECISION array, dimension (6)
          Results of each of the six tests below.

          RESULT(1) = | A - Q R | or | A - L Q |
          RESULT(2) = | I - Q^H Q | or | I - Q Q^H |
          RESULT(3) = | Q C - Q C |
          RESULT(4) = | Q^H C - Q^H C |
          RESULT(5) = | C Q - C Q |
          RESULT(6) = | C Q^H - C Q^H |
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Date
April 2012

Definition at line 84 of file ztsqr01.f.

84  IMPLICIT NONE
85 *
86 * -- LAPACK test routine (version 3.7.0) --
87 * -- LAPACK is a software package provided by Univ. of Tennessee, --
88 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
89 * April 2012
90 *
91 * .. Scalar Arguments ..
92  CHARACTER tssw
93  INTEGER m, n, mb, nb
94 * .. Return values ..
95  DOUBLE PRECISION result(6)
96 *
97 * =====================================================================
98 *
99 * ..
100 * .. Local allocatable arrays
101  COMPLEX*16, ALLOCATABLE :: af(:,:), q(:,:),
102  $ r(:,:), rwork(:), work( : ), t(:),
103  $ cf(:,:), df(:,:), a(:,:), c(:,:), d(:,:), lq(:,:)
104 *
105 * .. Parameters ..
106  DOUBLE PRECISION zero
107  COMPLEX*16 one, czero
108  parameter( zero = 0.0, one = (1.0,0.0), czero=(0.0,0.0) )
109 * ..
110 * .. Local Scalars ..
111  LOGICAL testzeros, ts
112  INTEGER info, j, k, l, lwork, tsize, mnb
113  DOUBLE PRECISION anorm, eps, resid, cnorm, dnorm
114 * ..
115 * .. Local Arrays ..
116  INTEGER iseed( 4 )
117  COMPLEX*16 tquery( 5 ), workquery
118 * ..
119 * .. External Functions ..
120  DOUBLE PRECISION dlamch, zlange, zlansy
121  LOGICAL lsame
122  INTEGER ilaenv
123  EXTERNAL dlamch, zlange, zlansy, lsame, ilaenv
124 * ..
125 * .. Intrinsic Functions ..
126  INTRINSIC max, min
127 * .. Scalars in Common ..
128  CHARACTER*32 srnamt
129 * ..
130 * .. Common blocks ..
131  COMMON / srnamc / srnamt
132 * ..
133 * .. Data statements ..
134  DATA iseed / 1988, 1989, 1990, 1991 /
135 *
136 * TEST TALL SKINNY OR SHORT WIDE
137 *
138  ts = lsame(tssw, 'TS')
139 *
140 * TEST MATRICES WITH HALF OF MATRIX BEING ZEROS
141 *
142  testzeros = .false.
143 *
144  eps = dlamch( 'Epsilon' )
145  k = min(m,n)
146  l = max(m,n,1)
147  mnb = max( mb, nb)
148  lwork = max(3,l)*mnb
149 *
150 * Dynamically allocate local arrays
151 *
152  ALLOCATE ( a(m,n), af(m,n), q(l,l), r(m,l), rwork(l),
153  $ c(m,n), cf(m,n),
154  $ d(n,m), df(n,m), lq(l,n) )
155 *
156 * Put random numbers into A and copy to AF
157 *
158  DO j=1,n
159  CALL zlarnv( 2, iseed, m, a( 1, j ) )
160  END DO
161  IF (testzeros) THEN
162  IF (m.GE.4) THEN
163  DO j=1,n
164  CALL zlarnv( 2, iseed, m/2, a( m/4, j ) )
165  END DO
166  END IF
167  END IF
168  CALL zlacpy( 'Full', m, n, a, m, af, m )
169 *
170  IF (ts) THEN
171 *
172 * Factor the matrix A in the array AF.
173 *
174  CALL zgeqr( m, n, af, m, tquery, -1, workquery, -1, info )
175  tsize = int( tquery( 1 ) )
176  lwork = int( workquery )
177  CALL zgemqr( 'L', 'N', m, m, k, af, m, tquery, tsize, cf, m,
178  $ workquery, -1, info)
179  lwork = max( lwork, int( workquery ) )
180  CALL zgemqr( 'L', 'N', m, n, k, af, m, tquery, tsize, cf, m,
181  $ workquery, -1, info)
182  lwork = max( lwork, int( workquery ) )
183  CALL zgemqr( 'L', 'C', m, n, k, af, m, tquery, tsize, cf, m,
184  $ workquery, -1, info)
185  lwork = max( lwork, int( workquery ) )
186  CALL zgemqr( 'R', 'N', n, m, k, af, m, tquery, tsize, df, n,
187  $ workquery, -1, info)
188  lwork = max( lwork, int( workquery ) )
189  CALL zgemqr( 'R', 'C', n, m, k, af, m, tquery, tsize, df, n,
190  $ workquery, -1, info)
191  lwork = max( lwork, int( workquery ) )
192  ALLOCATE ( t( tsize ) )
193  ALLOCATE ( work( lwork ) )
194  srnamt = 'ZGEQR'
195  CALL zgeqr( m, n, af, m, t, tsize, work, lwork, info )
196 *
197 * Generate the m-by-m matrix Q
198 *
199  CALL zlaset( 'Full', m, m, czero, one, q, m )
200  srnamt = 'ZGEMQR'
201  CALL zgemqr( 'L', 'N', m, m, k, af, m, t, tsize, q, m,
202  $ work, lwork, info )
203 *
204 * Copy R
205 *
206  CALL zlaset( 'Full', m, n, czero, czero, r, m )
207  CALL zlacpy( 'Upper', m, n, af, m, r, m )
208 *
209 * Compute |R - Q'*A| / |A| and store in RESULT(1)
210 *
211  CALL zgemm( 'C', 'N', m, n, m, -one, q, m, a, m, one, r, m )
212  anorm = zlange( '1', m, n, a, m, rwork )
213  resid = zlange( '1', m, n, r, m, rwork )
214  IF( anorm.GT.zero ) THEN
215  result( 1 ) = resid / (eps*max(1,m)*anorm)
216  ELSE
217  result( 1 ) = zero
218  END IF
219 *
220 * Compute |I - Q'*Q| and store in RESULT(2)
221 *
222  CALL zlaset( 'Full', m, m, czero, one, r, m )
223  CALL zherk( 'U', 'C', m, m, dreal(-one), q, m, dreal(one), r, m )
224  resid = zlansy( '1', 'Upper', m, r, m, rwork )
225  result( 2 ) = resid / (eps*max(1,m))
226 *
227 * Generate random m-by-n matrix C and a copy CF
228 *
229  DO j=1,n
230  CALL zlarnv( 2, iseed, m, c( 1, j ) )
231  END DO
232  cnorm = zlange( '1', m, n, c, m, rwork)
233  CALL zlacpy( 'Full', m, n, c, m, cf, m )
234 *
235 * Apply Q to C as Q*C
236 *
237  srnamt = 'ZGEMQR'
238  CALL zgemqr( 'L', 'N', m, n, k, af, m, t, tsize, cf, m,
239  $ work, lwork, info)
240 *
241 * Compute |Q*C - Q*C| / |C|
242 *
243  CALL zgemm( 'N', 'N', m, n, m, -one, q, m, c, m, one, cf, m )
244  resid = zlange( '1', m, n, cf, m, rwork )
245  IF( cnorm.GT.zero ) THEN
246  result( 3 ) = resid / (eps*max(1,m)*cnorm)
247  ELSE
248  result( 3 ) = zero
249  END IF
250 *
251 * Copy C into CF again
252 *
253  CALL zlacpy( 'Full', m, n, c, m, cf, m )
254 *
255 * Apply Q to C as QT*C
256 *
257  srnamt = 'ZGEMQR'
258  CALL zgemqr( 'L', 'C', m, n, k, af, m, t, tsize, cf, m,
259  $ work, lwork, info)
260 *
261 * Compute |QT*C - QT*C| / |C|
262 *
263  CALL zgemm( 'C', 'N', m, n, m, -one, q, m, c, m, one, cf, m )
264  resid = zlange( '1', m, n, cf, m, rwork )
265  IF( cnorm.GT.zero ) THEN
266  result( 4 ) = resid / (eps*max(1,m)*cnorm)
267  ELSE
268  result( 4 ) = zero
269  END IF
270 *
271 * Generate random n-by-m matrix D and a copy DF
272 *
273  DO j=1,m
274  CALL zlarnv( 2, iseed, n, d( 1, j ) )
275  END DO
276  dnorm = zlange( '1', n, m, d, n, rwork)
277  CALL zlacpy( 'Full', n, m, d, n, df, n )
278 *
279 * Apply Q to D as D*Q
280 *
281  srnamt = 'ZGEMQR'
282  CALL zgemqr( 'R', 'N', n, m, k, af, m, t, tsize, df, n,
283  $ work, lwork, info)
284 *
285 * Compute |D*Q - D*Q| / |D|
286 *
287  CALL zgemm( 'N', 'N', n, m, m, -one, d, n, q, m, one, df, n )
288  resid = zlange( '1', n, m, df, n, rwork )
289  IF( dnorm.GT.zero ) THEN
290  result( 5 ) = resid / (eps*max(1,m)*dnorm)
291  ELSE
292  result( 5 ) = zero
293  END IF
294 *
295 * Copy D into DF again
296 *
297  CALL zlacpy( 'Full', n, m, d, n, df, n )
298 *
299 * Apply Q to D as D*QT
300 *
301  CALL zgemqr( 'R', 'C', n, m, k, af, m, t, tsize, df, n,
302  $ work, lwork, info)
303 *
304 * Compute |D*QT - D*QT| / |D|
305 *
306  CALL zgemm( 'N', 'C', n, m, m, -one, d, n, q, m, one, df, n )
307  resid = zlange( '1', n, m, df, n, rwork )
308  IF( cnorm.GT.zero ) THEN
309  result( 6 ) = resid / (eps*max(1,m)*dnorm)
310  ELSE
311  result( 6 ) = zero
312  END IF
313 *
314 * Short and wide
315 *
316  ELSE
317  CALL zgelq( m, n, af, m, tquery, -1, workquery, -1, info )
318  tsize = int( tquery( 1 ) )
319  lwork = int( workquery )
320  CALL zgemlq( 'R', 'N', n, n, k, af, m, tquery, tsize, q, n,
321  $ workquery, -1, info )
322  lwork = max( lwork, int( workquery ) )
323  CALL zgemlq( 'L', 'N', n, m, k, af, m, tquery, tsize, df, n,
324  $ workquery, -1, info)
325  lwork = max( lwork, int( workquery ) )
326  CALL zgemlq( 'L', 'C', n, m, k, af, m, tquery, tsize, df, n,
327  $ workquery, -1, info)
328  lwork = max( lwork, int( workquery ) )
329  CALL zgemlq( 'R', 'N', m, n, k, af, m, tquery, tsize, cf, m,
330  $ workquery, -1, info)
331  lwork = max( lwork, int( workquery ) )
332  CALL zgemlq( 'R', 'C', m, n, k, af, m, tquery, tsize, cf, m,
333  $ workquery, -1, info)
334  lwork = max( lwork, int( workquery ) )
335  ALLOCATE ( t( tsize ) )
336  ALLOCATE ( work( lwork ) )
337  srnamt = 'ZGELQ'
338  CALL zgelq( m, n, af, m, t, tsize, work, lwork, info )
339 *
340 *
341 * Generate the n-by-n matrix Q
342 *
343  CALL zlaset( 'Full', n, n, czero, one, q, n )
344  srnamt = 'ZGEMLQ'
345  CALL zgemlq( 'R', 'N', n, n, k, af, m, t, tsize, q, n,
346  $ work, lwork, info )
347 *
348 * Copy R
349 *
350  CALL zlaset( 'Full', m, n, czero, czero, lq, l )
351  CALL zlacpy( 'Lower', m, n, af, m, lq, l )
352 *
353 * Compute |L - A*Q'| / |A| and store in RESULT(1)
354 *
355  CALL zgemm( 'N', 'C', m, n, n, -one, a, m, q, n, one, lq, l )
356  anorm = zlange( '1', m, n, a, m, rwork )
357  resid = zlange( '1', m, n, lq, l, rwork )
358  IF( anorm.GT.zero ) THEN
359  result( 1 ) = resid / (eps*max(1,n)*anorm)
360  ELSE
361  result( 1 ) = zero
362  END IF
363 *
364 * Compute |I - Q'*Q| and store in RESULT(2)
365 *
366  CALL zlaset( 'Full', n, n, czero, one, lq, l )
367  CALL zherk( 'U', 'C', n, n, dreal(-one), q, n, dreal(one), lq, l)
368  resid = zlansy( '1', 'Upper', n, lq, l, rwork )
369  result( 2 ) = resid / (eps*max(1,n))
370 *
371 * Generate random m-by-n matrix C and a copy CF
372 *
373  DO j=1,m
374  CALL zlarnv( 2, iseed, n, d( 1, j ) )
375  END DO
376  dnorm = zlange( '1', n, m, d, n, rwork)
377  CALL zlacpy( 'Full', n, m, d, n, df, n )
378 *
379 * Apply Q to C as Q*C
380 *
381  CALL zgemlq( 'L', 'N', n, m, k, af, m, t, tsize, df, n,
382  $ work, lwork, info)
383 *
384 * Compute |Q*D - Q*D| / |D|
385 *
386  CALL zgemm( 'N', 'N', n, m, n, -one, q, n, d, n, one, df, n )
387  resid = zlange( '1', n, m, df, n, rwork )
388  IF( dnorm.GT.zero ) THEN
389  result( 3 ) = resid / (eps*max(1,n)*dnorm)
390  ELSE
391  result( 3 ) = zero
392  END IF
393 *
394 * Copy D into DF again
395 *
396  CALL zlacpy( 'Full', n, m, d, n, df, n )
397 *
398 * Apply Q to D as QT*D
399 *
400  CALL zgemlq( 'L', 'C', n, m, k, af, m, t, tsize, df, n,
401  $ work, lwork, info)
402 *
403 * Compute |QT*D - QT*D| / |D|
404 *
405  CALL zgemm( 'C', 'N', n, m, n, -one, q, n, d, n, one, df, n )
406  resid = zlange( '1', n, m, df, n, rwork )
407  IF( dnorm.GT.zero ) THEN
408  result( 4 ) = resid / (eps*max(1,n)*dnorm)
409  ELSE
410  result( 4 ) = zero
411  END IF
412 *
413 * Generate random n-by-m matrix D and a copy DF
414 *
415  DO j=1,n
416  CALL zlarnv( 2, iseed, m, c( 1, j ) )
417  END DO
418  cnorm = zlange( '1', m, n, c, m, rwork)
419  CALL zlacpy( 'Full', m, n, c, m, cf, m )
420 *
421 * Apply Q to C as C*Q
422 *
423  CALL zgemlq( 'R', 'N', m, n, k, af, m, t, tsize, cf, m,
424  $ work, lwork, info)
425 *
426 * Compute |C*Q - C*Q| / |C|
427 *
428  CALL zgemm( 'N', 'N', m, n, n, -one, c, m, q, n, one, cf, m )
429  resid = zlange( '1', n, m, df, n, rwork )
430  IF( cnorm.GT.zero ) THEN
431  result( 5 ) = resid / (eps*max(1,n)*cnorm)
432  ELSE
433  result( 5 ) = zero
434  END IF
435 *
436 * Copy C into CF again
437 *
438  CALL zlacpy( 'Full', m, n, c, m, cf, m )
439 *
440 * Apply Q to D as D*QT
441 *
442  CALL zgemlq( 'R', 'C', m, n, k, af, m, t, tsize, cf, m,
443  $ work, lwork, info)
444 *
445 * Compute |C*QT - C*QT| / |C|
446 *
447  CALL zgemm( 'N', 'C', m, n, n, -one, c, m, q, n, one, cf, m )
448  resid = zlange( '1', m, n, cf, m, rwork )
449  IF( cnorm.GT.zero ) THEN
450  result( 6 ) = resid / (eps*max(1,n)*cnorm)
451  ELSE
452  result( 6 ) = zero
453  END IF
454 *
455  END IF
456 *
457 * Deallocate all arrays
458 *
459  DEALLOCATE ( a, af, q, r, rwork, work, t, c, d, cf, df)
460 *
461  RETURN
dlamch
double precision function dlamch(CMACH)
DLAMCH
Definition: dlamch.f:65
zgeqr
subroutine zgeqr(M, N, A, LDA, T, TSIZE, WORK, LWORK, INFO)
Definition: zgeqr.f:162
zlacpy
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
Definition: zlacpy.f:105
zgemm
subroutine zgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
ZGEMM
Definition: zgemm.f:189
ilaenv
integer function ilaenv(ISPEC, NAME, OPTS, N1, N2, N3, N4)
ILAENV
Definition: tstiee.f:83
zlange
double precision function zlange(NORM, M, N, A, LDA, WORK)
ZLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition: zlange.f:117
zlansy
double precision function zlansy(NORM, UPLO, N, A, LDA, WORK)
ZLANSY 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 symmetric matrix.
Definition: zlansy.f:125
zlaset
subroutine zlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
Definition: zlaset.f:108
lsame
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:55
zgemqr
subroutine zgemqr(SIDE, TRANS, M, N, K, A, LDA, T, TSIZE, C, LDC, WORK, LWORK, INFO)
Definition: zgemqr.f:171
zgelq
subroutine zgelq(M, N, A, LDA, T, TSIZE, WORK, LWORK, INFO)
Definition: zgelq.f:161
zherk
subroutine zherk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
ZHERK
Definition: zherk.f:175
zgemlq
subroutine zgemlq(SIDE, TRANS, M, N, K, A, LDA, T, TSIZE, C, LDC, WORK, LWORK, INFO)
Definition: zgemlq.f:168
zlarnv
subroutine zlarnv(IDIST, ISEED, N, X)
ZLARNV returns a vector of random numbers from a uniform or normal distribution.
Definition: zlarnv.f:101

Here is the call graph for this function:

Here is the caller graph for this function: