LAPACK  3.10.0
LAPACK: Linear Algebra PACKage
derrtsqr.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 DERRTSQR( 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 DOUBLE PRECISION 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 derrtsqr( 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, NB
74 * ..
75 * .. Local Arrays ..
76  DOUBLE PRECISION A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ),
77  $ C( NMAX, NMAX ), TAU(NMAX*2)
78 * ..
79 * .. External Subroutines ..
80  EXTERNAL alaesm, chkxer, dgeqr,
81  $ dgemqr, dgelq, dgemlq
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 dble
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 / dble( i+j )
105  c( i, j ) = 1.d0 / dble( i+j )
106  t( i, j ) = 1.d0 / dble( 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 * DGEQR
115 *
116  srnamt = 'DGEQR'
117  infot = 1
118  CALL dgeqr( -1, 0, a, 1, tau, 1, w, 1, info )
119  CALL chkxer( 'DGEQR', infot, nout, lerr, ok )
120  infot = 2
121  CALL dgeqr( 0, -1, a, 1, tau, 1, w, 1, info )
122  CALL chkxer( 'DGEQR', infot, nout, lerr, ok )
123  infot = 4
124  CALL dgeqr( 1, 1, a, 0, tau, 1, w, 1, info )
125  CALL chkxer( 'DGEQR', infot, nout, lerr, ok )
126  infot = 6
127  CALL dgeqr( 3, 2, a, 3, tau, 1, w, 1, info )
128  CALL chkxer( 'DGEQR', infot, nout, lerr, ok )
129  infot = 8
130  CALL dgeqr( 3, 2, a, 3, tau, 7, w, 0, info )
131  CALL chkxer( 'DGEQR', infot, nout, lerr, ok )
132 *
133 * DGEMQR
134 *
135  tau(1)=1
136  tau(2)=1
137  tau(3)=1
138  tau(4)=1
139  srnamt = 'DGEMQR'
140  nb=1
141  infot = 1
142  CALL dgemqr( '/', 'N', 0, 0, 0, a, 1, tau, 1, c, 1, w, 1,info)
143  CALL chkxer( 'DGEMQR', infot, nout, lerr, ok )
144  infot = 2
145  CALL dgemqr( 'L', '/', 0, 0, 0, a, 1, tau, 1, c, 1, w, 1,info)
146  CALL chkxer( 'DGEMQR', infot, nout, lerr, ok )
147  infot = 3
148  CALL dgemqr( 'L', 'N', -1, 0, 0, a, 1, tau, 1, c, 1, w,1,info)
149  CALL chkxer( 'DGEMQR', infot, nout, lerr, ok )
150  infot = 4
151  CALL dgemqr( 'L', 'N', 0, -1, 0, a, 1, tau, 1, c, 1, w,1,info)
152  CALL chkxer( 'DGEMQR', infot, nout, lerr, ok )
153  infot = 5
154  CALL dgemqr( 'L', 'N', 0, 0, -1, a, 1, tau, 1, c, 1, w,1,info)
155  CALL chkxer( 'DGEMQR', infot, nout, lerr, ok )
156  infot = 5
157  CALL dgemqr( 'R', 'N', 0, 0, -1, a, 1, tau, 1, c, 1, w,1,info)
158  CALL chkxer( 'DGEMQR', infot, nout, lerr, ok )
159  infot = 7
160  CALL dgemqr( 'L', 'N', 2, 1, 0, a, 0, tau, 1, c, 1, w, 1,info)
161  CALL chkxer( 'DGEMQR', infot, nout, lerr, ok )
162  infot = 9
163  CALL dgemqr( 'R', 'N', 2, 2, 1, a, 2, tau, 0, c, 1, w, 1,info)
164  CALL chkxer( 'DGEMQR', infot, nout, lerr, ok )
165  infot = 9
166  CALL dgemqr( 'L', 'N', 2, 2, 1, a, 2, tau, 0, c, 1, w, 1,info)
167  CALL chkxer( 'DGEMQR', infot, nout, lerr, ok )
168  infot = 11
169  CALL dgemqr( 'L', 'N', 2, 1, 1, a, 2, tau, 6, c, 0, w, 1,info)
170  CALL chkxer( 'DGEMQR', infot, nout, lerr, ok )
171  infot = 13
172  CALL dgemqr( 'L', 'N', 2, 2, 1, a, 2, tau, 6, c, 2, w, 0,info)
173  CALL chkxer( 'DGEMQR', infot, nout, lerr, ok )
174 *
175 * DGELQ
176 *
177  srnamt = 'DGELQ'
178  infot = 1
179  CALL dgelq( -1, 0, a, 1, tau, 1, w, 1, info )
180  CALL chkxer( 'DGELQ', infot, nout, lerr, ok )
181  infot = 2
182  CALL dgelq( 0, -1, a, 1, tau, 1, w, 1, info )
183  CALL chkxer( 'DGELQ', infot, nout, lerr, ok )
184  infot = 4
185  CALL dgelq( 1, 1, a, 0, tau, 1, w, 1, info )
186  CALL chkxer( 'DGELQ', infot, nout, lerr, ok )
187  infot = 6
188  CALL dgelq( 2, 3, a, 3, tau, 1, w, 1, info )
189  CALL chkxer( 'DGELQ', infot, nout, lerr, ok )
190  infot = 8
191  CALL dgelq( 2, 3, a, 3, tau, 7, w, 0, info )
192  CALL chkxer( 'DGELQ', infot, nout, lerr, ok )
193 *
194 * DGEMLQ
195 *
196  tau(1)=1
197  tau(2)=1
198  srnamt = 'DGEMLQ'
199  nb=1
200  infot = 1
201  CALL dgemlq( '/', 'N', 0, 0, 0, a, 1, tau, 1, c, 1, w, 1,info)
202  CALL chkxer( 'DGEMLQ', infot, nout, lerr, ok )
203  infot = 2
204  CALL dgemlq( 'L', '/', 0, 0, 0, a, 1, tau, 1, c, 1, w, 1,info)
205  CALL chkxer( 'DGEMLQ', infot, nout, lerr, ok )
206  infot = 3
207  CALL dgemlq( 'L', 'N', -1, 0, 0, a, 1, tau, 1, c, 1, w,1,info)
208  CALL chkxer( 'DGEMLQ', infot, nout, lerr, ok )
209  infot = 4
210  CALL dgemlq( 'L', 'N', 0, -1, 0, a, 1, tau, 1, c, 1, w,1,info)
211  CALL chkxer( 'DGEMLQ', infot, nout, lerr, ok )
212  infot = 5
213  CALL dgemlq( 'L', 'N', 0, 0, -1, a, 1, tau, 1, c, 1, w,1,info)
214  CALL chkxer( 'DGEMLQ', infot, nout, lerr, ok )
215  infot = 5
216  CALL dgemlq( 'R', 'N', 0, 0, -1, a, 1, tau, 1, c, 1, w,1,info)
217  CALL chkxer( 'DGEMLQ', infot, nout, lerr, ok )
218  infot = 7
219  CALL dgemlq( 'L', 'N', 1, 2, 0, a, 0, tau, 1, c, 1, w, 1,info)
220  CALL chkxer( 'DGEMLQ', infot, nout, lerr, ok )
221  infot = 9
222  CALL dgemlq( 'R', 'N', 2, 2, 1, a, 1, tau, 0, c, 1, w, 1,info)
223  CALL chkxer( 'DGEMLQ', infot, nout, lerr, ok )
224  infot = 9
225  CALL dgemlq( 'L', 'N', 2, 2, 1, a, 1, tau, 0, c, 1, w, 1,info)
226  CALL chkxer( 'DGEMLQ', infot, nout, lerr, ok )
227  infot = 11
228  CALL dgemlq( 'L', 'N', 1, 2, 1, a, 1, tau, 6, c, 0, w, 1,info)
229  CALL chkxer( 'DGEMLQ', infot, nout, lerr, ok )
230  infot = 13
231  CALL dgemlq( 'L', 'N', 2, 2, 1, a, 2, tau, 6, c, 2, w, 0,info)
232  CALL chkxer( 'DGEMLQ', infot, nout, lerr, ok )
233 *
234 * Print a summary line.
235 *
236  CALL alaesm( path, ok, nout )
237 *
238  RETURN
239 *
240 * End of DERRTSQR
241 *
242  END
chkxer
subroutine chkxer(SRNAMT, INFOT, NOUT, LERR, OK)
Definition: cblat2.f:3196
dgelq
subroutine dgelq(M, N, A, LDA, T, TSIZE, WORK, LWORK, INFO)
DGELQ
Definition: dgelq.f:172
dgemlq
subroutine dgemlq(SIDE, TRANS, M, N, K, A, LDA, T, TSIZE, C, LDC, WORK, LWORK, INFO)
DGEMLQ
Definition: dgemlq.f:171
dgemqr
subroutine dgemqr(SIDE, TRANS, M, N, K, A, LDA, T, TSIZE, C, LDC, WORK, LWORK, INFO)
DGEMQR
Definition: dgemqr.f:172
dgeqr
subroutine dgeqr(M, N, A, LDA, T, TSIZE, WORK, LWORK, INFO)
DGEQR
Definition: dgeqr.f:174
alaesm
subroutine alaesm(PATH, OK, NOUT)
ALAESM
Definition: alaesm.f:63
derrtsqr
subroutine derrtsqr(PATH, NUNIT)
DERRTSQR
Definition: derrtsqr.f:55