![[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|
Return to drotmg.f CVS log | Up to [local] / rpl / lapack / blas |
1.1 bertrand 1: SUBROUTINE DROTMG(DD1,DD2,DX1,DY1,DPARAM)
2: * .. Scalar Arguments ..
3: DOUBLE PRECISION DD1,DD2,DX1,DY1
4: * ..
5: * .. Array Arguments ..
6: DOUBLE PRECISION DPARAM(5)
7: * ..
8: *
9: * Purpose
10: * =======
11: *
12: * CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS
13: * THE SECOND COMPONENT OF THE 2-VECTOR (DSQRT(DD1)*DX1,DSQRT(DD2)*
14: * DY2)**T.
15: * WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS..
16: *
17: * DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0
18: *
19: * (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0)
20: * H=( ) ( ) ( ) ( )
21: * (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0).
22: * LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22
23: * RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE
24: * VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.)
25: *
26: * THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE
27: * INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE
28: * OF DD1 AND DD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
29: *
30: *
31: * Arguments
32: * =========
33: *
34: * DD1 (input/output) DOUBLE PRECISION
35: *
36: * DD2 (input/output) DOUBLE PRECISION
37: *
38: * DX1 (input/output) DOUBLE PRECISION
39: *
40: * DY1 (input) DOUBLE PRECISION
41: *
42: * DPARAM (input/output) DOUBLE PRECISION array, dimension 5
43: * DPARAM(1)=DFLAG
44: * DPARAM(2)=DH11
45: * DPARAM(3)=DH21
46: * DPARAM(4)=DH12
47: * DPARAM(5)=DH22
48: *
49: * =====================================================================
50: *
51: * .. Local Scalars ..
52: DOUBLE PRECISION DFLAG,DH11,DH12,DH21,DH22,DP1,DP2,DQ1,DQ2,DTEMP,
53: + DU,GAM,GAMSQ,ONE,RGAMSQ,TWO,ZERO
54: INTEGER IGO
55: * ..
56: * .. Intrinsic Functions ..
57: INTRINSIC DABS
58: * ..
59: * .. Data statements ..
60: *
61: DATA ZERO,ONE,TWO/0.D0,1.D0,2.D0/
62: DATA GAM,GAMSQ,RGAMSQ/4096.D0,16777216.D0,5.9604645D-8/
63: * ..
64:
65: IF (.NOT.DD1.LT.ZERO) GO TO 10
66: * GO ZERO-H-D-AND-DX1..
67: GO TO 60
68: 10 CONTINUE
69: * CASE-DD1-NONNEGATIVE
70: DP2 = DD2*DY1
71: IF (.NOT.DP2.EQ.ZERO) GO TO 20
72: DFLAG = -TWO
73: GO TO 260
74: * REGULAR-CASE..
75: 20 CONTINUE
76: DP1 = DD1*DX1
77: DQ2 = DP2*DY1
78: DQ1 = DP1*DX1
79: *
80: IF (.NOT.DABS(DQ1).GT.DABS(DQ2)) GO TO 40
81: DH21 = -DY1/DX1
82: DH12 = DP2/DP1
83: *
84: DU = ONE - DH12*DH21
85: *
86: IF (.NOT.DU.LE.ZERO) GO TO 30
87: * GO ZERO-H-D-AND-DX1..
88: GO TO 60
89: 30 CONTINUE
90: DFLAG = ZERO
91: DD1 = DD1/DU
92: DD2 = DD2/DU
93: DX1 = DX1*DU
94: * GO SCALE-CHECK..
95: GO TO 100
96: 40 CONTINUE
97: IF (.NOT.DQ2.LT.ZERO) GO TO 50
98: * GO ZERO-H-D-AND-DX1..
99: GO TO 60
100: 50 CONTINUE
101: DFLAG = ONE
102: DH11 = DP1/DP2
103: DH22 = DX1/DY1
104: DU = ONE + DH11*DH22
105: DTEMP = DD2/DU
106: DD2 = DD1/DU
107: DD1 = DTEMP
108: DX1 = DY1*DU
109: * GO SCALE-CHECK
110: GO TO 100
111: * PROCEDURE..ZERO-H-D-AND-DX1..
112: 60 CONTINUE
113: DFLAG = -ONE
114: DH11 = ZERO
115: DH12 = ZERO
116: DH21 = ZERO
117: DH22 = ZERO
118: *
119: DD1 = ZERO
120: DD2 = ZERO
121: DX1 = ZERO
122: * RETURN..
123: GO TO 220
124: * PROCEDURE..FIX-H..
125: 70 CONTINUE
126: IF (.NOT.DFLAG.GE.ZERO) GO TO 90
127: *
128: IF (.NOT.DFLAG.EQ.ZERO) GO TO 80
129: DH11 = ONE
130: DH22 = ONE
131: DFLAG = -ONE
132: GO TO 90
133: 80 CONTINUE
134: DH21 = -ONE
135: DH12 = ONE
136: DFLAG = -ONE
137: 90 CONTINUE
138: GO TO IGO(120,150,180,210)
139: * PROCEDURE..SCALE-CHECK
140: 100 CONTINUE
141: 110 CONTINUE
142: IF (.NOT.DD1.LE.RGAMSQ) GO TO 130
143: IF (DD1.EQ.ZERO) GO TO 160
144: ASSIGN 120 TO IGO
145: * FIX-H..
146: GO TO 70
147: 120 CONTINUE
148: DD1 = DD1*GAM**2
149: DX1 = DX1/GAM
150: DH11 = DH11/GAM
151: DH12 = DH12/GAM
152: GO TO 110
153: 130 CONTINUE
154: 140 CONTINUE
155: IF (.NOT.DD1.GE.GAMSQ) GO TO 160
156: ASSIGN 150 TO IGO
157: * FIX-H..
158: GO TO 70
159: 150 CONTINUE
160: DD1 = DD1/GAM**2
161: DX1 = DX1*GAM
162: DH11 = DH11*GAM
163: DH12 = DH12*GAM
164: GO TO 140
165: 160 CONTINUE
166: 170 CONTINUE
167: IF (.NOT.DABS(DD2).LE.RGAMSQ) GO TO 190
168: IF (DD2.EQ.ZERO) GO TO 220
169: ASSIGN 180 TO IGO
170: * FIX-H..
171: GO TO 70
172: 180 CONTINUE
173: DD2 = DD2*GAM**2
174: DH21 = DH21/GAM
175: DH22 = DH22/GAM
176: GO TO 170
177: 190 CONTINUE
178: 200 CONTINUE
179: IF (.NOT.DABS(DD2).GE.GAMSQ) GO TO 220
180: ASSIGN 210 TO IGO
181: * FIX-H..
182: GO TO 70
183: 210 CONTINUE
184: DD2 = DD2/GAM**2
185: DH21 = DH21*GAM
186: DH22 = DH22*GAM
187: GO TO 200
188: 220 CONTINUE
189: IF (DFLAG) 250,230,240
190: 230 CONTINUE
191: DPARAM(3) = DH21
192: DPARAM(4) = DH12
193: GO TO 260
194: 240 CONTINUE
195: DPARAM(2) = DH11
196: DPARAM(5) = DH22
197: GO TO 260
198: 250 CONTINUE
199: DPARAM(2) = DH11
200: DPARAM(3) = DH21
201: DPARAM(4) = DH12
202: DPARAM(5) = DH22
203: 260 CONTINUE
204: DPARAM(1) = DFLAG
205: RETURN
206: END