LAPACK  3.10.0 LAPACK: Linear Algebra PACKage
zlqt05.f
Go to the documentation of this file.
1 *> \brief \b ZLQT05
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 ZLQT05(M,N,L,NB,RESULT)
12 *
13 * .. Scalar Arguments ..
14 * INTEGER LWORK, M, N, L, NB, LDT
15 * .. Return values ..
16 * DOUBLE PRECISION RESULT(6)
17 *
18 *
19 *> \par Purpose:
20 * =============
21 *>
22 *> \verbatim
23 *>
24 *> ZQRT05 tests ZTPLQT and ZTPMLQT.
25 *> \endverbatim
26 *
27 * Arguments:
28 * ==========
29 *
30 *> \param[in] M
31 *> \verbatim
32 *> M is INTEGER
33 *> Number of rows in lower part of the 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] L
43 *> \verbatim
44 *> L is INTEGER
45 *> The number of rows of the upper trapezoidal part the
46 *> lower test matrix. 0 <= L <= M.
47 *> \endverbatim
48 *>
49 *> \param[in] NB
50 *> \verbatim
51 *> NB is INTEGER
52 *> Block size of test matrix. NB <= N.
53 *> \endverbatim
54 *>
55 *> \param[out] RESULT
56 *> \verbatim
57 *> RESULT is DOUBLE PRECISION array, dimension (6)
58 *> Results of each of the six tests below.
59 *>
60 *> RESULT(1) = | A - Q R |
61 *> RESULT(2) = | I - Q^H Q |
62 *> RESULT(3) = | Q C - Q C |
63 *> RESULT(4) = | Q^H C - Q^H C |
64 *> RESULT(5) = | C Q - C Q |
65 *> RESULT(6) = | C Q^H - C Q^H |
66 *> \endverbatim
67 *
68 * Authors:
69 * ========
70 *
71 *> \author Univ. of Tennessee
72 *> \author Univ. of California Berkeley
73 *> \author Univ. of Colorado Denver
74 *> \author NAG Ltd.
75 *
76 *> \ingroup double_lin
77 *
78 * =====================================================================
79  SUBROUTINE zlqt05(M,N,L,NB,RESULT)
80  IMPLICIT NONE
81 *
82 * -- LAPACK test routine --
83 * -- LAPACK is a software package provided by Univ. of Tennessee, --
84 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
85 *
86 * .. Scalar Arguments ..
87  INTEGER LWORK, M, N, L, NB, LDT
88 * .. Return values ..
89  DOUBLE PRECISION RESULT(6)
90 *
91 * =====================================================================
92 *
93 * ..
94 * .. Local allocatable arrays
95  COMPLEX*16, ALLOCATABLE :: AF(:,:), Q(:,:),
96  \$ R(:,:), RWORK(:), WORK( : ), T(:,:),
97  \$ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:)
98 *
99 * .. Parameters ..
100  DOUBLE PRECISION ZERO
101  COMPLEX*16 ONE, CZERO
102  parameter( zero = 0.0, one = (1.0,0.0), czero=(0.0,0.0) )
103 * ..
104 * .. Local Scalars ..
105  INTEGER INFO, J, K, N2, NP1,i
106  DOUBLE PRECISION ANORM, EPS, RESID, CNORM, DNORM
107 * ..
108 * .. Local Arrays ..
109  INTEGER ISEED( 4 )
110 * ..
111 * .. External Functions ..
112  DOUBLE PRECISION DLAMCH
113  DOUBLE PRECISION ZLANGE, ZLANSY
114  LOGICAL LSAME
115  EXTERNAL dlamch, zlange, zlansy, lsame
116 * ..
117 * .. Data statements ..
118  DATA iseed / 1988, 1989, 1990, 1991 /
119 *
120  eps = dlamch( 'Epsilon' )
121  k = m
122  n2 = m+n
123  IF( n.GT.0 ) THEN
124  np1 = m+1
125  ELSE
126  np1 = 1
127  END IF
128  lwork = n2*n2*nb
129 *
130 * Dynamically allocate all arrays
131 *
132  ALLOCATE(a(m,n2),af(m,n2),q(n2,n2),r(n2,n2),rwork(n2),
133  \$ work(lwork),t(nb,m),c(n2,m),cf(n2,m),
134  \$ d(m,n2),df(m,n2) )
135 *
136 * Put random stuff into A
137 *
138  ldt=nb
139  CALL zlaset( 'Full', m, n2, czero, czero, a, m )
140  CALL zlaset( 'Full', nb, m, czero, czero, t, nb )
141  DO j=1,m
142  CALL zlarnv( 2, iseed, m-j+1, a( j, j ) )
143  END DO
144  IF( n.GT.0 ) THEN
145  DO j=1,n-l
146  CALL zlarnv( 2, iseed, m, a( 1, min(n+m,m+1) + j - 1 ) )
147  END DO
148  END IF
149  IF( l.GT.0 ) THEN
150  DO j=1,l
151  CALL zlarnv( 2, iseed, m-j+1, a( j, min(n+m,n+m-l+1)
152  \$ + j - 1 ) )
153  END DO
154  END IF
155 *
156 * Copy the matrix A to the array AF.
157 *
158  CALL zlacpy( 'Full', m, n2, a, m, af, m )
159 *
160 * Factor the matrix A in the array AF.
161 *
162  CALL ztplqt( m,n,l,nb,af,m,af(1,np1),m,t,ldt,work,info)
163 *
164 * Generate the (M+N)-by-(M+N) matrix Q by applying H to I
165 *
166  CALL zlaset( 'Full', n2, n2, czero, one, q, n2 )
167  CALL zgemlqt( 'L', 'N', n2, n2, k, nb, af, m, t, ldt, q, n2,
168  \$ work, info )
169 *
170 * Copy L
171 *
172  CALL zlaset( 'Full', n2, n2, czero, czero, r, n2 )
173  CALL zlacpy( 'Lower', m, n2, af, m, r, n2 )
174 *
175 * Compute |L - A*Q*C| / |A| and store in RESULT(1)
176 *
177  CALL zgemm( 'N', 'C', m, n2, n2, -one, a, m, q, n2, one, r, n2)
178  anorm = zlange( '1', m, n2, a, m, rwork )
179  resid = zlange( '1', m, n2, r, n2, rwork )
180  IF( anorm.GT.zero ) THEN
181  result( 1 ) = resid / (eps*anorm*max(1,n2))
182  ELSE
183  result( 1 ) = zero
184  END IF
185 *
186 * Compute |I - Q*Q'| and store in RESULT(2)
187 *
188  CALL zlaset( 'Full', n2, n2, czero, one, r, n2 )
189  CALL zherk( 'U', 'N', n2, n2, dreal(-one), q, n2, dreal(one),
190  \$ r, n2 )
191  resid = zlansy( '1', 'Upper', n2, r, n2, rwork )
192  result( 2 ) = resid / (eps*max(1,n2))
193 *
194 * Generate random m-by-n matrix C and a copy CF
195 *
196  CALL zlaset( 'Full', n2, m, czero, one, c, n2 )
197  DO j=1,m
198  CALL zlarnv( 2, iseed, n2, c( 1, j ) )
199  END DO
200  cnorm = zlange( '1', n2, m, c, n2, rwork)
201  CALL zlacpy( 'Full', n2, m, c, n2, cf, n2 )
202 *
203 * Apply Q to C as Q*C
204 *
205  CALL ztpmlqt( 'L','N', n,m,k,l,nb,af(1, np1),m,t,ldt,cf,n2,
206  \$ cf(np1,1),n2,work,info)
207 *
208 * Compute |Q*C - Q*C| / |C|
209 *
210  CALL zgemm( 'N', 'N', n2, m, n2, -one, q, n2, c, n2, one, cf, n2 )
211  resid = zlange( '1', n2, m, cf, n2, rwork )
212  IF( cnorm.GT.zero ) THEN
213  result( 3 ) = resid / (eps*max(1,n2)*cnorm)
214  ELSE
215  result( 3 ) = zero
216  END IF
217
218 *
219 * Copy C into CF again
220 *
221  CALL zlacpy( 'Full', n2, m, c, n2, cf, n2 )
222 *
223 * Apply Q to C as QT*C
224 *
225  CALL ztpmlqt( 'L','C',n,m,k,l,nb,af(1,np1),m,t,ldt,cf,n2,
226  \$ cf(np1,1),n2,work,info)
227 *
228 * Compute |QT*C - QT*C| / |C|
229 *
230  CALL zgemm('C','N',n2,m,n2,-one,q,n2,c,n2,one,cf,n2)
231  resid = zlange( '1', n2, m, cf, n2, rwork )
232
233  IF( cnorm.GT.zero ) THEN
234  result( 4 ) = resid / (eps*max(1,n2)*cnorm)
235  ELSE
236  result( 4 ) = zero
237  END IF
238 *
239 * Generate random m-by-n matrix D and a copy DF
240 *
241  DO j=1,n2
242  CALL zlarnv( 2, iseed, m, d( 1, j ) )
243  END DO
244  dnorm = zlange( '1', m, n2, d, m, rwork)
245  CALL zlacpy( 'Full', m, n2, d, m, df, m )
246 *
247 * Apply Q to D as D*Q
248 *
249  CALL ztpmlqt('R','N',m,n,k,l,nb,af(1,np1),m,t,ldt,df,m,
250  \$ df(1,np1),m,work,info)
251 *
252 * Compute |D*Q - D*Q| / |D|
253 *
254  CALL zgemm('N','N',m,n2,n2,-one,d,m,q,n2,one,df,m)
255  resid = zlange('1',m, n2,df,m,rwork )
256  IF( cnorm.GT.zero ) THEN
257  result( 5 ) = resid / (eps*max(1,n2)*dnorm)
258  ELSE
259  result( 5 ) = zero
260  END IF
261 *
262 * Copy D into DF again
263 *
264  CALL zlacpy('Full',m,n2,d,m,df,m )
265 *
266 * Apply Q to D as D*QT
267 *
268  CALL ztpmlqt('R','C',m,n,k,l,nb,af(1,np1),m,t,ldt,df,m,
269  \$ df(1,np1),m,work,info)
270
271 *
272 * Compute |D*QT - D*QT| / |D|
273 *
274  CALL zgemm( 'N', 'C', m, n2, n2, -one, d, m, q, n2, one, df, m )
275  resid = zlange( '1', m, n2, df, m, rwork )
276  IF( cnorm.GT.zero ) THEN
277  result( 6 ) = resid / (eps*max(1,n2)*dnorm)
278  ELSE
279  result( 6 ) = zero
280  END IF
281 *
282 * Deallocate all arrays
283 *
284  DEALLOCATE ( a, af, q, r, rwork, work, t, c, d, cf, df)
285  RETURN
286  END
subroutine zgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
ZGEMM
Definition: zgemm.f:187
subroutine zherk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
ZHERK
Definition: zherk.f:173
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
Definition: zlacpy.f:103
subroutine zlarnv(IDIST, ISEED, N, X)
ZLARNV returns a vector of random numbers from a uniform or normal distribution.
Definition: zlarnv.f:99
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:106
subroutine zlqt05(M, N, L, NB, RESULT)
ZLQT05
Definition: zlqt05.f:80
subroutine zgemlqt(SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT, C, LDC, WORK, INFO)
ZGEMLQT
Definition: zgemlqt.f:168
subroutine ztplqt(M, N, L, MB, A, LDA, B, LDB, T, LDT, WORK, INFO)
ZTPLQT
Definition: ztplqt.f:189
subroutine ztpmlqt(SIDE, TRANS, M, N, K, L, MB, V, LDV, T, LDT, A, LDA, B, LDB, WORK, INFO)
ZTPMLQT
Definition: ztpmlqt.f:216