1      SUBROUTINE SROTMGF (SD1,SD2,SX1,SY1,SPARAM)
2C
3C     CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS
4C     THE SECOND COMPONENT OF THE 2-VECTOR  (SQRT(SD1)*SX1,SQRT(SD2)*
5C     SY2)**T.
6C     WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS..
7C
8C     SFLAG=-1.E0     SFLAG=0.E0        SFLAG=1.E0     SFLAG=-2.E0
9C
10C       (SH11  SH12)    (1.E0  SH12)    (SH11  1.E0)    (1.E0  0.E0)
11C     H=(          )    (          )    (          )    (          )
12C       (SH21  SH22),   (SH21  1.E0),   (-1.E0 SH22),   (0.E0  1.E0).
13C     LOCATIONS 2-4 OF SPARAM CONTAIN SH11,SH21,SH12, AND SH22
14C     RESPECTIVELY. (VALUES OF 1.E0, -1.E0, OR 0.E0 IMPLIED BY THE
15C     VALUE OF SPARAM(1) ARE NOT STORED IN SPARAM.)
16C
17C     THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE
18C     INEXACT.  THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE
19C     OF SD1 AND SD2.  ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
20C
21      DIMENSION SPARAM(5)
22C
23      DATA ZERO,ONE,TWO /0.E0,1.E0,2.E0/
24      DATA GAM,GAMSQ,RGAMSQ/4096.E0,1.67772E7,5.96046E-8/
25      IF(.NOT. SD1 .LT. ZERO) GO TO 10
26C       GO ZERO-H-D-AND-SX1..
27          GO TO 60
28   10 CONTINUE
29C     CASE-SD1-NONNEGATIVE
30      SP2=SD2*SY1
31      IF(.NOT. SP2 .EQ. ZERO) GO TO 20
32          SFLAG=-TWO
33          GO TO 260
34C     REGULAR-CASE..
35   20 CONTINUE
36      SP1=SD1*SX1
37      SQ2=SP2*SY1
38      SQ1=SP1*SX1
39C
40      IF(.NOT. ABS(SQ1) .GT. ABS(SQ2)) GO TO 40
41          SH21=-SY1/SX1
42          SH12=SP2/SP1
43C
44          SU=ONE-SH12*SH21
45C
46          IF(.NOT. SU .LE. ZERO) GO TO 30
47C         GO ZERO-H-D-AND-SX1..
48               GO TO 60
49   30     CONTINUE
50               SFLAG=ZERO
51               SD1=SD1/SU
52               SD2=SD2/SU
53               SX1=SX1*SU
54C         GO SCALE-CHECK..
55               GO TO 100
56   40 CONTINUE
57          IF(.NOT. SQ2 .LT. ZERO) GO TO 50
58C         GO ZERO-H-D-AND-SX1..
59               GO TO 60
60   50     CONTINUE
61               SFLAG=ONE
62               SH11=SP1/SP2
63               SH22=SX1/SY1
64               SU=ONE+SH11*SH22
65               STEMP=SD2/SU
66               SD2=SD1/SU
67               SD1=STEMP
68               SX1=SY1*SU
69C         GO SCALE-CHECK
70               GO TO 100
71C     PROCEDURE..ZERO-H-D-AND-SX1..
72   60 CONTINUE
73          SFLAG=-ONE
74          SH11=ZERO
75          SH12=ZERO
76          SH21=ZERO
77          SH22=ZERO
78C
79          SD1=ZERO
80          SD2=ZERO
81          SX1=ZERO
82C         RETURN..
83          GO TO 220
84C     PROCEDURE..FIX-H..
85   70 CONTINUE
86      IF(.NOT. SFLAG .GE. ZERO) GO TO 90
87C
88          IF(.NOT. SFLAG .EQ. ZERO) GO TO 80
89          SH11=ONE
90          SH22=ONE
91          SFLAG=-ONE
92          GO TO 90
93   80     CONTINUE
94          SH21=-ONE
95          SH12=ONE
96          SFLAG=-ONE
97   90 CONTINUE
98      GO TO IGO,(120,150,180,210)
99C     PROCEDURE..SCALE-CHECK
100  100 CONTINUE
101  110     CONTINUE
102          IF(.NOT. SD1 .LE. RGAMSQ) GO TO 130
103               IF(SD1 .EQ. ZERO) GO TO 160
104               ASSIGN 120 TO IGO
105C              FIX-H..
106               GO TO 70
107  120          CONTINUE
108               SD1=SD1*GAM**2
109               SX1=SX1/GAM
110               SH11=SH11/GAM
111               SH12=SH12/GAM
112          GO TO 110
113  130 CONTINUE
114  140     CONTINUE
115          IF(.NOT. SD1 .GE. GAMSQ) GO TO 160
116               ASSIGN 150 TO IGO
117C              FIX-H..
118               GO TO 70
119  150          CONTINUE
120               SD1=SD1/GAM**2
121               SX1=SX1*GAM
122               SH11=SH11*GAM
123               SH12=SH12*GAM
124          GO TO 140
125  160 CONTINUE
126  170     CONTINUE
127          IF(.NOT. ABS(SD2) .LE. RGAMSQ) GO TO 190
128               IF(SD2 .EQ. ZERO) GO TO 220
129               ASSIGN 180 TO IGO
130C              FIX-H..
131               GO TO 70
132  180          CONTINUE
133               SD2=SD2*GAM**2
134               SH21=SH21/GAM
135               SH22=SH22/GAM
136          GO TO 170
137  190 CONTINUE
138  200     CONTINUE
139          IF(.NOT. ABS(SD2) .GE. GAMSQ) GO TO 220
140               ASSIGN 210 TO IGO
141C              FIX-H..
142               GO TO 70
143  210          CONTINUE
144               SD2=SD2/GAM**2
145               SH21=SH21*GAM
146               SH22=SH22*GAM
147          GO TO 200
148  220 CONTINUE
149          IF(SFLAG)250,230,240
150  230     CONTINUE
151               SPARAM(3)=SH21
152               SPARAM(4)=SH12
153               GO TO 260
154  240     CONTINUE
155               SPARAM(2)=SH11
156               SPARAM(5)=SH22
157               GO TO 260
158  250     CONTINUE
159               SPARAM(2)=SH11
160               SPARAM(3)=SH21
161               SPARAM(4)=SH12
162               SPARAM(5)=SH22
163  260 CONTINUE
164          SPARAM(1)=SFLAG
165          RETURN
166      END
167