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
double lambda
Latent heat of blowing agent, J/kg.