srotmg.f.html
来自「famous linear algebra library (LAPACK) p」· HTML 代码 · 共 231 行
HTML
231 行
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
<html>
<head>
<title>srotmg.f</title>
<meta name="generator" content="emacs 21.3.1; htmlfontify 0.20">
<style type="text/css"><!--
body { background: rgb(255, 255, 255); color: rgb(0, 0, 0); font-style: normal; font-weight: 500; font-stretch: normal; font-family: adobe-courier; font-size: 11pt; text-decoration: none; }
span.default { background: rgb(255, 255, 255); color: rgb(0, 0, 0); font-style: normal; font-weight: 500; font-stretch: normal; font-family: adobe-courier; font-size: 11pt; text-decoration: none; }
span.default a { background: rgb(255, 255, 255); color: rgb(0, 0, 0); font-style: normal; font-weight: 500; font-stretch: normal; font-family: adobe-courier; font-size: 11pt; text-decoration: underline; }
span.comment { color: rgb(178, 34, 34); background: rgb(255, 255, 255); font-style: normal; font-weight: 500; font-stretch: normal; font-family: adobe-courier; font-size: 11pt; text-decoration: none; }
span.comment a { color: rgb(178, 34, 34); background: rgb(255, 255, 255); font-style: normal; font-weight: 500; font-stretch: normal; font-family: adobe-courier; font-size: 11pt; text-decoration: underline; }
--></style>
</head>
<body>
<pre>
SUBROUTINE <a name="SROTMG.1"></a><a href="srotmg.f.html#SROTMG.1">SROTMG</a>(SD1,SD2,SX1,SY1,SPARAM)
<span class="comment">*</span><span class="comment"> .. Scalar Arguments ..
</span> REAL SD1,SD2,SX1,SY1
<span class="comment">*</span><span class="comment"> ..
</span><span class="comment">*</span><span class="comment"> .. Array Arguments ..
</span> REAL SPARAM(5)
<span class="comment">*</span><span class="comment"> ..
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment"> Purpose
</span><span class="comment">*</span><span class="comment"> =======
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment"> CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS
</span><span class="comment">*</span><span class="comment"> THE <a name="SECOND.13"></a><a href="second.f.html#SECOND.1">SECOND</a> COMPONENT OF THE 2-VECTOR (SQRT(SD1)*SX1,SQRT(SD2)*
</span><span class="comment">*</span><span class="comment"> SY2)**T.
</span><span class="comment">*</span><span class="comment"> WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS..
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment"> SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment"> (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0)
</span><span class="comment">*</span><span class="comment"> H=( ) ( ) ( ) ( )
</span><span class="comment">*</span><span class="comment"> (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0).
</span><span class="comment">*</span><span class="comment"> LOCATIONS 2-4 OF SPARAM CONTAIN SH11,SH21,SH12, AND SH22
</span><span class="comment">*</span><span class="comment"> RESPECTIVELY. (VALUES OF 1.E0, -1.E0, OR 0.E0 IMPLIED BY THE
</span><span class="comment">*</span><span class="comment"> VALUE OF SPARAM(1) ARE NOT STORED IN SPARAM.)
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment"> THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE
</span><span class="comment">*</span><span class="comment"> INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE
</span><span class="comment">*</span><span class="comment"> OF SD1 AND SD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment"> Arguments
</span><span class="comment">*</span><span class="comment"> =========
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment"> SD1 (input/output) REAL
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment"> SD2 (input/output) REAL
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment"> SX1 (input/output) REAL
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment"> SY1 (input) REAL
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment"> SPARAM (input/output) REAL array, dimension 5
</span><span class="comment">*</span><span class="comment"> SPARAM(1)=SFLAG
</span><span class="comment">*</span><span class="comment"> SPARAM(2)=SH11
</span><span class="comment">*</span><span class="comment"> SPARAM(3)=SH21
</span><span class="comment">*</span><span class="comment"> SPARAM(4)=SH12
</span><span class="comment">*</span><span class="comment"> SPARAM(5)=SH22
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment"> =====================================================================
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment"> .. Local Scalars ..
</span> REAL GAM,GAMSQ,ONE,RGAMSQ,SFLAG,SH11,SH12,SH21,SH22,SP1,SP2,SQ1,
+ SQ2,STEMP,SU,TWO,ZERO
INTEGER IGO
<span class="comment">*</span><span class="comment"> ..
</span><span class="comment">*</span><span class="comment"> .. Intrinsic Functions ..
</span> INTRINSIC ABS
<span class="comment">*</span><span class="comment"> ..
</span><span class="comment">*</span><span class="comment"> .. Data statements ..
</span><span class="comment">*</span><span class="comment">
</span> DATA ZERO,ONE,TWO/0.E0,1.E0,2.E0/
DATA GAM,GAMSQ,RGAMSQ/4096.E0,1.67772E7,5.96046E-8/
<span class="comment">*</span><span class="comment"> ..
</span>
IF (.NOT.SD1.LT.ZERO) GO TO 10
<span class="comment">*</span><span class="comment"> GO ZERO-H-D-AND-SX1..
</span> GO TO 60
10 CONTINUE
<span class="comment">*</span><span class="comment"> CASE-SD1-NONNEGATIVE
</span> SP2 = SD2*SY1
IF (.NOT.SP2.EQ.ZERO) GO TO 20
SFLAG = -TWO
GO TO 260
<span class="comment">*</span><span class="comment"> REGULAR-CASE..
</span> 20 CONTINUE
SP1 = SD1*SX1
SQ2 = SP2*SY1
SQ1 = SP1*SX1
<span class="comment">*</span><span class="comment">
</span> IF (.NOT.ABS(SQ1).GT.ABS(SQ2)) GO TO 40
SH21 = -SY1/SX1
SH12 = SP2/SP1
<span class="comment">*</span><span class="comment">
</span> SU = ONE - SH12*SH21
<span class="comment">*</span><span class="comment">
</span> IF (.NOT.SU.LE.ZERO) GO TO 30
<span class="comment">*</span><span class="comment"> GO ZERO-H-D-AND-SX1..
</span> GO TO 60
30 CONTINUE
SFLAG = ZERO
SD1 = SD1/SU
SD2 = SD2/SU
SX1 = SX1*SU
<span class="comment">*</span><span class="comment"> GO SCALE-CHECK..
</span> GO TO 100
40 CONTINUE
IF (.NOT.SQ2.LT.ZERO) GO TO 50
<span class="comment">*</span><span class="comment"> GO ZERO-H-D-AND-SX1..
</span> 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
<span class="comment">*</span><span class="comment"> GO SCALE-CHECK
</span> GO TO 100
<span class="comment">*</span><span class="comment"> PROCEDURE..ZERO-H-D-AND-SX1..
</span> 60 CONTINUE
SFLAG = -ONE
SH11 = ZERO
SH12 = ZERO
SH21 = ZERO
SH22 = ZERO
<span class="comment">*</span><span class="comment">
</span> SD1 = ZERO
SD2 = ZERO
SX1 = ZERO
<span class="comment">*</span><span class="comment"> RETURN..
</span> GO TO 220
<span class="comment">*</span><span class="comment"> PROCEDURE..FIX-H..
</span> 70 CONTINUE
IF (.NOT.SFLAG.GE.ZERO) GO TO 90
<span class="comment">*</span><span class="comment">
</span> 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)
<span class="comment">*</span><span class="comment"> PROCEDURE..SCALE-CHECK
</span> 100 CONTINUE
110 CONTINUE
IF (.NOT.SD1.LE.RGAMSQ) GO TO 130
IF (SD1.EQ.ZERO) GO TO 160
ASSIGN 120 TO IGO
<span class="comment">*</span><span class="comment"> FIX-H..
</span> 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
<span class="comment">*</span><span class="comment"> FIX-H..
</span> 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
<span class="comment">*</span><span class="comment"> FIX-H..
</span> 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
<span class="comment">*</span><span class="comment"> FIX-H..
</span> 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
</pre>
</body>
</html>
⌨️ 快捷键说明
复制代码Ctrl + C
搜索代码Ctrl + F
全屏模式F11
增大字号Ctrl + =
减小字号Ctrl + -
显示快捷键?