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:
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