slartg()

subroutine slartg	(	real	F,
		real	G,
		real	CS,
		real	SN,
		real	R
	)

SLARTG generates a plane rotation with real cosine and real sine.

Download SLARTG + dependencies [TGZ] [ZIP] [TXT]

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.

Parameters

[in]	F	F is REAL The first component of vector to be rotated.
[in]	G	G is REAL The second component of vector to be rotated.
[out]	CS	CS is REAL The cosine of the rotation.
[out]	SN	SN is REAL The sine of the rotation.
[out]	R	R is 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.

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 96 of file slartg.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      REAL               CS, F, G, R, SN
*     ..
*
*  =====================================================================
*
*     .. 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 .AND. count .LT. 20)
     $         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
*

Here is the caller graph for this function: