LAPACK: SRC/slartgp.f Source File

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