177 SUBROUTINE sggbal( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE,
178 $ rscale, work, info )
187 INTEGER ihi, ilo, info, lda, ldb, n
190 REAL a( lda, * ),
b( ldb, * ), lscale( * ),
191 $ rscale( * ), work( * )
198 parameter( zero = 0.0e+0, half = 0.5e+0, one = 1.0e+0 )
200 parameter( three = 3.0e+0, sclfac = 1.0e+1 )
203 INTEGER i, icab, iflow, ip1, ir, irab, it,
j, jc, jp1,
204 $ k, kount, l, lcab, lm1, lrab, lsfmax, lsfmin,
206 REAL alpha, basl, beta, cab, cmax, coef, coef2,
207 $ coef5, cor, ew, ewc, gamma, pgamma, rab, sfmax,
208 $ sfmin, sum, t, ta, tb, tc
220 INTRINSIC abs, int, log10, max, min,
REAL, sign
227 IF( .NOT.
lsame( job,
'N' ) .AND. .NOT.
lsame( job,
'P' ) .AND.
228 $ .NOT.
lsame( job,
'S' ) .AND. .NOT.
lsame( job,
'B' ) )
THEN
230 ELSE IF( n.LT.0 )
THEN
232 ELSE IF( lda.LT.max( 1, n ) )
THEN
234 ELSE IF( ldb.LT.max( 1, n ) )
THEN
238 CALL
xerbla(
'SGGBAL', -info )
258 IF(
lsame( job,
'N' ) )
THEN
270 IF(
lsame( job,
'S' ) )
293 IF( a( i,
j ).NE.zero .OR.
b( i,
j ).NE.zero )
301 IF( a( i,
j ).NE.zero .OR.
b( i,
j ).NE.zero )
322 IF( a( i,
j ).NE.zero .OR.
b( i,
j ).NE.zero )
329 IF( a( i,
j ).NE.zero .OR.
b( i,
j ).NE.zero )
346 CALL
sswap( n-k+1, a( i, k ), lda, a( m, k ), lda )
347 CALL
sswap( n-k+1,
b( i, k ), ldb,
b( m, k ), ldb )
355 CALL
sswap( l, a( 1,
j ), 1, a( 1, m ), 1 )
356 CALL
sswap( l,
b( 1,
j ), 1,
b( 1, m ), 1 )
365 IF(
lsame( job,
'P' ) )
THEN
393 basl = log10( sclfac )
400 ta = log10( abs( ta ) ) / basl
404 tb = log10( abs( tb ) ) / basl
406 work( i+4*n ) = work( i+4*n ) - ta - tb
407 work(
j+5*n ) = work(
j+5*n ) - ta - tb
411 coef = one /
REAL( 2*nr )
422 gamma =
sdot( nr, work( ilo+4*n ), 1, work( ilo+4*n ), 1 ) +
423 $
sdot( nr, work( ilo+5*n ), 1, work( ilo+5*n ), 1 )
428 ew = ew + work( i+4*n )
429 ewc = ewc + work( i+5*n )
432 gamma = coef*gamma - coef2*( ew**2+ewc**2 ) - coef5*( ew-ewc )**2
436 $ beta = gamma / pgamma
437 t = coef5*( ewc-three*ew )
438 tc = coef5*( ew-three*ewc )
440 CALL
sscal( nr, beta, work( ilo ), 1 )
441 CALL
sscal( nr, beta, work( ilo+n ), 1 )
443 CALL
saxpy( nr, coef, work( ilo+4*n ), 1, work( ilo+n ), 1 )
444 CALL
saxpy( nr, coef, work( ilo+5*n ), 1, work( ilo ), 1 )
447 work( i ) = work( i ) + tc
448 work( i+n ) = work( i+n ) + t
457 IF( a( i,
j ).EQ.zero )
460 sum = sum + work(
j )
462 IF(
b( i,
j ).EQ.zero )
465 sum = sum + work(
j )
467 work( i+2*n ) =
REAL( kount )*work( i+n ) + sum
474 IF( a( i,
j ).EQ.zero )
477 sum = sum + work( i+n )
479 IF(
b( i,
j ).EQ.zero )
482 sum = sum + work( i+n )
484 work(
j+3*n ) =
REAL( kount )*work(
j ) + sum
487 sum =
sdot( nr, work( ilo+n ), 1, work( ilo+2*n ), 1 ) +
488 $
sdot( nr, work( ilo ), 1, work( ilo+3*n ), 1 )
495 cor = alpha*work( i+n )
496 IF( abs( cor ).GT.cmax )
498 lscale( i ) = lscale( i ) + cor
499 cor = alpha*work( i )
500 IF( abs( cor ).GT.cmax )
502 rscale( i ) = rscale( i ) + cor
507 CALL
saxpy( nr, -alpha, work( ilo+2*n ), 1, work( ilo+4*n ), 1 )
508 CALL
saxpy( nr, -alpha, work( ilo+3*n ), 1, work( ilo+5*n ), 1 )
520 lsfmin = int( log10( sfmin ) / basl+one )
521 lsfmax = int( log10( sfmax ) / basl )
523 irab =
isamax( n-ilo+1, a( i, ilo ), lda )
524 rab = abs( a( i, irab+ilo-1 ) )
525 irab =
isamax( n-ilo+1,
b( i, ilo ), ldb )
526 rab = max( rab, abs(
b( i, irab+ilo-1 ) ) )
527 lrab = int( log10( rab+sfmin ) / basl+one )
528 ir = lscale( i ) + sign( half, lscale( i ) )
529 ir = min( max( ir, lsfmin ), lsfmax, lsfmax-lrab )
530 lscale( i ) = sclfac**ir
531 icab =
isamax( ihi, a( 1, i ), 1 )
532 cab = abs( a( icab, i ) )
533 icab =
isamax( ihi,
b( 1, i ), 1 )
534 cab = max( cab, abs(
b( icab, i ) ) )
535 lcab = int( log10( cab+sfmin ) / basl+one )
536 jc = rscale( i ) + sign( half, rscale( i ) )
537 jc = min( max( jc, lsfmin ), lsfmax, lsfmax-lcab )
538 rscale( i ) = sclfac**jc
544 CALL
sscal( n-ilo+1, lscale( i ), a( i, ilo ), lda )
545 CALL
sscal( n-ilo+1, lscale( i ),
b( i, ilo ), ldb )
551 CALL
sscal( ihi, rscale(
j ), a( 1,
j ), 1 )
552 CALL
sscal( ihi, rscale(
j ),
b( 1,
j ), 1 )
LOGICAL function lsame(CA, CB)
LSAME
INTEGER function isamax(N, SX, INCX)
ISAMAX
subroutine sggbal(JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO)
SGGBAL
subroutine sswap(N, SX, INCX, SY, INCY)
SSWAP
REAL function slamch(CMACH)
SLAMCH
subroutine xerbla(SRNAME, INFO)
XERBLA
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine saxpy(N, SA, SX, INCX, SY, INCY)
SAXPY
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
REAL function sdot(N, SX, INCX, SY, INCY)
SDOT
subroutine sscal(N, SA, SX, INCX)
SSCAL