Annotation of rpl/lapack/blas/drotmg.f, revision 1.1
1.1 ! bertrand 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
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to drotmg.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / lapack / blas