slartgp()

subroutine slartgp	(	real	f,
		real	g,
		real	cs,
		real	sn,
		real	r )

SLARTGP generates a plane rotation so that the diagonal is nonnegative.

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

Purpose:

!>
!> SLARTGP generates 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 Level 1 BLAS 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.
!>
!> The sign is chosen so that R >= 0.
!> 

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 92 of file slartgp.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, sign, 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 = sign( one, f )
         sn = zero
         r = abs( f )
      ELSE IF( f.EQ.zero ) THEN
         cs = zero
         sn = sign( one, g )
         r = abs( 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( r.LT.zero ) THEN
            cs = -cs
            sn = -sn
            r = -r
         END IF
      END IF
      RETURN
*
*     End of SLARTGP
*

Here is the caller graph for this function: