LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
subroutine sdrvrf4 ( integer  NOUT,
integer  NN,
integer, dimension( nn )  NVAL,
real  THRESH,
real, dimension( ldc, * )  C1,
real, dimension( ldc, *)  C2,
integer  LDC,
real, dimension( * )  CRF,
real, dimension( lda, * )  A,
integer  LDA,
real, dimension( * )  S_WORK_SLANGE 
)

SDRVRF4

Purpose: 
 SDRVRF4 tests the LAPACK RFP routines:
     SSFRK
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 REAL
                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 REAL array,
                dimension (LDC,NMAX)
[out]C2
          C2 is REAL array,
                dimension (LDC,NMAX)
[in]LDC
          LDC is INTEGER
                The leading dimension of the array A.
                LDA >= max(1,NMAX).
[out]CRF
          CRF is REAL array,
                dimension ((NMAX*(NMAX+1))/2).
[out]A
          A is REAL array,
                dimension (LDA,NMAX)
[in]LDA
          LDA is INTEGER
                The leading dimension of the array A.  LDA >= max(1,NMAX).
[out]S_WORK_SLANGE
          S_WORK_SLANGE is REAL array, dimension (NMAX)
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Date
November 2011

Definition at line 120 of file sdrvrf4.f.

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

Here is the call graph for this function:

Here is the caller graph for this function: