OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
serrtsqr.f
Go to the documentation of this file.
1*> \brief \b DERRTSQR
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 SERRTSQR( PATH, NUNIT )
12*
13* .. Scalar Arguments ..
14* CHARACTER*3 PATH
15* INTEGER NUNIT
16* ..
17*
18*
19*> \par Purpose:
20* =============
21*>
22*> \verbatim
23*>
24*> DERRTSQR tests the error exits for the REAL routines
25*> that use the TSQR decomposition of a general matrix.
26*> \endverbatim
27*
28* Arguments:
29* ==========
30*
31*> \param[in] PATH
32*> \verbatim
33*> PATH is CHARACTER*3
34*> The LAPACK path name for the routines to be tested.
35*> \endverbatim
36*>
37*> \param[in] NUNIT
38*> \verbatim
39*> NUNIT is INTEGER
40*> The unit number for output.
41*> \endverbatim
42*
43* Authors:
44* ========
45*
46*> \author Univ. of Tennessee
47*> \author Univ. of California Berkeley
48*> \author Univ. of Colorado Denver
49*> \author NAG Ltd.
50*
51*> \ingroup double_lin
52*
53* =====================================================================
54 SUBROUTINE serrtsqr( PATH, NUNIT )
55 IMPLICIT NONE
56*
57* -- LAPACK test routine --
58* -- LAPACK is a software package provided by Univ. of Tennessee, --
59* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
60*
61* .. Scalar Arguments ..
62 CHARACTER*3 PATH
63 INTEGER NUNIT
64* ..
65*
66* =====================================================================
67*
68* .. Parameters ..
69 INTEGER NMAX
70 parameter( nmax = 2 )
71* ..
72* .. Local Scalars ..
73 INTEGER I, INFO, J, MB, NB
74* ..
75* .. Local Arrays ..
76 REAL A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ),
77 $ C( NMAX, NMAX ), TAU(NMAX*2)
78* ..
79* .. External Subroutines ..
80 EXTERNAL alaesm, chkxer, sgeqr,
81 $ sgemqr, sgelq, sgemlq
82* ..
83* .. Scalars in Common ..
84 LOGICAL LERR, OK
85 CHARACTER*32 SRNAMT
86 INTEGER INFOT, NOUT
87* ..
88* .. Common blocks ..
89 COMMON / infoc / infot, nout, ok, lerr
90 COMMON / srnamc / srnamt
91* ..
92* .. Intrinsic Functions ..
93 INTRINSIC real
94* ..
95* .. Executable Statements ..
96*
97 nout = nunit
98 WRITE( nout, fmt = * )
99*
100* Set the variables to innocuous values.
101*
102 DO j = 1, nmax
103 DO i = 1, nmax
104 a( i, j ) = 1.d0 / real( i+j )
105 c( i, j ) = 1.d0 / real( i+j )
106 t( i, j ) = 1.d0 / real( i+j )
107 END DO
108 w( j ) = 0.d0
109 END DO
110 ok = .true.
111*
112* Error exits for TS factorization
113*
114* SGEQR
115*
116 srnamt = 'SGEQR'
117 infot = 1
118 CALL sgeqr( -1, 0, a, 1, tau, 1, w, 1, info )
119 CALL chkxer( 'SGEQR', infot, nout, lerr, ok )
120 infot = 2
121 CALL sgeqr( 0, -1, a, 1, tau, 1, w, 1, info )
122 CALL chkxer( 'SGEQR', infot, nout, lerr, ok )
123 infot = 4
124 CALL sgeqr( 1, 1, a, 0, tau, 1, w, 1, info )
125 CALL chkxer( 'SGEQR', infot, nout, lerr, ok )
126 infot = 6
127 CALL sgeqr( 3, 2, a, 3, tau, 1, w, 1, info )
128 CALL chkxer( 'SGEQR', infot, nout, lerr, ok )
129 infot = 8
130 CALL sgeqr( 3, 2, a, 3, tau, 7, w, 0, info )
131 CALL chkxer( 'SGEQR', infot, nout, lerr, ok )
132*
133* SLATSQR
134*
135 mb = 1
136 nb = 1
137 srnamt = 'slatsqr'
138 INFOT = 1
139 CALL SLATSQR( -1, 0, MB, NB, A, 1, TAU, 1, W, 1, INFO )
140 CALL CHKXER( 'slatsqr', INFOT, NOUT, LERR, OK )
141 INFOT = 2
142 CALL SLATSQR( 1, 2, MB, NB, A, 1, TAU, 1, W, 1, INFO )
143 CALL CHKXER( 'slatsqr', INFOT, NOUT, LERR, OK )
144 CALL SLATSQR( 0, -1, MB, NB, A, 1, TAU, 1, W, 1, INFO )
145 CALL CHKXER( 'slatsqr', INFOT, NOUT, LERR, OK )
146 INFOT = 3
147 CALL SLATSQR( 2, 1, -1, NB, A, 2, TAU, 1, W, 1, INFO )
148 CALL CHKXER( 'slatsqr', INFOT, NOUT, LERR, OK )
149 INFOT = 4
150 CALL SLATSQR( 2, 1, MB, 2, A, 2, TAU, 1, W, 1, INFO )
151 CALL CHKXER( 'slatsqr', INFOT, NOUT, LERR, OK )
152 INFOT = 6
153 CALL SLATSQR( 2, 1, MB, NB, A, 1, TAU, 1, W, 1, INFO )
154 CALL CHKXER( 'slatsqr', INFOT, NOUT, LERR, OK )
155 INFOT = 8
156 CALL SLATSQR( 2, 1, MB, NB, A, 2, TAU, 0, W, 1, INFO )
157 CALL CHKXER( 'slatsqr', INFOT, NOUT, LERR, OK )
158 INFOT = 10
159 CALL SLATSQR( 2, 1, MB, NB, A, 2, TAU, 2, W, 0, INFO )
160 CALL CHKXER( 'slatsqr', INFOT, NOUT, LERR, OK )
161*
162* SGEMQR
163*
164 TAU(1)=1
165 TAU(2)=1
166 TAU(3)=1
167 TAU(4)=1
168 SRNAMT = 'sgemqr'
169 NB=1
170 INFOT = 1
171 CALL SGEMQR( '/', 'n', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO)
172 CALL CHKXER( 'sgemqr', INFOT, NOUT, LERR, OK )
173 INFOT = 2
174 CALL SGEMQR( 'l', '/', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO)
175 CALL CHKXER( 'sgemqr', INFOT, NOUT, LERR, OK )
176 INFOT = 3
177 CALL SGEMQR( 'l', 'n', -1, 0, 0, A, 1, TAU, 1, C, 1, W,1,INFO)
178 CALL CHKXER( 'sgemqr', INFOT, NOUT, LERR, OK )
179 INFOT = 4
180 CALL SGEMQR( 'l', 'n', 0, -1, 0, A, 1, TAU, 1, C, 1, W,1,INFO)
181 CALL CHKXER( 'sgemqr', INFOT, NOUT, LERR, OK )
182 INFOT = 5
183 CALL SGEMQR( 'l', 'n', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO)
184 CALL CHKXER( 'sgemqr', infot, nout, lerr, ok )
185 infot = 5
186 CALL sgemqr( 'R', 'N', 0, 0, -1, a, 1, tau, 1, c, 1, w,1,info)
187 CALL chkxer( 'SGEMQR', infot, nout, lerr, ok )
188 infot = 7
189 CALL sgemqr( 'L', 'N', 2, 1, 0, a, 0, tau, 1, c, 1, w, 1,info)
190 CALL chkxer( 'SGEMQR', infot, nout, lerr, ok )
191 infot = 9
192 CALL sgemqr( 'R', 'N', 2, 2, 1, a, 2, tau, 0, c, 1, w, 1,info)
193 CALL chkxer( 'SGEMQR', infot, nout, lerr, ok )
194 infot = 9
195 CALL sgemqr( 'L', 'N', 2, 2, 1, a, 2, tau, 0, c, 1, w, 1,info)
196 CALL chkxer( 'SGEMQR', infot, nout, lerr, ok )
197 infot = 11
198 CALL sgemqr( 'L', 'N', 2, 1, 1, a, 2, tau, 6, c, 0, w, 1,info)
199 CALL chkxer( 'SGEMQR', infot, nout, lerr, ok )
200 infot = 13
201 CALL sgemqr( 'L', 'N', 2, 2, 1, a, 2, tau, 6, c, 2, w, 0,info)
202 CALL chkxer( 'SGEMQR', infot, nout, lerr, ok )
203*
204* SGELQ
205*
206 srnamt = 'SGELQ'
207 infot = 1
208 CALL sgelq( -1, 0, a, 1, tau, 1, w, 1, info )
209 CALL chkxer( 'SGELQ', infot, nout, lerr, ok )
210 infot = 2
211 CALL sgelq( 0, -1, a, 1, tau, 1, w, 1, info )
212 CALL chkxer( 'SGELQ', infot, nout, lerr, ok )
213 infot = 4
214 CALL sgelq( 1, 1, a, 0, tau, 1, w, 1, info )
215 CALL chkxer( 'SGELQ', infot, nout, lerr, ok )
216 infot = 6
217 CALL sgelq( 2, 3, a, 3, tau, 1, w, 1, info )
218 CALL chkxer( 'SGELQ', infot, nout, lerr, ok )
219 infot = 8
220 CALL sgelq( 2, 3, a, 3, tau, 7, w, 0, info )
221 CALL chkxer( 'SGELQ', infot, nout, lerr, ok )
222*
223* SLASWLQ
224*
225 mb = 1
226 nb = 1
227 srnamt = 'SLASWLQ'
228 infot = 1
229 CALL slaswlq( -1, 0, mb, nb, a, 1, tau, 1, w, 1, info )
230 CALL chkxer( 'SLASWLQ', infot, nout, lerr, ok )
231 infot = 2
232 CALL slaswlq( 2, 1, mb, nb, a, 1, tau, 1, w, 1, info )
233 CALL chkxer( 'SLASWLQ', infot, nout, lerr, ok )
234 CALL slaswlq( 0, -1, mb, nb, a, 1, tau, 1, w, 1, info )
235 CALL chkxer( 'SLASWLQ', infot, nout, lerr, ok )
236 infot = 3
237 CALL slaswlq( 1, 2, -1, nb, a, 1, tau, 1, w, 1, info )
238 CALL chkxer( 'SLASWLQ', infot, nout, lerr, ok )
239 CALL slaswlq( 1, 1, 2, nb, a, 1, tau, 1, w, 1, info )
240 CALL chkxer( 'SLASWLQ', infot, nout, lerr, ok )
241 infot = 4
242 CALL slaswlq( 1, 2, mb, -1, a, 1, tau, 1, w, 1, info )
243 CALL chkxer( 'SLASWLQ', infot, nout, lerr, ok )
244 infot = 6
245 CALL slaswlq( 1, 2, mb, nb, a, 0, tau, 1, w, 1, info )
246 CALL chkxer( 'SLASWLQ', infot, nout, lerr, ok )
247 infot = 8
248 CALL slaswlq( 1, 2, mb, nb, a, 1, tau, 0, w, 1, info )
249 CALL chkxer( 'SLASWLQ', infot, nout, lerr, ok )
250 infot = 10
251 CALL slaswlq( 1, 2, mb, nb, a, 1, tau, 1, w, 0, info )
252 CALL chkxer( 'SLASWLQ', infot, nout, lerr, ok )
253*
254* SGEMLQ
255*
256 tau(1)=1
257 tau(2)=1
258 srnamt = 'SGEMLQ'
259 nb=1
260 infot = 1
261 CALL sgemlq( '/', 'N', 0, 0, 0, a, 1, tau, 1, c, 1, w, 1,info)
262 CALL chkxer( 'SGEMLQ', infot, nout, lerr, ok )
263 infot = 2
264 CALL sgemlq( 'l', '/', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO)
265 CALL CHKXER( 'sgemlq', INFOT, NOUT, LERR, OK )
266 INFOT = 3
267 CALL SGEMLQ( 'l', 'n', -1, 0, 0, A, 1, TAU, 1, C, 1, W,1,INFO)
268 CALL CHKXER( 'sgemlq', INFOT, NOUT, LERR, OK )
269 INFOT = 4
270 CALL SGEMLQ( 'l', 'n', 0, -1, 0, A, 1, TAU, 1, C, 1, W,1,INFO)
271 CALL CHKXER( 'sgemlq', INFOT, NOUT, LERR, OK )
272 INFOT = 5
273 CALL SGEMLQ( 'l', 'n', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO)
274 CALL CHKXER( 'sgemlq', INFOT, NOUT, LERR, OK )
275 INFOT = 5
276 CALL SGEMLQ( 'r', 'n', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO)
277 CALL CHKXER( 'sgemlq', INFOT, NOUT, LERR, OK )
278 INFOT = 7
279 CALL SGEMLQ( 'l', 'n', 1, 2, 0, A, 0, TAU, 1, C, 1, W, 1,INFO)
280 CALL CHKXER( 'sgemlq', INFOT, NOUT, LERR, OK )
281 INFOT = 9
282 CALL SGEMLQ( 'r', 'n', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO)
283 CALL CHKXER( 'sgemlq', INFOT, NOUT, LERR, OK )
284 INFOT = 9
285 CALL SGEMLQ( 'l', 'n', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO)
286 CALL CHKXER( 'sgemlq', INFOT, NOUT, LERR, OK )
287 INFOT = 11
288 CALL SGEMLQ( 'l', 'n', 1, 2, 1, A, 1, TAU, 6, C, 0, W, 1,INFO)
289 CALL CHKXER( 'sgemlq', INFOT, NOUT, LERR, OK )
290 INFOT = 13
291 CALL SGEMLQ( 'l', 'n', 2, 2, 1, A, 2, TAU, 6, C, 2, W, 0,INFO)
292 CALL CHKXER( 'sgemlq', INFOT, NOUT, LERR, OK )
293*
294* Print a summary line.
295*
296 CALL ALAESM( PATH, OK, NOUT )
297*
298 RETURN
299*
300* End of SERRTSQR
301*
302 END
chkxer
subroutine chkxer(srnamt, infot, nout, lerr, ok)
Definition cblat2.f:3196
alaesm
subroutine alaesm(path, ok, nout)
ALAESM
Definition alaesm.f:63
serrtsqr
subroutine serrtsqr(path, nunit)
DERRTSQR
Definition serrtsqr.f:55
sgelq
subroutine sgelq(m, n, a, lda, t, tsize, work, lwork, info)
SGELQ
Definition sgelq.f:172
sgemlq
subroutine sgemlq(side, trans, m, n, k, a, lda, t, tsize, c, ldc, work, lwork, info)
SGEMLQ
Definition sgemlq.f:170
sgemqr
subroutine sgemqr(side, trans, m, n, k, a, lda, t, tsize, c, ldc, work, lwork, info)
SGEMQR
Definition sgemqr.f:172
sgeqr
subroutine sgeqr(m, n, a, lda, t, tsize, work, lwork, info)
SGEQR
Definition sgeqr.f:174
slaswlq
subroutine slaswlq(m, n, mb, nb, a, lda, t, ldt, work, lwork, info)
SLASWLQ
Definition slaswlq.f:164
slatsqr
subroutine slatsqr(m, n, mb, nb, a, lda, t, ldt, work, lwork, info)
SLATSQR
Definition slatsqr.f:166