LAPACK  3.10.1
LAPACK: Linear Algebra PACKage

◆ zdrvrf4()

subroutine zdrvrf4 ( integer  NOUT,
integer  NN,
integer, dimension( nn )  NVAL,
double precision  THRESH,
complex*16, dimension( ldc, * )  C1,
complex*16, dimension( ldc, *)  C2,
integer  LDC,
complex*16, dimension( * )  CRF,
complex*16, dimension( lda, * )  A,
integer  LDA,
double precision, dimension( * )  D_WORK_ZLANGE 
)

ZDRVRF4

Purpose:
 ZDRVRF4 tests the LAPACK RFP routines:
     ZHFRK
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]C1
          C1 is COMPLEX*16 array, dimension (LDC,NMAX)
[out]C2
          C2 is COMPLEX*16 array, dimension (LDC,NMAX)
[in]LDC
          LDC is INTEGER
                The leading dimension of the array A.  LDA >= max(1,NMAX).
[out]CRF
          CRF is COMPLEX*16 array, dimension ((NMAX*(NMAX+1))/2).
[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]D_WORK_ZLANGE
          D_WORK_ZLANGE is DOUBLE PRECISION array, dimension (NMAX)
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 112 of file zdrvrf4.f.

114 *
115 * -- LAPACK test routine --
116 * -- LAPACK is a software package provided by Univ. of Tennessee, --
117 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
118 *
119 * .. Scalar Arguments ..
120  INTEGER LDA, LDC, NN, NOUT
121  DOUBLE PRECISION THRESH
122 * ..
123 * .. Array Arguments ..
124  INTEGER NVAL( NN )
125  DOUBLE PRECISION D_WORK_ZLANGE( * )
126  COMPLEX*16 A( LDA, * ), C1( LDC, * ), C2( LDC, *),
127  + CRF( * )
128 * ..
129 *
130 * =====================================================================
131 * ..
132 * .. Parameters ..
133  DOUBLE PRECISION ZERO, ONE
134  parameter( zero = 0.0d+0, one = 1.0d+0 )
135  INTEGER NTESTS
136  parameter( ntests = 1 )
137 * ..
138 * .. Local Scalars ..
139  CHARACTER UPLO, CFORM, TRANS
140  INTEGER I, IFORM, IIK, IIN, INFO, IUPLO, J, K, N,
141  + NFAIL, NRUN, IALPHA, ITRANS
142  DOUBLE PRECISION ALPHA, BETA, EPS, NORMA, NORMC
143 * ..
144 * .. Local Arrays ..
145  CHARACTER UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 )
146  INTEGER ISEED( 4 ), ISEEDY( 4 )
147  DOUBLE PRECISION RESULT( NTESTS )
148 * ..
149 * .. External Functions ..
150  DOUBLE PRECISION DLAMCH, DLARND, ZLANGE
151  COMPLEX*16 ZLARND
152  EXTERNAL dlamch, dlarnd, zlange, zlarnd
153 * ..
154 * .. External Subroutines ..
155  EXTERNAL zherk, zhfrk, ztfttr, ztrttf
156 * ..
157 * .. Intrinsic Functions ..
158  INTRINSIC dabs, max
159 * ..
160 * .. Scalars in Common ..
161  CHARACTER*32 SRNAMT
162 * ..
163 * .. Common blocks ..
164  COMMON / srnamc / srnamt
165 * ..
166 * .. Data statements ..
167  DATA iseedy / 1988, 1989, 1990, 1991 /
168  DATA uplos / 'U', 'L' /
169  DATA forms / 'N', 'C' /
170  DATA transs / 'N', 'C' /
171 * ..
172 * .. Executable Statements ..
173 *
174 * Initialize constants and the random number seed.
175 *
176  nrun = 0
177  nfail = 0
178  info = 0
179  DO 10 i = 1, 4
180  iseed( i ) = iseedy( i )
181  10 CONTINUE
182  eps = dlamch( 'Precision' )
183 *
184  DO 150 iin = 1, nn
185 *
186  n = nval( iin )
187 *
188  DO 140 iik = 1, nn
189 *
190  k = nval( iin )
191 *
192  DO 130 iform = 1, 2
193 *
194  cform = forms( iform )
195 *
196  DO 120 iuplo = 1, 2
197 *
198  uplo = uplos( iuplo )
199 *
200  DO 110 itrans = 1, 2
201 *
202  trans = transs( itrans )
203 *
204  DO 100 ialpha = 1, 4
205 *
206  IF ( ialpha.EQ. 1) THEN
207  alpha = zero
208  beta = zero
209  ELSE IF ( ialpha.EQ. 2) THEN
210  alpha = one
211  beta = zero
212  ELSE IF ( ialpha.EQ. 3) THEN
213  alpha = zero
214  beta = one
215  ELSE
216  alpha = dlarnd( 2, iseed )
217  beta = dlarnd( 2, iseed )
218  END IF
219 *
220 * All the parameters are set:
221 * CFORM, UPLO, TRANS, M, N,
222 * ALPHA, and BETA
223 * READY TO TEST!
224 *
225  nrun = nrun + 1
226 *
227  IF ( itrans.EQ.1 ) THEN
228 *
229 * In this case we are NOTRANS, so A is N-by-K
230 *
231  DO j = 1, k
232  DO i = 1, n
233  a( i, j) = zlarnd( 4, iseed )
234  END DO
235  END DO
236 *
237  norma = zlange( 'I', n, k, a, lda,
238  + d_work_zlange )
239 *
240  ELSE
241 *
242 * In this case we are TRANS, so A is K-by-N
243 *
244  DO j = 1,n
245  DO i = 1, k
246  a( i, j) = zlarnd( 4, iseed )
247  END DO
248  END DO
249 *
250  norma = zlange( 'I', k, n, a, lda,
251  + d_work_zlange )
252 *
253  END IF
254 *
255 *
256 * Generate C1 our N--by--N Hermitian matrix.
257 * Make sure C2 has the same upper/lower part,
258 * (the one that we do not touch), so
259 * copy the initial C1 in C2 in it.
260 *
261  DO j = 1, n
262  DO i = 1, n
263  c1( i, j) = zlarnd( 4, iseed )
264  c2(i,j) = c1(i,j)
265  END DO
266  END DO
267 *
268 * (See comment later on for why we use ZLANGE and
269 * not ZLANHE for C1.)
270 *
271  normc = zlange( 'I', n, n, c1, ldc,
272  + d_work_zlange )
273 *
274  srnamt = 'ZTRTTF'
275  CALL ztrttf( cform, uplo, n, c1, ldc, crf,
276  + info )
277 *
278 * call zherk the BLAS routine -> gives C1
279 *
280  srnamt = 'ZHERK '
281  CALL zherk( uplo, trans, n, k, alpha, a, lda,
282  + beta, c1, ldc )
283 *
284 * call zhfrk the RFP routine -> gives CRF
285 *
286  srnamt = 'ZHFRK '
287  CALL zhfrk( cform, uplo, trans, n, k, alpha, a,
288  + lda, beta, crf )
289 *
290 * convert CRF in full format -> gives C2
291 *
292  srnamt = 'ZTFTTR'
293  CALL ztfttr( cform, uplo, n, crf, c2, ldc,
294  + info )
295 *
296 * compare C1 and C2
297 *
298  DO j = 1, n
299  DO i = 1, n
300  c1(i,j) = c1(i,j)-c2(i,j)
301  END DO
302  END DO
303 *
304 * Yes, C1 is Hermitian so we could call ZLANHE,
305 * but we want to check the upper part that is
306 * supposed to be unchanged and the diagonal that
307 * is supposed to be real -> ZLANGE
308 *
309  result(1) = zlange( 'I', n, n, c1, ldc,
310  + d_work_zlange )
311  result(1) = result(1)
312  + / max( dabs( alpha ) * norma * norma
313  + + dabs( beta ) * normc, one )
314  + / max( n , 1 ) / eps
315 *
316  IF( result(1).GE.thresh ) THEN
317  IF( nfail.EQ.0 ) THEN
318  WRITE( nout, * )
319  WRITE( nout, fmt = 9999 )
320  END IF
321  WRITE( nout, fmt = 9997 ) 'ZHFRK',
322  + cform, uplo, trans, n, k, result(1)
323  nfail = nfail + 1
324  END IF
325 *
326  100 CONTINUE
327  110 CONTINUE
328  120 CONTINUE
329  130 CONTINUE
330  140 CONTINUE
331  150 CONTINUE
332 *
333 * Print a summary of the results.
334 *
335  IF ( nfail.EQ.0 ) THEN
336  WRITE( nout, fmt = 9996 ) 'ZHFRK', nrun
337  ELSE
338  WRITE( nout, fmt = 9995 ) 'ZHFRK', nfail, nrun
339  END IF
340 *
341  9999 FORMAT( 1x, ' *** Error(s) or Failure(s) while testing ZHFRK
342  + ***')
343  9997 FORMAT( 1x, ' Failure in ',a5,', CFORM=''',a1,''',',
344  + ' UPLO=''',a1,''',',' TRANS=''',a1,''',', ' N=',i3,', K =', i3,
345  + ', test=',g12.5)
346  9996 FORMAT( 1x, 'All tests for ',a5,' auxiliary routine passed the ',
347  + 'threshold ( ',i6,' tests run)')
348  9995 FORMAT( 1x, a6, ' auxiliary routine: ',i6,' out of ',i6,
349  + ' tests failed to pass the threshold')
350 *
351  RETURN
352 *
353 * End of ZDRVRF4
354 *
double precision function dlamch(CMACH)
DLAMCH
Definition: dlamch.f:69
subroutine zherk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
ZHERK
Definition: zherk.f:173
complex *16 function zlarnd(IDIST, ISEED)
ZLARND
Definition: zlarnd.f:75
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
subroutine zhfrk(TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C)
ZHFRK performs a Hermitian rank-k operation for matrix in RFP format.
Definition: zhfrk.f:168
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
subroutine ztfttr(TRANSR, UPLO, N, ARF, A, LDA, INFO)
ZTFTTR copies a triangular matrix from the rectangular full packed format (TF) to the standard full f...
Definition: ztfttr.f:216
double precision function dlarnd(IDIST, ISEED)
DLARND
Definition: dlarnd.f:73
Here is the call graph for this function:
Here is the caller graph for this function: