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*> \ingroup single_blas_level1 87* 88* ===================================================================== 89 SUBROUTINE SROTMG(SD1,SD2,SX1,SY1,SPARAM) 90* 91* -- Reference BLAS level1 routine -- 92* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 93* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 94* 95* .. Scalar Arguments .. 96 REAL SD1,SD2,SX1,SY1 97* .. 98* .. Array Arguments .. 99 REAL SPARAM(5) 100* .. 101* 102* ===================================================================== 103* 104* .. Local Scalars .. 105 REAL GAM,GAMSQ,ONE,RGAMSQ,SFLAG,SH11,SH12,SH21,SH22,SP1,SP2,SQ1, 106 $ SQ2,STEMP,SU,TWO,ZERO 107* .. 108* .. Intrinsic Functions .. 109 INTRINSIC ABS 110* .. 111* .. Data statements .. 112* 113 DATA ZERO,ONE,TWO/0.E0,1.E0,2.E0/ 114 DATA GAM,GAMSQ,RGAMSQ/4096.E0,1.67772E7,5.96046E-8/ 115* .. 116 117 IF (SD1.LT.ZERO) THEN 118* GO ZERO-H-D-AND-SX1.. 119 SFLAG = -ONE 120 SH11 = ZERO 121 SH12 = ZERO 122 SH21 = ZERO 123 SH22 = ZERO 124* 125 SD1 = ZERO 126 SD2 = ZERO 127 SX1 = ZERO 128 ELSE 129* CASE-SD1-NONNEGATIVE 130 SP2 = SD2*SY1 131 IF (SP2.EQ.ZERO) THEN 132 SFLAG = -TWO 133 SPARAM(1) = SFLAG 134 RETURN 135 END IF 136* REGULAR-CASE.. 137 SP1 = SD1*SX1 138 SQ2 = SP2*SY1 139 SQ1 = SP1*SX1 140* 141 IF (ABS(SQ1).GT.ABS(SQ2)) THEN 142 SH21 = -SY1/SX1 143 SH12 = SP2/SP1 144* 145 SU = ONE - SH12*SH21 146* 147 IF (SU.GT.ZERO) THEN 148 SFLAG = ZERO 149 SD1 = SD1/SU 150 SD2 = SD2/SU 151 SX1 = SX1*SU 152 ELSE 153* This code path if here for safety. We do not expect this 154* condition to ever hold except in edge cases with rounding 155* errors. See DOI: 10.1145/355841.355847 156 SFLAG = -ONE 157 SH11 = ZERO 158 SH12 = ZERO 159 SH21 = ZERO 160 SH22 = ZERO 161* 162 SD1 = ZERO 163 SD2 = ZERO 164 SX1 = ZERO 165 END IF 166 ELSE 167 168 IF (SQ2.LT.ZERO) THEN 169* GO ZERO-H-D-AND-SX1.. 170 SFLAG = -ONE 171 SH11 = ZERO 172 SH12 = ZERO 173 SH21 = ZERO 174 SH22 = ZERO 175* 176 SD1 = ZERO 177 SD2 = ZERO 178 SX1 = ZERO 179 ELSE 180 SFLAG = ONE 181 SH11 = SP1/SP2 182 SH22 = SX1/SY1 183 SU = ONE + SH11*SH22 184 STEMP = SD2/SU 185 SD2 = SD1/SU 186 SD1 = STEMP 187 SX1 = SY1*SU 188 END IF 189 END IF 190 191* PROCEDURE..SCALE-CHECK 192 IF (SD1.NE.ZERO) THEN 193 DO WHILE ((SD1.LE.RGAMSQ) .OR. (SD1.GE.GAMSQ)) 194 IF (SFLAG.EQ.ZERO) THEN 195 SH11 = ONE 196 SH22 = ONE 197 SFLAG = -ONE 198 ELSE 199 SH21 = -ONE 200 SH12 = ONE 201 SFLAG = -ONE 202 END IF 203 IF (SD1.LE.RGAMSQ) THEN 204 SD1 = SD1*GAM**2 205 SX1 = SX1/GAM 206 SH11 = SH11/GAM 207 SH12 = SH12/GAM 208 ELSE 209 SD1 = SD1/GAM**2 210 SX1 = SX1*GAM 211 SH11 = SH11*GAM 212 SH12 = SH12*GAM 213 END IF 214 ENDDO 215 END IF 216 217 IF (SD2.NE.ZERO) THEN 218 DO WHILE ( (ABS(SD2).LE.RGAMSQ) .OR. (ABS(SD2).GE.GAMSQ) ) 219 IF (SFLAG.EQ.ZERO) THEN 220 SH11 = ONE 221 SH22 = ONE 222 SFLAG = -ONE 223 ELSE 224 SH21 = -ONE 225 SH12 = ONE 226 SFLAG = -ONE 227 END IF 228 IF (ABS(SD2).LE.RGAMSQ) THEN 229 SD2 = SD2*GAM**2 230 SH21 = SH21/GAM 231 SH22 = SH22/GAM 232 ELSE 233 SD2 = SD2/GAM**2 234 SH21 = SH21*GAM 235 SH22 = SH22*GAM 236 END IF 237 END DO 238 END IF 239 240 END IF 241 242 IF (SFLAG.LT.ZERO) THEN 243 SPARAM(2) = SH11 244 SPARAM(3) = SH21 245 SPARAM(4) = SH12 246 SPARAM(5) = SH22 247 ELSE IF (SFLAG.EQ.ZERO) THEN 248 SPARAM(3) = SH21 249 SPARAM(4) = SH12 250 ELSE 251 SPARAM(2) = SH11 252 SPARAM(5) = SH22 253 END IF 254 255 SPARAM(1) = SFLAG 256 RETURN 257* 258* End of SROTMG 259* 260 END 261