github.com/gonum/lapack@v0.0.0-20181123203213-e4cdc5a0bff9/internal/testdata/netlib/dlaqr1.f (about) 1 *> \brief \b DLAQR1 sets a scalar multiple of the first column of the product of 2-by-2 or 3-by-3 matrix H and specified shifts. 2 * 3 * =========== DOCUMENTATION =========== 4 * 5 * Online html documentation available at 6 * http://www.netlib.org/lapack/explore-html/ 7 * 8 *> \htmlonly 9 *> Download DLAQR1 + dependencies 10 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlaqr1.f"> 11 *> [TGZ]</a> 12 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlaqr1.f"> 13 *> [ZIP]</a> 14 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlaqr1.f"> 15 *> [TXT]</a> 16 *> \endhtmlonly 17 * 18 * Definition: 19 * =========== 20 * 21 * SUBROUTINE DLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V ) 22 * 23 * .. Scalar Arguments .. 24 * DOUBLE PRECISION SI1, SI2, SR1, SR2 25 * INTEGER LDH, N 26 * .. 27 * .. Array Arguments .. 28 * DOUBLE PRECISION H( LDH, * ), V( * ) 29 * .. 30 * 31 * 32 *> \par Purpose: 33 * ============= 34 *> 35 *> \verbatim 36 *> 37 *> Given a 2-by-2 or 3-by-3 matrix H, DLAQR1 sets v to a 38 *> scalar multiple of the first column of the product 39 *> 40 *> (*) K = (H - (sr1 + i*si1)*I)*(H - (sr2 + i*si2)*I) 41 *> 42 *> scaling to avoid overflows and most underflows. It 43 *> is assumed that either 44 *> 45 *> 1) sr1 = sr2 and si1 = -si2 46 *> or 47 *> 2) si1 = si2 = 0. 48 *> 49 *> This is useful for starting double implicit shift bulges 50 *> in the QR algorithm. 51 *> \endverbatim 52 * 53 * Arguments: 54 * ========== 55 * 56 *> \param[in] N 57 *> \verbatim 58 *> N is integer 59 *> Order of the matrix H. N must be either 2 or 3. 60 *> \endverbatim 61 *> 62 *> \param[in] H 63 *> \verbatim 64 *> H is DOUBLE PRECISION array of dimension (LDH,N) 65 *> The 2-by-2 or 3-by-3 matrix H in (*). 66 *> \endverbatim 67 *> 68 *> \param[in] LDH 69 *> \verbatim 70 *> LDH is integer 71 *> The leading dimension of H as declared in 72 *> the calling procedure. LDH.GE.N 73 *> \endverbatim 74 *> 75 *> \param[in] SR1 76 *> \verbatim 77 *> SR1 is DOUBLE PRECISION 78 *> \endverbatim 79 *> 80 *> \param[in] SI1 81 *> \verbatim 82 *> SI1 is DOUBLE PRECISION 83 *> \endverbatim 84 *> 85 *> \param[in] SR2 86 *> \verbatim 87 *> SR2 is DOUBLE PRECISION 88 *> \endverbatim 89 *> 90 *> \param[in] SI2 91 *> \verbatim 92 *> SI2 is DOUBLE PRECISION 93 *> The shifts in (*). 94 *> \endverbatim 95 *> 96 *> \param[out] V 97 *> \verbatim 98 *> V is DOUBLE PRECISION array of dimension N 99 *> A scalar multiple of the first column of the 100 *> matrix K in (*). 101 *> \endverbatim 102 * 103 * Authors: 104 * ======== 105 * 106 *> \author Univ. of Tennessee 107 *> \author Univ. of California Berkeley 108 *> \author Univ. of Colorado Denver 109 *> \author NAG Ltd. 110 * 111 *> \date September 2012 112 * 113 *> \ingroup doubleOTHERauxiliary 114 * 115 *> \par Contributors: 116 * ================== 117 *> 118 *> Karen Braman and Ralph Byers, Department of Mathematics, 119 *> University of Kansas, USA 120 *> 121 * ===================================================================== 122 SUBROUTINE DLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V ) 123 * 124 * -- LAPACK auxiliary routine (version 3.4.2) -- 125 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 126 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 127 * September 2012 128 * 129 * .. Scalar Arguments .. 130 DOUBLE PRECISION SI1, SI2, SR1, SR2 131 INTEGER LDH, N 132 * .. 133 * .. Array Arguments .. 134 DOUBLE PRECISION H( LDH, * ), V( * ) 135 * .. 136 * 137 * ================================================================ 138 * 139 * .. Parameters .. 140 DOUBLE PRECISION ZERO 141 PARAMETER ( ZERO = 0.0d0 ) 142 * .. 143 * .. Local Scalars .. 144 DOUBLE PRECISION H21S, H31S, S 145 * .. 146 * .. Intrinsic Functions .. 147 INTRINSIC ABS 148 * .. 149 * .. Executable Statements .. 150 IF( N.EQ.2 ) THEN 151 S = ABS( H( 1, 1 )-SR2 ) + ABS( SI2 ) + ABS( H( 2, 1 ) ) 152 IF( S.EQ.ZERO ) THEN 153 V( 1 ) = ZERO 154 V( 2 ) = ZERO 155 ELSE 156 H21S = H( 2, 1 ) / S 157 V( 1 ) = H21S*H( 1, 2 ) + ( H( 1, 1 )-SR1 )* 158 $ ( ( H( 1, 1 )-SR2 ) / S ) - SI1*( SI2 / S ) 159 V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-SR1-SR2 ) 160 END IF 161 ELSE 162 S = ABS( H( 1, 1 )-SR2 ) + ABS( SI2 ) + ABS( H( 2, 1 ) ) + 163 $ ABS( H( 3, 1 ) ) 164 IF( S.EQ.ZERO ) THEN 165 V( 1 ) = ZERO 166 V( 2 ) = ZERO 167 V( 3 ) = ZERO 168 ELSE 169 H21S = H( 2, 1 ) / S 170 H31S = H( 3, 1 ) / S 171 V( 1 ) = ( H( 1, 1 )-SR1 )*( ( H( 1, 1 )-SR2 ) / S ) - 172 $ SI1*( SI2 / S ) + H( 1, 2 )*H21S + H( 1, 3 )*H31S 173 V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-SR1-SR2 ) + 174 $ H( 2, 3 )*H31S 175 V( 3 ) = H31S*( H( 1, 1 )+H( 3, 3 )-SR1-SR2 ) + 176 $ H21S*H( 3, 2 ) 177 END IF 178 END IF 179 END