srotmg.f

          SUBROUTINE SROTMG(SD1,SD2,SX1,SY1,SPARAM)
    *     .. Scalar Arguments ..
          REAL SD1,SD2,SX1,SY1
    *     ..
    *     .. Array Arguments ..
          REAL SPARAM(5)
    *     ..
    *
    *  Purpose
    *  =======
    *
    *     CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS
    *     THE SECOND COMPONENT OF THE 2-VECTOR  (SQRT(SD1)*SX1,SQRT(SD2)*
    *     SY2)**T.
    *     WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS..
    *
    *     SFLAG=-1.E0     SFLAG=0.E0        SFLAG=1.E0     SFLAG=-2.E0
    *
    *       (SH11  SH12)    (1.E0  SH12)    (SH11  1.E0)    (1.E0  0.E0)
    *     H=(          )    (          )    (          )    (          )
    *       (SH21  SH22),   (SH21  1.E0),   (-1.E0 SH22),   (0.E0  1.E0).
    *     LOCATIONS 2-4 OF SPARAM CONTAIN SH11,SH21,SH12, AND SH22
    *     RESPECTIVELY. (VALUES OF 1.E0, -1.E0, OR 0.E0 IMPLIED BY THE
    *     VALUE OF SPARAM(1) ARE NOT STORED IN SPARAM.)
    *
    *     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 SD1 AND SD2.  ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
    *
    *
    *  Arguments
    *  =========
    *
    *
    *  SD1    (input/output) REAL
    *
    *  SD2    (input/output) REAL
    *
    *  SX1    (input/output) REAL
    *
    *  SY1    (input) REAL
    *
    *
    *  SPARAM (input/output)  REAL array, dimension 5
    *     SPARAM(1)=SFLAG
    *     SPARAM(2)=SH11
    *     SPARAM(3)=SH21
    *     SPARAM(4)=SH12
    *     SPARAM(5)=SH22
    *
    *  =====================================================================
    *
    *     .. Local Scalars ..
          REAL GAM,GAMSQ,ONE,RGAMSQ,SFLAG,SH11,SH12,SH21,SH22,SP1,SP2,SQ1,
         +     SQ2,STEMP,SU,TWO,ZERO
          INTEGER IGO
    *     ..
    *     .. Intrinsic Functions ..
          INTRINSIC ABS
    *     ..
    *     .. Data statements ..
    *
          DATA ZERO,ONE,TWO/0.E0,1.E0,2.E0/
          DATA GAM,GAMSQ,RGAMSQ/4096.E0,1.67772E7,5.96046E-8/
    *     ..

          IF (.NOT.SD1.LT.ZERO) GO TO 10
    *       GO ZERO-H-D-AND-SX1..
          GO TO 60
       10 CONTINUE
    *     CASE-SD1-NONNEGATIVE
          SP2 = SD2*SY1
          IF (.NOT.SP2.EQ.ZERO) GO TO 20
          SFLAG = -TWO
          GO TO 260
    *     REGULAR-CASE..
       20 CONTINUE
          SP1 = SD1*SX1
          SQ2 = SP2*SY1
          SQ1 = SP1*SX1
    *
          IF (.NOT.ABS(SQ1).GT.ABS(SQ2)) GO TO 40
          SH21 = -SY1/SX1
          SH12 = SP2/SP1
    *
          SU = ONE - SH12*SH21
    *
          IF (.NOT.SU.LE.ZERO) GO TO 30
    *         GO ZERO-H-D-AND-SX1..
          GO TO 60
       30 CONTINUE
          SFLAG = ZERO
          SD1 = SD1/SU
          SD2 = SD2/SU
          SX1 = SX1*SU
    *         GO SCALE-CHECK..
          GO TO 100
       40 CONTINUE
          IF (.NOT.SQ2.LT.ZERO) GO TO 50
    *         GO ZERO-H-D-AND-SX1..
          GO TO 60
       50 CONTINUE
          SFLAG = ONE
          SH11 = SP1/SP2
          SH22 = SX1/SY1
          SU = ONE + SH11*SH22
          STEMP = SD2/SU
          SD2 = SD1/SU
          SD1 = STEMP
          SX1 = SY1*SU
    *         GO SCALE-CHECK
          GO TO 100
    *     PROCEDURE..ZERO-H-D-AND-SX1..
       60 CONTINUE
          SFLAG = -ONE
          SH11 = ZERO
          SH12 = ZERO
          SH21 = ZERO
          SH22 = ZERO
    *
          SD1 = ZERO
          SD2 = ZERO
          SX1 = ZERO
    *         RETURN..
          GO TO 220
    *     PROCEDURE..FIX-H..
       70 CONTINUE
          IF (.NOT.SFLAG.GE.ZERO) GO TO 90
    *
          IF (.NOT.SFLAG.EQ.ZERO) GO TO 80
          SH11 = ONE
          SH22 = ONE
          SFLAG = -ONE
          GO TO 90
       80 CONTINUE
          SH21 = -ONE
          SH12 = ONE
          SFLAG = -ONE
       90 CONTINUE
          GO TO IGO(120,150,180,210)
    *     PROCEDURE..SCALE-CHECK
      100 CONTINUE
      110 CONTINUE
          IF (.NOT.SD1.LE.RGAMSQ) GO TO 130
          IF (SD1.EQ.ZERO) GO TO 160
          ASSIGN 120 TO IGO
    *              FIX-H..
          GO TO 70
      120 CONTINUE
          SD1 = SD1*GAM**2
          SX1 = SX1/GAM
          SH11 = SH11/GAM
          SH12 = SH12/GAM
          GO TO 110
      130 CONTINUE
      140 CONTINUE
          IF (.NOT.SD1.GE.GAMSQ) GO TO 160
          ASSIGN 150 TO IGO
    *              FIX-H..
          GO TO 70
      150 CONTINUE
          SD1 = SD1/GAM**2
          SX1 = SX1*GAM
          SH11 = SH11*GAM
          SH12 = SH12*GAM
          GO TO 140
      160 CONTINUE
      170 CONTINUE
          IF (.NOT.ABS(SD2).LE.RGAMSQ) GO TO 190
          IF (SD2.EQ.ZERO) GO TO 220
          ASSIGN 180 TO IGO
    *              FIX-H..
          GO TO 70
      180 CONTINUE
          SD2 = SD2*GAM**2
          SH21 = SH21/GAM
          SH22 = SH22/GAM
          GO TO 170
      190 CONTINUE
      200 CONTINUE
          IF (.NOT.ABS(SD2).GE.GAMSQ) GO TO 220
          ASSIGN 210 TO IGO
    *              FIX-H..
          GO TO 70
      210 CONTINUE
          SD2 = SD2/GAM**2
          SH21 = SH21*GAM
          SH22 = SH22*GAM
          GO TO 200
      220 CONTINUE
          IF (SFLAG) 250,230,240
      230 CONTINUE
          SPARAM(3) = SH21
          SPARAM(4) = SH12
          GO TO 260
      240 CONTINUE
          SPARAM(2) = SH11
          SPARAM(5) = SH22
          GO TO 260
      250 CONTINUE
          SPARAM(2) = SH11
          SPARAM(3) = SH21
          SPARAM(4) = SH12
          SPARAM(5) = SH22
      260 CONTINUE
          SPARAM(1) = SFLAG
          RETURN
          END