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