source: branches/2789_MathNetNumerics-Exploration/HeuristicLab.Algorithms.DataAnalysis.Experimental/sbart/srotmg.f @ 17014

      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