LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ 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
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

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: