55 IMPLICIT NONE
56
57
58
59
60
61
62 CHARACTER*3 PATH
63 INTEGER NUNIT
64
65
66
67
68
69 INTEGER NMAX
70 parameter( nmax = 2 )
71
72
73 INTEGER I, INFO, J
74
75
76 COMPLEX*16 A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ),
77 $ B( NMAX, NMAX ), C( NMAX, NMAX )
78
79
82
83
84 LOGICAL LERR, OK
85 CHARACTER*32 SRNAMT
86 INTEGER INFOT, NOUT
87
88
89 COMMON / infoc / infot, nout, ok, lerr
90 COMMON / srnamc / srnamt
91
92
93 INTRINSIC dble, dcmplx
94
95
96
97 nout = nunit
98 WRITE( nout, fmt = * )
99
100
101
102 DO j = 1, nmax
103 DO i = 1, nmax
104 a( i, j ) = 1.d0 / dcmplx(dble( i+j ),0.d0)
105 c( i, j ) = 1.d0 / dcmplx(dble( i+j ),0.d0)
106 t( i, j ) = 1.d0 / dcmplx(dble( i+j ),0.d0)
107 END DO
108 w( j ) = dcmplx(0.d0,0.d0)
109 END DO
110 ok = .true.
111
112
113
114
115
116 srnamt = 'ZTPQRT'
117 infot = 1
118 CALL ztpqrt( -1, 1, 0, 1, a, 1, b, 1, t, 1, w, info )
119 CALL chkxer(
'ZTPQRT', infot, nout, lerr, ok )
120 infot = 2
121 CALL ztpqrt( 1, -1, 0, 1, a, 1, b, 1, t, 1, w, info )
122 CALL chkxer(
'ZTPQRT', infot, nout, lerr, ok )
123 infot = 3
124 CALL ztpqrt( 0, 1, -1, 1, a, 1, b, 1, t, 1, w, info )
125 CALL chkxer(
'ZTPQRT', infot, nout, lerr, ok )
126 infot = 3
127 CALL ztpqrt( 0, 1, 1, 1, a, 1, b, 1, t, 1, w, info )
128 CALL chkxer(
'ZTPQRT', infot, nout, lerr, ok )
129 infot = 4
130 CALL ztpqrt( 0, 1, 0, 0, a, 1, b, 1, t, 1, w, info )
131 CALL chkxer(
'ZTPQRT', infot, nout, lerr, ok )
132 infot = 4
133 CALL ztpqrt( 0, 1, 0, 2, a, 1, b, 1, t, 1, w, info )
134 CALL chkxer(
'ZTPQRT', infot, nout, lerr, ok )
135 infot = 6
136 CALL ztpqrt( 1, 2, 0, 2, a, 1, b, 1, t, 1, w, info )
137 CALL chkxer(
'ZTPQRT', infot, nout, lerr, ok )
138 infot = 8
139 CALL ztpqrt( 2, 1, 0, 1, a, 1, b, 1, t, 1, w, info )
140 CALL chkxer(
'ZTPQRT', infot, nout, lerr, ok )
141 infot = 10
142 CALL ztpqrt( 2, 2, 1, 2, a, 2, b, 2, t, 1, w, info )
143 CALL chkxer(
'ZTPQRT', infot, nout, lerr, ok )
144
145
146
147 srnamt = 'ZTPQRT2'
148 infot = 1
149 CALL ztpqrt2( -1, 0, 0, a, 1, b, 1, t, 1, info )
150 CALL chkxer(
'ZTPQRT2', infot, nout, lerr, ok )
151 infot = 2
152 CALL ztpqrt2( 0, -1, 0, a, 1, b, 1, t, 1, info )
153 CALL chkxer(
'ZTPQRT2', infot, nout, lerr, ok )
154 infot = 3
155 CALL ztpqrt2( 0, 0, -1, a, 1, b, 1, t, 1, info )
156 CALL chkxer(
'ZTPQRT2', infot, nout, lerr, ok )
157 infot = 5
158 CALL ztpqrt2( 2, 2, 0, a, 1, b, 2, t, 2, info )
159 CALL chkxer(
'ZTPQRT2', infot, nout, lerr, ok )
160 infot = 7
161 CALL ztpqrt2( 2, 2, 0, a, 2, b, 1, t, 2, info )
162 CALL chkxer(
'ZTPQRT2', infot, nout, lerr, ok )
163 infot = 9
164 CALL ztpqrt2( 2, 2, 0, a, 2, b, 2, t, 1, info )
165 CALL chkxer(
'ZTPQRT2', infot, nout, lerr, ok )
166
167
168
169 srnamt = 'ZTPMQRT'
170 infot = 1
171 CALL ztpmqrt(
'/',
'N', 0, 0, 0, 0, 1, a, 1, t, 1, b, 1, c, 1,
172 $ w, info )
173 CALL chkxer(
'ZTPMQRT', infot, nout, lerr, ok )
174 infot = 2
175 CALL ztpmqrt(
'L',
'/', 0, 0, 0, 0, 1, a, 1, t, 1, b, 1, c, 1,
176 $ w, info )
177 CALL chkxer(
'ZTPMQRT', infot, nout, lerr, ok )
178 infot = 3
179 CALL ztpmqrt(
'L',
'N', -1, 0, 0, 0, 1, a, 1, t, 1, b, 1, c, 1,
180 $ w, info )
181 CALL chkxer(
'ZTPMQRT', infot, nout, lerr, ok )
182 infot = 4
183 CALL ztpmqrt(
'L',
'N', 0, -1, 0, 0, 1, a, 1, t, 1, b, 1, c, 1,
184 $ w, info )
185 CALL chkxer(
'ZTPMQRT', infot, nout, lerr, ok )
186 infot = 5
187 CALL ztpmqrt(
'L',
'N', 0, 0, -1, 0, 1, a, 1, t, 1, b, 1, c, 1,
188 $ w, info )
189 infot = 6
190 CALL ztpmqrt(
'L',
'N', 0, 0, 0, -1, 1, a, 1, t, 1, b, 1, c, 1,
191 $ w, info )
192 CALL chkxer(
'ZTPMQRT', infot, nout, lerr, ok )
193 infot = 7
194 CALL ztpmqrt(
'L',
'N', 0, 0, 0, 0, 0, a, 1, t, 1, b, 1, c, 1,
195 $ w, info )
196 CALL chkxer(
'ZTPMQRT', infot, nout, lerr, ok )
197 infot = 9
198 CALL ztpmqrt(
'R',
'N', 1, 2, 1, 1, 1, a, 1, t, 1, b, 1, c, 1,
199 $ w, info )
200 CALL chkxer(
'ZTPMQRT', infot, nout, lerr, ok )
201 infot = 9
202 CALL ztpmqrt(
'L',
'N', 2, 1, 1, 1, 1, a, 1, t, 1, b, 1, c, 1,
203 $ w, info )
204 CALL chkxer(
'ZTPMQRT', infot, nout, lerr, ok )
205 infot = 11
206 CALL ztpmqrt(
'R',
'N', 1, 1, 1, 1, 1, a, 1, t, 0, b, 1, c, 1,
207 $ w, info )
208 CALL chkxer(
'ZTPMQRT', infot, nout, lerr, ok )
209 infot = 13
210 CALL ztpmqrt(
'L',
'N', 1, 1, 1, 1, 1, a, 1, t, 1, b, 0, c, 1,
211 $ w, info )
212 CALL chkxer(
'ZTPMQRT', infot, nout, lerr, ok )
213 infot = 15
214 CALL ztpmqrt(
'L',
'N', 1, 1, 1, 1, 1, a, 1, t, 1, b, 1, c, 0,
215 $ w, info )
216 CALL chkxer(
'ZTPMQRT', infot, nout, lerr, ok )
217
218
219
220 CALL alaesm( path, ok, nout )
221
222 RETURN
223
224
225
subroutine alaesm(path, ok, nout)
ALAESM
subroutine chkxer(srnamt, infot, nout, lerr, ok)
subroutine ztpmqrt(side, trans, m, n, k, l, nb, v, ldv, t, ldt, a, lda, b, ldb, work, info)
ZTPMQRT
subroutine ztpqrt2(m, n, l, a, lda, b, ldb, t, ldt, info)
ZTPQRT2 computes a QR factorization of a real or complex "triangular-pentagonal" matrix,...
subroutine ztpqrt(m, n, l, nb, a, lda, b, ldb, t, ldt, work, info)
ZTPQRT