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*> \date November 2017
87*
88*> \ingroup single_blas_level1
89*
90*  =====================================================================
91      SUBROUTINE SROTMG(SD1,SD2,SX1,SY1,SPARAM)
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
247      END
248
249
250
251
252