LAPACK  3.10.0
LAPACK: Linear Algebra PACKage
drotmg.f
Go to the documentation of this file.
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 *> \ingroup double_blas_level1
87 *
88 * =====================================================================
89  SUBROUTINE drotmg(DD1,DD2,DX1,DY1,DPARAM)
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  DOUBLE PRECISION DD1,DD2,DX1,DY1
97 * ..
98 * .. Array Arguments ..
99  DOUBLE PRECISION DPARAM(5)
100 * ..
101 *
102 * =====================================================================
103 *
104 * .. Local Scalars ..
105  DOUBLE PRECISION DFLAG,DH11,DH12,DH21,DH22,DP1,DP2,DQ1,DQ2,DTEMP,
106  $ DU,GAM,GAMSQ,ONE,RGAMSQ,TWO,ZERO
107 * ..
108 * .. Intrinsic Functions ..
109  INTRINSIC dabs
110 * ..
111 * .. Data statements ..
112 *
113  DATA zero,one,two/0.d0,1.d0,2.d0/
114  DATA gam,gamsq,rgamsq/4096.d0,16777216.d0,5.9604645d-8/
115 * ..
116 
117  IF (dd1.LT.zero) THEN
118 * GO ZERO-H-D-AND-DX1..
119  dflag = -one
120  dh11 = zero
121  dh12 = zero
122  dh21 = zero
123  dh22 = zero
124 *
125  dd1 = zero
126  dd2 = zero
127  dx1 = zero
128  ELSE
129 * CASE-DD1-NONNEGATIVE
130  dp2 = dd2*dy1
131  IF (dp2.EQ.zero) THEN
132  dflag = -two
133  dparam(1) = dflag
134  RETURN
135  END IF
136 * REGULAR-CASE..
137  dp1 = dd1*dx1
138  dq2 = dp2*dy1
139  dq1 = dp1*dx1
140 *
141  IF (dabs(dq1).GT.dabs(dq2)) THEN
142  dh21 = -dy1/dx1
143  dh12 = dp2/dp1
144 *
145  du = one - dh12*dh21
146 *
147  IF (du.GT.zero) THEN
148  dflag = zero
149  dd1 = dd1/du
150  dd2 = dd2/du
151  dx1 = dx1*du
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  dflag = -one
157  dh11 = zero
158  dh12 = zero
159  dh21 = zero
160  dh22 = zero
161 *
162  dd1 = zero
163  dd2 = zero
164  dx1 = zero
165  END IF
166  ELSE
167 
168  IF (dq2.LT.zero) THEN
169 * GO ZERO-H-D-AND-DX1..
170  dflag = -one
171  dh11 = zero
172  dh12 = zero
173  dh21 = zero
174  dh22 = zero
175 *
176  dd1 = zero
177  dd2 = zero
178  dx1 = zero
179  ELSE
180  dflag = one
181  dh11 = dp1/dp2
182  dh22 = dx1/dy1
183  du = one + dh11*dh22
184  dtemp = dd2/du
185  dd2 = dd1/du
186  dd1 = dtemp
187  dx1 = dy1*du
188  END IF
189  END IF
190 
191 * PROCEDURE..SCALE-CHECK
192  IF (dd1.NE.zero) THEN
193  DO WHILE ((dd1.LE.rgamsq) .OR. (dd1.GE.gamsq))
194  IF (dflag.EQ.zero) THEN
195  dh11 = one
196  dh22 = one
197  dflag = -one
198  ELSE
199  dh21 = -one
200  dh12 = one
201  dflag = -one
202  END IF
203  IF (dd1.LE.rgamsq) THEN
204  dd1 = dd1*gam**2
205  dx1 = dx1/gam
206  dh11 = dh11/gam
207  dh12 = dh12/gam
208  ELSE
209  dd1 = dd1/gam**2
210  dx1 = dx1*gam
211  dh11 = dh11*gam
212  dh12 = dh12*gam
213  END IF
214  ENDDO
215  END IF
216 
217  IF (dd2.NE.zero) THEN
218  DO WHILE ( (dabs(dd2).LE.rgamsq) .OR. (dabs(dd2).GE.gamsq) )
219  IF (dflag.EQ.zero) THEN
220  dh11 = one
221  dh22 = one
222  dflag = -one
223  ELSE
224  dh21 = -one
225  dh12 = one
226  dflag = -one
227  END IF
228  IF (dabs(dd2).LE.rgamsq) THEN
229  dd2 = dd2*gam**2
230  dh21 = dh21/gam
231  dh22 = dh22/gam
232  ELSE
233  dd2 = dd2/gam**2
234  dh21 = dh21*gam
235  dh22 = dh22*gam
236  END IF
237  END DO
238  END IF
239 
240  END IF
241 
242  IF (dflag.LT.zero) THEN
243  dparam(2) = dh11
244  dparam(3) = dh21
245  dparam(4) = dh12
246  dparam(5) = dh22
247  ELSE IF (dflag.EQ.zero) THEN
248  dparam(3) = dh21
249  dparam(4) = dh12
250  ELSE
251  dparam(2) = dh11
252  dparam(5) = dh22
253  END IF
254 
255  dparam(1) = dflag
256  RETURN
257 *
258 * End of DROTMG
259 *
260  END
subroutine drotmg(DD1, DD2, DX1, DY1, DPARAM)
DROTMG
Definition: drotmg.f:90