LAPACK  3.10.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)
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 116 of file sdrvrf4.f.

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