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