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
261