LAPACK  3.4.1
LAPACK: Linear Algebra PACKage
dlartg.f
Go to the documentation of this file.
00001 *> \brief \b DLARTG
00002 *
00003 *  =========== DOCUMENTATION ===========
00004 *
00005 * Online html documentation available at 
00006 *            http://www.netlib.org/lapack/explore-html/ 
00007 *
00008 *> \htmlonly
00009 *> Download DLARTG + dependencies 
00010 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlartg.f"> 
00011 *> [TGZ]</a> 
00012 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlartg.f"> 
00013 *> [ZIP]</a> 
00014 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlartg.f"> 
00015 *> [TXT]</a>
00016 *> \endhtmlonly 
00017 *
00018 *  Definition:
00019 *  ===========
00020 *
00021 *       SUBROUTINE DLARTG( F, G, CS, SN, R )
00022 * 
00023 *       .. Scalar Arguments ..
00024 *       DOUBLE PRECISION   CS, F, G, R, SN
00025 *       ..
00026 *  
00027 *
00028 *> \par Purpose:
00029 *  =============
00030 *>
00031 *> \verbatim
00032 *>
00033 *> DLARTG generate a plane rotation so that
00034 *>
00035 *>    [  CS  SN  ]  .  [ F ]  =  [ R ]   where CS**2 + SN**2 = 1.
00036 *>    [ -SN  CS  ]     [ G ]     [ 0 ]
00037 *>
00038 *> This is a slower, more accurate version of the BLAS1 routine DROTG,
00039 *> with the following other differences:
00040 *>    F and G are unchanged on return.
00041 *>    If G=0, then CS=1 and SN=0.
00042 *>    If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any
00043 *>       floating point operations (saves work in DBDSQR when
00044 *>       there are zeros on the diagonal).
00045 *>
00046 *> If F exceeds G in magnitude, CS will be positive.
00047 *> \endverbatim
00048 *
00049 *  Arguments:
00050 *  ==========
00051 *
00052 *> \param[in] F
00053 *> \verbatim
00054 *>          F is DOUBLE PRECISION
00055 *>          The first component of vector to be rotated.
00056 *> \endverbatim
00057 *>
00058 *> \param[in] G
00059 *> \verbatim
00060 *>          G is DOUBLE PRECISION
00061 *>          The second component of vector to be rotated.
00062 *> \endverbatim
00063 *>
00064 *> \param[out] CS
00065 *> \verbatim
00066 *>          CS is DOUBLE PRECISION
00067 *>          The cosine of the rotation.
00068 *> \endverbatim
00069 *>
00070 *> \param[out] SN
00071 *> \verbatim
00072 *>          SN is DOUBLE PRECISION
00073 *>          The sine of the rotation.
00074 *> \endverbatim
00075 *>
00076 *> \param[out] R
00077 *> \verbatim
00078 *>          R is DOUBLE PRECISION
00079 *>          The nonzero component of the rotated vector.
00080 *>
00081 *>  This version has a few statements commented out for thread safety
00082 *>  (machine parameters are computed on each entry). 10 feb 03, SJH.
00083 *> \endverbatim
00084 *
00085 *  Authors:
00086 *  ========
00087 *
00088 *> \author Univ. of Tennessee 
00089 *> \author Univ. of California Berkeley 
00090 *> \author Univ. of Colorado Denver 
00091 *> \author NAG Ltd. 
00092 *
00093 *> \date November 2011
00094 *
00095 *> \ingroup auxOTHERauxiliary
00096 *
00097 *  =====================================================================
00098       SUBROUTINE DLARTG( F, G, CS, SN, R )
00099 *
00100 *  -- LAPACK auxiliary routine (version 3.4.0) --
00101 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
00102 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
00103 *     November 2011
00104 *
00105 *     .. Scalar Arguments ..
00106       DOUBLE PRECISION   CS, F, G, R, SN
00107 *     ..
00108 *
00109 *  =====================================================================
00110 *
00111 *     .. Parameters ..
00112       DOUBLE PRECISION   ZERO
00113       PARAMETER          ( ZERO = 0.0D0 )
00114       DOUBLE PRECISION   ONE
00115       PARAMETER          ( ONE = 1.0D0 )
00116       DOUBLE PRECISION   TWO
00117       PARAMETER          ( TWO = 2.0D0 )
00118 *     ..
00119 *     .. Local Scalars ..
00120 *     LOGICAL            FIRST
00121       INTEGER            COUNT, I
00122       DOUBLE PRECISION   EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE
00123 *     ..
00124 *     .. External Functions ..
00125       DOUBLE PRECISION   DLAMCH
00126       EXTERNAL           DLAMCH
00127 *     ..
00128 *     .. Intrinsic Functions ..
00129       INTRINSIC          ABS, INT, LOG, MAX, SQRT
00130 *     ..
00131 *     .. Save statement ..
00132 *     SAVE               FIRST, SAFMX2, SAFMIN, SAFMN2
00133 *     ..
00134 *     .. Data statements ..
00135 *     DATA               FIRST / .TRUE. /
00136 *     ..
00137 *     .. Executable Statements ..
00138 *
00139 *     IF( FIRST ) THEN
00140          SAFMIN = DLAMCH( 'S' )
00141          EPS = DLAMCH( 'E' )
00142          SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
00143      $            LOG( DLAMCH( 'B' ) ) / TWO )
00144          SAFMX2 = ONE / SAFMN2
00145 *        FIRST = .FALSE.
00146 *     END IF
00147       IF( G.EQ.ZERO ) THEN
00148          CS = ONE
00149          SN = ZERO
00150          R = F
00151       ELSE IF( F.EQ.ZERO ) THEN
00152          CS = ZERO
00153          SN = ONE
00154          R = G
00155       ELSE
00156          F1 = F
00157          G1 = G
00158          SCALE = MAX( ABS( F1 ), ABS( G1 ) )
00159          IF( SCALE.GE.SAFMX2 ) THEN
00160             COUNT = 0
00161    10       CONTINUE
00162             COUNT = COUNT + 1
00163             F1 = F1*SAFMN2
00164             G1 = G1*SAFMN2
00165             SCALE = MAX( ABS( F1 ), ABS( G1 ) )
00166             IF( SCALE.GE.SAFMX2 )
00167      $         GO TO 10
00168             R = SQRT( F1**2+G1**2 )
00169             CS = F1 / R
00170             SN = G1 / R
00171             DO 20 I = 1, COUNT
00172                R = R*SAFMX2
00173    20       CONTINUE
00174          ELSE IF( SCALE.LE.SAFMN2 ) THEN
00175             COUNT = 0
00176    30       CONTINUE
00177             COUNT = COUNT + 1
00178             F1 = F1*SAFMX2
00179             G1 = G1*SAFMX2
00180             SCALE = MAX( ABS( F1 ), ABS( G1 ) )
00181             IF( SCALE.LE.SAFMN2 )
00182      $         GO TO 30
00183             R = SQRT( F1**2+G1**2 )
00184             CS = F1 / R
00185             SN = G1 / R
00186             DO 40 I = 1, COUNT
00187                R = R*SAFMN2
00188    40       CONTINUE
00189          ELSE
00190             R = SQRT( F1**2+G1**2 )
00191             CS = F1 / R
00192             SN = G1 / R
00193          END IF
00194          IF( ABS( F ).GT.ABS( G ) .AND. CS.LT.ZERO ) THEN
00195             CS = -CS
00196             SN = -SN
00197             R = -R
00198          END IF
00199       END IF
00200       RETURN
00201 *
00202 *     End of DLARTG
00203 *
00204       END
 All Files Functions