1      SUBROUTINE SROTMG(SD1,SD2,SX1,SY1,SPARAM)
2*     .. Scalar Arguments ..
3      REAL SD1,SD2,SX1,SY1
4*     ..
5*     .. Array Arguments ..
6      REAL SPARAM(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  (SQRT(SD1)*SX1,SQRT(SD2)*
14*     SY2)**T.
15*     WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS..
16*
17*     SFLAG=-1.E0     SFLAG=0.E0        SFLAG=1.E0     SFLAG=-2.E0
18*
19*       (SH11  SH12)    (1.E0  SH12)    (SH11  1.E0)    (1.E0  0.E0)
20*     H=(          )    (          )    (          )    (          )
21*       (SH21  SH22),   (SH21  1.E0),   (-1.E0 SH22),   (0.E0  1.E0).
22*     LOCATIONS 2-4 OF SPARAM CONTAIN SH11,SH21,SH12, AND SH22
23*     RESPECTIVELY. (VALUES OF 1.E0, -1.E0, OR 0.E0 IMPLIED BY THE
24*     VALUE OF SPARAM(1) ARE NOT STORED IN SPARAM.)
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 SD1 AND SD2.  ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
29*
30*
31*  Arguments
32*  =========
33*
34*
35*  SD1    (input/output) REAL
36*
37*  SD2    (input/output) REAL
38*
39*  SX1    (input/output) REAL
40*
41*  SY1    (input) REAL
42*
43*
44*  SPARAM (input/output)  REAL array, dimension 5
45*     SPARAM(1)=SFLAG
46*     SPARAM(2)=SH11
47*     SPARAM(3)=SH21
48*     SPARAM(4)=SH12
49*     SPARAM(5)=SH22
50*
51*  =====================================================================
52*
53*     .. Local Scalars ..
54      REAL GAM,GAMSQ,ONE,RGAMSQ,SFLAG,SH11,SH12,SH21,SH22,SP1,SP2,SQ1,
55     +     SQ2,STEMP,SU,TWO,ZERO
56      INTEGER IGO
57*     ..
58*     .. Intrinsic Functions ..
59      INTRINSIC ABS
60*     ..
61*     .. Data statements ..
62*
63      DATA ZERO,ONE,TWO/0.E0,1.E0,2.E0/
64      DATA GAM,GAMSQ,RGAMSQ/4096.E0,1.67772E7,5.96046E-8/
65*     ..
66
67      IF (.NOT.SD1.LT.ZERO) GO TO 10
68*       GO ZERO-H-D-AND-SX1..
69      GO TO 60
70   10 CONTINUE
71*     CASE-SD1-NONNEGATIVE
72      SP2 = SD2*SY1
73      IF (.NOT.SP2.EQ.ZERO) GO TO 20
74      SFLAG = -TWO
75      GO TO 260
76*     REGULAR-CASE..
77   20 CONTINUE
78      SP1 = SD1*SX1
79      SQ2 = SP2*SY1
80      SQ1 = SP1*SX1
81*
82      IF (.NOT.ABS(SQ1).GT.ABS(SQ2)) GO TO 40
83      SH21 = -SY1/SX1
84      SH12 = SP2/SP1
85*
86      SU = ONE - SH12*SH21
87*
88      IF (.NOT.SU.LE.ZERO) GO TO 30
89*         GO ZERO-H-D-AND-SX1..
90      GO TO 60
91   30 CONTINUE
92      SFLAG = ZERO
93      SD1 = SD1/SU
94      SD2 = SD2/SU
95      SX1 = SX1*SU
96*         GO SCALE-CHECK..
97      GO TO 100
98   40 CONTINUE
99      IF (.NOT.SQ2.LT.ZERO) GO TO 50
100*         GO ZERO-H-D-AND-SX1..
101      GO TO 60
102   50 CONTINUE
103      SFLAG = ONE
104      SH11 = SP1/SP2
105      SH22 = SX1/SY1
106      SU = ONE + SH11*SH22
107      STEMP = SD2/SU
108      SD2 = SD1/SU
109      SD1 = STEMP
110      SX1 = SY1*SU
111*         GO SCALE-CHECK
112      GO TO 100
113*     PROCEDURE..ZERO-H-D-AND-SX1..
114   60 CONTINUE
115      SFLAG = -ONE
116      SH11 = ZERO
117      SH12 = ZERO
118      SH21 = ZERO
119      SH22 = ZERO
120*
121      SD1 = ZERO
122      SD2 = ZERO
123      SX1 = ZERO
124*         RETURN..
125      GO TO 220
126*     PROCEDURE..FIX-H..
127   70 CONTINUE
128      IF (.NOT.SFLAG.GE.ZERO) GO TO 90
129*
130      IF (.NOT.SFLAG.EQ.ZERO) GO TO 80
131      SH11 = ONE
132      SH22 = ONE
133      SFLAG = -ONE
134      GO TO 90
135   80 CONTINUE
136      SH21 = -ONE
137      SH12 = ONE
138      SFLAG = -ONE
139   90 CONTINUE
140      GO TO IGO(120,150,180,210)
141*     PROCEDURE..SCALE-CHECK
142  100 CONTINUE
143  110 CONTINUE
144      IF (.NOT.SD1.LE.RGAMSQ) GO TO 130
145      IF (SD1.EQ.ZERO) GO TO 160
146      ASSIGN 120 TO IGO
147*              FIX-H..
148      GO TO 70
149  120 CONTINUE
150      SD1 = SD1*GAM**2
151      SX1 = SX1/GAM
152      SH11 = SH11/GAM
153      SH12 = SH12/GAM
154      GO TO 110
155  130 CONTINUE
156  140 CONTINUE
157      IF (.NOT.SD1.GE.GAMSQ) GO TO 160
158      ASSIGN 150 TO IGO
159*              FIX-H..
160      GO TO 70
161  150 CONTINUE
162      SD1 = SD1/GAM**2
163      SX1 = SX1*GAM
164      SH11 = SH11*GAM
165      SH12 = SH12*GAM
166      GO TO 140
167  160 CONTINUE
168  170 CONTINUE
169      IF (.NOT.ABS(SD2).LE.RGAMSQ) GO TO 190
170      IF (SD2.EQ.ZERO) GO TO 220
171      ASSIGN 180 TO IGO
172*              FIX-H..
173      GO TO 70
174  180 CONTINUE
175      SD2 = SD2*GAM**2
176      SH21 = SH21/GAM
177      SH22 = SH22/GAM
178      GO TO 170
179  190 CONTINUE
180  200 CONTINUE
181      IF (.NOT.ABS(SD2).GE.GAMSQ) GO TO 220
182      ASSIGN 210 TO IGO
183*              FIX-H..
184      GO TO 70
185  210 CONTINUE
186      SD2 = SD2/GAM**2
187      SH21 = SH21*GAM
188      SH22 = SH22*GAM
189      GO TO 200
190  220 CONTINUE
191      IF (SFLAG) 250,230,240
192  230 CONTINUE
193      SPARAM(3) = SH21
194      SPARAM(4) = SH12
195      GO TO 260
196  240 CONTINUE
197      SPARAM(2) = SH11
198      SPARAM(5) = SH22
199      GO TO 260
200  250 CONTINUE
201      SPARAM(2) = SH11
202      SPARAM(3) = SH21
203      SPARAM(4) = SH12
204      SPARAM(5) = SH22
205  260 CONTINUE
206      SPARAM(1) = SFLAG
207      RETURN
208      END
209