SRC/slartg.f

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