diff options
Diffstat (limited to 'blas/fortran/srotmg.f')
| -rw-r--r-- | blas/fortran/srotmg.f | 208 |
1 files changed, 208 insertions, 0 deletions
diff --git a/blas/fortran/srotmg.f b/blas/fortran/srotmg.f new file mode 100644 index 000000000..7b3bd4272 --- /dev/null +++ b/blas/fortran/srotmg.f @@ -0,0 +1,208 @@ + 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 |