|
|
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
|
