LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
slaqz1.f
Go to the documentation of this file.
1*> \brief \b SLAQZ1
2*
3* =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6* http://www.netlib.org/lapack/explore-html/
7*
8*> \htmlonly
9*> Download SLAQZ1 + dependencies
10*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slaqz1.f">
11*> [TGZ]</a>
12*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slaqz1.f">
13*> [ZIP]</a>
14*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slaqz1.f">
15*> [TXT]</a>
16*> \endhtmlonly
17*
18* Definition:
19* ===========
20*
21* SUBROUTINE SLAQZ1( A, LDA, B, LDB, SR1, SR2, SI, BETA1, BETA2,
22* $ V )
23* IMPLICIT NONE
24*
25* Arguments
26* INTEGER, INTENT( IN ) :: LDA, LDB
27* REAL, INTENT( IN ) :: A( LDA, * ), B( LDB, * ), SR1, SR2, SI,
28* $ BETA1, BETA2
29* REAL, INTENT( OUT ) :: V( * )
30* ..
31*
32*
33*> \par Purpose:
34* =============
35*>
36*> \verbatim
37*>
38*> Given a 3-by-3 matrix pencil (A,B), SLAQZ1 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 REAL 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 REAL 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 REAL
86*> \endverbatim
87*>
88*> \param[in] SR2
89*> \verbatim
90*> SR2 is REAL
91*> \endverbatim
92*>
93*> \param[in] SI
94*> \verbatim
95*> SI is REAL
96*> \endverbatim
97*>
98*> \param[in] BETA1
99*> \verbatim
100*> BETA1 is REAL
101*> \endverbatim
102*>
103*> \param[in] BETA2
104*> \verbatim
105*> BETA2 is REAL
106*> \endverbatim
107*>
108*> \param[out] V
109*> \verbatim
110*> V is REAL 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 laqz1
123*>
124* =====================================================================
125 SUBROUTINE slaqz1( A, LDA, B, LDB, SR1, SR2, SI, BETA1, BETA2,
126 $ V )
127 IMPLICIT NONE
128*
129* Arguments
130 INTEGER, INTENT( IN ) :: LDA, LDB
131 REAL, INTENT( IN ) :: A( LDA, * ), B( LDB, * ), SR1, SR2, SI,
132 $ beta1, beta2
133 REAL, INTENT( OUT ) :: V( * )
134*
135* Parameters
136 REAL :: ZERO, ONE, HALF
137 parameter( zero = 0.0, one = 1.0, half = 0.5 )
138*
139* Local scalars
140 REAL :: W( 2 ), SAFMIN, SAFMAX, SCALE1, SCALE2
141*
142* External Functions
143 REAL, EXTERNAL :: SLAMCH
144 LOGICAL, EXTERNAL :: SISNAN
145*
146 safmin = slamch( '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. sisnan( v( 1 ) ) .OR.
186 $ sisnan( v( 2 ) ) .OR. sisnan( v( 3 ) ) ) THEN
187 v( 1 ) = zero
188 v( 2 ) = zero
189 v( 3 ) = zero
190 END IF
191*
192* End of SLAQZ1
193*
194 END SUBROUTINE
subroutine slaqz1(a, lda, b, ldb, sr1, sr2, si, beta1, beta2, v)
SLAQZ1
Definition slaqz1.f:127