LAPACK  3.4.1
LAPACK: Linear Algebra PACKage
srotmg.f
Go to the documentation of this file.
00001 *> \brief \b SROTMG
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 SROTMG(SD1,SD2,SX1,SY1,SPARAM)
00012 * 
00013 *       .. Scalar Arguments ..
00014 *       REAL SD1,SD2,SX1,SY1
00015 *       ..
00016 *       .. Array Arguments ..
00017 *       REAL SPARAM(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  (SQRT(SD1)*SX1,SQRT(SD2)*>    SY2)**T.
00028 *>    WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS..
00029 *>
00030 *>    SFLAG=-1.E0     SFLAG=0.E0        SFLAG=1.E0     SFLAG=-2.E0
00031 *>
00032 *>      (SH11  SH12)    (1.E0  SH12)    (SH11  1.E0)    (1.E0  0.E0)
00033 *>    H=(          )    (          )    (          )    (          )
00034 *>      (SH21  SH22),   (SH21  1.E0),   (-1.E0 SH22),   (0.E0  1.E0).
00035 *>    LOCATIONS 2-4 OF SPARAM CONTAIN SH11,SH21,SH12, AND SH22
00036 *>    RESPECTIVELY. (VALUES OF 1.E0, -1.E0, OR 0.E0 IMPLIED BY THE
00037 *>    VALUE OF SPARAM(1) ARE NOT STORED IN SPARAM.)
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 SD1 AND SD2.  ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
00042 *>
00043 *> \endverbatim
00044 *
00045 *  Arguments:
00046 *  ==========
00047 *
00048 *> \param[in,out] SD1
00049 *> \verbatim
00050 *>          SD1 is REAL
00051 *> \endverbatim
00052 *>
00053 *> \param[in,out] SD2
00054 *> \verbatim
00055 *>          SD2 is REAL
00056 *> \endverbatim
00057 *>
00058 *> \param[in,out] SX1
00059 *> \verbatim
00060 *>          SX1 is REAL
00061 *> \endverbatim
00062 *>
00063 *> \param[in] SY1
00064 *> \verbatim
00065 *>          SY1 is REAL
00066 *> \endverbatim
00067 *>
00068 *> \param[in,out] SPARAM
00069 *> \verbatim
00070 *>          SPARAM is REAL array, dimension 5
00071 *>     SPARAM(1)=SFLAG
00072 *>     SPARAM(2)=SH11
00073 *>     SPARAM(3)=SH21
00074 *>     SPARAM(4)=SH12
00075 *>     SPARAM(5)=SH22
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 single_blas_level1
00089 *
00090 *  =====================================================================
00091       SUBROUTINE SROTMG(SD1,SD2,SX1,SY1,SPARAM)
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       REAL SD1,SD2,SX1,SY1
00100 *     ..
00101 *     .. Array Arguments ..
00102       REAL SPARAM(5)
00103 *     ..
00104 *
00105 *  =====================================================================
00106 *
00107 *     .. Local Scalars ..
00108       REAL GAM,GAMSQ,ONE,RGAMSQ,SFLAG,SH11,SH12,SH21,SH22,SP1,SP2,SQ1,
00109      $     SQ2,STEMP,SU,TWO,ZERO
00110 *     ..
00111 *     .. Intrinsic Functions ..
00112       INTRINSIC ABS
00113 *     ..
00114 *     .. Data statements ..
00115 *
00116       DATA ZERO,ONE,TWO/0.E0,1.E0,2.E0/
00117       DATA GAM,GAMSQ,RGAMSQ/4096.E0,1.67772E7,5.96046E-8/
00118 *     ..
00119 
00120       IF (SD1.LT.ZERO) THEN
00121 *        GO ZERO-H-D-AND-SX1..
00122          SFLAG = -ONE
00123          SH11 = ZERO
00124          SH12 = ZERO
00125          SH21 = ZERO
00126          SH22 = ZERO
00127 *
00128          SD1 = ZERO
00129          SD2 = ZERO
00130          SX1 = ZERO
00131       ELSE
00132 *        CASE-SD1-NONNEGATIVE
00133          SP2 = SD2*SY1
00134          IF (SP2.EQ.ZERO) THEN
00135             SFLAG = -TWO
00136             SPARAM(1) = SFLAG
00137             RETURN
00138          END IF 
00139 *        REGULAR-CASE..
00140          SP1 = SD1*SX1
00141          SQ2 = SP2*SY1
00142          SQ1 = SP1*SX1
00143 *
00144          IF (ABS(SQ1).GT.ABS(SQ2)) THEN
00145             SH21 = -SY1/SX1
00146             SH12 = SP2/SP1
00147 *
00148             SU = ONE - SH12*SH21
00149 *
00150            IF (SU.GT.ZERO) THEN
00151              SFLAG = ZERO
00152              SD1 = SD1/SU
00153              SD2 = SD2/SU
00154              SX1 = SX1*SU
00155            END IF
00156          ELSE
00157 
00158             IF (SQ2.LT.ZERO) THEN
00159 *              GO ZERO-H-D-AND-SX1..
00160                SFLAG = -ONE
00161                SH11 = ZERO
00162                SH12 = ZERO
00163                SH21 = ZERO
00164                SH22 = ZERO
00165 *
00166                SD1 = ZERO
00167                SD2 = ZERO
00168                SX1 = ZERO
00169             ELSE
00170                SFLAG = ONE
00171                SH11 = SP1/SP2
00172                SH22 = SX1/SY1
00173                SU = ONE + SH11*SH22
00174                STEMP = SD2/SU
00175                SD2 = SD1/SU
00176                SD1 = STEMP
00177                SX1 = SY1*SU
00178             END IF
00179          END IF
00180 
00181 *     PROCESURE..SCALE-CHECK
00182          IF (SD1.NE.ZERO) THEN
00183             DO WHILE ((SD1.LE.RGAMSQ) .OR. (SD1.GE.GAMSQ))
00184                IF (SFLAG.EQ.ZERO) THEN
00185                   SH11 = ONE
00186                   SH22 = ONE
00187                   SFLAG = -ONE
00188                ELSE
00189                   SH21 = -ONE
00190                   SH12 = ONE
00191                   SFLAG = -ONE
00192                END IF
00193                IF (SD1.LE.RGAMSQ) THEN
00194                   SD1 = SD1*GAM**2
00195                   SX1 = SX1/GAM
00196                   SH11 = SH11/GAM
00197                   SH12 = SH12/GAM
00198                ELSE
00199                   SD1 = SD1/GAM**2
00200                   SX1 = SX1*GAM
00201                   SH11 = SH11*GAM
00202                   SH12 = SH12*GAM
00203                END IF
00204             ENDDO
00205          END IF
00206   
00207          IF (SD2.NE.ZERO) THEN
00208             DO WHILE ( (ABS(SD2).LE.RGAMSQ) .OR. (ABS(SD2).GE.GAMSQ) )
00209                IF (SFLAG.EQ.ZERO) THEN
00210                   SH11 = ONE
00211                   SH22 = ONE
00212                   SFLAG = -ONE
00213                ELSE
00214                   SH21 = -ONE
00215                   SH12 = ONE
00216                   SFLAG = -ONE
00217                END IF
00218                IF (ABS(SD2).LE.RGAMSQ) THEN
00219                   SD2 = SD2*GAM**2
00220                   SH21 = SH21/GAM
00221                   SH22 = SH22/GAM
00222                ELSE
00223                   SD2 = SD2/GAM**2
00224                   SH21 = SH21*GAM
00225                   SH22 = SH22*GAM
00226                END IF      
00227             END DO
00228          END IF
00229      
00230       END IF
00231 
00232       IF (SFLAG.LT.ZERO) THEN
00233          SPARAM(2) = SH11
00234          SPARAM(3) = SH21
00235          SPARAM(4) = SH12
00236          SPARAM(5) = SH22
00237       ELSE IF (SFLAG.EQ.ZERO) THEN
00238          SPARAM(3) = SH21
00239          SPARAM(4) = SH12 
00240       ELSE
00241          SPARAM(2) = SH11
00242          SPARAM(5) = SH22
00243       END IF
00244 
00245       SPARAM(1) = SFLAG
00246       RETURN
00247       END
00248       
00249      
00250      
00251      
 All Files Functions