LAPACK  3.9.0
LAPACK: Linear Algebra PACKage
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 *> \date December 2016
52 *
53 *> \ingroup double_lin
54 *
55 * =====================================================================
56  SUBROUTINE serrtsqr( PATH, NUNIT )
57  IMPLICIT NONE
58 *
59 * -- LAPACK test routine (version 3.7.0) --
60 * -- LAPACK is a software package provided by Univ. of Tennessee, --
61 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
62 * December 2016
63 *
64 * .. Scalar Arguments ..
65  CHARACTER*3 PATH
66  INTEGER NUNIT
67 * ..
68 *
69 * =====================================================================
70 *
71 * .. Parameters ..
72  INTEGER NMAX
73  parameter( nmax = 2 )
74 * ..
75 * .. Local Scalars ..
76  INTEGER I, INFO, J, NB
77 * ..
78 * .. Local Arrays ..
79  REAL A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ),
80  $ C( NMAX, NMAX ), TAU(NMAX)
81 * ..
82 * .. External Subroutines ..
83  EXTERNAL alaesm, chkxer, sgeqr,
84  $ sgemqr, sgelq, sgemlq
85 * ..
86 * .. Scalars in Common ..
87  LOGICAL LERR, OK
88  CHARACTER*32 SRNAMT
89  INTEGER INFOT, NOUT
90 * ..
91 * .. Common blocks ..
92  COMMON / infoc / infot, nout, ok, lerr
93  COMMON / srnamc / srnamt
94 * ..
95 * .. Intrinsic Functions ..
96  INTRINSIC real
97 * ..
98 * .. Executable Statements ..
99 *
100  nout = nunit
101  WRITE( nout, fmt = * )
102 *
103 * Set the variables to innocuous values.
104 *
105  DO j = 1, nmax
106  DO i = 1, nmax
107  a( i, j ) = 1.d0 / real( i+j )
108  c( i, j ) = 1.d0 / real( i+j )
109  t( i, j ) = 1.d0 / real( i+j )
110  END DO
111  w( j ) = 0.d0
112  END DO
113  ok = .true.
114 *
115 * Error exits for TS factorization
116 *
117 * SGEQR
118 *
119  srnamt = 'SGEQR'
120  infot = 1
121  CALL sgeqr( -1, 0, a, 1, tau, 1, w, 1, info )
122  CALL chkxer( 'SGEQR', infot, nout, lerr, ok )
123  infot = 2
124  CALL sgeqr( 0, -1, a, 1, tau, 1, w, 1, info )
125  CALL chkxer( 'SGEQR', infot, nout, lerr, ok )
126  infot = 4
127  CALL sgeqr( 1, 1, a, 0, tau, 1, w, 1, info )
128  CALL chkxer( 'SGEQR', infot, nout, lerr, ok )
129  infot = 6
130  CALL sgeqr( 3, 2, a, 3, tau, 1, w, 1, info )
131  CALL chkxer( 'SGEQR', infot, nout, lerr, ok )
132  infot = 8
133  CALL sgeqr( 3, 2, a, 3, tau, 7, w, 0, info )
134  CALL chkxer( 'SGEQR', infot, nout, lerr, ok )
135 *
136 * SGEMQR
137 *
138  tau(1)=1
139  tau(2)=1
140  srnamt = 'SGEMQR'
141  nb=1
142  infot = 1
143  CALL sgemqr( '/', 'N', 0, 0, 0, a, 1, tau, 1, c, 1, w, 1,info)
144  CALL chkxer( 'SGEMQR', infot, nout, lerr, ok )
145  infot = 2
146  CALL sgemqr( 'L', '/', 0, 0, 0, a, 1, tau, 1, c, 1, w, 1,info)
147  CALL chkxer( 'SGEMQR', infot, nout, lerr, ok )
148  infot = 3
149  CALL sgemqr( 'L', 'N', -1, 0, 0, a, 1, tau, 1, c, 1, w,1,info)
150  CALL chkxer( 'SGEMQR', infot, nout, lerr, ok )
151  infot = 4
152  CALL sgemqr( 'L', 'N', 0, -1, 0, a, 1, tau, 1, c, 1, w,1,info)
153  CALL chkxer( 'SGEMQR', infot, nout, lerr, ok )
154  infot = 5
155  CALL sgemqr( 'L', 'N', 0, 0, -1, a, 1, tau, 1, c, 1, w,1,info)
156  CALL chkxer( 'SGEMQR', infot, nout, lerr, ok )
157  infot = 5
158  CALL sgemqr( 'R', 'N', 0, 0, -1, a, 1, tau, 1, c, 1, w,1,info)
159  CALL chkxer( 'SGEMQR', infot, nout, lerr, ok )
160  infot = 7
161  CALL sgemqr( 'L', 'N', 2, 1, 0, a, 0, tau, 1, c, 1, w, 1,info)
162  CALL chkxer( 'SGEMQR', infot, nout, lerr, ok )
163  infot = 9
164  CALL sgemqr( 'R', 'N', 2, 2, 1, a, 2, tau, 0, c, 1, w, 1,info)
165  CALL chkxer( 'SGEMQR', infot, nout, lerr, ok )
166  infot = 9
167  CALL sgemqr( 'L', 'N', 2, 2, 1, a, 2, tau, 0, c, 1, w, 1,info)
168  CALL chkxer( 'SGEMQR', infot, nout, lerr, ok )
169  infot = 11
170  CALL sgemqr( 'L', 'N', 2, 1, 1, a, 2, tau, 6, c, 0, w, 1,info)
171  CALL chkxer( 'SGEMQR', infot, nout, lerr, ok )
172  infot = 13
173  CALL sgemqr( 'L', 'N', 2, 2, 1, a, 2, tau, 6, c, 2, w, 0,info)
174  CALL chkxer( 'SGEMQR', infot, nout, lerr, ok )
175 *
176 * SGELQ
177 *
178  srnamt = 'SGELQ'
179  infot = 1
180  CALL sgelq( -1, 0, a, 1, tau, 1, w, 1, info )
181  CALL chkxer( 'SGELQ', infot, nout, lerr, ok )
182  infot = 2
183  CALL sgelq( 0, -1, a, 1, tau, 1, w, 1, info )
184  CALL chkxer( 'SGELQ', infot, nout, lerr, ok )
185  infot = 4
186  CALL sgelq( 1, 1, a, 0, tau, 1, w, 1, info )
187  CALL chkxer( 'SGELQ', infot, nout, lerr, ok )
188  infot = 6
189  CALL sgelq( 2, 3, a, 3, tau, 1, w, 1, info )
190  CALL chkxer( 'SGELQ', infot, nout, lerr, ok )
191  infot = 8
192  CALL sgelq( 2, 3, a, 3, tau, 7, w, 0, info )
193  CALL chkxer( 'SGELQ', infot, nout, lerr, ok )
194 *
195 * SGEMLQ
196 *
197  tau(1)=1
198  tau(2)=1
199  srnamt = 'SGEMLQ'
200  nb=1
201  infot = 1
202  CALL sgemlq( '/', 'N', 0, 0, 0, a, 1, tau, 1, c, 1, w, 1,info)
203  CALL chkxer( 'SGEMLQ', infot, nout, lerr, ok )
204  infot = 2
205  CALL sgemlq( 'L', '/', 0, 0, 0, a, 1, tau, 1, c, 1, w, 1,info)
206  CALL chkxer( 'SGEMLQ', infot, nout, lerr, ok )
207  infot = 3
208  CALL sgemlq( 'L', 'N', -1, 0, 0, a, 1, tau, 1, c, 1, w,1,info)
209  CALL chkxer( 'SGEMLQ', infot, nout, lerr, ok )
210  infot = 4
211  CALL sgemlq( 'L', 'N', 0, -1, 0, a, 1, tau, 1, c, 1, w,1,info)
212  CALL chkxer( 'SGEMLQ', infot, nout, lerr, ok )
213  infot = 5
214  CALL sgemlq( 'L', 'N', 0, 0, -1, a, 1, tau, 1, c, 1, w,1,info)
215  CALL chkxer( 'SGEMLQ', infot, nout, lerr, ok )
216  infot = 5
217  CALL sgemlq( 'R', 'N', 0, 0, -1, a, 1, tau, 1, c, 1, w,1,info)
218  CALL chkxer( 'SGEMLQ', infot, nout, lerr, ok )
219  infot = 7
220  CALL sgemlq( 'L', 'N', 1, 2, 0, a, 0, tau, 1, c, 1, w, 1,info)
221  CALL chkxer( 'SGEMLQ', infot, nout, lerr, ok )
222  infot = 9
223  CALL sgemlq( 'R', 'N', 2, 2, 1, a, 1, tau, 0, c, 1, w, 1,info)
224  CALL chkxer( 'SGEMLQ', infot, nout, lerr, ok )
225  infot = 9
226  CALL sgemlq( 'L', 'N', 2, 2, 1, a, 1, tau, 0, c, 1, w, 1,info)
227  CALL chkxer( 'SGEMLQ', infot, nout, lerr, ok )
228  infot = 11
229  CALL sgemlq( 'L', 'N', 1, 2, 1, a, 1, tau, 6, c, 0, w, 1,info)
230  CALL chkxer( 'SGEMLQ', infot, nout, lerr, ok )
231  infot = 13
232  CALL sgemlq( 'L', 'N', 2, 2, 1, a, 2, tau, 6, c, 2, w, 0,info)
233  CALL chkxer( 'SGEMLQ', infot, nout, lerr, ok )
234 *
235 * Print a summary line.
236 *
237  CALL alaesm( path, ok, nout )
238 *
239  RETURN
240 *
241 * End of SERRTSQR
242 *
243  END
alaesm
subroutine alaesm(PATH, OK, NOUT)
ALAESM
Definition: alaesm.f:65
sgeqr
subroutine sgeqr(M, N, A, LDA, T, TSIZE, WORK, LWORK, INFO)
SGEQR
Definition: sgeqr.f:174
serrtsqr
subroutine serrtsqr(PATH, NUNIT)
DERRTSQR
Definition: serrtsqr.f:57
sgelq
subroutine sgelq(M, N, A, LDA, T, TSIZE, WORK, LWORK, INFO)
SGELQ
Definition: sgelq.f:172
sgemqr
subroutine sgemqr(SIDE, TRANS, M, N, K, A, LDA, T, TSIZE, C, LDC, WORK, LWORK, INFO)
SGEMQR
Definition: sgemqr.f:172
chkxer
subroutine chkxer(SRNAMT, INFOT, NOUT, LERR, OK)
Definition: cblat2.f:3199
sgemlq
subroutine sgemlq(SIDE, TRANS, M, N, K, A, LDA, T, TSIZE, C, LDC, WORK, LWORK, INFO)
SGEMLQ
Definition: sgemlq.f:170