| SUBROUTINE DROTMG(DD1,DD2,DX1,DY1,DPARAM) |
| * .. Scalar Arguments .. |
| DOUBLE PRECISION DD1,DD2,DX1,DY1 |
| * .. |
| * .. Array Arguments .. |
| DOUBLE PRECISION DPARAM(5) |
| * .. |
| * |
| * Purpose |
| * ======= |
| * |
| * CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS |
| * THE SECOND COMPONENT OF THE 2-VECTOR (DSQRT(DD1)*DX1,DSQRT(DD2)* |
| * DY2)**T. |
| * WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. |
| * |
| * DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 |
| * |
| * (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) |
| * H=( ) ( ) ( ) ( ) |
| * (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). |
| * LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22 |
| * RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE |
| * VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.) |
| * |
| * THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE |
| * INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE |
| * OF DD1 AND DD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. |
| * |
| * |
| * Arguments |
| * ========= |
| * |
| * DD1 (input/output) DOUBLE PRECISION |
| * |
| * DD2 (input/output) DOUBLE PRECISION |
| * |
| * DX1 (input/output) DOUBLE PRECISION |
| * |
| * DY1 (input) DOUBLE PRECISION |
| * |
| * DPARAM (input/output) DOUBLE PRECISION array, dimension 5 |
| * DPARAM(1)=DFLAG |
| * DPARAM(2)=DH11 |
| * DPARAM(3)=DH21 |
| * DPARAM(4)=DH12 |
| * DPARAM(5)=DH22 |
| * |
| * ===================================================================== |
| * |
| * .. Local Scalars .. |
| DOUBLE PRECISION DFLAG,DH11,DH12,DH21,DH22,DP1,DP2,DQ1,DQ2,DTEMP, |
| + DU,GAM,GAMSQ,ONE,RGAMSQ,TWO,ZERO |
| INTEGER IGO |
| * .. |
| * .. Intrinsic Functions .. |
| INTRINSIC DABS |
| * .. |
| * .. Data statements .. |
| * |
| DATA ZERO,ONE,TWO/0.D0,1.D0,2.D0/ |
| DATA GAM,GAMSQ,RGAMSQ/4096.D0,16777216.D0,5.9604645D-8/ |
| * .. |
| |
| IF (.NOT.DD1.LT.ZERO) GO TO 10 |
| * GO ZERO-H-D-AND-DX1.. |
| GO TO 60 |
| 10 CONTINUE |
| * CASE-DD1-NONNEGATIVE |
| DP2 = DD2*DY1 |
| IF (.NOT.DP2.EQ.ZERO) GO TO 20 |
| DFLAG = -TWO |
| GO TO 260 |
| * REGULAR-CASE.. |
| 20 CONTINUE |
| DP1 = DD1*DX1 |
| DQ2 = DP2*DY1 |
| DQ1 = DP1*DX1 |
| * |
| IF (.NOT.DABS(DQ1).GT.DABS(DQ2)) GO TO 40 |
| DH21 = -DY1/DX1 |
| DH12 = DP2/DP1 |
| * |
| DU = ONE - DH12*DH21 |
| * |
| IF (.NOT.DU.LE.ZERO) GO TO 30 |
| * GO ZERO-H-D-AND-DX1.. |
| GO TO 60 |
| 30 CONTINUE |
| DFLAG = ZERO |
| DD1 = DD1/DU |
| DD2 = DD2/DU |
| DX1 = DX1*DU |
| * GO SCALE-CHECK.. |
| GO TO 100 |
| 40 CONTINUE |
| IF (.NOT.DQ2.LT.ZERO) GO TO 50 |
| * GO ZERO-H-D-AND-DX1.. |
| GO TO 60 |
| 50 CONTINUE |
| DFLAG = ONE |
| DH11 = DP1/DP2 |
| DH22 = DX1/DY1 |
| DU = ONE + DH11*DH22 |
| DTEMP = DD2/DU |
| DD2 = DD1/DU |
| DD1 = DTEMP |
| DX1 = DY1*DU |
| * GO SCALE-CHECK |
| GO TO 100 |
| * PROCEDURE..ZERO-H-D-AND-DX1.. |
| 60 CONTINUE |
| DFLAG = -ONE |
| DH11 = ZERO |
| DH12 = ZERO |
| DH21 = ZERO |
| DH22 = ZERO |
| * |
| DD1 = ZERO |
| DD2 = ZERO |
| DX1 = ZERO |
| * RETURN.. |
| GO TO 220 |
| * PROCEDURE..FIX-H.. |
| 70 CONTINUE |
| IF (.NOT.DFLAG.GE.ZERO) GO TO 90 |
| * |
| IF (.NOT.DFLAG.EQ.ZERO) GO TO 80 |
| DH11 = ONE |
| DH22 = ONE |
| DFLAG = -ONE |
| GO TO 90 |
| 80 CONTINUE |
| DH21 = -ONE |
| DH12 = ONE |
| DFLAG = -ONE |
| 90 CONTINUE |
| GO TO IGO(120,150,180,210) |
| * PROCEDURE..SCALE-CHECK |
| 100 CONTINUE |
| 110 CONTINUE |
| IF (.NOT.DD1.LE.RGAMSQ) GO TO 130 |
| IF (DD1.EQ.ZERO) GO TO 160 |
| ASSIGN 120 TO IGO |
| * FIX-H.. |
| GO TO 70 |
| 120 CONTINUE |
| DD1 = DD1*GAM**2 |
| DX1 = DX1/GAM |
| DH11 = DH11/GAM |
| DH12 = DH12/GAM |
| GO TO 110 |
| 130 CONTINUE |
| 140 CONTINUE |
| IF (.NOT.DD1.GE.GAMSQ) GO TO 160 |
| ASSIGN 150 TO IGO |
| * FIX-H.. |
| GO TO 70 |
| 150 CONTINUE |
| DD1 = DD1/GAM**2 |
| DX1 = DX1*GAM |
| DH11 = DH11*GAM |
| DH12 = DH12*GAM |
| GO TO 140 |
| 160 CONTINUE |
| 170 CONTINUE |
| IF (.NOT.DABS(DD2).LE.RGAMSQ) GO TO 190 |
| IF (DD2.EQ.ZERO) GO TO 220 |
| ASSIGN 180 TO IGO |
| * FIX-H.. |
| GO TO 70 |
| 180 CONTINUE |
| DD2 = DD2*GAM**2 |
| DH21 = DH21/GAM |
| DH22 = DH22/GAM |
| GO TO 170 |
| 190 CONTINUE |
| 200 CONTINUE |
| IF (.NOT.DABS(DD2).GE.GAMSQ) GO TO 220 |
| ASSIGN 210 TO IGO |
| * FIX-H.. |
| GO TO 70 |
| 210 CONTINUE |
| DD2 = DD2/GAM**2 |
| DH21 = DH21*GAM |
| DH22 = DH22*GAM |
| GO TO 200 |
| 220 CONTINUE |
| IF (DFLAG) 250,230,240 |
| 230 CONTINUE |
| DPARAM(3) = DH21 |
| DPARAM(4) = DH12 |
| GO TO 260 |
| 240 CONTINUE |
| DPARAM(2) = DH11 |
| DPARAM(5) = DH22 |
| GO TO 260 |
| 250 CONTINUE |
| DPARAM(2) = DH11 |
| DPARAM(3) = DH21 |
| DPARAM(4) = DH12 |
| DPARAM(5) = DH22 |
| 260 CONTINUE |
| DPARAM(1) = DFLAG |
| RETURN |
| END |
