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.

Date

September 2012

Definition at line 97 of file slartgp.f.

*
*  -- LAPACK auxiliary routine (version 3.4.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     September 2012
*
*     .. 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 )
     $         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 SLARTG
*

Here is the caller graph for this function: