1*> \brief \b SROTMG 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 SROTMG(SD1,SD2,SX1,SY1,SPARAM) 12* 13* .. Scalar Arguments .. 14* REAL SD1,SD2,SX1,SY1 15* .. 16* .. Array Arguments .. 17* REAL SPARAM(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 (SQRT(SD1)*SX1,SQRT(SD2)*> SY2)**T. 28*> WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS.. 29*> 30*> SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 31*> 32*> (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) 33*> H=( ) ( ) ( ) ( ) 34*> (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). 35*> LOCATIONS 2-4 OF SPARAM CONTAIN SH11,SH21,SH12, AND SH22 36*> RESPECTIVELY. (VALUES OF 1.E0, -1.E0, OR 0.E0 IMPLIED BY THE 37*> VALUE OF SPARAM(1) ARE NOT STORED IN SPARAM.) 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 SD1 AND SD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. 42*> 43*> \endverbatim 44* 45* Arguments: 46* ========== 47* 48*> \param[in,out] SD1 49*> \verbatim 50*> SD1 is REAL 51*> \endverbatim 52*> 53*> \param[in,out] SD2 54*> \verbatim 55*> SD2 is REAL 56*> \endverbatim 57*> 58*> \param[in,out] SX1 59*> \verbatim 60*> SX1 is REAL 61*> \endverbatim 62*> 63*> \param[in] SY1 64*> \verbatim 65*> SY1 is REAL 66*> \endverbatim 67*> 68*> \param[out] SPARAM 69*> \verbatim 70*> SPARAM is REAL array, dimension (5) 71*> SPARAM(1)=SFLAG 72*> SPARAM(2)=SH11 73*> SPARAM(3)=SH21 74*> SPARAM(4)=SH12 75*> SPARAM(5)=SH22 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 2017 87* 88*> \ingroup single_blas_level1 89* 90* ===================================================================== 91 SUBROUTINE SROTMG(SD1,SD2,SX1,SY1,SPARAM) 92* 93* -- Reference BLAS level1 routine (version 3.8.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 2017 97* 98* .. Scalar Arguments .. 99 REAL SD1,SD2,SX1,SY1 100* .. 101* .. Array Arguments .. 102 REAL SPARAM(5) 103* .. 104* 105* ===================================================================== 106* 107* .. Local Scalars .. 108 REAL GAM,GAMSQ,ONE,RGAMSQ,SFLAG,SH11,SH12,SH21,SH22,SP1,SP2,SQ1, 109 $ SQ2,STEMP,SU,TWO,ZERO 110* .. 111* .. Intrinsic Functions .. 112 INTRINSIC ABS 113* .. 114* .. Data statements .. 115* 116 DATA ZERO,ONE,TWO/0.E0,1.E0,2.E0/ 117 DATA GAM,GAMSQ,RGAMSQ/4096.E0,1.67772E7,5.96046E-8/ 118* .. 119 120 IF (SD1.LT.ZERO) THEN 121* GO ZERO-H-D-AND-SX1.. 122 SFLAG = -ONE 123 SH11 = ZERO 124 SH12 = ZERO 125 SH21 = ZERO 126 SH22 = ZERO 127* 128 SD1 = ZERO 129 SD2 = ZERO 130 SX1 = ZERO 131 ELSE 132* CASE-SD1-NONNEGATIVE 133 SP2 = SD2*SY1 134 IF (SP2.EQ.ZERO) THEN 135 SFLAG = -TWO 136 SPARAM(1) = SFLAG 137 RETURN 138 END IF 139* REGULAR-CASE.. 140 SP1 = SD1*SX1 141 SQ2 = SP2*SY1 142 SQ1 = SP1*SX1 143* 144 IF (ABS(SQ1).GT.ABS(SQ2)) THEN 145 SH21 = -SY1/SX1 146 SH12 = SP2/SP1 147* 148 SU = ONE - SH12*SH21 149* 150 IF (SU.GT.ZERO) THEN 151 SFLAG = ZERO 152 SD1 = SD1/SU 153 SD2 = SD2/SU 154 SX1 = SX1*SU 155 END IF 156 ELSE 157 158 IF (SQ2.LT.ZERO) THEN 159* GO ZERO-H-D-AND-SX1.. 160 SFLAG = -ONE 161 SH11 = ZERO 162 SH12 = ZERO 163 SH21 = ZERO 164 SH22 = ZERO 165* 166 SD1 = ZERO 167 SD2 = ZERO 168 SX1 = ZERO 169 ELSE 170 SFLAG = ONE 171 SH11 = SP1/SP2 172 SH22 = SX1/SY1 173 SU = ONE + SH11*SH22 174 STEMP = SD2/SU 175 SD2 = SD1/SU 176 SD1 = STEMP 177 SX1 = SY1*SU 178 END IF 179 END IF 180 181* PROCESURE..SCALE-CHECK 182 IF (SD1.NE.ZERO) THEN 183 DO WHILE ((SD1.LE.RGAMSQ) .OR. (SD1.GE.GAMSQ)) 184 IF (SFLAG.EQ.ZERO) THEN 185 SH11 = ONE 186 SH22 = ONE 187 SFLAG = -ONE 188 ELSE 189 SH21 = -ONE 190 SH12 = ONE 191 SFLAG = -ONE 192 END IF 193 IF (SD1.LE.RGAMSQ) THEN 194 SD1 = SD1*GAM**2 195 SX1 = SX1/GAM 196 SH11 = SH11/GAM 197 SH12 = SH12/GAM 198 ELSE 199 SD1 = SD1/GAM**2 200 SX1 = SX1*GAM 201 SH11 = SH11*GAM 202 SH12 = SH12*GAM 203 END IF 204 ENDDO 205 END IF 206 207 IF (SD2.NE.ZERO) THEN 208 DO WHILE ( (ABS(SD2).LE.RGAMSQ) .OR. (ABS(SD2).GE.GAMSQ) ) 209 IF (SFLAG.EQ.ZERO) THEN 210 SH11 = ONE 211 SH22 = ONE 212 SFLAG = -ONE 213 ELSE 214 SH21 = -ONE 215 SH12 = ONE 216 SFLAG = -ONE 217 END IF 218 IF (ABS(SD2).LE.RGAMSQ) THEN 219 SD2 = SD2*GAM**2 220 SH21 = SH21/GAM 221 SH22 = SH22/GAM 222 ELSE 223 SD2 = SD2/GAM**2 224 SH21 = SH21*GAM 225 SH22 = SH22*GAM 226 END IF 227 END DO 228 END IF 229 230 END IF 231 232 IF (SFLAG.LT.ZERO) THEN 233 SPARAM(2) = SH11 234 SPARAM(3) = SH21 235 SPARAM(4) = SH12 236 SPARAM(5) = SH22 237 ELSE IF (SFLAG.EQ.ZERO) THEN 238 SPARAM(3) = SH21 239 SPARAM(4) = SH12 240 ELSE 241 SPARAM(2) = SH11 242 SPARAM(5) = SH22 243 END IF 244 245 SPARAM(1) = SFLAG 246 RETURN 247 END 248 249 250 251 252