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