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

◆ cdrvrf3()

subroutine cdrvrf3 ( integer  nout,
integer  nn,
integer, dimension( nn )  nval,
real  thresh,
complex, dimension( lda, * )  a,
integer  lda,
complex, dimension( * )  arf,
complex, dimension( lda, * )  b1,
complex, dimension( lda, * )  b2,
real, dimension( * )  s_work_clange,
complex, dimension( * )  c_work_cgeqrf,
complex, dimension( * )  tau 
)

CDRVRF3

Purpose:
 CDRVRF3 tests the LAPACK RFP routines:
     CTFSM
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 array, dimension ((NMAX*(NMAX+1))/2).
[out]B1
          B1 is COMPLEX array, dimension (LDA,NMAX)
[out]B2
          B2 is COMPLEX array, dimension (LDA,NMAX)
[out]S_WORK_CLANGE
          S_WORK_CLANGE is REAL array, dimension (NMAX)
[out]C_WORK_CGEQRF
          C_WORK_CGEQRF is COMPLEX array, dimension (NMAX)
[out]TAU
          TAU is COMPLEX array, dimension (NMAX)
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 117 of file cdrvrf3.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 REAL THRESH
127* ..
128* .. Array Arguments ..
129 INTEGER NVAL( NN )
130 REAL S_WORK_CLANGE( * )
131 COMPLEX A( LDA, * ), ARF( * ), B1( LDA, * ),
132 + B2( LDA, * )
133 COMPLEX C_WORK_CGEQRF( * ), TAU( * )
134* ..
135*
136* =====================================================================
137* ..
138* .. Parameters ..
139 COMPLEX ZERO, ONE
140 parameter( zero = ( 0.0e+0, 0.0e+0 ) ,
141 + one = ( 1.0e+0, 0.0e+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 ALPHA
150 REAL 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 REAL RESULT( NTESTS )
157* ..
158* .. External Functions ..
159 LOGICAL LSAME
160 REAL SLAMCH, CLANGE
161 COMPLEX CLARND
162 EXTERNAL slamch, clarnd, clange, lsame
163* ..
164* .. External Subroutines ..
165 EXTERNAL ctrttf, cgeqrf, cgeqlf, ctfsm, ctrsm
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 = slamch( '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 = clarnd( 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 ) = clarnd( 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 = 'CGEQRF'
277 CALL cgeqrf( na, na, a, lda, tau,
278 + c_work_cgeqrf, 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 = 'CGELQF'
300 CALL cgelqf( na, na, a, lda, tau,
301 + c_work_cgeqrf, 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 + clarnd( 5, iseed )
327 END DO
328*
329* Store a copy of A in RFP format (in ARF).
330*
331 srnamt = 'CTRTTF'
332 CALL ctrttf( 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 ) = clarnd( 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 CTRSM
347*
348 srnamt = 'CTRSM'
349 CALL ctrsm( 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 CTFSM
354*
355 srnamt = 'CTFSM'
356 CALL ctfsm( 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 ) = clange( 'I', m, n, b1, lda,
369 + s_work_clange )
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 ) 'CTFSM',
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 ) 'CTFSM', nrun
398 ELSE
399 WRITE( nout, fmt = 9995 ) 'CTFSM', nfail, nrun
400 END IF
401*
402 9999 FORMAT( 1x, ' *** Error(s) or Failure(s) while testing CTFSM
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 CDRVRF3
415*
clarnd
complex function clarnd(idist, iseed)
CLARND
Definition clarnd.f:75
cgelqf
subroutine cgelqf(m, n, a, lda, tau, work, lwork, info)
CGELQF
Definition cgelqf.f:143
cgeqlf
subroutine cgeqlf(m, n, a, lda, tau, work, lwork, info)
CGEQLF
Definition cgeqlf.f:138
cgeqrf
subroutine cgeqrf(m, n, a, lda, tau, work, lwork, info)
CGEQRF
Definition cgeqrf.f:146
slamch
real function slamch(cmach)
SLAMCH
Definition slamch.f:68
clange
real function clange(norm, m, n, a, lda, work)
CLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition clange.f:115
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:48
ctfsm
subroutine ctfsm(transr, side, uplo, trans, diag, m, n, alpha, a, b, ldb)
CTFSM solves a matrix equation (one operand is a triangular matrix in RFP format).
Definition ctfsm.f:298
ctrsm
subroutine ctrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
CTRSM
Definition ctrsm.f:180
ctrttf
subroutine ctrttf(transr, uplo, n, a, lda, arf, info)
CTRTTF copies a triangular matrix from the standard full format (TR) to the rectangular full packed f...
Definition ctrttf.f:216
Here is the call graph for this function:
Here is the caller graph for this function: