1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
|
*> \brief \b DLARTGS generates a plane rotation designed to introduce a bulge in implicit QR iteration for the bidiagonal SVD problem.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLARTGS + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlartgs.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlartgs.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlartgs.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLARTGS( X, Y, SIGMA, CS, SN )
*
* .. Scalar Arguments ..
* DOUBLE PRECISION CS, SIGMA, SN, X, Y
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLARTGS generates a plane rotation designed to introduce a bulge in
*> Golub-Reinsch-style implicit QR iteration for the bidiagonal SVD
*> problem. X and Y are the top-row entries, and SIGMA is the shift.
*> The computed CS and SN define a plane rotation satisfying
*>
*> [ CS SN ] . [ X^2 - SIGMA ] = [ R ],
*> [ -SN CS ] [ X * Y ] [ 0 ]
*>
*> with R nonnegative. If X^2 - SIGMA and X * Y are 0, then the
*> rotation is by PI/2.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] X
*> \verbatim
*> X is DOUBLE PRECISION
*> The (1,1) entry of an upper bidiagonal matrix.
*> \endverbatim
*>
*> \param[in] Y
*> \verbatim
*> Y is DOUBLE PRECISION
*> The (1,2) entry of an upper bidiagonal matrix.
*> \endverbatim
*>
*> \param[in] SIGMA
*> \verbatim
*> SIGMA is DOUBLE PRECISION
*> The shift.
*> \endverbatim
*>
*> \param[out] CS
*> \verbatim
*> CS is DOUBLE PRECISION
*> The cosine of the rotation.
*> \endverbatim
*>
*> \param[out] SN
*> \verbatim
*> SN is DOUBLE PRECISION
*> The sine of the rotation.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup auxOTHERcomputational
*
* =====================================================================
SUBROUTINE DLARTGS( X, Y, SIGMA, CS, SN )
*
* -- LAPACK computational routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
DOUBLE PRECISION CS, SIGMA, SN, X, Y
* ..
*
* ===================================================================
*
* .. Parameters ..
DOUBLE PRECISION NEGONE, ONE, ZERO
PARAMETER ( NEGONE = -1.0D0, ONE = 1.0D0, ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION R, S, THRESH, W, Z
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* .. Executable Statements ..
*
THRESH = DLAMCH('E')
*
* Compute the first column of B**T*B - SIGMA^2*I, up to a scale
* factor.
*
IF( (SIGMA .EQ. ZERO .AND. ABS(X) .LT. THRESH) .OR.
$ (ABS(X) .EQ. SIGMA .AND. Y .EQ. ZERO) ) THEN
Z = ZERO
W = ZERO
ELSE IF( SIGMA .EQ. ZERO ) THEN
IF( X .GE. ZERO ) THEN
Z = X
W = Y
ELSE
Z = -X
W = -Y
END IF
ELSE IF( ABS(X) .LT. THRESH ) THEN
Z = -SIGMA*SIGMA
W = ZERO
ELSE
IF( X .GE. ZERO ) THEN
S = ONE
ELSE
S = NEGONE
END IF
Z = S * (ABS(X)-SIGMA) * (S+SIGMA/X)
W = S * Y
END IF
*
* Generate the rotation.
* CALL DLARTGP( Z, W, CS, SN, R ) might seem more natural;
* reordering the arguments ensures that if Z = 0 then the rotation
* is by PI/2.
*
CALL DLARTGP( W, Z, SN, CS, R )
*
RETURN
*
* End DLARTGS
*
END
|
