001:       SUBROUTINE SLARTG( F, G, CS, SN, R )
002: *
003: *  -- LAPACK auxiliary routine (version 3.2) --
004: *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
005: *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
006: *     November 2006
007: *
008: *     .. Scalar Arguments ..
009:       REAL               CS, F, G, R, SN
010: *     ..
011: *
012: *  Purpose
013: *  =======
014: *
015: *  SLARTG generate a plane rotation so that
016: *
017: *     [  CS  SN  ]  .  [ F ]  =  [ R ]   where CS**2 + SN**2 = 1.
018: *     [ -SN  CS  ]     [ G ]     [ 0 ]
019: *
020: *  This is a slower, more accurate version of the BLAS1 routine SROTG,
021: *  with the following other differences:
022: *     F and G are unchanged on return.
023: *     If G=0, then CS=1 and SN=0.
024: *     If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any
025: *        floating point operations (saves work in SBDSQR when
026: *        there are zeros on the diagonal).
027: *
028: *  If F exceeds G in magnitude, CS will be positive.
029: *
030: *  Arguments
031: *  =========
032: *
033: *  F       (input) REAL
034: *          The first component of vector to be rotated.
035: *
036: *  G       (input) REAL
037: *          The second component of vector to be rotated.
038: *
039: *  CS      (output) REAL
040: *          The cosine of the rotation.
041: *
042: *  SN      (output) REAL
043: *          The sine of the rotation.
044: *
045: *  R       (output) REAL
046: *          The nonzero component of the rotated vector.
047: *
048: *  This version has a few statements commented out for thread safety
049: *  (machine parameters are computed on each entry). 10 feb 03, SJH.
050: *
051: *  =====================================================================
052: *
053: *     .. Parameters ..
054:       REAL               ZERO
055:       PARAMETER          ( ZERO = 0.0E0 )
056:       REAL               ONE
057:       PARAMETER          ( ONE = 1.0E0 )
058:       REAL               TWO
059:       PARAMETER          ( TWO = 2.0E0 )
060: *     ..
061: *     .. Local Scalars ..
062: *     LOGICAL            FIRST
063:       INTEGER            COUNT, I
064:       REAL               EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE
065: *     ..
066: *     .. External Functions ..
067:       REAL               SLAMCH
068:       EXTERNAL           SLAMCH
069: *     ..
070: *     .. Intrinsic Functions ..
071:       INTRINSIC          ABS, INT, LOG, MAX, SQRT
072: *     ..
073: *     .. Save statement ..
074: *     SAVE               FIRST, SAFMX2, SAFMIN, SAFMN2
075: *     ..
076: *     .. Data statements ..
077: *     DATA               FIRST / .TRUE. /
078: *     ..
079: *     .. Executable Statements ..
080: *
081: *     IF( FIRST ) THEN
082:          SAFMIN = SLAMCH( 'S' )
083:          EPS = SLAMCH( 'E' )
084:          SAFMN2 = SLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
085:      $            LOG( SLAMCH( 'B' ) ) / TWO )
086:          SAFMX2 = ONE / SAFMN2
087: *        FIRST = .FALSE.
088: *     END IF
089:       IF( G.EQ.ZERO ) THEN
090:          CS = ONE
091:          SN = ZERO
092:          R = F
093:       ELSE IF( F.EQ.ZERO ) THEN
094:          CS = ZERO
095:          SN = ONE
096:          R = G
097:       ELSE
098:          F1 = F
099:          G1 = G
100:          SCALE = MAX( ABS( F1 ), ABS( G1 ) )
101:          IF( SCALE.GE.SAFMX2 ) THEN
102:             COUNT = 0
103:    10       CONTINUE
104:             COUNT = COUNT + 1
105:             F1 = F1*SAFMN2
106:             G1 = G1*SAFMN2
107:             SCALE = MAX( ABS( F1 ), ABS( G1 ) )
108:             IF( SCALE.GE.SAFMX2 )
109:      $         GO TO 10
110:             R = SQRT( F1**2+G1**2 )
111:             CS = F1 / R
112:             SN = G1 / R
113:             DO 20 I = 1, COUNT
114:                R = R*SAFMX2
115:    20       CONTINUE
116:          ELSE IF( SCALE.LE.SAFMN2 ) THEN
117:             COUNT = 0
118:    30       CONTINUE
119:             COUNT = COUNT + 1
120:             F1 = F1*SAFMX2
121:             G1 = G1*SAFMX2
122:             SCALE = MAX( ABS( F1 ), ABS( G1 ) )
123:             IF( SCALE.LE.SAFMN2 )
124:      $         GO TO 30
125:             R = SQRT( F1**2+G1**2 )
126:             CS = F1 / R
127:             SN = G1 / R
128:             DO 40 I = 1, COUNT
129:                R = R*SAFMN2
130:    40       CONTINUE
131:          ELSE
132:             R = SQRT( F1**2+G1**2 )
133:             CS = F1 / R
134:             SN = G1 / R
135:          END IF
136:          IF( ABS( F ).GT.ABS( G ) .AND. CS.LT.ZERO ) THEN
137:             CS = -CS
138:             SN = -SN
139:             R = -R
140:          END IF
141:       END IF
142:       RETURN
143: *
144: *     End of SLARTG
145: *
146:       END
147: