SRC/dlartgp.f

   1 *> \brief \b DLARTGP generates a plane rotation so that the diagonal is nonnegative.
   2 *
   3 *  =========== DOCUMENTATION ===========
   4 *
   5 * Online html documentation available at
   6 *            http://www.netlib.org/lapack/explore-html/
   7 *
   8 *> \htmlonly
   9 *> Download DLARTGP + dependencies
  10 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlartgp.f">
  11 *> [TGZ]</a>
  12 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlartgp.f">
  13 *> [ZIP]</a>
  14 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlartgp.f">
  15 *> [TXT]</a>
  16 *> \endhtmlonly
  17 *
  18 *  Definition:
  19 *  ===========
  20 *
  21 *       SUBROUTINE DLARTGP( F, G, CS, SN, R )
  22 *
  23 *       .. Scalar Arguments ..
  24 *       DOUBLE PRECISION   CS, F, G, R, SN
  25 *       ..
  26 *
  27 *
  28 *> \par Purpose:
  29 *  =============
  30 *>
  31 *> \verbatim
  32 *>
  33 *> DLARTGP generates a plane rotation so that
  34 *>
  35 *>    [  CS  SN  ]  .  [ F ]  =  [ R ]   where CS**2 + SN**2 = 1.
  36 *>    [ -SN  CS  ]     [ G ]     [ 0 ]
  37 *>
  38 *> This is a slower, more accurate version of the Level 1 BLAS routine DROTG,
  39 *> with the following other differences:
  40 *>    F and G are unchanged on return.
  41 *>    If G=0, then CS=(+/-)1 and SN=0.
  42 *>    If F=0 and (G .ne. 0), then CS=0 and SN=(+/-)1.
  43 *>
  44 *> The sign is chosen so that R >= 0.
  45 *> \endverbatim
  46 *
  47 *  Arguments:
  48 *  ==========
  49 *
  50 *> \param[in] F
  51 *> \verbatim
  52 *>          F is DOUBLE PRECISION
  53 *>          The first component of vector to be rotated.
  54 *> \endverbatim
  55 *>
  56 *> \param[in] G
  57 *> \verbatim
  58 *>          G is DOUBLE PRECISION
  59 *>          The second component of vector to be rotated.
  60 *> \endverbatim
  61 *>
  62 *> \param[out] CS
  63 *> \verbatim
  64 *>          CS is DOUBLE PRECISION
  65 *>          The cosine of the rotation.
  66 *> \endverbatim
  67 *>
  68 *> \param[out] SN
  69 *> \verbatim
  70 *>          SN is DOUBLE PRECISION
  71 *>          The sine of the rotation.
  72 *> \endverbatim
  73 *>
  74 *> \param[out] R
  75 *> \verbatim
  76 *>          R is DOUBLE PRECISION
  77 *>          The nonzero component of the rotated vector.
  78 *>
  79 *>  This version has a few statements commented out for thread safety
  80 *>  (machine parameters are computed on each entry). 10 feb 03, SJH.
  81 *> \endverbatim
  82 *
  83 *  Authors:
  84 *  ========
  85 *
  86 *> \author Univ. of Tennessee
  87 *> \author Univ. of California Berkeley
  88 *> \author Univ. of Colorado Denver
  89 *> \author NAG Ltd.
  90 *
  91 *> \date September 2012
  92 *
  93 *> \ingroup OTHERauxiliary
  94 *
  95 *  =====================================================================
  96       SUBROUTINE DLARTGP( F, G, CS, SN, R )
  97 *
  98 *  -- LAPACK auxiliary routine (version 3.4.2) --
  99 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
 100 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
 101 *     September 2012
 102 *
 103 *     .. Scalar Arguments ..
 104       DOUBLE PRECISION   CS, F, G, R, SN
 105 *     ..
 106 *
 107 *  =====================================================================
 108 *
 109 *     .. Parameters ..
 110       DOUBLE PRECISION   ZERO
 111       PARAMETER          ( ZERO = 0.0D0 )
 112       DOUBLE PRECISION   ONE
 113       PARAMETER          ( ONE = 1.0D0 )
 114       DOUBLE PRECISION   TWO
 115       PARAMETER          ( TWO = 2.0D0 )
 116 *     ..
 117 *     .. Local Scalars ..
 118 *     LOGICAL            FIRST
 119       INTEGER            COUNT, I
 120       DOUBLE PRECISION   EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE
 121 *     ..
 122 *     .. External Functions ..
 123       DOUBLE PRECISION   DLAMCH
 124       EXTERNAL           DLAMCH
 125 *     ..
 126 *     .. Intrinsic Functions ..
 127       INTRINSIC          ABS, INT, LOG, MAX, SIGN, SQRT
 128 *     ..
 129 *     .. Save statement ..
 130 *     SAVE               FIRST, SAFMX2, SAFMIN, SAFMN2
 131 *     ..
 132 *     .. Data statements ..
 133 *     DATA               FIRST / .TRUE. /
 134 *     ..
 135 *     .. Executable Statements ..
 136 *
 137 *     IF( FIRST ) THEN
 138          SAFMIN = DLAMCH( 'S' )
 139          EPS = DLAMCH( 'E' )
 140          SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
 141      $            LOG( DLAMCH( 'B' ) ) / TWO )
 142          SAFMX2 = ONE / SAFMN2
 143 *        FIRST = .FALSE.
 144 *     END IF
 145       IF( G.EQ.ZERO ) THEN
 146          CS = SIGN( ONE, F )
 147          SN = ZERO
 148          R = ABS( F )
 149       ELSE IF( F.EQ.ZERO ) THEN
 150          CS = ZERO
 151          SN = SIGN( ONE, G )
 152          R = ABS( G )
 153       ELSE
 154          F1 = F
 155          G1 = G
 156          SCALE = MAX( ABS( F1 ), ABS( G1 ) )
 157          IF( SCALE.GE.SAFMX2 ) THEN
 158             COUNT = 0
 159    10       CONTINUE
 160             COUNT = COUNT + 1
 161             F1 = F1*SAFMN2
 162             G1 = G1*SAFMN2
 163             SCALE = MAX( ABS( F1 ), ABS( G1 ) )
 164             IF( SCALE.GE.SAFMX2 )
 165      $         GO TO 10
 166             R = SQRT( F1**2+G1**2 )
 167             CS = F1 / R
 168             SN = G1 / R
 169             DO 20 I = 1, COUNT
 170                R = R*SAFMX2
 171    20       CONTINUE
 172          ELSE IF( SCALE.LE.SAFMN2 ) THEN
 173             COUNT = 0
 174    30       CONTINUE
 175             COUNT = COUNT + 1
 176             F1 = F1*SAFMX2
 177             G1 = G1*SAFMX2
 178             SCALE = MAX( ABS( F1 ), ABS( G1 ) )
 179             IF( SCALE.LE.SAFMN2 )
 180      $         GO TO 30
 181             R = SQRT( F1**2+G1**2 )
 182             CS = F1 / R
 183             SN = G1 / R
 184             DO 40 I = 1, COUNT
 185                R = R*SAFMN2
 186    40       CONTINUE
 187          ELSE
 188             R = SQRT( F1**2+G1**2 )
 189             CS = F1 / R
 190             SN = G1 / R
 191          END IF
 192          IF( R.LT.ZERO ) THEN
 193             CS = -CS
 194             SN = -SN
 195             R = -R
 196          END IF
 197       END IF
 198       RETURN
 199 *
 200 *     End of DLARTGP
 201 *
 202       END