1*> \brief \b DROTMG 2* 3* =========== DOCUMENTATION =========== 4* 5* Online html documentation available at 6* http://www.netlib.org/lapack/explore-html/ 7* 8* Definition: 9* =========== 10* 11* SUBROUTINE DROTMG(DD1,DD2,DX1,DY1,DPARAM) 12* 13* .. Scalar Arguments .. 14* DOUBLE PRECISION DD1,DD2,DX1,DY1 15* .. 16* .. Array Arguments .. 17* DOUBLE PRECISION DPARAM(5) 18* .. 19* 20* 21*> \par Purpose: 22* ============= 23*> 24*> \verbatim 25*> 26*> CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS 27*> THE SECOND COMPONENT OF THE 2-VECTOR (DSQRT(DD1)*DX1,DSQRT(DD2)*> DY2)**T. 28*> WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. 29*> 30*> DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 31*> 32*> (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) 33*> H=( ) ( ) ( ) ( ) 34*> (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). 35*> LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22 36*> RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE 37*> VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.) 38*> 39*> THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE 40*> INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE 41*> OF DD1 AND DD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. 42*> 43*> \endverbatim 44* 45* Arguments: 46* ========== 47* 48*> \param[in,out] DD1 49*> \verbatim 50*> DD1 is DOUBLE PRECISION 51*> \endverbatim 52*> 53*> \param[in,out] DD2 54*> \verbatim 55*> DD2 is DOUBLE PRECISION 56*> \endverbatim 57*> 58*> \param[in,out] DX1 59*> \verbatim 60*> DX1 is DOUBLE PRECISION 61*> \endverbatim 62*> 63*> \param[in] DY1 64*> \verbatim 65*> DY1 is DOUBLE PRECISION 66*> \endverbatim 67*> 68*> \param[in,out] DPARAM 69*> \verbatim 70*> DPARAM is DOUBLE PRECISION array, dimension 5 71*> DPARAM(1)=DFLAG 72*> DPARAM(2)=DH11 73*> DPARAM(3)=DH21 74*> DPARAM(4)=DH12 75*> DPARAM(5)=DH22 76*> \endverbatim 77* 78* Authors: 79* ======== 80* 81*> \author Univ. of Tennessee 82*> \author Univ. of California Berkeley 83*> \author Univ. of Colorado Denver 84*> \author NAG Ltd. 85* 86*> \date November 2011 87* 88*> \ingroup double_blas_level1 89* 90* ===================================================================== 91 SUBROUTINE DROTMG(DD1,DD2,DX1,DY1,DPARAM) 92* 93* -- Reference BLAS level1 routine (version 3.4.0) -- 94* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 95* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 96* November 2011 97* 98* .. Scalar Arguments .. 99 DOUBLE PRECISION DD1,DD2,DX1,DY1 100* .. 101* .. Array Arguments .. 102 DOUBLE PRECISION DPARAM(5) 103* .. 104* 105* ===================================================================== 106* 107* .. Local Scalars .. 108 DOUBLE PRECISION DFLAG,DH11,DH12,DH21,DH22,DP1,DP2,DQ1,DQ2,DTEMP, 109 $ DU,GAM,GAMSQ,ONE,RGAMSQ,TWO,ZERO 110* .. 111* .. Intrinsic Functions .. 112 INTRINSIC DABS 113* .. 114* .. Data statements .. 115* 116 DATA ZERO,ONE,TWO/0.D0,1.D0,2.D0/ 117 DATA GAM,GAMSQ,RGAMSQ/4096.D0,16777216.D0,5.9604645D-8/ 118* .. 119 120 IF (DD1.LT.ZERO) THEN 121* GO ZERO-H-D-AND-DX1.. 122 DFLAG = -ONE 123 DH11 = ZERO 124 DH12 = ZERO 125 DH21 = ZERO 126 DH22 = ZERO 127* 128 DD1 = ZERO 129 DD2 = ZERO 130 DX1 = ZERO 131 ELSE 132* CASE-DD1-NONNEGATIVE 133 DP2 = DD2*DY1 134 IF (DP2.EQ.ZERO) THEN 135 DFLAG = -TWO 136 DPARAM(1) = DFLAG 137 RETURN 138 END IF 139* REGULAR-CASE.. 140 DP1 = DD1*DX1 141 DQ2 = DP2*DY1 142 DQ1 = DP1*DX1 143* 144 IF (DABS(DQ1).GT.DABS(DQ2)) THEN 145 DH21 = -DY1/DX1 146 DH12 = DP2/DP1 147* 148 DU = ONE - DH12*DH21 149* 150 IF (DU.GT.ZERO) THEN 151 DFLAG = ZERO 152 DD1 = DD1/DU 153 DD2 = DD2/DU 154 DX1 = DX1*DU 155 END IF 156 ELSE 157 158 IF (DQ2.LT.ZERO) THEN 159* GO ZERO-H-D-AND-DX1.. 160 DFLAG = -ONE 161 DH11 = ZERO 162 DH12 = ZERO 163 DH21 = ZERO 164 DH22 = ZERO 165* 166 DD1 = ZERO 167 DD2 = ZERO 168 DX1 = ZERO 169 ELSE 170 DFLAG = ONE 171 DH11 = DP1/DP2 172 DH22 = DX1/DY1 173 DU = ONE + DH11*DH22 174 DTEMP = DD2/DU 175 DD2 = DD1/DU 176 DD1 = DTEMP 177 DX1 = DY1*DU 178 END IF 179 END IF 180 181* PROCEDURE..SCALE-CHECK 182 IF (DD1.NE.ZERO) THEN 183 DO WHILE ((DD1.LE.RGAMSQ) .OR. (DD1.GE.GAMSQ)) 184 IF (DFLAG.EQ.ZERO) THEN 185 DH11 = ONE 186 DH22 = ONE 187 DFLAG = -ONE 188 ELSE 189 DH21 = -ONE 190 DH12 = ONE 191 DFLAG = -ONE 192 END IF 193 IF (DD1.LE.RGAMSQ) THEN 194 DD1 = DD1*GAM**2 195 DX1 = DX1/GAM 196 DH11 = DH11/GAM 197 DH12 = DH12/GAM 198 ELSE 199 DD1 = DD1/GAM**2 200 DX1 = DX1*GAM 201 DH11 = DH11*GAM 202 DH12 = DH12*GAM 203 END IF 204 ENDDO 205 END IF 206 207 IF (DD2.NE.ZERO) THEN 208 DO WHILE ( (DABS(DD2).LE.RGAMSQ) .OR. (DABS(DD2).GE.GAMSQ) ) 209 IF (DFLAG.EQ.ZERO) THEN 210 DH11 = ONE 211 DH22 = ONE 212 DFLAG = -ONE 213 ELSE 214 DH21 = -ONE 215 DH12 = ONE 216 DFLAG = -ONE 217 END IF 218 IF (DABS(DD2).LE.RGAMSQ) THEN 219 DD2 = DD2*GAM**2 220 DH21 = DH21/GAM 221 DH22 = DH22/GAM 222 ELSE 223 DD2 = DD2/GAM**2 224 DH21 = DH21*GAM 225 DH22 = DH22*GAM 226 END IF 227 END DO 228 END IF 229 230 END IF 231 232 IF (DFLAG.LT.ZERO) THEN 233 DPARAM(2) = DH11 234 DPARAM(3) = DH21 235 DPARAM(4) = DH12 236 DPARAM(5) = DH22 237 ELSE IF (DFLAG.EQ.ZERO) THEN 238 DPARAM(3) = DH21 239 DPARAM(4) = DH12 240 ELSE 241 DPARAM(2) = DH11 242 DPARAM(5) = DH22 243 END IF 244 245 DPARAM(1) = DFLAG 246 RETURN 247 END 248 249 250 251 252