LAPACK 3.11.0 LAPACK: Linear Algebra PACKage
Searching...
No Matches
dlaqz1.f
Go to the documentation of this file.
1*> \brief \b DLAQZ1
2*
3* =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6* http://www.netlib.org/lapack/explore-html/
7*
8*> \htmlonly
10*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlaqz1.f">
11*> [TGZ]</a>
12*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlaqz1.f">
13*> [ZIP]</a>
14*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlaqz1.f">
15*> [TXT]</a>
16*> \endhtmlonly
17*
18* Definition:
19* ===========
20*
21* SUBROUTINE DLAQZ1( A, LDA, B, LDB, SR1, SR2, SI, BETA1, BETA2,
22* \$ V )
23* IMPLICIT NONE
24*
25* Arguments
26* INTEGER, INTENT( IN ) :: LDA, LDB
27* DOUBLE PRECISION, INTENT( IN ) :: A( LDA, * ), B( LDB, * ), SR1,
28* \$ SR2, SI, BETA1, BETA2
29* DOUBLE PRECISION, INTENT( OUT ) :: V( * )
30* ..
31*
32*
33*> \par Purpose:
34* =============
35*>
36*> \verbatim
37*>
38*> Given a 3-by-3 matrix pencil (A,B), DLAQZ1 sets v to a
39*> scalar multiple of the first column of the product
40*>
41*> (*) K = (A - (beta2*sr2 - i*si)*B)*B^(-1)*(beta1*A - (sr2 + i*si2)*B)*B^(-1).
42*>
43*> It is assumed that either
44*>
45*> 1) sr1 = sr2
46*> or
47*> 2) si = 0.
48*>
49*> This is useful for starting double implicit shift bulges
50*> in the QZ algorithm.
51*> \endverbatim
52*
53*
54* Arguments:
55* ==========
56*
57*> \param[in] A
58*> \verbatim
59*> A is DOUBLE PRECISION array, dimension (LDA,N)
60*> The 3-by-3 matrix A in (*).
61*> \endverbatim
62*>
63*> \param[in] LDA
64*> \verbatim
65*> LDA is INTEGER
66*> The leading dimension of A as declared in
67*> the calling procedure.
68*> \endverbatim
69*
70*> \param[in] B
71*> \verbatim
72*> B is DOUBLE PRECISION array, dimension (LDB,N)
73*> The 3-by-3 matrix B in (*).
74*> \endverbatim
75*>
76*> \param[in] LDB
77*> \verbatim
78*> LDB is INTEGER
79*> The leading dimension of B as declared in
80*> the calling procedure.
81*> \endverbatim
82*>
83*> \param[in] SR1
84*> \verbatim
85*> SR1 is DOUBLE PRECISION
86*> \endverbatim
87*>
88*> \param[in] SR2
89*> \verbatim
90*> SR2 is DOUBLE PRECISION
91*> \endverbatim
92*>
93*> \param[in] SI
94*> \verbatim
95*> SI is DOUBLE PRECISION
96*> \endverbatim
97*>
98*> \param[in] BETA1
99*> \verbatim
100*> BETA1 is DOUBLE PRECISION
101*> \endverbatim
102*>
103*> \param[in] BETA2
104*> \verbatim
105*> BETA2 is DOUBLE PRECISION
106*> \endverbatim
107*>
108*> \param[out] V
109*> \verbatim
110*> V is DOUBLE PRECISION array, dimension (N)
111*> A scalar multiple of the first column of the
112*> matrix K in (*).
113*> \endverbatim
114*
115* Authors:
116* ========
117*
118*> \author Thijs Steel, KU Leuven
119*
120*> \date May 2020
121*
122*> \ingroup doubleGEcomputational
123*>
124* =====================================================================
125 SUBROUTINE dlaqz1( A, LDA, B, LDB, SR1, SR2, SI, BETA1, BETA2,
126 \$ V )
127 IMPLICIT NONE
128*
129* Arguments
130 INTEGER, INTENT( IN ) :: LDA, LDB
131 DOUBLE PRECISION, INTENT( IN ) :: A( LDA, * ), B( LDB, * ), SR1,
132 \$ sr2, si, beta1, beta2
133 DOUBLE PRECISION, INTENT( OUT ) :: V( * )
134*
135* Parameters
136 DOUBLE PRECISION :: ZERO, ONE, HALF
137 parameter( zero = 0.0d0, one = 1.0d0, half = 0.5d0 )
138*
139* Local scalars
140 DOUBLE PRECISION :: W( 2 ), SAFMIN, SAFMAX, SCALE1, SCALE2
141*
142* External Functions
143 DOUBLE PRECISION, EXTERNAL :: DLAMCH
144 LOGICAL, EXTERNAL :: DISNAN
145*
146 safmin = dlamch( 'SAFE MINIMUM' )
147 safmax = one/safmin
148*
149* Calculate first shifted vector
150*
151 w( 1 ) = beta1*a( 1, 1 )-sr1*b( 1, 1 )
152 w( 2 ) = beta1*a( 2, 1 )-sr1*b( 2, 1 )
153 scale1 = sqrt( abs( w( 1 ) ) ) * sqrt( abs( w( 2 ) ) )
154 IF( scale1 .GE. safmin .AND. scale1 .LE. safmax ) THEN
155 w( 1 ) = w( 1 )/scale1
156 w( 2 ) = w( 2 )/scale1
157 END IF
158*
159* Solve linear system
160*
161 w( 2 ) = w( 2 )/b( 2, 2 )
162 w( 1 ) = ( w( 1 )-b( 1, 2 )*w( 2 ) )/b( 1, 1 )
163 scale2 = sqrt( abs( w( 1 ) ) ) * sqrt( abs( w( 2 ) ) )
164 IF( scale2 .GE. safmin .AND. scale2 .LE. safmax ) THEN
165 w( 1 ) = w( 1 )/scale2
166 w( 2 ) = w( 2 )/scale2
167 END IF
168*
169* Apply second shift
170*
171 v( 1 ) = beta2*( a( 1, 1 )*w( 1 )+a( 1, 2 )*w( 2 ) )-sr2*( b( 1,
172 \$ 1 )*w( 1 )+b( 1, 2 )*w( 2 ) )
173 v( 2 ) = beta2*( a( 2, 1 )*w( 1 )+a( 2, 2 )*w( 2 ) )-sr2*( b( 2,
174 \$ 1 )*w( 1 )+b( 2, 2 )*w( 2 ) )
175 v( 3 ) = beta2*( a( 3, 1 )*w( 1 )+a( 3, 2 )*w( 2 ) )-sr2*( b( 3,
176 \$ 1 )*w( 1 )+b( 3, 2 )*w( 2 ) )
177*
178* Account for imaginary part
179*
180 v( 1 ) = v( 1 )+si*si*b( 1, 1 )/scale1/scale2
181*
182* Check for overflow
183*
184 IF( abs( v( 1 ) ).GT.safmax .OR. abs( v( 2 ) ) .GT. safmax .OR.
185 \$ abs( v( 3 ) ).GT.safmax .OR. disnan( v( 1 ) ) .OR.
186 \$ disnan( v( 2 ) ) .OR. disnan( v( 3 ) ) ) THEN
187 v( 1 ) = zero
188 v( 2 ) = zero
189 v( 3 ) = zero
190 END IF
191*
192* End of DLAQZ1
193*
194 END SUBROUTINE
subroutine dlaqz1(A, LDA, B, LDB, SR1, SR2, SI, BETA1, BETA2, V)
DLAQZ1
Definition: dlaqz1.f:127