LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ 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.
Date
June 2017

Definition at line 121 of file cdrvrf3.f.

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