LAPACK  3.10.0
LAPACK: Linear Algebra PACKage
sdrvrf4.f
Go to the documentation of this file.
1 *> \brief \b SDRVRF4
2 *
3 * =========== DOCUMENTATION ===========
4 *
5 * Online html documentation available at
6 * http://www.netlib.org/lapack/explore-html/
7 *
8 * Definition:
9 * ===========
10 *
11 * SUBROUTINE SDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A,
12 * + LDA, S_WORK_SLANGE )
13 *
14 * .. Scalar Arguments ..
15 * INTEGER LDA, LDC, NN, NOUT
16 * REAL THRESH
17 * ..
18 * .. Array Arguments ..
19 * INTEGER NVAL( NN )
20 * REAL A( LDA, * ), C1( LDC, * ), C2( LDC, *),
21 * + CRF( * ), S_WORK_SLANGE( * )
22 * ..
23 *
24 *
25 *> \par Purpose:
26 * =============
27 *>
28 *> \verbatim
29 *>
30 *> SDRVRF4 tests the LAPACK RFP routines:
31 *> SSFRK
32 *> \endverbatim
33 *
34 * Arguments:
35 * ==========
36 *
37 *> \param[in] NOUT
38 *> \verbatim
39 *> NOUT is INTEGER
40 *> The unit number for output.
41 *> \endverbatim
42 *>
43 *> \param[in] NN
44 *> \verbatim
45 *> NN is INTEGER
46 *> The number of values of N contained in the vector NVAL.
47 *> \endverbatim
48 *>
49 *> \param[in] NVAL
50 *> \verbatim
51 *> NVAL is INTEGER array, dimension (NN)
52 *> The values of the matrix dimension N.
53 *> \endverbatim
54 *>
55 *> \param[in] THRESH
56 *> \verbatim
57 *> THRESH is REAL
58 *> The threshold value for the test ratios. A result is
59 *> included in the output file if RESULT >= THRESH. To
60 *> have every test ratio printed, use THRESH = 0.
61 *> \endverbatim
62 *>
63 *> \param[out] C1
64 *> \verbatim
65 *> C1 is REAL array,
66 *> dimension (LDC,NMAX)
67 *> \endverbatim
68 *>
69 *> \param[out] C2
70 *> \verbatim
71 *> C2 is REAL array,
72 *> dimension (LDC,NMAX)
73 *> \endverbatim
74 *>
75 *> \param[in] LDC
76 *> \verbatim
77 *> LDC is INTEGER
78 *> The leading dimension of the array A.
79 *> LDA >= max(1,NMAX).
80 *> \endverbatim
81 *>
82 *> \param[out] CRF
83 *> \verbatim
84 *> CRF is REAL array,
85 *> dimension ((NMAX*(NMAX+1))/2).
86 *> \endverbatim
87 *>
88 *> \param[out] A
89 *> \verbatim
90 *> A is REAL array,
91 *> dimension (LDA,NMAX)
92 *> \endverbatim
93 *>
94 *> \param[in] LDA
95 *> \verbatim
96 *> LDA is INTEGER
97 *> The leading dimension of the array A. LDA >= max(1,NMAX).
98 *> \endverbatim
99 *>
100 *> \param[out] S_WORK_SLANGE
101 *> \verbatim
102 *> S_WORK_SLANGE is REAL array, dimension (NMAX)
103 *> \endverbatim
104 *
105 * Authors:
106 * ========
107 *
108 *> \author Univ. of Tennessee
109 *> \author Univ. of California Berkeley
110 *> \author Univ. of Colorado Denver
111 *> \author NAG Ltd.
112 *
113 *> \ingroup single_lin
114 *
115 * =====================================================================
116  SUBROUTINE sdrvrf4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A,
117  + LDA, S_WORK_SLANGE )
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 *
357  END
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
subroutine sdrvrf4(NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, LDA, S_WORK_SLANGE)
SDRVRF4
Definition: sdrvrf4.f:118