LAPACK  3.10.0
LAPACK: Linear Algebra PACKage
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 doubleGEcomputational
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