209 lines
4.7 KiB
FortranFixed
209 lines
4.7 KiB
FortranFixed
|
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
|