LAPACK 3.12.0 LAPACK: Linear Algebra PACKage
Searching...
No Matches

## ◆ srotmg()

 subroutine srotmg ( real sd1, real sd2, real sx1, real sy1, real, dimension(5) sparam )

SROTMG

Purpose:
```    CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS
THE SECOND COMPONENT OF THE 2-VECTOR  (SQRT(SD1)*SX1,SQRT(SD2)*>    SY2)**T.
WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS..

SFLAG=-1.E0     SFLAG=0.E0        SFLAG=1.E0     SFLAG=-2.E0

(SH11  SH12)    (1.E0  SH12)    (SH11  1.E0)    (1.E0  0.E0)
H=(          )    (          )    (          )    (          )
(SH21  SH22),   (SH21  1.E0),   (-1.E0 SH22),   (0.E0  1.E0).
LOCATIONS 2-4 OF SPARAM CONTAIN SH11,SH21,SH12, AND SH22
RESPECTIVELY. (VALUES OF 1.E0, -1.E0, OR 0.E0 IMPLIED BY THE
VALUE OF SPARAM(1) ARE NOT STORED IN SPARAM.)

THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE
INEXACT.  THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE
OF SD1 AND SD2.  ALL ACTUAL SCALING OF DATA IS DONE USING GAM.```
Parameters
 [in,out] SD1 ` SD1 is REAL` [in,out] SD2 ` SD2 is REAL` [in,out] SX1 ` SX1 is REAL` [in] SY1 ` SY1 is REAL` [out] SPARAM ``` SPARAM is REAL array, dimension (5) SPARAM(1)=SFLAG SPARAM(2)=SH11 SPARAM(3)=SH21 SPARAM(4)=SH12 SPARAM(5)=SH22```

Definition at line 89 of file srotmg.f.

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*
Here is the caller graph for this function: