LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ sdrvrf2()

subroutine sdrvrf2 ( integer  nout,
integer  nn,
integer, dimension( nn )  nval,
real, dimension( lda, * )  a,
integer  lda,
real, dimension( * )  arf,
real, dimension(*)  ap,
real, dimension( lda, * )  asav 
)

SDRVRF2

Purpose:
 SDRVRF2 tests the LAPACK RFP conversion routines.
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.
[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]ARF
          ARF is REAL array, dimension ((NMAX*(NMAX+1))/2).
[out]AP
          AP is REAL array, dimension ((NMAX*(NMAX+1))/2).
[out]ASAV
          ASAV is REAL array, dimension (LDA,NMAX)
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 88 of file sdrvrf2.f.

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*
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
real function slarnd(idist, iseed)
SLARND
Definition slarnd.f:73
Here is the call graph for this function:
Here is the caller graph for this function: