drotmg.f.html
来自「famous linear algebra library (LAPACK) p」· HTML 代码 · 共 229 行
HTML
229 行
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
<html>
<head>
<title>drotmg.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="DROTMG.1"></a><a href="drotmg.f.html#DROTMG.1">DROTMG</a>(DD1,DD2,DX1,DY1,DPARAM)
<span class="comment">*</span><span class="comment"> .. Scalar Arguments ..
</span> DOUBLE PRECISION DD1,DD2,DX1,DY1
<span class="comment">*</span><span class="comment"> ..
</span><span class="comment">*</span><span class="comment"> .. Array Arguments ..
</span> DOUBLE PRECISION DPARAM(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 (DSQRT(DD1)*DX1,DSQRT(DD2)*
</span><span class="comment">*</span><span class="comment"> DY2)**T.
</span><span class="comment">*</span><span class="comment"> WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS..
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment"> DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment"> (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0)
</span><span class="comment">*</span><span class="comment"> H=( ) ( ) ( ) ( )
</span><span class="comment">*</span><span class="comment"> (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0).
</span><span class="comment">*</span><span class="comment"> LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22
</span><span class="comment">*</span><span class="comment"> RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE
</span><span class="comment">*</span><span class="comment"> VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.)
</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 DD1 AND DD2. 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"> DD1 (input/output) DOUBLE PRECISION
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment"> DD2 (input/output) DOUBLE PRECISION
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment"> DX1 (input/output) DOUBLE PRECISION
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment"> DY1 (input) DOUBLE PRECISION
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment"> DPARAM (input/output) DOUBLE PRECISION array, dimension 5
</span><span class="comment">*</span><span class="comment"> DPARAM(1)=DFLAG
</span><span class="comment">*</span><span class="comment"> DPARAM(2)=DH11
</span><span class="comment">*</span><span class="comment"> DPARAM(3)=DH21
</span><span class="comment">*</span><span class="comment"> DPARAM(4)=DH12
</span><span class="comment">*</span><span class="comment"> DPARAM(5)=DH22
</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> DOUBLE PRECISION DFLAG,DH11,DH12,DH21,DH22,DP1,DP2,DQ1,DQ2,DTEMP,
+ DU,GAM,GAMSQ,ONE,RGAMSQ,TWO,ZERO
INTEGER IGO
<span class="comment">*</span><span class="comment"> ..
</span><span class="comment">*</span><span class="comment"> .. Intrinsic Functions ..
</span> INTRINSIC DABS
<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.D0,1.D0,2.D0/
DATA GAM,GAMSQ,RGAMSQ/4096.D0,16777216.D0,5.9604645D-8/
<span class="comment">*</span><span class="comment"> ..
</span>
IF (.NOT.DD1.LT.ZERO) GO TO 10
<span class="comment">*</span><span class="comment"> GO ZERO-H-D-AND-DX1..
</span> GO TO 60
10 CONTINUE
<span class="comment">*</span><span class="comment"> CASE-DD1-NONNEGATIVE
</span> DP2 = DD2*DY1
IF (.NOT.DP2.EQ.ZERO) GO TO 20
DFLAG = -TWO
GO TO 260
<span class="comment">*</span><span class="comment"> REGULAR-CASE..
</span> 20 CONTINUE
DP1 = DD1*DX1
DQ2 = DP2*DY1
DQ1 = DP1*DX1
<span class="comment">*</span><span class="comment">
</span> IF (.NOT.DABS(DQ1).GT.DABS(DQ2)) GO TO 40
DH21 = -DY1/DX1
DH12 = DP2/DP1
<span class="comment">*</span><span class="comment">
</span> DU = ONE - DH12*DH21
<span class="comment">*</span><span class="comment">
</span> IF (.NOT.DU.LE.ZERO) GO TO 30
<span class="comment">*</span><span class="comment"> GO ZERO-H-D-AND-DX1..
</span> GO TO 60
30 CONTINUE
DFLAG = ZERO
DD1 = DD1/DU
DD2 = DD2/DU
DX1 = DX1*DU
<span class="comment">*</span><span class="comment"> GO SCALE-CHECK..
</span> GO TO 100
40 CONTINUE
IF (.NOT.DQ2.LT.ZERO) GO TO 50
<span class="comment">*</span><span class="comment"> GO ZERO-H-D-AND-DX1..
</span> GO TO 60
50 CONTINUE
DFLAG = ONE
DH11 = DP1/DP2
DH22 = DX1/DY1
DU = ONE + DH11*DH22
DTEMP = DD2/DU
DD2 = DD1/DU
DD1 = DTEMP
DX1 = DY1*DU
<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-DX1..
</span> 60 CONTINUE
DFLAG = -ONE
DH11 = ZERO
DH12 = ZERO
DH21 = ZERO
DH22 = ZERO
<span class="comment">*</span><span class="comment">
</span> DD1 = ZERO
DD2 = ZERO
DX1 = 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.DFLAG.GE.ZERO) GO TO 90
<span class="comment">*</span><span class="comment">
</span> IF (.NOT.DFLAG.EQ.ZERO) GO TO 80
DH11 = ONE
DH22 = ONE
DFLAG = -ONE
GO TO 90
80 CONTINUE
DH21 = -ONE
DH12 = ONE
DFLAG = -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.DD1.LE.RGAMSQ) GO TO 130
IF (DD1.EQ.ZERO) GO TO 160
ASSIGN 120 TO IGO
<span class="comment">*</span><span class="comment"> FIX-H..
</span> GO TO 70
120 CONTINUE
DD1 = DD1*GAM**2
DX1 = DX1/GAM
DH11 = DH11/GAM
DH12 = DH12/GAM
GO TO 110
130 CONTINUE
140 CONTINUE
IF (.NOT.DD1.GE.GAMSQ) GO TO 160
ASSIGN 150 TO IGO
<span class="comment">*</span><span class="comment"> FIX-H..
</span> GO TO 70
150 CONTINUE
DD1 = DD1/GAM**2
DX1 = DX1*GAM
DH11 = DH11*GAM
DH12 = DH12*GAM
GO TO 140
160 CONTINUE
170 CONTINUE
IF (.NOT.DABS(DD2).LE.RGAMSQ) GO TO 190
IF (DD2.EQ.ZERO) GO TO 220
ASSIGN 180 TO IGO
<span class="comment">*</span><span class="comment"> FIX-H..
</span> GO TO 70
180 CONTINUE
DD2 = DD2*GAM**2
DH21 = DH21/GAM
DH22 = DH22/GAM
GO TO 170
190 CONTINUE
200 CONTINUE
IF (.NOT.DABS(DD2).GE.GAMSQ) GO TO 220
ASSIGN 210 TO IGO
<span class="comment">*</span><span class="comment"> FIX-H..
</span> GO TO 70
210 CONTINUE
DD2 = DD2/GAM**2
DH21 = DH21*GAM
DH22 = DH22*GAM
GO TO 200
220 CONTINUE
IF (DFLAG) 250,230,240
230 CONTINUE
DPARAM(3) = DH21
DPARAM(4) = DH12
GO TO 260
240 CONTINUE
DPARAM(2) = DH11
DPARAM(5) = DH22
GO TO 260
250 CONTINUE
DPARAM(2) = DH11
DPARAM(3) = DH21
DPARAM(4) = DH12
DPARAM(5) = DH22
260 CONTINUE
DPARAM(1) = DFLAG
RETURN
END
</pre>
</body>
</html>
⌨️ 快捷键说明
复制代码Ctrl + C
搜索代码Ctrl + F
全屏模式F11
增大字号Ctrl + =
减小字号Ctrl + -
显示快捷键?