LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
cerrqrt.f
Go to the documentation of this file.
1 *> \brief \b CERRQRT
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 CERRQRT( 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 *> CERRQRT tests the error exits for the COMPLEX routines
25 *> that use the QRT 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 November 2011
52 *
53 *> \ingroup complex_lin
54 *
55 * =====================================================================
56  SUBROUTINE cerrqrt( PATH, NUNIT )
57  IMPLICIT NONE
58 *
59 * -- LAPACK test routine (version 3.4.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 * November 2011
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
77 * ..
78 * .. Local Arrays ..
79  COMPLEX a( nmax, nmax ), t( nmax, nmax ), w( nmax ),
80  $ c( nmax, nmax )
81 * ..
82 * .. External Subroutines ..
83  EXTERNAL alaesm, chkxer, cgeqrt2, cgeqrt3, cgeqrt,
84  $ cgemqrt
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 float, cmplx
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.0 / cmplx( float(i+j), 0.0 )
108  c( i, j ) = 1.0 / cmplx( float(i+j), 0.0 )
109  t( i, j ) = 1.0 / cmplx( float(i+j), 0.0 )
110  END DO
111  w( j ) = 0.0
112  END DO
113  ok = .true.
114 *
115 * Error exits for QRT factorization
116 *
117 * CGEQRT
118 *
119  srnamt = 'CGEQRT'
120  infot = 1
121  CALL cgeqrt( -1, 0, 1, a, 1, t, 1, w, info )
122  CALL chkxer( 'CGEQRT', infot, nout, lerr, ok )
123  infot = 2
124  CALL cgeqrt( 0, -1, 1, a, 1, t, 1, w, info )
125  CALL chkxer( 'CGEQRT', infot, nout, lerr, ok )
126  infot = 3
127  CALL cgeqrt( 0, 0, 0, a, 1, t, 1, w, info )
128  CALL chkxer( 'CGEQRT', infot, nout, lerr, ok )
129  infot = 5
130  CALL cgeqrt( 2, 1, 1, a, 1, t, 1, w, info )
131  CALL chkxer( 'CGEQRT', infot, nout, lerr, ok )
132  infot = 7
133  CALL cgeqrt( 2, 2, 2, a, 2, t, 1, w, info )
134  CALL chkxer( 'CGEQRT', infot, nout, lerr, ok )
135 *
136 * CGEQRT2
137 *
138  srnamt = 'CGEQRT2'
139  infot = 1
140  CALL cgeqrt2( -1, 0, a, 1, t, 1, info )
141  CALL chkxer( 'CGEQRT2', infot, nout, lerr, ok )
142  infot = 2
143  CALL cgeqrt2( 0, -1, a, 1, t, 1, info )
144  CALL chkxer( 'CGEQRT2', infot, nout, lerr, ok )
145  infot = 4
146  CALL cgeqrt2( 2, 1, a, 1, t, 1, info )
147  CALL chkxer( 'CGEQRT2', infot, nout, lerr, ok )
148  infot = 6
149  CALL cgeqrt2( 2, 2, a, 2, t, 1, info )
150  CALL chkxer( 'CGEQRT2', infot, nout, lerr, ok )
151 *
152 * CGEQRT3
153 *
154  srnamt = 'CGEQRT3'
155  infot = 1
156  CALL cgeqrt3( -1, 0, a, 1, t, 1, info )
157  CALL chkxer( 'CGEQRT3', infot, nout, lerr, ok )
158  infot = 2
159  CALL cgeqrt3( 0, -1, a, 1, t, 1, info )
160  CALL chkxer( 'CGEQRT3', infot, nout, lerr, ok )
161  infot = 4
162  CALL cgeqrt3( 2, 1, a, 1, t, 1, info )
163  CALL chkxer( 'CGEQRT3', infot, nout, lerr, ok )
164  infot = 6
165  CALL cgeqrt3( 2, 2, a, 2, t, 1, info )
166  CALL chkxer( 'CGEQRT3', infot, nout, lerr, ok )
167 *
168 * CGEMQRT
169 *
170  srnamt = 'CGEMQRT'
171  infot = 1
172  CALL cgemqrt( '/', 'N', 0, 0, 0, 1, a, 1, t, 1, c, 1, w, info )
173  CALL chkxer( 'CGEMQRT', infot, nout, lerr, ok )
174  infot = 2
175  CALL cgemqrt( 'L', '/', 0, 0, 0, 1, a, 1, t, 1, c, 1, w, info )
176  CALL chkxer( 'CGEMQRT', infot, nout, lerr, ok )
177  infot = 3
178  CALL cgemqrt( 'L', 'N', -1, 0, 0, 1, a, 1, t, 1, c, 1, w, info )
179  CALL chkxer( 'CGEMQRT', infot, nout, lerr, ok )
180  infot = 4
181  CALL cgemqrt( 'L', 'N', 0, -1, 0, 1, a, 1, t, 1, c, 1, w, info )
182  CALL chkxer( 'CGEMQRT', infot, nout, lerr, ok )
183  infot = 5
184  CALL cgemqrt( 'L', 'N', 0, 0, -1, 1, a, 1, t, 1, c, 1, w, info )
185  CALL chkxer( 'CGEMQRT', infot, nout, lerr, ok )
186  infot = 5
187  CALL cgemqrt( 'R', 'N', 0, 0, -1, 1, a, 1, t, 1, c, 1, w, info )
188  CALL chkxer( 'CGEMQRT', infot, nout, lerr, ok )
189  infot = 6
190  CALL cgemqrt( 'L', 'N', 0, 0, 0, 0, a, 1, t, 1, c, 1, w, info )
191  CALL chkxer( 'CGEMQRT', infot, nout, lerr, ok )
192  infot = 8
193  CALL cgemqrt( 'R', 'N', 1, 2, 1, 1, a, 1, t, 1, c, 1, w, info )
194  CALL chkxer( 'CGEMQRT', infot, nout, lerr, ok )
195  infot = 8
196  CALL cgemqrt( 'L', 'N', 2, 1, 1, 1, a, 1, t, 1, c, 1, w, info )
197  CALL chkxer( 'CGEMQRT', infot, nout, lerr, ok )
198  infot = 10
199  CALL cgemqrt( 'R', 'N', 1, 1, 1, 1, a, 1, t, 0, c, 1, w, info )
200  CALL chkxer( 'CGEMQRT', infot, nout, lerr, ok )
201  infot = 12
202  CALL cgemqrt( 'L', 'N', 1, 1, 1, 1, a, 1, t, 1, c, 0, w, info )
203  CALL chkxer( 'CGEMQRT', infot, nout, lerr, ok )
204 *
205 * Print a summary line.
206 *
207  CALL alaesm( path, ok, nout )
208 *
209  return
210 *
211 * End of CERRQRT
212 *
213  END