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 SLARTGS 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 SLARTGS + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slartgs.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slartgs.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slartgs.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE SLARTGS( X, Y, SIGMA, CS, SN )
*
* .. Scalar Arguments ..
* REAL CS, SIGMA, SN, X, Y
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SLARTGS 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 REAL
*> The (1,1) entry of an upper bidiagonal matrix.
*> \endverbatim
*>
*> \param[in] Y
*> \verbatim
*> Y is REAL
*> The (1,2) entry of an upper bidiagonal matrix.
*> \endverbatim
*>
*> \param[in] SIGMA
*> \verbatim
*> SIGMA is REAL
*> The shift.
*> \endverbatim
*>
*> \param[out] CS
*> \verbatim
*> CS is REAL
*> The cosine of the rotation.
*> \endverbatim
*>
*> \param[out] SN
*> \verbatim
*> SN is REAL
*> 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 December 2016
*
*> \ingroup auxOTHERcomputational
*
* =====================================================================
SUBROUTINE SLARTGS( X, Y, SIGMA, CS, SN )
*
* -- LAPACK computational routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
REAL CS, SIGMA, SN, X, Y
* ..
*
* ===================================================================
*
* .. Parameters ..
REAL NEGONE, ONE, ZERO
PARAMETER ( NEGONE = -1.0E0, ONE = 1.0E0, ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
REAL R, S, THRESH, W, Z
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* .. Executable Statements ..
*
THRESH = SLAMCH('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 SLARTGP( 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 SLARTGP( W, Z, SN, CS, R )
*
RETURN
*
* End SLARTGS
*
END
|
