LAPACK 3.11.0 LAPACK: Linear Algebra PACKage
Searching...
No Matches

◆ slasq5()

 subroutine slasq5 ( integer I0, integer N0, real, dimension( * ) Z, integer PP, real TAU, real SIGMA, real DMIN, real DMIN1, real DMIN2, real DN, real DNM1, real DNM2, logical IEEE, real EPS )

SLASQ5 computes one dqds transform in ping-pong form. Used by sbdsqr and sstegr.

Purpose:
``` SLASQ5 computes one dqds transform in ping-pong form, one
version for IEEE machines another for non IEEE machines.```
Parameters
 [in] I0 ``` I0 is INTEGER First index.``` [in] N0 ``` N0 is INTEGER Last index.``` [in] Z ``` Z is REAL array, dimension ( 4*N ) Z holds the qd array. EMIN is stored in Z(4*N0) to avoid an extra argument.``` [in] PP ``` PP is INTEGER PP=0 for ping, PP=1 for pong.``` [in] TAU ``` TAU is REAL This is the shift.``` [in] SIGMA ``` SIGMA is REAL This is the accumulated shift up to this step.``` [out] DMIN ``` DMIN is REAL Minimum value of d.``` [out] DMIN1 ``` DMIN1 is REAL Minimum value of d, excluding D( N0 ).``` [out] DMIN2 ``` DMIN2 is REAL Minimum value of d, excluding D( N0 ) and D( N0-1 ).``` [out] DN ``` DN is REAL d(N0), the last value of d.``` [out] DNM1 ``` DNM1 is REAL d(N0-1).``` [out] DNM2 ``` DNM2 is REAL d(N0-2).``` [in] IEEE ``` IEEE is LOGICAL Flag for IEEE or non IEEE arithmetic.``` [in] EPS ``` EPS is REAL This is the value of epsilon used.```

Definition at line 142 of file slasq5.f.

