LAPACK  3.4.2 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 convertion 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 *> \date November 2011
86 *
87 *> \ingroup single_lin
88 *
89 * =====================================================================
90  SUBROUTINE sdrvrf2( NOUT, NN, NVAL, A, LDA, ARF, AP, ASAV )
91 *
92 * -- LAPACK test routine (version 3.4.0) --
93 * -- LAPACK is a software package provided by Univ. of Tennessee, --
94 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
95 * November 2011
96 *
97 * .. Scalar Arguments ..
98  INTEGER lda, nn, nout
99 * ..
100 * .. Array Arguments ..
101  INTEGER nval( nn )
102  REAL a( lda, * ), arf( * ), ap(*), asav( lda, * )
103 * ..
104 *
105 * =====================================================================
106 * ..
107 * .. Local Scalars ..
108  LOGICAL lower, ok1, ok2
109  CHARACTER uplo, cform
110  INTEGER i, iform, iin, info, iuplo, j, n,
111  + nerrs, nrun
112 * ..
113 * .. Local Arrays ..
114  CHARACTER uplos( 2 ), forms( 2 )
115  INTEGER iseed( 4 ), iseedy( 4 )
116 * ..
117 * .. External Functions ..
118  REAL slarnd
119  EXTERNAL slarnd
120 * ..
121 * .. External Subroutines ..
122  EXTERNAL stfttr, stfttp, strttf, strttp, stpttr, stpttf
123 * ..
124 * .. Scalars in Common ..
125  CHARACTER*32 srnamt
126 * ..
127 * .. Common blocks ..
128  common / srnamc / srnamt
129 * ..
130 * .. Data statements ..
131  DATA iseedy / 1988, 1989, 1990, 1991 /
132  DATA uplos / 'U', 'L' /
133  DATA forms / 'N', 'T' /
134 * ..
135 * .. Executable Statements ..
136 *
137 * Initialize constants and the random number seed.
138 *
139  nrun = 0
140  nerrs = 0
141  info = 0
142  DO 10 i = 1, 4
143  iseed( i ) = iseedy( i )
144  10 continue
145 *
146  DO 120 iin = 1, nn
147 *
148  n = nval( iin )
149 *
150 * Do first for UPLO = 'U', then for UPLO = 'L'
151 *
152  DO 110 iuplo = 1, 2
153 *
154  uplo = uplos( iuplo )
155  lower = .true.
156  IF ( iuplo.EQ.1 ) lower = .false.
157 *
158 * Do first for CFORM = 'N', then for CFORM = 'T'
159 *
160  DO 100 iform = 1, 2
161 *
162  cform = forms( iform )
163 *
164  nrun = nrun + 1
165 *
166  DO j = 1, n
167  DO i = 1, n
168  a( i, j) = slarnd( 2, iseed )
169  END DO
170  END DO
171 *
172  srnamt = 'DTRTTF'
173  CALL strttf( cform, uplo, n, a, lda, arf, info )
174 *
175  srnamt = 'DTFTTP'
176  CALL stfttp( cform, uplo, n, arf, ap, info )
177 *
178  srnamt = 'DTPTTR'
179  CALL stpttr( uplo, n, ap, asav, lda, info )
180 *
181  ok1 = .true.
182  IF ( lower ) THEN
183  DO j = 1, n
184  DO i = j, n
185  IF ( a(i,j).NE.asav(i,j) ) THEN
186  ok1 = .false.
187  END IF
188  END DO
189  END DO
190  ELSE
191  DO j = 1, n
192  DO i = 1, j
193  IF ( a(i,j).NE.asav(i,j) ) THEN
194  ok1 = .false.
195  END IF
196  END DO
197  END DO
198  END IF
199 *
200  nrun = nrun + 1
201 *
202  srnamt = 'DTRTTP'
203  CALL strttp( uplo, n, a, lda, ap, info )
204 *
205  srnamt = 'DTPTTF'
206  CALL stpttf( cform, uplo, n, ap, arf, info )
207 *
208  srnamt = 'DTFTTR'
209  CALL stfttr( cform, uplo, n, arf, asav, lda, info )
210 *
211  ok2 = .true.
212  IF ( lower ) THEN
213  DO j = 1, n
214  DO i = j, n
215  IF ( a(i,j).NE.asav(i,j) ) THEN
216  ok2 = .false.
217  END IF
218  END DO
219  END DO
220  ELSE
221  DO j = 1, n
222  DO i = 1, j
223  IF ( a(i,j).NE.asav(i,j) ) THEN
224  ok2 = .false.
225  END IF
226  END DO
227  END DO
228  END IF
229 *
230  IF (( .NOT.ok1 ).OR.( .NOT.ok2 )) THEN
231  IF( nerrs.EQ.0 ) THEN
232  WRITE( nout, * )
233  WRITE( nout, fmt = 9999 )
234  END IF
235  WRITE( nout, fmt = 9998 ) n, uplo, cform
236  nerrs = nerrs + 1
237  END IF
238 *
239  100 continue
240  110 continue
241  120 continue
242 *
243 * Print a summary of the results.
244 *
245  IF ( nerrs.EQ.0 ) THEN
246  WRITE( nout, fmt = 9997 ) nrun
247  ELSE
248  WRITE( nout, fmt = 9996 ) nerrs, nrun
249  END IF
250 *
251  9999 format( 1x, ' *** Error(s) while testing the RFP convertion',
252  + ' routines ***')
253  9998 format( 1x, ' Error in RFP,convertion routines N=',i5,
254  + ' UPLO=''', a1, ''', FORM =''',a1,'''')
255  9997 format( 1x, 'All tests for the RFP convertion routines passed ( ',
256  + i5,' tests run)')
257  9996 format( 1x, 'RFP convertion routines: ',i5,' out of ',i5,
258  + ' error message recorded')
259 *
260  return
261 *
262 * End of SDRVRF2
263 *
264  END