LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
sdrvrf2.f
Go to the documentation of this file.
1*> \brief \b SDRVRF2
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 SDRVRF2( NOUT, NN, NVAL, A, LDA, ARF, AP, ASAV )
12*
13* .. Scalar Arguments ..
14* INTEGER LDA, NN, NOUT
15* ..
16* .. Array Arguments ..
17* INTEGER NVAL( NN )
18* REAL A( LDA, * ), ARF( * ), AP(*), ASAV( LDA, * )
19* ..
20*
21*
22*> \par Purpose:
23* =============
24*>
25*> \verbatim
26*>
27*> SDRVRF2 tests the LAPACK RFP conversion routines.
28*> \endverbatim
29*
30* Arguments:
31* ==========
32*
33*> \param[in] NOUT
34*> \verbatim
35*> NOUT is INTEGER
36*> The unit number for output.
37*> \endverbatim
38*>
39*> \param[in] NN
40*> \verbatim
41*> NN is INTEGER
42*> The number of values of N contained in the vector NVAL.
43*> \endverbatim
44*>
45*> \param[in] NVAL
46*> \verbatim
47*> NVAL is INTEGER array, dimension (NN)
48*> The values of the matrix dimension N.
49*> \endverbatim
50*>
51*> \param[out] A
52*> \verbatim
53*> A is REAL array, dimension (LDA,NMAX)
54*> \endverbatim
55*>
56*> \param[in] LDA
57*> \verbatim
58*> LDA is INTEGER
59*> The leading dimension of the array A. LDA >= max(1,NMAX).
60*> \endverbatim
61*>
62*> \param[out] ARF
63*> \verbatim
64*> ARF is REAL array, dimension ((NMAX*(NMAX+1))/2).
65*> \endverbatim
66*>
67*> \param[out] AP
68*> \verbatim
69*> AP is REAL array, dimension ((NMAX*(NMAX+1))/2).
70*> \endverbatim
71*>
72*> \param[out] ASAV
73*> \verbatim
74*> ASAV is REAL array, dimension (LDA,NMAX)
75*> \endverbatim
76*
77* Authors:
78* ========
79*
80*> \author Univ. of Tennessee
81*> \author Univ. of California Berkeley
82*> \author Univ. of Colorado Denver
83*> \author NAG Ltd.
84*
85*> \ingroup single_lin
86*
87* =====================================================================
88 SUBROUTINE sdrvrf2( NOUT, NN, NVAL, A, LDA, ARF, AP, ASAV )
89*
90* -- LAPACK test routine --
91* -- LAPACK is a software package provided by Univ. of Tennessee, --
92* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
93*
94* .. Scalar Arguments ..
95 INTEGER LDA, NN, NOUT
96* ..
97* .. Array Arguments ..
98 INTEGER NVAL( NN )
99 REAL A( LDA, * ), ARF( * ), AP(*), ASAV( LDA, * )
100* ..
101*
102* =====================================================================
103* ..
104* .. Local Scalars ..
105 LOGICAL LOWER, OK1, OK2
106 CHARACTER UPLO, CFORM
107 INTEGER I, IFORM, IIN, INFO, IUPLO, J, N,
108 + NERRS, NRUN
109* ..
110* .. Local Arrays ..
111 CHARACTER UPLOS( 2 ), FORMS( 2 )
112 INTEGER ISEED( 4 ), ISEEDY( 4 )
113* ..
114* .. External Functions ..
115 REAL SLARND
116 EXTERNAL slarnd
117* ..
118* .. External Subroutines ..
119 EXTERNAL stfttr, stfttp, strttf, strttp, stpttr, stpttf
120* ..
121* .. Scalars in Common ..
122 CHARACTER*32 SRNAMT
123* ..
124* .. Common blocks ..
125 COMMON / srnamc / srnamt
126* ..
127* .. Data statements ..
128 DATA iseedy / 1988, 1989, 1990, 1991 /
129 DATA uplos / 'U', 'L' /
130 DATA forms / 'N', 'T' /
131* ..
132* .. Executable Statements ..
133*
134* Initialize constants and the random number seed.
135*
136 nrun = 0
137 nerrs = 0
138 info = 0
139 DO 10 i = 1, 4
140 iseed( i ) = iseedy( i )
141 10 CONTINUE
142*
143 DO 120 iin = 1, nn
144*
145 n = nval( iin )
146*
147* Do first for UPLO = 'U', then for UPLO = 'L'
148*
149 DO 110 iuplo = 1, 2
150*
151 uplo = uplos( iuplo )
152 lower = .true.
153 IF ( iuplo.EQ.1 ) lower = .false.
154*
155* Do first for CFORM = 'N', then for CFORM = 'T'
156*
157 DO 100 iform = 1, 2
158*
159 cform = forms( iform )
160*
161 nrun = nrun + 1
162*
163 DO j = 1, n
164 DO i = 1, n
165 a( i, j) = slarnd( 2, iseed )
166 END DO
167 END DO
168*
169 srnamt = 'DTRTTF'
170 CALL strttf( cform, uplo, n, a, lda, arf, info )
171*
172 srnamt = 'DTFTTP'
173 CALL stfttp( cform, uplo, n, arf, ap, info )
174*
175 srnamt = 'DTPTTR'
176 CALL stpttr( uplo, n, ap, asav, lda, info )
177*
178 ok1 = .true.
179 IF ( lower ) THEN
180 DO j = 1, n
181 DO i = j, n
182 IF ( a(i,j).NE.asav(i,j) ) THEN
183 ok1 = .false.
184 END IF
185 END DO
186 END DO
187 ELSE
188 DO j = 1, n
189 DO i = 1, j
190 IF ( a(i,j).NE.asav(i,j) ) THEN
191 ok1 = .false.
192 END IF
193 END DO
194 END DO
195 END IF
196*
197 nrun = nrun + 1
198*
199 srnamt = 'DTRTTP'
200 CALL strttp( uplo, n, a, lda, ap, info )
201*
202 srnamt = 'DTPTTF'
203 CALL stpttf( cform, uplo, n, ap, arf, info )
204*
205 srnamt = 'DTFTTR'
206 CALL stfttr( cform, uplo, n, arf, asav, lda, info )
207*
208 ok2 = .true.
209 IF ( lower ) THEN
210 DO j = 1, n
211 DO i = j, n
212 IF ( a(i,j).NE.asav(i,j) ) THEN
213 ok2 = .false.
214 END IF
215 END DO
216 END DO
217 ELSE
218 DO j = 1, n
219 DO i = 1, j
220 IF ( a(i,j).NE.asav(i,j) ) THEN
221 ok2 = .false.
222 END IF
223 END DO
224 END DO
225 END IF
226*
227 IF (( .NOT.ok1 ).OR.( .NOT.ok2 )) THEN
228 IF( nerrs.EQ.0 ) THEN
229 WRITE( nout, * )
230 WRITE( nout, fmt = 9999 )
231 END IF
232 WRITE( nout, fmt = 9998 ) n, uplo, cform
233 nerrs = nerrs + 1
234 END IF
235*
236 100 CONTINUE
237 110 CONTINUE
238 120 CONTINUE
239*
240* Print a summary of the results.
241*
242 IF ( nerrs.EQ.0 ) THEN
243 WRITE( nout, fmt = 9997 ) nrun
244 ELSE
245 WRITE( nout, fmt = 9996 ) nerrs, nrun
246 END IF
247*
248 9999 FORMAT( 1x, ' *** Error(s) while testing the RFP conversion',
249 + ' routines ***')
250 9998 FORMAT( 1x, ' Error in RFP,conversion routines N=',i5,
251 + ' UPLO=''', a1, ''', FORM =''',a1,'''')
252 9997 FORMAT( 1x, 'All tests for the RFP conversion routines passed ( ',
253 + i5,' tests run)')
254 9996 FORMAT( 1x, 'RFP conversion routines: ',i5,' out of ',i5,
255 + ' error message recorded')
256*
257 RETURN
258*
259* End of SDRVRF2
260*
261 END
subroutine stfttp(transr, uplo, n, arf, ap, info)
STFTTP copies a triangular matrix from the rectangular full packed format (TF) to the standard packed...
Definition stfttp.f:187
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 stpttf(transr, uplo, n, ap, arf, info)
STPTTF copies a triangular matrix from the standard packed format (TP) to the rectangular full packed...
Definition stpttf.f:186
subroutine stpttr(uplo, n, ap, a, lda, info)
STPTTR copies a triangular matrix from the standard packed format (TP) to the standard full format (T...
Definition stpttr.f:104
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 strttp(uplo, n, a, lda, ap, info)
STRTTP copies a triangular matrix from the standard full format (TR) to the standard packed format (T...
Definition strttp.f:104
subroutine sdrvrf2(nout, nn, nval, a, lda, arf, ap, asav)
SDRVRF2
Definition sdrvrf2.f:89