LAPACK  3.4.1
LAPACK: Linear Algebra PACKage
drotmg.f
Go to the documentation of this file.
00001 *> \brief \b DROTMG
00002 *
00003 *  =========== DOCUMENTATION ===========
00004 *
00005 * Online html documentation available at 
00006 *            http://www.netlib.org/lapack/explore-html/ 
00007 *
00008 *  Definition:
00009 *  ===========
00010 *
00011 *       SUBROUTINE DROTMG(DD1,DD2,DX1,DY1,DPARAM)
00012 * 
00013 *       .. Scalar Arguments ..
00014 *       DOUBLE PRECISION DD1,DD2,DX1,DY1
00015 *       ..
00016 *       .. Array Arguments ..
00017 *       DOUBLE PRECISION DPARAM(5)
00018 *       ..
00019 *  
00020 *
00021 *> \par Purpose:
00022 *  =============
00023 *>
00024 *> \verbatim
00025 *>
00026 *>    CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS
00027 *>    THE SECOND COMPONENT OF THE 2-VECTOR  (DSQRT(DD1)*DX1,DSQRT(DD2)*>    DY2)**T.
00028 *>    WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS..
00029 *>
00030 *>    DFLAG=-1.D0     DFLAG=0.D0        DFLAG=1.D0     DFLAG=-2.D0
00031 *>
00032 *>      (DH11  DH12)    (1.D0  DH12)    (DH11  1.D0)    (1.D0  0.D0)
00033 *>    H=(          )    (          )    (          )    (          )
00034 *>      (DH21  DH22),   (DH21  1.D0),   (-1.D0 DH22),   (0.D0  1.D0).
00035 *>    LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22
00036 *>    RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE
00037 *>    VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.)
00038 *>
00039 *>    THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE
00040 *>    INEXACT.  THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE
00041 *>    OF DD1 AND DD2.  ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
00042 *>
00043 *> \endverbatim
00044 *
00045 *  Arguments:
00046 *  ==========
00047 *
00048 *> \param[in,out] DD1
00049 *> \verbatim
00050 *>          DD1 is DOUBLE PRECISION
00051 *> \endverbatim
00052 *>
00053 *> \param[in,out] DD2
00054 *> \verbatim
00055 *>          DD2 is DOUBLE PRECISION
00056 *> \endverbatim
00057 *>
00058 *> \param[in,out] DX1
00059 *> \verbatim
00060 *>          DX1 is DOUBLE PRECISION
00061 *> \endverbatim
00062 *>
00063 *> \param[in] DY1
00064 *> \verbatim
00065 *>          DY1 is DOUBLE PRECISION
00066 *> \endverbatim
00067 *>
00068 *> \param[in,out] DPARAM
00069 *> \verbatim
00070 *>          DPARAM is DOUBLE PRECISION array, dimension 5
00071 *>     DPARAM(1)=DFLAG
00072 *>     DPARAM(2)=DH11
00073 *>     DPARAM(3)=DH21
00074 *>     DPARAM(4)=DH12
00075 *>     DPARAM(5)=DH22
00076 *> \endverbatim
00077 *
00078 *  Authors:
00079 *  ========
00080 *
00081 *> \author Univ. of Tennessee 
00082 *> \author Univ. of California Berkeley 
00083 *> \author Univ. of Colorado Denver 
00084 *> \author NAG Ltd. 
00085 *
00086 *> \date November 2011
00087 *
00088 *> \ingroup double_blas_level1
00089 *
00090 *  =====================================================================
00091       SUBROUTINE DROTMG(DD1,DD2,DX1,DY1,DPARAM)
00092 *
00093 *  -- Reference BLAS level1 routine (version 3.4.0) --
00094 *  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
00095 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
00096 *     November 2011
00097 *
00098 *     .. Scalar Arguments ..
00099       DOUBLE PRECISION DD1,DD2,DX1,DY1
00100 *     ..
00101 *     .. Array Arguments ..
00102       DOUBLE PRECISION DPARAM(5)
00103 *     ..
00104 *
00105 *  =====================================================================
00106 *
00107 *     .. Local Scalars ..
00108       DOUBLE PRECISION DFLAG,DH11,DH12,DH21,DH22,DP1,DP2,DQ1,DQ2,DTEMP,
00109      $                 DU,GAM,GAMSQ,ONE,RGAMSQ,TWO,ZERO
00110 *     ..
00111 *     .. Intrinsic Functions ..
00112       INTRINSIC DABS
00113 *     ..
00114 *     .. Data statements ..
00115 *
00116       DATA ZERO,ONE,TWO/0.D0,1.D0,2.D0/
00117       DATA GAM,GAMSQ,RGAMSQ/4096.D0,16777216.D0,5.9604645D-8/
00118 *     ..
00119 
00120       IF (DD1.LT.ZERO) THEN
00121 *        GO ZERO-H-D-AND-DX1..
00122          DFLAG = -ONE
00123          DH11 = ZERO
00124          DH12 = ZERO
00125          DH21 = ZERO
00126          DH22 = ZERO
00127 *
00128          DD1 = ZERO
00129          DD2 = ZERO
00130          DX1 = ZERO
00131       ELSE
00132 *        CASE-DD1-NONNEGATIVE
00133          DP2 = DD2*DY1
00134          IF (DP2.EQ.ZERO) THEN
00135             DFLAG = -TWO
00136             DPARAM(1) = DFLAG
00137             RETURN
00138          END IF 
00139 *        REGULAR-CASE..
00140          DP1 = DD1*DX1
00141          DQ2 = DP2*DY1
00142          DQ1 = DP1*DX1
00143 *
00144          IF (DABS(DQ1).GT.DABS(DQ2)) THEN
00145             DH21 = -DY1/DX1
00146             DH12 = DP2/DP1
00147 *
00148             DU = ONE - DH12*DH21
00149 *
00150            IF (DU.GT.ZERO) THEN
00151              DFLAG = ZERO
00152              DD1 = DD1/DU
00153              DD2 = DD2/DU
00154              DX1 = DX1*DU
00155            END IF
00156          ELSE
00157 
00158             IF (DQ2.LT.ZERO) THEN
00159 *              GO ZERO-H-D-AND-DX1..
00160                DFLAG = -ONE
00161                DH11 = ZERO
00162                DH12 = ZERO
00163                DH21 = ZERO
00164                DH22 = ZERO
00165 *
00166                DD1 = ZERO
00167                DD2 = ZERO
00168                DX1 = ZERO
00169             ELSE
00170                DFLAG = ONE
00171                DH11 = DP1/DP2
00172                DH22 = DX1/DY1
00173                DU = ONE + DH11*DH22
00174                DTEMP = DD2/DU
00175                DD2 = DD1/DU
00176                DD1 = DTEMP
00177                DX1 = DY1*DU
00178             END IF
00179          END IF
00180 
00181 *     PROCEDURE..SCALE-CHECK
00182          IF (DD1.NE.ZERO) THEN
00183             DO WHILE ((DD1.LE.RGAMSQ) .OR. (DD1.GE.GAMSQ))
00184                IF (DFLAG.EQ.ZERO) THEN
00185                   DH11 = ONE
00186                   DH22 = ONE
00187                   DFLAG = -ONE
00188                ELSE
00189                   DH21 = -ONE
00190                   DH12 = ONE
00191                   DFLAG = -ONE
00192                END IF
00193                IF (DD1.LE.RGAMSQ) THEN
00194                   DD1 = DD1*GAM**2
00195                   DX1 = DX1/GAM
00196                   DH11 = DH11/GAM
00197                   DH12 = DH12/GAM
00198                ELSE
00199                   DD1 = DD1/GAM**2
00200                   DX1 = DX1*GAM
00201                   DH11 = DH11*GAM
00202                   DH12 = DH12*GAM
00203                END IF
00204             ENDDO
00205          END IF
00206   
00207          IF (DD2.NE.ZERO) THEN
00208             DO WHILE ( (DABS(DD2).LE.RGAMSQ) .OR. (DABS(DD2).GE.GAMSQ) )
00209                IF (DFLAG.EQ.ZERO) THEN
00210                   DH11 = ONE
00211                   DH22 = ONE
00212                   DFLAG = -ONE
00213                ELSE
00214                   DH21 = -ONE
00215                   DH12 = ONE
00216                   DFLAG = -ONE
00217                END IF
00218                IF (DABS(DD2).LE.RGAMSQ) THEN
00219                   DD2 = DD2*GAM**2
00220                   DH21 = DH21/GAM
00221                   DH22 = DH22/GAM
00222                ELSE
00223                   DD2 = DD2/GAM**2
00224                   DH21 = DH21*GAM
00225                   DH22 = DH22*GAM
00226                END IF      
00227             END DO
00228          END IF
00229      
00230       END IF
00231 
00232       IF (DFLAG.LT.ZERO) THEN
00233          DPARAM(2) = DH11
00234          DPARAM(3) = DH21
00235          DPARAM(4) = DH12
00236          DPARAM(5) = DH22
00237       ELSE IF (DFLAG.EQ.ZERO) THEN
00238          DPARAM(3) = DH21
00239          DPARAM(4) = DH12 
00240       ELSE
00241          DPARAM(2) = DH11
00242          DPARAM(5) = DH22
00243       END IF
00244 
00245       DPARAM(1) = DFLAG
00246       RETURN
00247       END
00248       
00249      
00250      
00251      
 All Files Functions