LAPACK: SRC/slartg.f Source File

Go to the documentation of this file.
00001       SUBROUTINE SLARTG( F, G, CS, SN, R )
00002 *
00003 *  -- LAPACK auxiliary routine (version 3.2) --
00004 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
00005 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
00006 *     November 2006
00007 *
00008 *     .. Scalar Arguments ..
00009       REAL               CS, F, G, R, SN
00010 *     ..
00011 *
00012 *  Purpose
00013 *  =======
00014 *
00015 *  SLARTG generate a plane rotation so that
00016 *
00017 *     [  CS  SN  ]  .  [ F ]  =  [ R ]   where CS**2 + SN**2 = 1.
00018 *     [ -SN  CS  ]     [ G ]     [ 0 ]
00019 *
00020 *  This is a slower, more accurate version of the BLAS1 routine SROTG,
00021 *  with the following other differences:
00022 *     F and G are unchanged on return.
00023 *     If G=0, then CS=1 and SN=0.
00024 *     If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any
00025 *        floating point operations (saves work in SBDSQR when
00026 *        there are zeros on the diagonal).
00027 *
00028 *  If F exceeds G in magnitude, CS will be positive.
00029 *
00030 *  Arguments
00031 *  =========
00032 *
00033 *  F       (input) REAL
00034 *          The first component of vector to be rotated.
00035 *
00036 *  G       (input) REAL
00037 *          The second component of vector to be rotated.
00038 *
00039 *  CS      (output) REAL
00040 *          The cosine of the rotation.
00041 *
00042 *  SN      (output) REAL
00043 *          The sine of the rotation.
00044 *
00045 *  R       (output) REAL
00046 *          The nonzero component of the rotated vector.
00047 *
00048 *  This version has a few statements commented out for thread safety
00049 *  (machine parameters are computed on each entry). 10 feb 03, SJH.
00050 *
00051 *  =====================================================================
00052 *
00053 *     .. Parameters ..
00054       REAL               ZERO
00055       PARAMETER          ( ZERO = 0.0E0 )
00056       REAL               ONE
00057       PARAMETER          ( ONE = 1.0E0 )
00058       REAL               TWO
00059       PARAMETER          ( TWO = 2.0E0 )
00060 *     ..
00061 *     .. Local Scalars ..
00062 *     LOGICAL            FIRST
00063       INTEGER            COUNT, I
00064       REAL               EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE
00065 *     ..
00066 *     .. External Functions ..
00067       REAL               SLAMCH
00068       EXTERNAL           SLAMCH
00069 *     ..
00070 *     .. Intrinsic Functions ..
00071       INTRINSIC          ABS, INT, LOG, MAX, SQRT
00072 *     ..
00073 *     .. Save statement ..
00074 *     SAVE               FIRST, SAFMX2, SAFMIN, SAFMN2
00075 *     ..
00076 *     .. Data statements ..
00077 *     DATA               FIRST / .TRUE. /
00078 *     ..
00079 *     .. Executable Statements ..
00080 *
00081 *     IF( FIRST ) THEN
00082          SAFMIN = SLAMCH( 'S' )
00083          EPS = SLAMCH( 'E' )
00084          SAFMN2 = SLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
00085      $            LOG( SLAMCH( 'B' ) ) / TWO )
00086          SAFMX2 = ONE / SAFMN2
00087 *        FIRST = .FALSE.
00088 *     END IF
00089       IF( G.EQ.ZERO ) THEN
00090          CS = ONE
00091          SN = ZERO
00092          R = F
00093       ELSE IF( F.EQ.ZERO ) THEN
00094          CS = ZERO
00095          SN = ONE
00096          R = G
00097       ELSE
00098          F1 = F
00099          G1 = G
00100          SCALE = MAX( ABS( F1 ), ABS( G1 ) )
00101          IF( SCALE.GE.SAFMX2 ) THEN
00102             COUNT = 0
00103    10       CONTINUE
00104             COUNT = COUNT + 1
00105             F1 = F1*SAFMN2
00106             G1 = G1*SAFMN2
00107             SCALE = MAX( ABS( F1 ), ABS( G1 ) )
00108             IF( SCALE.GE.SAFMX2 )
00109      $         GO TO 10
00110             R = SQRT( F1**2+G1**2 )
00111             CS = F1 / R
00112             SN = G1 / R
00113             DO 20 I = 1, COUNT
00114                R = R*SAFMX2
00115    20       CONTINUE
00116          ELSE IF( SCALE.LE.SAFMN2 ) THEN
00117             COUNT = 0
00118    30       CONTINUE
00119             COUNT = COUNT + 1
00120             F1 = F1*SAFMX2
00121             G1 = G1*SAFMX2
00122             SCALE = MAX( ABS( F1 ), ABS( G1 ) )
00123             IF( SCALE.LE.SAFMN2 )
00124      $         GO TO 30
00125             R = SQRT( F1**2+G1**2 )
00126             CS = F1 / R
00127             SN = G1 / R
00128             DO 40 I = 1, COUNT
00129                R = R*SAFMN2
00130    40       CONTINUE
00131          ELSE
00132             R = SQRT( F1**2+G1**2 )
00133             CS = F1 / R
00134             SN = G1 / R
00135          END IF
00136          IF( ABS( F ).GT.ABS( G ) .AND. CS.LT.ZERO ) THEN
00137             CS = -CS
00138             SN = -SN
00139             R = -R
00140          END IF
00141       END IF
00142       RETURN
00143 *
00144 *     End of SLARTG
00145 *
00146       END