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
