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