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
207