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 * ..
57 * .. Intrinsic Functions ..
58 INTRINSIC ABS
59 * ..
60 * .. Data statements ..
61 *
62 DATA ZERO,ONE,TWO/0.E0,1.E0,2.E0/
63 DATA GAM,GAMSQ,RGAMSQ/4096.E0,1.67772E7,5.96046E-8/
64 * ..
65
66 IF (SD1.LT.ZERO) THEN
67 * GO ZERO-H-D-AND-SX1..
68 SFLAG = -ONE
69 SH11 = ZERO
70 SH12 = ZERO
71 SH21 = ZERO
72 SH22 = ZERO
73 *
74 SD1 = ZERO
75 SD2 = ZERO
76 SX1 = ZERO
77 ELSE
78 * CASE-SD1-NONNEGATIVE
79 SP2 = SD2*SY1
80 IF (SP2.EQ.ZERO) THEN
81 SFLAG = -TWO
82 SPARAM(1) = SFLAG
83 RETURN
84 END IF
85 * REGULAR-CASE..
86 SP1 = SD1*SX1
87 SQ2 = SP2*SY1
88 SQ1 = SP1*SX1
89 *
90 IF (ABS(SQ1).GT.ABS(SQ2)) THEN
91 SH21 = -SY1/SX1
92 SH12 = SP2/SP1
93 *
94 SU = ONE - SH12*SH21
95 *
96 IF (SU.GT.ZERO) THEN
97 SFLAG = ZERO
98 SD1 = SD1/SU
99 SD2 = SD2/SU
100 SX1 = SX1*SU
101 END IF
102 ELSE
103
104 IF (SQ2.LT.ZERO) THEN
105 * GO ZERO-H-D-AND-SX1..
106 SFLAG = -ONE
107 SH11 = ZERO
108 SH12 = ZERO
109 SH21 = ZERO
110 SH22 = ZERO
111 *
112 SD1 = ZERO
113 SD2 = ZERO
114 SX1 = ZERO
115 ELSE
116 SFLAG = ONE
117 SH11 = SP1/SP2
118 SH22 = SX1/SY1
119 SU = ONE + SH11*SH22
120 STEMP = SD2/SU
121 SD2 = SD1/SU
122 SD1 = STEMP
123 SX1 = SY1*SU
124 END IF
125 END IF
126
127 * PROCESURE..SCALE-CHECK
128 IF (SD1.NE.ZERO) THEN
129 DO WHILE ((SD1.LE.RGAMSQ) .OR. (SD1.GE.GAMSQ))
130 IF (SFLAG.EQ.ZERO) THEN
131 SH11 = ONE
132 SH22 = ONE
133 SFLAG = -ONE
134 ELSE
135 SH21 = -ONE
136 SH12 = ONE
137 SFLAG = -ONE
138 END IF
139 IF (SD1.LE.RGAMSQ) THEN
140 SD1 = SD1*GAM**2
141 SX1 = SX1/GAM
142 SH11 = SH11/GAM
143 SH12 = SH12/GAM
144 ELSE
145 SD1 = SD1/GAM**2
146 SX1 = SX1*GAM
147 SH11 = SH11*GAM
148 SH12 = SH12*GAM
149 END IF
150 ENDDO
151 END IF
152
153 IF (SD2.NE.ZERO) THEN
154 DO WHILE ( (ABS(SD2).LE.RGAMSQ) .OR. (ABS(SD2).GE.GAMSQ) )
155 IF (SFLAG.EQ.ZERO) THEN
156 SH11 = ONE
157 SH22 = ONE
158 SFLAG = -ONE
159 ELSE
160 SH21 = -ONE
161 SH12 = ONE
162 SFLAG = -ONE
163 END IF
164 IF (ABS(SD2).LE.RGAMSQ) THEN
165 SD2 = SD2*GAM**2
166 SH21 = SH21/GAM
167 SH22 = SH22/GAM
168 ELSE
169 SD2 = SD2/GAM**2
170 SH21 = SH21*GAM
171 SH22 = SH22*GAM
172 END IF
173 END DO
174 END IF
175
176 END IF
177
178 IF (SFLAG.LT.ZERO) THEN
179 SPARAM(2) = SH11
180 SPARAM(3) = SH21
181 SPARAM(4) = SH12
182 SPARAM(5) = SH22
183 ELSE IF (SFLAG.EQ.ZERO) THEN
184 SPARAM(3) = SH21
185 SPARAM(4) = SH12
186 ELSE
187 SPARAM(2) = SH11
188 SPARAM(5) = SH22
189 END IF
190
191 260 CONTINUE
192 SPARAM(1) = SFLAG
193 RETURN
194 END
195
196
197
198
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 * ..
57 * .. Intrinsic Functions ..
58 INTRINSIC ABS
59 * ..
60 * .. Data statements ..
61 *
62 DATA ZERO,ONE,TWO/0.E0,1.E0,2.E0/
63 DATA GAM,GAMSQ,RGAMSQ/4096.E0,1.67772E7,5.96046E-8/
64 * ..
65
66 IF (SD1.LT.ZERO) THEN
67 * GO ZERO-H-D-AND-SX1..
68 SFLAG = -ONE
69 SH11 = ZERO
70 SH12 = ZERO
71 SH21 = ZERO
72 SH22 = ZERO
73 *
74 SD1 = ZERO
75 SD2 = ZERO
76 SX1 = ZERO
77 ELSE
78 * CASE-SD1-NONNEGATIVE
79 SP2 = SD2*SY1
80 IF (SP2.EQ.ZERO) THEN
81 SFLAG = -TWO
82 SPARAM(1) = SFLAG
83 RETURN
84 END IF
85 * REGULAR-CASE..
86 SP1 = SD1*SX1
87 SQ2 = SP2*SY1
88 SQ1 = SP1*SX1
89 *
90 IF (ABS(SQ1).GT.ABS(SQ2)) THEN
91 SH21 = -SY1/SX1
92 SH12 = SP2/SP1
93 *
94 SU = ONE - SH12*SH21
95 *
96 IF (SU.GT.ZERO) THEN
97 SFLAG = ZERO
98 SD1 = SD1/SU
99 SD2 = SD2/SU
100 SX1 = SX1*SU
101 END IF
102 ELSE
103
104 IF (SQ2.LT.ZERO) THEN
105 * GO ZERO-H-D-AND-SX1..
106 SFLAG = -ONE
107 SH11 = ZERO
108 SH12 = ZERO
109 SH21 = ZERO
110 SH22 = ZERO
111 *
112 SD1 = ZERO
113 SD2 = ZERO
114 SX1 = ZERO
115 ELSE
116 SFLAG = ONE
117 SH11 = SP1/SP2
118 SH22 = SX1/SY1
119 SU = ONE + SH11*SH22
120 STEMP = SD2/SU
121 SD2 = SD1/SU
122 SD1 = STEMP
123 SX1 = SY1*SU
124 END IF
125 END IF
126
127 * PROCESURE..SCALE-CHECK
128 IF (SD1.NE.ZERO) THEN
129 DO WHILE ((SD1.LE.RGAMSQ) .OR. (SD1.GE.GAMSQ))
130 IF (SFLAG.EQ.ZERO) THEN
131 SH11 = ONE
132 SH22 = ONE
133 SFLAG = -ONE
134 ELSE
135 SH21 = -ONE
136 SH12 = ONE
137 SFLAG = -ONE
138 END IF
139 IF (SD1.LE.RGAMSQ) THEN
140 SD1 = SD1*GAM**2
141 SX1 = SX1/GAM
142 SH11 = SH11/GAM
143 SH12 = SH12/GAM
144 ELSE
145 SD1 = SD1/GAM**2
146 SX1 = SX1*GAM
147 SH11 = SH11*GAM
148 SH12 = SH12*GAM
149 END IF
150 ENDDO
151 END IF
152
153 IF (SD2.NE.ZERO) THEN
154 DO WHILE ( (ABS(SD2).LE.RGAMSQ) .OR. (ABS(SD2).GE.GAMSQ) )
155 IF (SFLAG.EQ.ZERO) THEN
156 SH11 = ONE
157 SH22 = ONE
158 SFLAG = -ONE
159 ELSE
160 SH21 = -ONE
161 SH12 = ONE
162 SFLAG = -ONE
163 END IF
164 IF (ABS(SD2).LE.RGAMSQ) THEN
165 SD2 = SD2*GAM**2
166 SH21 = SH21/GAM
167 SH22 = SH22/GAM
168 ELSE
169 SD2 = SD2/GAM**2
170 SH21 = SH21*GAM
171 SH22 = SH22*GAM
172 END IF
173 END DO
174 END IF
175
176 END IF
177
178 IF (SFLAG.LT.ZERO) THEN
179 SPARAM(2) = SH11
180 SPARAM(3) = SH21
181 SPARAM(4) = SH12
182 SPARAM(5) = SH22
183 ELSE IF (SFLAG.EQ.ZERO) THEN
184 SPARAM(3) = SH21
185 SPARAM(4) = SH12
186 ELSE
187 SPARAM(2) = SH11
188 SPARAM(5) = SH22
189 END IF
190
191 260 CONTINUE
192 SPARAM(1) = SFLAG
193 RETURN
194 END
195
196
197
198