vendor/gonum.org/v1/gonum/lapack/internal/testdata/netlib/dlaqr1.f

   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