229 SUBROUTINE clar1v( 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 REAL GAPTOL, LAMBDA, MINGMA, NRMINV, PIVMIN, RESID,
246 REAL D( * ), L( * ), LD( * ), LLD( * ),
255 parameter ( zero = 0.0e0, one = 1.0e0 )
257 parameter ( cone = ( 1.0e0, 0.0e0 ) )
261 LOGICAL SAWNAN1, SAWNAN2
262 INTEGER I, INDLPL, INDP, INDS, INDUMN, NEG1, NEG2, R1,
264 REAL DMINUS, DPLUS, EPS, S, TMP
269 EXTERNAL sisnan, slamch
276 eps = slamch(
'Precision' )
297 work( inds+b1-1 ) = lld( b1-1 )
306 s = work( inds+b1-1 ) - lambda
309 work( indlpl+i ) = ld( i ) / dplus
310 IF(dplus.LT.zero) neg1 = neg1 + 1
311 work( inds+i ) = s*work( indlpl+i )*l( i )
312 s = work( inds+i ) - lambda
314 sawnan1 = sisnan( s )
315 IF( sawnan1 )
GOTO 60
318 work( indlpl+i ) = ld( i ) / dplus
319 work( inds+i ) = s*work( indlpl+i )*l( i )
320 s = work( inds+i ) - lambda
322 sawnan1 = sisnan( s )
328 s = work( inds+b1-1 ) - lambda
331 IF(abs(dplus).LT.pivmin) dplus = -pivmin
332 work( indlpl+i ) = ld( i ) / dplus
333 IF(dplus.LT.zero) neg1 = neg1 + 1
334 work( inds+i ) = s*work( indlpl+i )*l( i )
335 IF( work( indlpl+i ).EQ.zero )
336 $ work( inds+i ) = lld( i )
337 s = work( inds+i ) - lambda
341 IF(abs(dplus).LT.pivmin) dplus = -pivmin
342 work( indlpl+i ) = ld( i ) / dplus
343 work( inds+i ) = s*work( indlpl+i )*l( i )
344 IF( work( indlpl+i ).EQ.zero )
345 $ work( inds+i ) = lld( i )
346 s = work( inds+i ) - lambda
355 work( indp+bn-1 ) = d( bn ) - lambda
356 DO 80 i = bn - 1, r1, -1
357 dminus = lld( i ) + work( indp+i )
358 tmp = d( i ) / dminus
359 IF(dminus.LT.zero) neg2 = neg2 + 1
360 work( indumn+i ) = l( i )*tmp
361 work( indp+i-1 ) = work( indp+i )*tmp - lambda
363 tmp = work( indp+r1-1 )
364 sawnan2 = sisnan( tmp )
369 DO 100 i = bn-1, r1, -1
370 dminus = lld( i ) + work( indp+i )
371 IF(abs(dminus).LT.pivmin) dminus = -pivmin
372 tmp = d( i ) / dminus
373 IF(dminus.LT.zero) neg2 = neg2 + 1
374 work( indumn+i ) = l( i )*tmp
375 work( indp+i-1 ) = work( indp+i )*tmp - lambda
377 $ work( indp+i-1 ) = d( i ) - lambda
384 mingma = work( inds+r1-1 ) + work( indp+r1-1 )
385 IF( mingma.LT.zero ) neg1 = neg1 + 1
391 IF( abs(mingma).EQ.zero )
392 $ mingma = eps*work( inds+r1-1 )
394 DO 110 i = r1, r2 - 1
395 tmp = work( inds+i ) + work( indp+i )
397 $ tmp = eps*work( inds+i )
398 IF( abs( tmp ).LE.abs( mingma ) )
THEN
413 IF( .NOT.sawnan1 .AND. .NOT.sawnan2 )
THEN
414 DO 210 i = r-1, b1, -1
415 z( i ) = -( work( indlpl+i )*z( i+1 ) )
416 IF( (abs(z(i))+abs(z(i+1)))* abs(ld(i)).LT.gaptol )
422 ztz = ztz +
REAL( Z( I )*Z( I ) )
427 DO 230 i = r - 1, b1, -1
428 IF( z( i+1 ).EQ.zero )
THEN
429 z( i ) = -( ld( i+1 ) / ld( i ) )*z( i+2 )
431 z( i ) = -( work( indlpl+i )*z( i+1 ) )
433 IF( (abs(z(i))+abs(z(i+1)))* abs(ld(i)).LT.gaptol )
439 ztz = ztz +
REAL( Z( I )*Z( I ) )
445 IF( .NOT.sawnan1 .AND. .NOT.sawnan2 )
THEN
447 z( i+1 ) = -( work( indumn+i )*z( i ) )
448 IF( (abs(z(i))+abs(z(i+1)))* abs(ld(i)).LT.gaptol )
454 ztz = ztz +
REAL( Z( I+1 )*Z( I+1 ) )
460 IF( z( i ).EQ.zero )
THEN
461 z( i+1 ) = -( ld( i-1 ) / ld( i ) )*z( i-1 )
463 z( i+1 ) = -( work( indumn+i )*z( i ) )
465 IF( (abs(z(i))+abs(z(i+1)))* abs(ld(i)).LT.gaptol )
471 ztz = ztz +
REAL( Z( I+1 )*Z( I+1 ) )
480 resid = abs( mingma )*nrminv
subroutine clar1v(N, B1, BN, LAMBDA, D, L, LD, LLD, PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA, R, ISUPPZ, NRMINV, RESID, RQCORR, WORK)
CLAR1V computes the (scaled) r-th column of the inverse of the submatrix in rows b1 through bn of the...