slartg.f

          SUBROUTINE SLARTG( F, G, CS, SN, R )
    *
    *  -- LAPACK auxiliary routine (version 3.1) --
    *     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
    *     November 2006
    *
    *     .. Scalar Arguments ..
          REAL               CS, F, G, R, SN
    *     ..
    *
    *  Purpose
    *  =======
    *
    *  SLARTG generate a plane rotation so that
    *
    *     [  CS  SN  ]  .  [ F ]  =  [ R ]   where CS**2 + SN**2 = 1.
    *     [ -SN  CS  ]     [ G ]     [ 0 ]
    *
    *  This is a slower, more accurate version of the BLAS1 routine SROTG,
    *  with the following other differences:
    *     F and G are unchanged on return.
    *     If G=0, then CS=1 and SN=0.
    *     If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any
    *        floating point operations (saves work in SBDSQR when
    *        there are zeros on the diagonal).
    *
    *  If F exceeds G in magnitude, CS will be positive.
    *
    *  Arguments
    *  =========
    *
    *  F       (input) REAL
    *          The first component of vector to be rotated.
    *
    *  G       (input) REAL
    *          The second component of vector to be rotated.
    *
    *  CS      (output) REAL
    *          The cosine of the rotation.
    *
    *  SN      (output) REAL
    *          The sine of the rotation.
    *
    *  R       (output) REAL
    *          The nonzero component of the rotated vector.
    *
    *  This version has a few statements commented out for thread safety
    *  (machine parameters are computed on each entry). 10 feb 03, SJH.
    *
    *  =====================================================================
    *
    *     .. Parameters ..
          REAL               ZERO
          PARAMETER          ( ZERO = 0.0E0 )
          REAL               ONE
          PARAMETER          ( ONE = 1.0E0 )
          REAL               TWO
          PARAMETER          ( TWO = 2.0E0 )
    *     ..
    *     .. Local Scalars ..
    *     LOGICAL            FIRST
          INTEGER            COUNT, I
          REAL               EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE
    *     ..
    *     .. External Functions ..
          REAL               SLAMCH
          EXTERNAL           SLAMCH
    *     ..
    *     .. Intrinsic Functions ..
          INTRINSIC          ABS, INT, LOG, MAX, SQRT
    *     ..
    *     .. Save statement ..
    *     SAVE               FIRST, SAFMX2, SAFMIN, SAFMN2
    *     ..
    *     .. Data statements ..
    *     DATA               FIRST / .TRUE. /
    *     ..
    *     .. Executable Statements ..
    *
    *     IF( FIRST ) THEN
             SAFMIN = SLAMCH( 'S' )
             EPS = SLAMCH( 'E' )
             SAFMN2 = SLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
         $            LOG( SLAMCH( 'B' ) ) / TWO )
             SAFMX2 = ONE / SAFMN2
    *        FIRST = .FALSE.
    *     END IF
          IF( G.EQ.ZERO ) THEN
             CS = ONE
             SN = ZERO
             R = F
          ELSE IF( F.EQ.ZERO ) THEN
             CS = ZERO
             SN = ONE
             R = G
          ELSE
             F1 = F
             G1 = G
             SCALE = MAX( ABS( F1 ), ABS( G1 ) )
             IF( SCALE.GE.SAFMX2 ) THEN
                COUNT = 0
       10       CONTINUE
                COUNT = COUNT + 1
                F1 = F1*SAFMN2
                G1 = G1*SAFMN2
                SCALE = MAX( ABS( F1 ), ABS( G1 ) )
                IF( SCALE.GE.SAFMX2 )
         $         GO TO 10
                R = SQRT( F1**2+G1**2 )
                CS = F1 / R
                SN = G1 / R
                DO 20 I = 1, COUNT
                   R = R*SAFMX2
       20       CONTINUE
             ELSE IF( SCALE.LE.SAFMN2 ) THEN
                COUNT = 0
       30       CONTINUE
                COUNT = COUNT + 1
                F1 = F1*SAFMX2
                G1 = G1*SAFMX2
                SCALE = MAX( ABS( F1 ), ABS( G1 ) )
                IF( SCALE.LE.SAFMN2 )
         $         GO TO 30
                R = SQRT( F1**2+G1**2 )
                CS = F1 / R
                SN = G1 / R
                DO 40 I = 1, COUNT
                   R = R*SAFMN2
       40       CONTINUE
             ELSE
                R = SQRT( F1**2+G1**2 )
                CS = F1 / R
                SN = G1 / R
             END IF
             IF( ABS( F ).GT.ABS( G ) .AND. CS.LT.ZERO ) THEN
                CS = -CS
                SN = -SN
                R = -R
             END IF
          END IF
          RETURN
    *
    *     End of SLARTG
    *
          END