LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
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[in,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 *> \date November 2011
87 *
88 *> \ingroup single_blas_level1
89 *
90 * =====================================================================
91  SUBROUTINE srotmg(SD1,SD2,SX1,SY1,SPARAM)
92 *
93 * -- Reference BLAS level1 routine (version 3.4.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 2011
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
247  END
248 
249 
250 
251