144*
145* -- LAPACK computational routine --
146* -- LAPACK is a software package provided by Univ. of Tennessee, --
147* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
148*
149* .. Scalar Arguments ..
150 LOGICAL IEEE
151 INTEGER I0, N0, PP
152 REAL DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, TAU,
153 \$ SIGMA, EPS
154* ..
155* .. Array Arguments ..
156 REAL Z( * )
157* ..
158*
159* =====================================================================
160*
161* .. Parameter ..
162 REAL ZERO, HALF
163 parameter( zero = 0.0e0, half = 0.5 )
164* ..
165* .. Local Scalars ..
166 INTEGER J4, J4P2
167 REAL D, EMIN, TEMP, DTHRESH
168* ..
169* .. Intrinsic Functions ..
170 INTRINSIC min
171* ..
172* .. Executable Statements ..
173*
174 IF( ( n0-i0-1 ).LE.0 )
175 \$ RETURN
176*
177 dthresh = eps*(sigma+tau)
178 IF( tau.LT.dthresh*half ) tau = zero
179 IF( tau.NE.zero ) THEN
180 j4 = 4*i0 + pp - 3
181 emin = z( j4+4 )
182 d = z( j4 ) - tau
183 dmin = d
184 dmin1 = -z( j4 )
185*
186 IF( ieee ) THEN
187*
188* Code for IEEE arithmetic.
189*
190 IF( pp.EQ.0 ) THEN
191 DO 10 j4 = 4*i0, 4*( n0-3 ), 4
192 z( j4-2 ) = d + z( j4-1 )
193 temp = z( j4+1 ) / z( j4-2 )
194 d = d*temp - tau
195 dmin = min( dmin, d )
196 z( j4 ) = z( j4-1 )*temp
197 emin = min( z( j4 ), emin )
198 10 CONTINUE
199 ELSE
200 DO 20 j4 = 4*i0, 4*( n0-3 ), 4
201 z( j4-3 ) = d + z( j4 )
202 temp = z( j4+2 ) / z( j4-3 )
203 d = d*temp - tau
204 dmin = min( dmin, d )
205 z( j4-1 ) = z( j4 )*temp
206 emin = min( z( j4-1 ), emin )
207 20 CONTINUE
208 END IF
209*
210* Unroll last two steps.
211*
212 dnm2 = d
213 dmin2 = dmin
214 j4 = 4*( n0-2 ) - pp
215 j4p2 = j4 + 2*pp - 1
216 z( j4-2 ) = dnm2 + z( j4p2 )
217 z( j4 ) = z( j4p2+2 )*( z( j4p2 ) / z( j4-2 ) )
218 dnm1 = z( j4p2+2 )*( dnm2 / z( j4-2 ) ) - tau
219 dmin = min( dmin, dnm1 )
220*
221 dmin1 = dmin
222 j4 = j4 + 4
223 j4p2 = j4 + 2*pp - 1
224 z( j4-2 ) = dnm1 + z( j4p2 )
225 z( j4 ) = z( j4p2+2 )*( z( j4p2 ) / z( j4-2 ) )
226 dn = z( j4p2+2 )*( dnm1 / z( j4-2 ) ) - tau
227 dmin = min( dmin, dn )
228*
229 ELSE
230*
231* Code for non IEEE arithmetic.
232*
233 IF( pp.EQ.0 ) THEN
234 DO 30 j4 = 4*i0, 4*( n0-3 ), 4
235 z( j4-2 ) = d + z( j4-1 )
236 IF( d.LT.zero ) THEN
237 RETURN
238 ELSE
239 z( j4 ) = z( j4+1 )*( z( j4-1 ) / z( j4-2 ) )
240 d = z( j4+1 )*( d / z( j4-2 ) ) - tau
241 END IF
242 dmin = min( dmin, d )
243 emin = min( emin, z( j4 ) )
244 30 CONTINUE
245 ELSE
246 DO 40 j4 = 4*i0, 4*( n0-3 ), 4
247 z( j4-3 ) = d + z( j4 )
248 IF( d.LT.zero ) THEN
249 RETURN
250 ELSE
251 z( j4-1 ) = z( j4+2 )*( z( j4 ) / z( j4-3 ) )
252 d = z( j4+2 )*( d / z( j4-3 ) ) - tau
253 END IF
254 dmin = min( dmin, d )
255 emin = min( emin, z( j4-1 ) )
256 40 CONTINUE
257 END IF
258*
259* Unroll last two steps.
260*
261 dnm2 = d
262 dmin2 = dmin
263 j4 = 4*( n0-2 ) - pp
264 j4p2 = j4 + 2*pp - 1
265 z( j4-2 ) = dnm2 + z( j4p2 )
266 IF( dnm2.LT.zero ) THEN
267 RETURN
268 ELSE
269 z( j4 ) = z( j4p2+2 )*( z( j4p2 ) / z( j4-2 ) )
270 dnm1 = z( j4p2+2 )*( dnm2 / z( j4-2 ) ) - tau
271 END IF
272 dmin = min( dmin, dnm1 )
273*
274 dmin1 = dmin
275 j4 = j4 + 4
276 j4p2 = j4 + 2*pp - 1
277 z( j4-2 ) = dnm1 + z( j4p2 )
278 IF( dnm1.LT.zero ) THEN
279 RETURN
280 ELSE
281 z( j4 ) = z( j4p2+2 )*( z( j4p2 ) / z( j4-2 ) )
282 dn = z( j4p2+2 )*( dnm1 / z( j4-2 ) ) - tau
283 END IF
284 dmin = min( dmin, dn )
285*
286 END IF
287*
288 ELSE
289* This is the version that sets d's to zero if they are small enough
290 j4 = 4*i0 + pp - 3
291 emin = z( j4+4 )
292 d = z( j4 ) - tau
293 dmin = d
294 dmin1 = -z( j4 )
295 IF( ieee ) THEN
296*
297* Code for IEEE arithmetic.
298*
299 IF( pp.EQ.0 ) THEN
300 DO 50 j4 = 4*i0, 4*( n0-3 ), 4
301 z( j4-2 ) = d + z( j4-1 )
302 temp = z( j4+1 ) / z( j4-2 )
303 d = d*temp - tau
304 IF( d.LT.dthresh ) d = zero
305 dmin = min( dmin, d )
306 z( j4 ) = z( j4-1 )*temp
307 emin = min( z( j4 ), emin )
308 50 CONTINUE
309 ELSE
310 DO 60 j4 = 4*i0, 4*( n0-3 ), 4
311 z( j4-3 ) = d + z( j4 )
312 temp = z( j4+2 ) / z( j4-3 )
313 d = d*temp - tau
314 IF( d.LT.dthresh ) d = zero
315 dmin = min( dmin, d )
316 z( j4-1 ) = z( j4 )*temp
317 emin = min( z( j4-1 ), emin )
318 60 CONTINUE
319 END IF
320*
321* Unroll last two steps.
322*
323 dnm2 = d
324 dmin2 = dmin
325 j4 = 4*( n0-2 ) - pp
326 j4p2 = j4 + 2*pp - 1
327 z( j4-2 ) = dnm2 + z( j4p2 )
328 z( j4 ) = z( j4p2+2 )*( z( j4p2 ) / z( j4-2 ) )
329 dnm1 = z( j4p2+2 )*( dnm2 / z( j4-2 ) ) - tau
330 dmin = min( dmin, dnm1 )
331*
332 dmin1 = dmin
333 j4 = j4 + 4
334 j4p2 = j4 + 2*pp - 1
335 z( j4-2 ) = dnm1 + z( j4p2 )
336 z( j4 ) = z( j4p2+2 )*( z( j4p2 ) / z( j4-2 ) )
337 dn = z( j4p2+2 )*( dnm1 / z( j4-2 ) ) - tau
338 dmin = min( dmin, dn )
339*
340 ELSE
341*
342* Code for non IEEE arithmetic.
343*
344 IF( pp.EQ.0 ) THEN
345 DO 70 j4 = 4*i0, 4*( n0-3 ), 4
346 z( j4-2 ) = d + z( j4-1 )
347 IF( d.LT.zero ) THEN
348 RETURN
349 ELSE
350 z( j4 ) = z( j4+1 )*( z( j4-1 ) / z( j4-2 ) )
351 d = z( j4+1 )*( d / z( j4-2 ) ) - tau
352 END IF
353 IF( d.LT.dthresh ) d = zero
354 dmin = min( dmin, d )
355 emin = min( emin, z( j4 ) )
356 70 CONTINUE
357 ELSE
358 DO 80 j4 = 4*i0, 4*( n0-3 ), 4
359 z( j4-3 ) = d + z( j4 )
360 IF( d.LT.zero ) THEN
361 RETURN
362 ELSE
363 z( j4-1 ) = z( j4+2 )*( z( j4 ) / z( j4-3 ) )
364 d = z( j4+2 )*( d / z( j4-3 ) ) - tau
365 END IF
366 IF( d.LT.dthresh ) d = zero
367 dmin = min( dmin, d )
368 emin = min( emin, z( j4-1 ) )
369 80 CONTINUE
370 END IF
371*
372* Unroll last two steps.
373*
374 dnm2 = d
375 dmin2 = dmin
376 j4 = 4*( n0-2 ) - pp
377 j4p2 = j4 + 2*pp - 1
378 z( j4-2 ) = dnm2 + z( j4p2 )
379 IF( dnm2.LT.zero ) THEN
380 RETURN
381 ELSE
382 z( j4 ) = z( j4p2+2 )*( z( j4p2 ) / z( j4-2 ) )
383 dnm1 = z( j4p2+2 )*( dnm2 / z( j4-2 ) ) - tau
384 END IF
385 dmin = min( dmin, dnm1 )
386*
387 dmin1 = dmin
388 j4 = j4 + 4
389 j4p2 = j4 + 2*pp - 1
390 z( j4-2 ) = dnm1 + z( j4p2 )
391 IF( dnm1.LT.zero ) THEN
392 RETURN
393 ELSE
394 z( j4 ) = z( j4p2+2 )*( z( j4p2 ) / z( j4-2 ) )
395 dn = z( j4p2+2 )*( dnm1 / z( j4-2 ) ) - tau
396 END IF
397 dmin = min( dmin, dn )
398*
399 END IF
400*
401 END IF
402 z( j4+2 ) = dn
403 z( 4*n0-pp ) = emin
404 RETURN
405*
406* End of SLASQ5
407*
Here is the caller graph for this function: