229 SUBROUTINE dlar1v( N, B1, BN, LAMBDA, D, L, LD, LLD,
230 $ pivmin, gaptol, z, wantnc, negcnt, ztz, mingma,
231 $ r, isuppz, nrminv, resid, rqcorr, work )
240 INTEGER B1, BN, N, NEGCNT, R
241 DOUBLE PRECISION GAPTOL, LAMBDA, MINGMA, NRMINV, PIVMIN, RESID,
246 DOUBLE PRECISION D( * ), L( * ), LD( * ), LLD( * ),
248 DOUBLE PRECISION Z( * )
254 DOUBLE PRECISION ZERO, ONE
255 parameter ( zero = 0.0d0, one = 1.0d0 )
259 LOGICAL SAWNAN1, SAWNAN2
260 INTEGER I, INDLPL, INDP, INDS, INDUMN, NEG1, NEG2, R1,
262 DOUBLE PRECISION DMINUS, DPLUS, EPS, S, TMP
266 DOUBLE PRECISION DLAMCH
267 EXTERNAL disnan, dlamch
274 eps = dlamch(
'Precision' )
295 work( inds+b1-1 ) = lld( b1-1 )
304 s = work( inds+b1-1 ) - lambda
307 work( indlpl+i ) = ld( i ) / dplus
308 IF(dplus.LT.zero) neg1 = neg1 + 1
309 work( inds+i ) = s*work( indlpl+i )*l( i )
310 s = work( inds+i ) - lambda
312 sawnan1 = disnan( s )
313 IF( sawnan1 )
GOTO 60
316 work( indlpl+i ) = ld( i ) / dplus
317 work( inds+i ) = s*work( indlpl+i )*l( i )
318 s = work( inds+i ) - lambda
320 sawnan1 = disnan( s )
326 s = work( inds+b1-1 ) - lambda
329 IF(abs(dplus).LT.pivmin) dplus = -pivmin
330 work( indlpl+i ) = ld( i ) / dplus
331 IF(dplus.LT.zero) neg1 = neg1 + 1
332 work( inds+i ) = s*work( indlpl+i )*l( i )
333 IF( work( indlpl+i ).EQ.zero )
334 $ work( inds+i ) = lld( i )
335 s = work( inds+i ) - lambda
339 IF(abs(dplus).LT.pivmin) dplus = -pivmin
340 work( indlpl+i ) = ld( i ) / dplus
341 work( inds+i ) = s*work( indlpl+i )*l( i )
342 IF( work( indlpl+i ).EQ.zero )
343 $ work( inds+i ) = lld( i )
344 s = work( inds+i ) - lambda
353 work( indp+bn-1 ) = d( bn ) - lambda
354 DO 80 i = bn - 1, r1, -1
355 dminus = lld( i ) + work( indp+i )
356 tmp = d( i ) / dminus
357 IF(dminus.LT.zero) neg2 = neg2 + 1
358 work( indumn+i ) = l( i )*tmp
359 work( indp+i-1 ) = work( indp+i )*tmp - lambda
361 tmp = work( indp+r1-1 )
362 sawnan2 = disnan( tmp )
367 DO 100 i = bn-1, r1, -1
368 dminus = lld( i ) + work( indp+i )
369 IF(abs(dminus).LT.pivmin) dminus = -pivmin
370 tmp = d( i ) / dminus
371 IF(dminus.LT.zero) neg2 = neg2 + 1
372 work( indumn+i ) = l( i )*tmp
373 work( indp+i-1 ) = work( indp+i )*tmp - lambda
375 $ work( indp+i-1 ) = d( i ) - lambda
382 mingma = work( inds+r1-1 ) + work( indp+r1-1 )
383 IF( mingma.LT.zero ) neg1 = neg1 + 1
389 IF( abs(mingma).EQ.zero )
390 $ mingma = eps*work( inds+r1-1 )
392 DO 110 i = r1, r2 - 1
393 tmp = work( inds+i ) + work( indp+i )
395 $ tmp = eps*work( inds+i )
396 IF( abs( tmp ).LE.abs( mingma ) )
THEN
411 IF( .NOT.sawnan1 .AND. .NOT.sawnan2 )
THEN
412 DO 210 i = r-1, b1, -1
413 z( i ) = -( work( indlpl+i )*z( i+1 ) )
414 IF( (abs(z(i))+abs(z(i+1)))* abs(ld(i)).LT.gaptol )
420 ztz = ztz + z( i )*z( i )
425 DO 230 i = r - 1, b1, -1
426 IF( z( i+1 ).EQ.zero )
THEN
427 z( i ) = -( ld( i+1 ) / ld( i ) )*z( i+2 )
429 z( i ) = -( work( indlpl+i )*z( i+1 ) )
431 IF( (abs(z(i))+abs(z(i+1)))* abs(ld(i)).LT.gaptol )
437 ztz = ztz + z( i )*z( i )
443 IF( .NOT.sawnan1 .AND. .NOT.sawnan2 )
THEN
445 z( i+1 ) = -( work( indumn+i )*z( i ) )
446 IF( (abs(z(i))+abs(z(i+1)))* abs(ld(i)).LT.gaptol )
452 ztz = ztz + z( i+1 )*z( i+1 )
458 IF( z( i ).EQ.zero )
THEN
459 z( i+1 ) = -( ld( i-1 ) / ld( i ) )*z( i-1 )
461 z( i+1 ) = -( work( indumn+i )*z( i ) )
463 IF( (abs(z(i))+abs(z(i+1)))* abs(ld(i)).LT.gaptol )
469 ztz = ztz + z( i+1 )*z( i+1 )
478 resid = abs( mingma )*nrminv
subroutine dlar1v(N, B1, BN, LAMBDA, D, L, LD, LLD, PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA, R, ISUPPZ, NRMINV, RESID, RQCORR, WORK)
DLAR1V computes the (scaled) r-th column of the inverse of the submatrix in rows b1 through bn of the...