drotmg.f

          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