1*> \brief \b DROTMG
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 DROTMG(DD1,DD2,DX1,DY1,DPARAM)
12*
13*       .. Scalar Arguments ..
14*       DOUBLE PRECISION DD1,DD2,DX1,DY1
15*       ..
16*       .. Array Arguments ..
17*       DOUBLE PRECISION DPARAM(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  (DSQRT(DD1)*DX1,DSQRT(DD2)*>    DY2)**T.
28*>    WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS..
29*>
30*>    DFLAG=-1.D0     DFLAG=0.D0        DFLAG=1.D0     DFLAG=-2.D0
31*>
32*>      (DH11  DH12)    (1.D0  DH12)    (DH11  1.D0)    (1.D0  0.D0)
33*>    H=(          )    (          )    (          )    (          )
34*>      (DH21  DH22),   (DH21  1.D0),   (-1.D0 DH22),   (0.D0  1.D0).
35*>    LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22
36*>    RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE
37*>    VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.)
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 DD1 AND DD2.  ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
42*>
43*> \endverbatim
44*
45*  Arguments:
46*  ==========
47*
48*> \param[in,out] DD1
49*> \verbatim
50*>          DD1 is DOUBLE PRECISION
51*> \endverbatim
52*>
53*> \param[in,out] DD2
54*> \verbatim
55*>          DD2 is DOUBLE PRECISION
56*> \endverbatim
57*>
58*> \param[in,out] DX1
59*> \verbatim
60*>          DX1 is DOUBLE PRECISION
61*> \endverbatim
62*>
63*> \param[in] DY1
64*> \verbatim
65*>          DY1 is DOUBLE PRECISION
66*> \endverbatim
67*>
68*> \param[out] DPARAM
69*> \verbatim
70*>          DPARAM is DOUBLE PRECISION array, dimension (5)
71*>     DPARAM(1)=DFLAG
72*>     DPARAM(2)=DH11
73*>     DPARAM(3)=DH21
74*>     DPARAM(4)=DH12
75*>     DPARAM(5)=DH22
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 double_blas_level1
89*
90*  =====================================================================
91      SUBROUTINE DROTMG(DD1,DD2,DX1,DY1,DPARAM)
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      DOUBLE PRECISION DD1,DD2,DX1,DY1
100*     ..
101*     .. Array Arguments ..
102      DOUBLE PRECISION DPARAM(5)
103*     ..
104*
105*  =====================================================================
106*
107*     .. Local Scalars ..
108      DOUBLE PRECISION DFLAG,DH11,DH12,DH21,DH22,DP1,DP2,DQ1,DQ2,DTEMP,
109     $                 DU,GAM,GAMSQ,ONE,RGAMSQ,TWO,ZERO
110*     ..
111*     .. Intrinsic Functions ..
112      INTRINSIC DABS
113*     ..
114*     .. Data statements ..
115*
116      DATA ZERO,ONE,TWO/0.D0,1.D0,2.D0/
117      DATA GAM,GAMSQ,RGAMSQ/4096.D0,16777216.D0,5.9604645D-8/
118*     ..
119
120      IF (DD1.LT.ZERO) THEN
121*        GO ZERO-H-D-AND-DX1..
122         DFLAG = -ONE
123         DH11 = ZERO
124         DH12 = ZERO
125         DH21 = ZERO
126         DH22 = ZERO
127*
128         DD1 = ZERO
129         DD2 = ZERO
130         DX1 = ZERO
131      ELSE
132*        CASE-DD1-NONNEGATIVE
133         DP2 = DD2*DY1
134         IF (DP2.EQ.ZERO) THEN
135            DFLAG = -TWO
136            DPARAM(1) = DFLAG
137            RETURN
138         END IF
139*        REGULAR-CASE..
140         DP1 = DD1*DX1
141         DQ2 = DP2*DY1
142         DQ1 = DP1*DX1
143*
144         IF (DABS(DQ1).GT.DABS(DQ2)) THEN
145            DH21 = -DY1/DX1
146            DH12 = DP2/DP1
147*
148            DU = ONE - DH12*DH21
149*
150           IF (DU.GT.ZERO) THEN
151             DFLAG = ZERO
152             DD1 = DD1/DU
153             DD2 = DD2/DU
154             DX1 = DX1*DU
155           END IF
156         ELSE
157
158            IF (DQ2.LT.ZERO) THEN
159*              GO ZERO-H-D-AND-DX1..
160               DFLAG = -ONE
161               DH11 = ZERO
162               DH12 = ZERO
163               DH21 = ZERO
164               DH22 = ZERO
165*
166               DD1 = ZERO
167               DD2 = ZERO
168               DX1 = ZERO
169            ELSE
170               DFLAG = ONE
171               DH11 = DP1/DP2
172               DH22 = DX1/DY1
173               DU = ONE + DH11*DH22
174               DTEMP = DD2/DU
175               DD2 = DD1/DU
176               DD1 = DTEMP
177               DX1 = DY1*DU
178            END IF
179         END IF
180
181*     PROCEDURE..SCALE-CHECK
182         IF (DD1.NE.ZERO) THEN
183            DO WHILE ((DD1.LE.RGAMSQ) .OR. (DD1.GE.GAMSQ))
184               IF (DFLAG.EQ.ZERO) THEN
185                  DH11 = ONE
186                  DH22 = ONE
187                  DFLAG = -ONE
188               ELSE
189                  DH21 = -ONE
190                  DH12 = ONE
191                  DFLAG = -ONE
192               END IF
193               IF (DD1.LE.RGAMSQ) THEN
194                  DD1 = DD1*GAM**2
195                  DX1 = DX1/GAM
196                  DH11 = DH11/GAM
197                  DH12 = DH12/GAM
198               ELSE
199                  DD1 = DD1/GAM**2
200                  DX1 = DX1*GAM
201                  DH11 = DH11*GAM
202                  DH12 = DH12*GAM
203               END IF
204            ENDDO
205         END IF
206
207         IF (DD2.NE.ZERO) THEN
208            DO WHILE ( (DABS(DD2).LE.RGAMSQ) .OR. (DABS(DD2).GE.GAMSQ) )
209               IF (DFLAG.EQ.ZERO) THEN
210                  DH11 = ONE
211                  DH22 = ONE
212                  DFLAG = -ONE
213               ELSE
214                  DH21 = -ONE
215                  DH12 = ONE
216                  DFLAG = -ONE
217               END IF
218               IF (DABS(DD2).LE.RGAMSQ) THEN
219                  DD2 = DD2*GAM**2
220                  DH21 = DH21/GAM
221                  DH22 = DH22/GAM
222               ELSE
223                  DD2 = DD2/GAM**2
224                  DH21 = DH21*GAM
225                  DH22 = DH22*GAM
226               END IF
227            END DO
228         END IF
229
230      END IF
231
232      IF (DFLAG.LT.ZERO) THEN
233         DPARAM(2) = DH11
234         DPARAM(3) = DH21
235         DPARAM(4) = DH12
236         DPARAM(5) = DH22
237      ELSE IF (DFLAG.EQ.ZERO) THEN
238         DPARAM(3) = DH21
239         DPARAM(4) = DH12
240      ELSE
241         DPARAM(2) = DH11
242         DPARAM(5) = DH22
243      END IF
244
245      DPARAM(1) = DFLAG
246      RETURN
247      END
248
249
250
251
252