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
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to drotmg.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / lapack / blas