LAPACK  3.5.0
LAPACK: Linear Algebra PACKage
 All Classes Files Functions Variables Typedefs Macros
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[in,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 2011
87 *
88 *> \ingroup double_blas_level1
89 *
90 * =====================================================================
91  SUBROUTINE drotmg(DD1,DD2,DX1,DY1,DPARAM)
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  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