LAPACK  3.7.0
LAPACK: Linear Algebra PACKage
subroutine dlqt05 ( integer  M,
integer  N,
integer  L,
integer  NB,
double precision, dimension(6)  RESULT 
)

DLQT05

Purpose: 
 DQRT05 tests DTPLQT and DTPMLQT.
Parameters
[in]M
          M is INTEGER
          Number of rows in lower part of the test matrix.
[in]N
          N is INTEGER
          Number of columns in test matrix.
[in]L
          L is INTEGER
          The number of rows of the upper trapezoidal part the
          lower test matrix.  0 <= L <= M.
[in]NB
          NB is INTEGER
          Block size of test matrix.  NB <= N.
[out]RESULT
          RESULT is DOUBLE PRECISION array, dimension (6)
          Results of each of the six tests below.

          RESULT(1) = | A - Q R |
          RESULT(2) = | I - Q^H Q |
          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 82 of file dlqt05.f.

82  IMPLICIT NONE
83 *
84 * -- LAPACK test routine (version 3.7.0) --
85 * -- LAPACK is a software package provided by Univ. of Tennessee, --
86 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
87 * April 2012
88 *
89 * .. Scalar Arguments ..
90  INTEGER lwork, m, n, l, nb, ldt
91 * .. Return values ..
92  DOUBLE PRECISION result(6)
93 *
94 * =====================================================================
95 *
96 * ..
97 * .. Local allocatable arrays
98  DOUBLE PRECISION, ALLOCATABLE :: af(:,:), q(:,:),
99  $ r(:,:), rwork(:), work( : ), t(:,:),
100  $ cf(:,:), df(:,:), a(:,:), c(:,:), d(:,:)
101 *
102 * .. Parameters ..
103  DOUBLE PRECISION one, zero
104  parameter( zero = 0.0, one = 1.0 )
105 * ..
106 * .. Local Scalars ..
107  INTEGER info, j, k, n2, np1,i
108  DOUBLE PRECISION anorm, eps, resid, cnorm, dnorm
109 * ..
110 * .. Local Arrays ..
111  INTEGER iseed( 4 )
112 * ..
113 * .. External Functions ..
114  DOUBLE PRECISION dlamch, dlange, dlansy
115  LOGICAL lsame
116  EXTERNAL dlamch, dlange, dlansy, lsame
117 * ..
118 * .. Data statements ..
119  DATA iseed / 1988, 1989, 1990, 1991 /
120 *
121  eps = dlamch( 'Epsilon' )
122  k = m
123  n2 = m+n
124  IF( n.GT.0 ) THEN
125  np1 = m+1
126  ELSE
127  np1 = 1
128  END IF
129  lwork = n2*n2*nb
130 *
131 * Dynamically allocate all arrays
132 *
133  ALLOCATE(a(m,n2),af(m,n2),q(n2,n2),r(n2,n2),rwork(n2),
134  $ work(lwork),t(nb,m),c(n2,m),cf(n2,m),
135  $ d(m,n2),df(m,n2) )
136 *
137 * Put random stuff into A
138 *
139  ldt=nb
140  CALL dlaset( 'Full', m, n2, zero, zero, a, m )
141  CALL dlaset( 'Full', nb, m, zero, zero, t, nb )
142  DO j=1,m
143  CALL dlarnv( 2, iseed, m-j+1, a( j, j ) )
144  END DO
145  IF( n.GT.0 ) THEN
146  DO j=1,n-l
147  CALL dlarnv( 2, iseed, m, a( 1, min(n+m,m+1) + j - 1 ) )
148  END DO
149  END IF
150  IF( l.GT.0 ) THEN
151  DO j=1,l
152  CALL dlarnv( 2, iseed, m-j+1, a( j, min(n+m,n+m-l+1)
153  $ + j - 1 ) )
154  END DO
155  END IF
156 *
157 * Copy the matrix A to the array AF.
158 *
159  CALL dlacpy( 'Full', m, n2, a, m, af, m )
160 *
161 * Factor the matrix A in the array AF.
162 *
163  CALL dtplqt( m,n,l,nb,af,m,af(1,np1),m,t,ldt,work,info)
164 *
165 * Generate the (M+N)-by-(M+N) matrix Q by applying H to I
166 *
167  CALL dlaset( 'Full', n2, n2, zero, one, q, n2 )
168  CALL dgemlqt( 'L', 'N', n2, n2, k, nb, af, m, t, ldt, q, n2,
169  $ work, info )
170 *
171 * Copy L
172 *
173  CALL dlaset( 'Full', n2, n2, zero, zero, r, n2 )
174  CALL dlacpy( 'Lower', m, n2, af, m, r, n2 )
175 *
176 * Compute |L - A*Q*T| / |A| and store in RESULT(1)
177 *
178  CALL dgemm( 'N', 'T', m, n2, n2, -one, a, m, q, n2, one, r, n2)
179  anorm = dlange( '1', m, n2, a, m, rwork )
180  resid = dlange( '1', m, n2, r, n2, rwork )
181  IF( anorm.GT.zero ) THEN
182  result( 1 ) = resid / (eps*anorm*max(1,n2))
183  ELSE
184  result( 1 ) = zero
185  END IF
186 *
187 * Compute |I - Q*Q'| and store in RESULT(2)
188 *
189  CALL dlaset( 'Full', n2, n2, zero, one, r, n2 )
190  CALL dsyrk( 'U', 'N', n2, n2, -one, q, n2, one, r, n2 )
191  resid = dlansy( '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 dlaset( 'Full', n2, m, zero, one, c, n2 )
197  DO j=1,m
198  CALL dlarnv( 2, iseed, n2, c( 1, j ) )
199  END DO
200  cnorm = dlange( '1', n2, m, c, n2, rwork)
201  CALL dlacpy( 'Full', n2, m, c, n2, cf, n2 )
202 *
203 * Apply Q to C as Q*C
204 *
205  CALL dtpmlqt( '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 dgemm( 'N', 'N', n2, m, n2, -one, q, n2, c, n2, one, cf, n2 )
211  resid = dlange( '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 dlacpy( 'Full', n2, m, c, n2, cf, n2 )
222 *
223 * Apply Q to C as QT*C
224 *
225  CALL dtpmlqt( 'L','T',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 dgemm('T','N',n2,m,n2,-one,q,n2,c,n2,one,cf,n2)
231  resid = dlange( '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 dlarnv( 2, iseed, m, d( 1, j ) )
243  END DO
244  dnorm = dlange( '1', m, n2, d, m, rwork)
245  CALL dlacpy( 'Full', m, n2, d, m, df, m )
246 *
247 * Apply Q to D as D*Q
248 *
249  CALL dtpmlqt('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 dgemm('N','N',m,n2,n2,-one,d,m,q,n2,one,df,m)
255  resid = dlange('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 dlacpy('Full',m,n2,d,m,df,m )
265 *
266 * Apply Q to D as D*QT
267 *
268  CALL dtpmlqt('R','T',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 dgemm( 'N', 'T', m, n2, n2, -one, d, m, q, n2, one, df, m )
275  resid = dlange( '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
dlacpy
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
Definition: dlacpy.f:105
dlamch
double precision function dlamch(CMACH)
DLAMCH
Definition: dlamch.f:65
dlansy
double precision function dlansy(NORM, UPLO, N, A, LDA, WORK)
DLANSY returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real symmetric matrix.
Definition: dlansy.f:124
dlarnv
subroutine dlarnv(IDIST, ISEED, N, X)
DLARNV returns a vector of random numbers from a uniform or normal distribution.
Definition: dlarnv.f:99
dlaset
subroutine dlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
Definition: dlaset.f:112
dgemm
subroutine dgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
DGEMM
Definition: dgemm.f:189
dsyrk
subroutine dsyrk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
DSYRK
Definition: dsyrk.f:171
dgemlqt
subroutine dgemlqt(SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT, C, LDC, WORK, INFO)
DGEMLQT
Definition: dgemlqt.f:170
dlange
double precision function dlange(NORM, M, N, A, LDA, WORK)
DLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition: dlange.f:116
dtpmlqt
subroutine dtpmlqt(SIDE, TRANS, M, N, K, L, MB, V, LDV, T, LDT, A, LDA, B, LDB, WORK, INFO)
DTPMLQT
Definition: dtpmlqt.f:218
lsame
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:55
dtplqt
subroutine dtplqt(M, N, L, MB, A, LDA, B, LDB, T, LDT, WORK, INFO)
DTPLQT
Definition: dtplqt.f:191

Here is the call graph for this function:

Here is the caller graph for this function: