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