LAPACK 3.12.0 LAPACK: Linear Algebra PACKage
Searching...
No Matches
slasq6.f
Go to the documentation of this file.
1*> \brief \b SLASQ6 computes one dqd transform in ping-pong form. Used by sbdsqr and sstegr.
2*
3* =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6* http://www.netlib.org/lapack/explore-html/
7*
8*> \htmlonly
10*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slasq6.f">
11*> [TGZ]</a>
12*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slasq6.f">
13*> [ZIP]</a>
14*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slasq6.f">
15*> [TXT]</a>
16*> \endhtmlonly
17*
18* Definition:
19* ===========
20*
21* SUBROUTINE SLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN,
22* DNM1, DNM2 )
23*
24* .. Scalar Arguments ..
25* INTEGER I0, N0, PP
26* REAL DMIN, DMIN1, DMIN2, DN, DNM1, DNM2
27* ..
28* .. Array Arguments ..
29* REAL Z( * )
30* ..
31*
32*
33*> \par Purpose:
34* =============
35*>
36*> \verbatim
37*>
38*> SLASQ6 computes one dqd (shift equal to zero) transform in
39*> ping-pong form, with protection against underflow and overflow.
40*> \endverbatim
41*
42* Arguments:
43* ==========
44*
45*> \param[in] I0
46*> \verbatim
47*> I0 is INTEGER
48*> First index.
49*> \endverbatim
50*>
51*> \param[in] N0
52*> \verbatim
53*> N0 is INTEGER
54*> Last index.
55*> \endverbatim
56*>
57*> \param[in] Z
58*> \verbatim
59*> Z is REAL array, dimension ( 4*N )
60*> Z holds the qd array. EMIN is stored in Z(4*N0) to avoid
61*> an extra argument.
62*> \endverbatim
63*>
64*> \param[in] PP
65*> \verbatim
66*> PP is INTEGER
67*> PP=0 for ping, PP=1 for pong.
68*> \endverbatim
69*>
70*> \param[out] DMIN
71*> \verbatim
72*> DMIN is REAL
73*> Minimum value of d.
74*> \endverbatim
75*>
76*> \param[out] DMIN1
77*> \verbatim
78*> DMIN1 is REAL
79*> Minimum value of d, excluding D( N0 ).
80*> \endverbatim
81*>
82*> \param[out] DMIN2
83*> \verbatim
84*> DMIN2 is REAL
85*> Minimum value of d, excluding D( N0 ) and D( N0-1 ).
86*> \endverbatim
87*>
88*> \param[out] DN
89*> \verbatim
90*> DN is REAL
91*> d(N0), the last value of d.
92*> \endverbatim
93*>
94*> \param[out] DNM1
95*> \verbatim
96*> DNM1 is REAL
97*> d(N0-1).
98*> \endverbatim
99*>
100*> \param[out] DNM2
101*> \verbatim
102*> DNM2 is REAL
103*> d(N0-2).
104*> \endverbatim
105*
106* Authors:
107* ========
108*
109*> \author Univ. of Tennessee
110*> \author Univ. of California Berkeley
111*> \author Univ. of Colorado Denver
112*> \author NAG Ltd.
113*
114*> \ingroup lasq6
115*
116* =====================================================================
117 SUBROUTINE slasq6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN,
118 \$ DNM1, DNM2 )
119*
120* -- LAPACK computational routine --
121* -- LAPACK is a software package provided by Univ. of Tennessee, --
122* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
123*
124* .. Scalar Arguments ..
125 INTEGER I0, N0, PP
126 REAL DMIN, DMIN1, DMIN2, DN, DNM1, DNM2
127* ..
128* .. Array Arguments ..
129 REAL Z( * )
130* ..
131*
132* =====================================================================
133*
134* .. Parameter ..
135 REAL ZERO
136 parameter( zero = 0.0e0 )
137* ..
138* .. Local Scalars ..
139 INTEGER J4, J4P2
140 REAL D, EMIN, SAFMIN, TEMP
141* ..
142* .. External Function ..
143 REAL SLAMCH
144 EXTERNAL slamch
145* ..
146* .. Intrinsic Functions ..
147 INTRINSIC min
148* ..
149* .. Executable Statements ..
150*
151 IF( ( n0-i0-1 ).LE.0 )
152 \$ RETURN
153*
154 safmin = slamch( 'Safe minimum' )
155 j4 = 4*i0 + pp - 3
156 emin = z( j4+4 )
157 d = z( j4 )
158 dmin = d
159*
160 IF( pp.EQ.0 ) THEN
161 DO 10 j4 = 4*i0, 4*( n0-3 ), 4
162 z( j4-2 ) = d + z( j4-1 )
163 IF( z( j4-2 ).EQ.zero ) THEN
164 z( j4 ) = zero
165 d = z( j4+1 )
166 dmin = d
167 emin = zero
168 ELSE IF( safmin*z( j4+1 ).LT.z( j4-2 ) .AND.
169 \$ safmin*z( j4-2 ).LT.z( j4+1 ) ) THEN
170 temp = z( j4+1 ) / z( j4-2 )
171 z( j4 ) = z( j4-1 )*temp
172 d = d*temp
173 ELSE
174 z( j4 ) = z( j4+1 )*( z( j4-1 ) / z( j4-2 ) )
175 d = z( j4+1 )*( d / z( j4-2 ) )
176 END IF
177 dmin = min( dmin, d )
178 emin = min( emin, z( j4 ) )
179 10 CONTINUE
180 ELSE
181 DO 20 j4 = 4*i0, 4*( n0-3 ), 4
182 z( j4-3 ) = d + z( j4 )
183 IF( z( j4-3 ).EQ.zero ) THEN
184 z( j4-1 ) = zero
185 d = z( j4+2 )
186 dmin = d
187 emin = zero
188 ELSE IF( safmin*z( j4+2 ).LT.z( j4-3 ) .AND.
189 \$ safmin*z( j4-3 ).LT.z( j4+2 ) ) THEN
190 temp = z( j4+2 ) / z( j4-3 )
191 z( j4-1 ) = z( j4 )*temp
192 d = d*temp
193 ELSE
194 z( j4-1 ) = z( j4+2 )*( z( j4 ) / z( j4-3 ) )
195 d = z( j4+2 )*( d / z( j4-3 ) )
196 END IF
197 dmin = min( dmin, d )
198 emin = min( emin, z( j4-1 ) )
199 20 CONTINUE
200 END IF
201*
202* Unroll last two steps.
203*
204 dnm2 = d
205 dmin2 = dmin
206 j4 = 4*( n0-2 ) - pp
207 j4p2 = j4 + 2*pp - 1
208 z( j4-2 ) = dnm2 + z( j4p2 )
209 IF( z( j4-2 ).EQ.zero ) THEN
210 z( j4 ) = zero
211 dnm1 = z( j4p2+2 )
212 dmin = dnm1
213 emin = zero
214 ELSE IF( safmin*z( j4p2+2 ).LT.z( j4-2 ) .AND.
215 \$ safmin*z( j4-2 ).LT.z( j4p2+2 ) ) THEN
216 temp = z( j4p2+2 ) / z( j4-2 )
217 z( j4 ) = z( j4p2 )*temp
218 dnm1 = dnm2*temp
219 ELSE
220 z( j4 ) = z( j4p2+2 )*( z( j4p2 ) / z( j4-2 ) )
221 dnm1 = z( j4p2+2 )*( dnm2 / z( j4-2 ) )
222 END IF
223 dmin = min( dmin, dnm1 )
224*
225 dmin1 = dmin
226 j4 = j4 + 4
227 j4p2 = j4 + 2*pp - 1
228 z( j4-2 ) = dnm1 + z( j4p2 )
229 IF( z( j4-2 ).EQ.zero ) THEN
230 z( j4 ) = zero
231 dn = z( j4p2+2 )
232 dmin = dn
233 emin = zero
234 ELSE IF( safmin*z( j4p2+2 ).LT.z( j4-2 ) .AND.
235 \$ safmin*z( j4-2 ).LT.z( j4p2+2 ) ) THEN
236 temp = z( j4p2+2 ) / z( j4-2 )
237 z( j4 ) = z( j4p2 )*temp
238 dn = dnm1*temp
239 ELSE
240 z( j4 ) = z( j4p2+2 )*( z( j4p2 ) / z( j4-2 ) )
241 dn = z( j4p2+2 )*( dnm1 / z( j4-2 ) )
242 END IF
243 dmin = min( dmin, dn )
244*
245 z( j4+2 ) = dn
246 z( 4*n0-pp ) = emin
247 RETURN
248*
249* End of SLASQ6
250*
251 END
subroutine slasq6(i0, n0, z, pp, dmin, dmin1, dmin2, dn, dnm1, dnm2)
SLASQ6 computes one dqd transform in ping-pong form. Used by sbdsqr and sstegr.
Definition slasq6.f:119