LAPACK  3.10.1
LAPACK: Linear Algebra PACKage
srotmg.f
Go to the documentation of this file.
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
subroutine srotmg(SD1, SD2, SX1, SY1, SPARAM)
SROTMG
Definition: srotmg.f:90