LAPACK 3.11.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 REAL SLAMCH, CLANGE
160 COMPLEX CLARND
161 EXTERNAL slamch, clarnd, clange
162* ..
163* .. External Subroutines ..
164 EXTERNAL ctrttf, cgeqrf, cgeqlf, ctfsm, ctrsm
165* ..
166* .. Intrinsic Functions ..
167 INTRINSIC max, sqrt
168* ..
169* .. Scalars in Common ..
170 CHARACTER*32 SRNAMT
171* ..
172* .. Common blocks ..
173 COMMON / srnamc / srnamt
174* ..
175* .. Data statements ..
176 DATA iseedy / 1988, 1989, 1990, 1991 /
177 DATA uplos / 'U', 'L' /
178 DATA forms / 'N', 'C' /
179 DATA sides / 'L', 'R' /
180 DATA transs / 'N', 'C' /
181 DATA diags / 'N', 'U' /
182* ..
183* .. Executable Statements ..
184*
185* Initialize constants and the random number seed.
186*
187 nrun = 0
188 nfail = 0
189 info = 0
190 DO 10 i = 1, 4
191 iseed( i ) = iseedy( i )
192 10 CONTINUE
193 eps = slamch( 'Precision' )
194*
195 DO 170 iim = 1, nn
196*
197 m = nval( iim )
198*
199 DO 160 iin = 1, nn
200*
201 n = nval( iin )
202*
203 DO 150 iform = 1, 2
204*
205 cform = forms( iform )
206*
207 DO 140 iuplo = 1, 2
208*
209 uplo = uplos( iuplo )
210*
211 DO 130 iside = 1, 2
212*
213 side = sides( iside )
214*
215 DO 120 itrans = 1, 2
216*
217 trans = transs( itrans )
218*
219 DO 110 idiag = 1, 2
220*
221 diag = diags( idiag )
222*
223 DO 100 ialpha = 1, 3
224*
225 IF ( ialpha.EQ. 1) THEN
226 alpha = zero
227 ELSE IF ( ialpha.EQ. 2) THEN
228 alpha = one
229 ELSE
230 alpha = clarnd( 4, iseed )
231 END IF
232*
233* All the parameters are set:
234* CFORM, SIDE, UPLO, TRANS, DIAG, M, N,
235* and ALPHA
236* READY TO TEST!
237*
238 nrun = nrun + 1
239*
240 IF ( iside.EQ.1 ) THEN
241*
242* The case ISIDE.EQ.1 is when SIDE.EQ.'L'
243* -> A is M-by-M ( B is M-by-N )
244*
245 na = m
246*
247 ELSE
248*
249* The case ISIDE.EQ.2 is when SIDE.EQ.'R'
250* -> A is N-by-N ( B is M-by-N )
251*
252 na = n
253*
254 END IF
255*
256* Generate A our NA--by--NA triangular
257* matrix.
258* Our test is based on forward error so we
259* do want A to be well conditioned! To get
260* a well-conditioned triangular matrix, we
261* take the R factor of the QR/LQ factorization
262* of a random matrix.
263*
264 DO j = 1, na
265 DO i = 1, na
266 a( i, j) = clarnd( 4, iseed )
267 END DO
268 END DO
269*
270 IF ( iuplo.EQ.1 ) THEN
271*
272* The case IUPLO.EQ.1 is when SIDE.EQ.'U'
273* -> QR factorization.
274*
275 srnamt = 'CGEQRF'
276 CALL cgeqrf( na, na, a, lda, tau,
277 + c_work_cgeqrf, lda,
278 + info )
279 ELSE
280*
281* The case IUPLO.EQ.2 is when SIDE.EQ.'L'
282* -> QL factorization.
283*
284 srnamt = 'CGELQF'
285 CALL cgelqf( na, na, a, lda, tau,
286 + c_work_cgeqrf, lda,
287 + info )
288 END IF
289*
290* After the QR factorization, the diagonal
291* of A is made of real numbers, we multiply
292* by a random complex number of absolute
293* value 1.0E+00.
294*
295 DO j = 1, na
296 a( j, j) = a(j,j) * clarnd( 5, iseed )
297 END DO
298*
299* Store a copy of A in RFP format (in ARF).
300*
301 srnamt = 'CTRTTF'
302 CALL ctrttf( cform, uplo, na, a, lda, arf,
303 + info )
304*
305* Generate B1 our M--by--N right-hand side
306* and store a copy in B2.
307*
308 DO j = 1, n
309 DO i = 1, m
310 b1( i, j) = clarnd( 4, iseed )
311 b2( i, j) = b1( i, j)
312 END DO
313 END DO
314*
315* Solve op( A ) X = B or X op( A ) = B
316* with CTRSM
317*
318 srnamt = 'CTRSM'
319 CALL ctrsm( side, uplo, trans, diag, m, n,
320 + alpha, a, lda, b1, lda )
321*
322* Solve op( A ) X = B or X op( A ) = B
323* with CTFSM
324*
325 srnamt = 'CTFSM'
326 CALL ctfsm( cform, side, uplo, trans,
327 + diag, m, n, alpha, arf, b2,
328 + lda )
329*
330* Check that the result agrees.
331*
332 DO j = 1, n
333 DO i = 1, m
334 b1( i, j) = b2( i, j ) - b1( i, j )
335 END DO
336 END DO
337*
338 result(1) = clange( 'I', m, n, b1, lda,
339 + s_work_clange )
340*
341 result(1) = result(1) / sqrt( eps )
342 + / max( max( m, n), 1 )
343*
344 IF( result(1).GE.thresh ) THEN
345 IF( nfail.EQ.0 ) THEN
346 WRITE( nout, * )
347 WRITE( nout, fmt = 9999 )
348 END IF
349 WRITE( nout, fmt = 9997 ) 'CTFSM',
350 + cform, side, uplo, trans, diag, m,
351 + n, result(1)
352 nfail = nfail + 1
353 END IF
354*
355 100 CONTINUE
356 110 CONTINUE
357 120 CONTINUE
358 130 CONTINUE
359 140 CONTINUE
360 150 CONTINUE
361 160 CONTINUE
362 170 CONTINUE
363*
364* Print a summary of the results.
365*
366 IF ( nfail.EQ.0 ) THEN
367 WRITE( nout, fmt = 9996 ) 'CTFSM', nrun
368 ELSE
369 WRITE( nout, fmt = 9995 ) 'CTFSM', nfail, nrun
370 END IF
371*
372 9999 FORMAT( 1x, ' *** Error(s) or Failure(s) while testing CTFSM
373 + ***')
374 9997 FORMAT( 1x, ' Failure in ',a5,', CFORM=''',a1,''',',
375 + ' SIDE=''',a1,''',',' UPLO=''',a1,''',',' TRANS=''',a1,''',',
376 + ' DIAG=''',a1,''',',' M=',i3,', N =', i3,', test=',g12.5)
377 9996 FORMAT( 1x, 'All tests for ',a5,' auxiliary routine passed the ',
378 + 'threshold ( ',i5,' tests run)')
379 9995 FORMAT( 1x, a6, ' auxiliary routine: ',i5,' out of ',i5,
380 + ' tests failed to pass the threshold')
381*
382 RETURN
383*
384* End of CDRVRF3
385*
subroutine ctrsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
CTRSM
Definition: ctrsm.f:180
complex function clarnd(IDIST, ISEED)
CLARND
Definition: clarnd.f:75
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
subroutine cgeqlf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
CGEQLF
Definition: cgeqlf.f:138
subroutine cgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
CGEQRF
Definition: cgeqrf.f:146
subroutine cgelqf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
CGELQF
Definition: cgelqf.f:143
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
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
real function slamch(CMACH)
SLAMCH
Definition: slamch.f:68
Here is the call graph for this function:
Here is the caller graph for this function: