LAPACK  3.8.0 LAPACK: Linear Algebra PACKage

## ◆ sdrvrf4()

 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)`
Date
December 2016

Definition at line 120 of file sdrvrf4.f.

120 *
121 * -- LAPACK test routine (version 3.7.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 * December 2016
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
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 *
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
subroutine ssyrk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
SSYRK
Definition: ssyrk.f:171
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
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
real function slarnd(IDIST, ISEED)
SLARND
Definition: slarnd.f:75
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
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: