LAPACK  3.10.0 LAPACK: Linear Algebra PACKage
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 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 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 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 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 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 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 sdrvrf2(NOUT, NN, NVAL, A, LDA, ARF, AP, ASAV)
SDRVRF2
Definition: sdrvrf2.f:89