![]() ![]() | ![]() |
Mise à jour de lapack vers la version 3.2.2.
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: 20 CONTINUE 75: * REGULAR-CASE.. 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: 60 CONTINUE 112: * PROCEDURE..ZERO-H-D-AND-DX1.. 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: 70 CONTINUE 125: * PROCEDURE..FIX-H.. 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 (150,180,210) IGO 139: GO TO 120 140: 100 CONTINUE 141: * PROCEDURE..SCALE-CHECK 142: 110 CONTINUE 143: IF (.NOT.DD1.LE.RGAMSQ) GO TO 130 144: IF (DD1.EQ.ZERO) GO TO 160 145: IGO = 0 146: * FIX-H.. 147: GO TO 70 148: 120 CONTINUE 149: DD1 = DD1*GAM**2 150: DX1 = DX1/GAM 151: DH11 = DH11/GAM 152: DH12 = DH12/GAM 153: GO TO 110 154: 130 CONTINUE 155: 140 CONTINUE 156: IF (.NOT.DD1.GE.GAMSQ) GO TO 160 157: IGO = 1 158: * FIX-H.. 159: GO TO 70 160: 150 CONTINUE 161: DD1 = DD1/GAM**2 162: DX1 = DX1*GAM 163: DH11 = DH11*GAM 164: DH12 = DH12*GAM 165: GO TO 140 166: 160 CONTINUE 167: 170 CONTINUE 168: IF (.NOT.DABS(DD2).LE.RGAMSQ) GO TO 190 169: IF (DD2.EQ.ZERO) GO TO 220 170: IGO = 2 171: * FIX-H.. 172: GO TO 70 173: 180 CONTINUE 174: DD2 = DD2*GAM**2 175: DH21 = DH21/GAM 176: DH22 = DH22/GAM 177: GO TO 170 178: 190 CONTINUE 179: 200 CONTINUE 180: IF (.NOT.DABS(DD2).GE.GAMSQ) GO TO 220 181: IGO = 3 182: * FIX-H.. 183: GO TO 70 184: 210 CONTINUE 185: DD2 = DD2/GAM**2 186: DH21 = DH21*GAM 187: DH22 = DH22*GAM 188: GO TO 200 189: 220 CONTINUE 190: IF (DFLAG.LT.ZERO) THEN 191: GO TO 250 192: ELSE IF (DFLAG.EQ.ZERO) THEN 193: GO TO 230 194: ELSE 195: GO TO 240 196: END IF 197: 230 CONTINUE 198: DPARAM(3) = DH21 199: DPARAM(4) = DH12 200: GO TO 260 201: 240 CONTINUE 202: DPARAM(2) = DH11 203: DPARAM(5) = DH22 204: GO TO 260 205: 250 CONTINUE 206: DPARAM(2) = DH11 207: DPARAM(3) = DH21 208: DPARAM(4) = DH12 209: DPARAM(5) = DH22 210: 260 CONTINUE 211: DPARAM(1) = DFLAG 212: RETURN 213: END