LAPACK  3.8.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.
Date
November 2017

Definition at line 92 of file srotmg.f.

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