LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ zdrvrf3()

subroutine zdrvrf3 ( integer  nout,
integer  nn,
integer, dimension( nn )  nval,
double precision  thresh,
complex*16, dimension( lda, * )  a,
integer  lda,
complex*16, dimension( * )  arf,
complex*16, dimension( lda, * )  b1,
complex*16, dimension( lda, * )  b2,
double precision, dimension( * )  d_work_zlange,
complex*16, dimension( * )  z_work_zgeqrf,
complex*16, dimension( * )  tau 
)

ZDRVRF3

Purpose:
 ZDRVRF3 tests the LAPACK RFP routines:
     ZTFSM
Parameters
[in]NOUT
          NOUT is INTEGER
                The unit number for output.
[in]NN
          NN is INTEGER
                The number of values of N contained in the vector NVAL.
[in]NVAL
          NVAL is INTEGER array, dimension (NN)
                The values of the matrix dimension N.
[in]THRESH
          THRESH is DOUBLE PRECISION
                The threshold value for the test ratios.  A result is
                included in the output file if RESULT >= THRESH.  To have
                every test ratio printed, use THRESH = 0.
[out]A
          A is COMPLEX*16 array, dimension (LDA,NMAX)
[in]LDA
          LDA is INTEGER
                The leading dimension of the array A.  LDA >= max(1,NMAX).
[out]ARF
          ARF is COMPLEX*16 array, dimension ((NMAX*(NMAX+1))/2).
[out]B1
          B1 is COMPLEX*16 array, dimension (LDA,NMAX)
[out]B2
          B2 is COMPLEX*16 array, dimension (LDA,NMAX)
[out]D_WORK_ZLANGE
          D_WORK_ZLANGE is DOUBLE PRECISION array, dimension (NMAX)
[out]Z_WORK_ZGEQRF
          Z_WORK_ZGEQRF is COMPLEX*16 array, dimension (NMAX)
[out]TAU
          TAU is COMPLEX*16 array, dimension (NMAX)
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 117 of file zdrvrf3.f.

119*
120* -- LAPACK test routine --
121* -- LAPACK is a software package provided by Univ. of Tennessee, --
122* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
123*
124* .. Scalar Arguments ..
125 INTEGER LDA, NN, NOUT
126 DOUBLE PRECISION THRESH
127* ..
128* .. Array Arguments ..
129 INTEGER NVAL( NN )
130 DOUBLE PRECISION D_WORK_ZLANGE( * )
131 COMPLEX*16 A( LDA, * ), ARF( * ), B1( LDA, * ),
132 + B2( LDA, * )
133 COMPLEX*16 Z_WORK_ZGEQRF( * ), TAU( * )
134* ..
135*
136* =====================================================================
137* ..
138* .. Parameters ..
139 COMPLEX*16 ZERO, ONE
140 parameter( zero = ( 0.0d+0, 0.0d+0 ) ,
141 + one = ( 1.0d+0, 0.0d+0 ) )
142 INTEGER NTESTS
143 parameter( ntests = 1 )
144* ..
145* .. Local Scalars ..
146 CHARACTER UPLO, CFORM, DIAG, TRANS, SIDE
147 INTEGER I, IFORM, IIM, IIN, INFO, IUPLO, J, M, N, NA,
148 + NFAIL, NRUN, ISIDE, IDIAG, IALPHA, ITRANS
149 COMPLEX*16 ALPHA
150 DOUBLE PRECISION EPS
151* ..
152* .. Local Arrays ..
153 CHARACTER UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 ),
154 + DIAGS( 2 ), SIDES( 2 )
155 INTEGER ISEED( 4 ), ISEEDY( 4 )
156 DOUBLE PRECISION RESULT( NTESTS )
157* ..
158* .. External Functions ..
159 LOGICAL LSAME
160 DOUBLE PRECISION DLAMCH, ZLANGE
161 COMPLEX*16 ZLARND
162 EXTERNAL dlamch, zlarnd, zlange, lsame
163* ..
164* .. External Subroutines ..
165 EXTERNAL ztrttf, zgeqrf, zgeqlf, ztfsm, ztrsm
166* ..
167* .. Intrinsic Functions ..
168 INTRINSIC max, sqrt
169* ..
170* .. Scalars in Common ..
171 CHARACTER*32 SRNAMT
172* ..
173* .. Common blocks ..
174 COMMON / srnamc / srnamt
175* ..
176* .. Data statements ..
177 DATA iseedy / 1988, 1989, 1990, 1991 /
178 DATA uplos / 'U', 'L' /
179 DATA forms / 'N', 'C' /
180 DATA sides / 'L', 'R' /
181 DATA transs / 'N', 'C' /
182 DATA diags / 'N', 'U' /
183* ..
184* .. Executable Statements ..
185*
186* Initialize constants and the random number seed.
187*
188 nrun = 0
189 nfail = 0
190 info = 0
191 DO 10 i = 1, 4
192 iseed( i ) = iseedy( i )
193 10 CONTINUE
194 eps = dlamch( 'Precision' )
195*
196 DO 170 iim = 1, nn
197*
198 m = nval( iim )
199*
200 DO 160 iin = 1, nn
201*
202 n = nval( iin )
203*
204 DO 150 iform = 1, 2
205*
206 cform = forms( iform )
207*
208 DO 140 iuplo = 1, 2
209*
210 uplo = uplos( iuplo )
211*
212 DO 130 iside = 1, 2
213*
214 side = sides( iside )
215*
216 DO 120 itrans = 1, 2
217*
218 trans = transs( itrans )
219*
220 DO 110 idiag = 1, 2
221*
222 diag = diags( idiag )
223*
224 DO 100 ialpha = 1, 3
225*
226 IF ( ialpha.EQ.1 ) THEN
227 alpha = zero
228 ELSE IF ( ialpha.EQ.2 ) THEN
229 alpha = one
230 ELSE
231 alpha = zlarnd( 4, iseed )
232 END IF
233*
234* All the parameters are set:
235* CFORM, SIDE, UPLO, TRANS, DIAG, M, N,
236* and ALPHA
237* READY TO TEST!
238*
239 nrun = nrun + 1
240*
241 IF ( iside.EQ.1 ) THEN
242*
243* The case ISIDE.EQ.1 is when SIDE.EQ.'L'
244* -> A is M-by-M ( B is M-by-N )
245*
246 na = m
247*
248 ELSE
249*
250* The case ISIDE.EQ.2 is when SIDE.EQ.'R'
251* -> A is N-by-N ( B is M-by-N )
252*
253 na = n
254*
255 END IF
256*
257* Generate A our NA--by--NA triangular
258* matrix.
259* Our test is based on forward error so we
260* do want A to be well conditioned! To get
261* a well-conditioned triangular matrix, we
262* take the R factor of the QR/LQ factorization
263* of a random matrix.
264*
265 DO j = 1, na
266 DO i = 1, na
267 a( i, j ) = zlarnd( 4, iseed )
268 END DO
269 END DO
270*
271 IF ( iuplo.EQ.1 ) THEN
272*
273* The case IUPLO.EQ.1 is when SIDE.EQ.'U'
274* -> QR factorization.
275*
276 srnamt = 'ZGEQRF'
277 CALL zgeqrf( na, na, a, lda, tau,
278 + z_work_zgeqrf, lda,
279 + info )
280*
281* Forcing main diagonal of test matrix to
282* be unit makes it ill-conditioned for
283* some test cases
284*
285 IF ( lsame( diag, 'U' ) ) THEN
286 DO j = 1, na
287 DO i = 1, j
288 a( i, j ) = a( i, j ) /
289 + ( 2.0 * a( j, j ) )
290 END DO
291 END DO
292 END IF
293*
294 ELSE
295*
296* The case IUPLO.EQ.2 is when SIDE.EQ.'L'
297* -> QL factorization.
298*
299 srnamt = 'ZGELQF'
300 CALL zgelqf( na, na, a, lda, tau,
301 + z_work_zgeqrf, lda,
302 + info )
303*
304* Forcing main diagonal of test matrix to
305* be unit makes it ill-conditioned for
306* some test cases
307*
308 IF ( lsame( diag, 'U' ) ) THEN
309 DO i = 1, na
310 DO j = 1, i
311 a( i, j ) = a( i, j ) /
312 + ( 2.0 * a( i, i ) )
313 END DO
314 END DO
315 END IF
316*
317 END IF
318*
319* After the QR factorization, the diagonal
320* of A is made of real numbers, we multiply
321* by a random complex number of absolute
322* value 1.0E+00.
323*
324 DO j = 1, na
325 a( j, j ) = a( j, j ) *
326 + zlarnd( 5, iseed )
327 END DO
328*
329* Store a copy of A in RFP format (in ARF).
330*
331 srnamt = 'ZTRTTF'
332 CALL ztrttf( cform, uplo, na, a, lda, arf,
333 + info )
334*
335* Generate B1 our M--by--N right-hand side
336* and store a copy in B2.
337*
338 DO j = 1, n
339 DO i = 1, m
340 b1( i, j ) = zlarnd( 4, iseed )
341 b2( i, j ) = b1( i, j )
342 END DO
343 END DO
344*
345* Solve op( A ) X = B or X op( A ) = B
346* with ZTRSM
347*
348 srnamt = 'ZTRSM'
349 CALL ztrsm( side, uplo, trans, diag, m, n,
350 + alpha, a, lda, b1, lda )
351*
352* Solve op( A ) X = B or X op( A ) = B
353* with ZTFSM
354*
355 srnamt = 'ZTFSM'
356 CALL ztfsm( cform, side, uplo, trans,
357 + diag, m, n, alpha, arf, b2,
358 + lda )
359*
360* Check that the result agrees.
361*
362 DO j = 1, n
363 DO i = 1, m
364 b1( i, j ) = b2( i, j ) - b1( i, j )
365 END DO
366 END DO
367*
368 result( 1 ) = zlange( 'I', m, n, b1, lda,
369 + d_work_zlange )
370*
371 result( 1 ) = result( 1 ) / sqrt( eps )
372 + / max( max( m, n ), 1 )
373*
374 IF( result( 1 ).GE.thresh ) THEN
375 IF( nfail.EQ.0 ) THEN
376 WRITE( nout, * )
377 WRITE( nout, fmt = 9999 )
378 END IF
379 WRITE( nout, fmt = 9997 ) 'ZTFSM',
380 + cform, side, uplo, trans, diag, m,
381 + n, result( 1 )
382 nfail = nfail + 1
383 END IF
384*
385 100 CONTINUE
386 110 CONTINUE
387 120 CONTINUE
388 130 CONTINUE
389 140 CONTINUE
390 150 CONTINUE
391 160 CONTINUE
392 170 CONTINUE
393*
394* Print a summary of the results.
395*
396 IF ( nfail.EQ.0 ) THEN
397 WRITE( nout, fmt = 9996 ) 'ZTFSM', nrun
398 ELSE
399 WRITE( nout, fmt = 9995 ) 'ZTFSM', nfail, nrun
400 END IF
401*
402 9999 FORMAT( 1x, ' *** Error(s) or Failure(s) while testing ZTFSM
403 + ***')
404 9997 FORMAT( 1x, ' Failure in ',a5,', CFORM=''',a1,''',',
405 + ' SIDE=''',a1,''',',' UPLO=''',a1,''',',' TRANS=''',a1,''',',
406 + ' DIAG=''',a1,''',',' M=',i3,', N =', i3,', test=',g12.5)
407 9996 FORMAT( 1x, 'All tests for ',a5,' auxiliary routine passed the ',
408 + 'threshold ( ',i5,' tests run)')
409 9995 FORMAT( 1x, a6, ' auxiliary routine:',i5,' out of ',i5,
410 + ' tests failed to pass the threshold')
411*
412 RETURN
413*
414* End of ZDRVRF3
415*
zgelqf
subroutine zgelqf(m, n, a, lda, tau, work, lwork, info)
ZGELQF
Definition zgelqf.f:143
zgeqlf
subroutine zgeqlf(m, n, a, lda, tau, work, lwork, info)
ZGEQLF
Definition zgeqlf.f:138
zgeqrf
subroutine zgeqrf(m, n, a, lda, tau, work, lwork, info)
ZGEQRF
Definition zgeqrf.f:146
dlamch
double precision function dlamch(cmach)
DLAMCH
Definition dlamch.f:69
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:115
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:48
ztfsm
subroutine ztfsm(transr, side, uplo, trans, diag, m, n, alpha, a, b, ldb)
ZTFSM solves a matrix equation (one operand is a triangular matrix in RFP format).
Definition ztfsm.f:298
ztrsm
subroutine ztrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
ZTRSM
Definition ztrsm.f:180
ztrttf
subroutine ztrttf(transr, uplo, n, a, lda, arf, info)
ZTRTTF copies a triangular matrix from the standard full format (TR) to the rectangular full packed f...
Definition ztrttf.f:216
zlarnd
complex *16 function zlarnd(idist, iseed)
ZLARND
Definition zlarnd.f:75
Here is the call graph for this function:
Here is the caller graph for this function: