296 SUBROUTINE cdrgvx( NSIZE, THRESH, NIN, NOUT, A, LDA, B, AI, BI,
297 $ alpha, beta, vl, vr, ilo, ihi, lscale, rscale,
298 $ s, stru, dif, diftru, work, lwork, rwork,
299 $ iwork, liwork, result, bwork, info )
307 INTEGER ihi, ilo, info, lda, liwork, lwork, nin, nout,
314 REAL dif( * ), diftru( * ), lscale( * ),
315 $ result( 4 ), rscale( * ), rwork( * ), s( * ),
317 COMPLEX a( lda, * ), ai( lda, * ), alpha( * ),
318 $ b( lda, * ), beta( * ), bi( lda, * ),
319 $ vl( lda, * ), vr( lda, * ), work( * )
325 REAL zero, one, ten, tnth, half
326 parameter( zero = 0.0e+0, one = 1.0e+0, ten = 1.0e+1,
327 $ tnth = 1.0e-1, half = 0.5e+0 )
330 INTEGER i, iptype, iwa, iwb, iwx, iwy, j, linfo,
331 $ maxwrk, minwrk, n, nerrs, nmax, nptknt, ntestt
332 REAL abnorm, anorm, bnorm, ratio1, ratio2, thrsh2,
347 INTRINSIC abs, cmplx, max, sqrt
357 IF( nsize.LT.0 )
THEN
359 ELSE IF( thresh.LT.zero )
THEN
361 ELSE IF( nin.LE.0 )
THEN
363 ELSE IF( nout.LE.0 )
THEN
365 ELSE IF( lda.LT.1 .OR. lda.LT.nmax )
THEN
367 ELSE IF( liwork.LT.nmax+2 )
THEN
379 IF( info.EQ.0 .AND. lwork.GE.1 )
THEN
380 minwrk = 2*nmax*( nmax+1 )
381 maxwrk = nmax*( 1+
ilaenv( 1,
'CGEQRF',
' ', nmax, 1, nmax,
383 maxwrk = max( maxwrk, 2*nmax*( nmax+1 ) )
387 IF( lwork.LT.minwrk )
391 CALL
xerbla(
'CDRGVX', -info )
408 weight( 1 ) = cmplx( tnth, zero )
409 weight( 2 ) = cmplx( half, zero )
411 weight( 4 ) = one / weight( 2 )
412 weight( 5 ) = one / weight( 1 )
422 CALL
clatm6( iptype, 5, a, lda, b, vr, lda, vl,
423 $ lda, weight( iwa ), weight( iwb ),
424 $ weight( iwx ), weight( iwy ), stru,
431 CALL
clacpy(
'F', n, n, a, lda, ai, lda )
432 CALL
clacpy(
'F', n, n, b, lda, bi, lda )
434 CALL
cggevx(
'N',
'V',
'V',
'B', n, ai, lda, bi,
435 $ lda, alpha, beta, vl, lda, vr, lda,
436 $ ilo, ihi, lscale, rscale, anorm,
437 $ bnorm, s, dif, work, lwork, rwork,
438 $ iwork, bwork, linfo )
439 IF( linfo.NE.0 )
THEN
440 WRITE( nout, fmt = 9999 )
'CGGEVX', linfo, n,
441 $ iptype, iwa, iwb, iwx, iwy
447 CALL
clacpy(
'Full', n, n, ai, lda, work, n )
448 CALL
clacpy(
'Full', n, n, bi, lda, work( n*n+1 ),
450 abnorm =
clange(
'Fro', n, 2*n, work, n, rwork )
455 CALL
cget52( .true., n, a, lda, b, lda, vl, lda,
456 $ alpha, beta, work, rwork,
458 IF( result( 2 ).GT.thresh )
THEN
459 WRITE( nout, fmt = 9998 )
'Left',
'CGGEVX',
460 $ result( 2 ), n, iptype, iwa, iwb, iwx, iwy
464 CALL
cget52( .false., n, a, lda, b, lda, vr, lda,
465 $ alpha, beta, work, rwork,
467 IF( result( 3 ).GT.thresh )
THEN
468 WRITE( nout, fmt = 9998 )
'Right',
'CGGEVX',
469 $ result( 3 ), n, iptype, iwa, iwb, iwx, iwy
476 IF( s( i ).EQ.zero )
THEN
477 IF( stru( i ).GT.abnorm*ulp )
478 $ result( 3 ) = ulpinv
479 ELSE IF( stru( i ).EQ.zero )
THEN
480 IF( s( i ).GT.abnorm*ulp )
481 $ result( 3 ) = ulpinv
483 rwork( i ) = max( abs( stru( i ) / s( i ) ),
484 $ abs( s( i ) / stru( i ) ) )
485 result( 3 ) = max( result( 3 ), rwork( i ) )
492 IF( dif( 1 ).EQ.zero )
THEN
493 IF( diftru( 1 ).GT.abnorm*ulp )
494 $ result( 4 ) = ulpinv
495 ELSE IF( diftru( 1 ).EQ.zero )
THEN
496 IF( dif( 1 ).GT.abnorm*ulp )
497 $ result( 4 ) = ulpinv
498 ELSE IF( dif( 5 ).EQ.zero )
THEN
499 IF( diftru( 5 ).GT.abnorm*ulp )
500 $ result( 4 ) = ulpinv
501 ELSE IF( diftru( 5 ).EQ.zero )
THEN
502 IF( dif( 5 ).GT.abnorm*ulp )
503 $ result( 4 ) = ulpinv
505 ratio1 = max( abs( diftru( 1 ) / dif( 1 ) ),
506 $ abs( dif( 1 ) / diftru( 1 ) ) )
507 ratio2 = max( abs( diftru( 5 ) / dif( 5 ) ),
508 $ abs( dif( 5 ) / diftru( 5 ) ) )
509 result( 4 ) = max( ratio1, ratio2 )
517 IF( ( result( j ).GE.thrsh2 .AND. j.GE.4 ) .OR.
518 $ ( result( j ).GE.thresh .AND. j.LE.3 ) )
524 IF( nerrs.EQ.0 )
THEN
525 WRITE( nout, fmt = 9997 )
'CXV'
531 WRITE( nout, fmt = 9995 )
532 WRITE( nout, fmt = 9994 )
533 WRITE( nout, fmt = 9993 )
537 WRITE( nout, fmt = 9992 )
'''',
542 IF( result( j ).LT.10000.0 )
THEN
543 WRITE( nout, fmt = 9991 )iptype, iwa,
544 $ iwb, iwx, iwy, j, result( j )
546 WRITE( nout, fmt = 9990 )iptype, iwa,
547 $ iwb, iwx, iwy, j, result( j )
567 READ( nin, fmt = *,
END = 150 )n
571 READ( nin, fmt = * )( a( i, j ), j = 1, n )
574 READ( nin, fmt = * )( b( i, j ), j = 1, n )
576 READ( nin, fmt = * )( stru( i ), i = 1, n )
577 READ( nin, fmt = * )( diftru( i ), i = 1, n )
585 CALL
clacpy(
'F', n, n, a, lda, ai, lda )
586 CALL
clacpy(
'F', n, n, b, lda, bi, lda )
588 CALL
cggevx(
'N',
'V',
'V',
'B', n, ai, lda, bi, lda, alpha, beta,
589 $ vl, lda, vr, lda, ilo, ihi, lscale, rscale, anorm,
590 $ bnorm, s, dif, work, lwork, rwork, iwork, bwork,
593 IF( linfo.NE.0 )
THEN
594 WRITE( nout, fmt = 9987 )
'CGGEVX', linfo, n, nptknt
600 CALL
clacpy(
'Full', n, n, ai, lda, work, n )
601 CALL
clacpy(
'Full', n, n, bi, lda, work( n*n+1 ), n )
602 abnorm =
clange(
'Fro', n, 2*n, work, n, rwork )
607 CALL
cget52( .true., n, a, lda, b, lda, vl, lda, alpha, beta,
608 $ work, rwork, result( 1 ) )
609 IF( result( 2 ).GT.thresh )
THEN
610 WRITE( nout, fmt = 9986 )
'Left',
'CGGEVX', result( 2 ), n,
615 CALL
cget52( .false., n, a, lda, b, lda, vr, lda, alpha, beta,
616 $ work, rwork, result( 2 ) )
617 IF( result( 3 ).GT.thresh )
THEN
618 WRITE( nout, fmt = 9986 )
'Right',
'CGGEVX', result( 3 ), n,
626 IF( s( i ).EQ.zero )
THEN
627 IF( stru( i ).GT.abnorm*ulp )
628 $ result( 3 ) = ulpinv
629 ELSE IF( stru( i ).EQ.zero )
THEN
630 IF( s( i ).GT.abnorm*ulp )
631 $ result( 3 ) = ulpinv
633 rwork( i ) = max( abs( stru( i ) / s( i ) ),
634 $ abs( s( i ) / stru( i ) ) )
635 result( 3 ) = max( result( 3 ), rwork( i ) )
642 IF( dif( 1 ).EQ.zero )
THEN
643 IF( diftru( 1 ).GT.abnorm*ulp )
644 $ result( 4 ) = ulpinv
645 ELSE IF( diftru( 1 ).EQ.zero )
THEN
646 IF( dif( 1 ).GT.abnorm*ulp )
647 $ result( 4 ) = ulpinv
648 ELSE IF( dif( 5 ).EQ.zero )
THEN
649 IF( diftru( 5 ).GT.abnorm*ulp )
650 $ result( 4 ) = ulpinv
651 ELSE IF( diftru( 5 ).EQ.zero )
THEN
652 IF( dif( 5 ).GT.abnorm*ulp )
653 $ result( 4 ) = ulpinv
655 ratio1 = max( abs( diftru( 1 ) / dif( 1 ) ),
656 $ abs( dif( 1 ) / diftru( 1 ) ) )
657 ratio2 = max( abs( diftru( 5 ) / dif( 5 ) ),
658 $ abs( dif( 5 ) / diftru( 5 ) ) )
659 result( 4 ) = max( ratio1, ratio2 )
667 IF( result( j ).GE.thrsh2 )
THEN
672 IF( nerrs.EQ.0 )
THEN
673 WRITE( nout, fmt = 9997 )
'CXV'
679 WRITE( nout, fmt = 9996 )
683 WRITE( nout, fmt = 9992 )
'''',
'transpose',
''''
687 IF( result( j ).LT.10000.0 )
THEN
688 WRITE( nout, fmt = 9989 )nptknt, n, j, result( j )
690 WRITE( nout, fmt = 9988 )nptknt, n, j, result( j )
702 CALL
alasvm(
'CXV', nout, nerrs, ntestt, 0 )
708 9999 format(
' CDRGVX: ', a,
' returned INFO=', i6,
'.', / 9x,
'N=',
709 $ i6,
', JTYPE=', i6,
')' )
711 9998 format(
' CDRGVX: ', a,
' Eigenvectors from ', a,
' incorrectly ',
712 $
'normalized.', /
' Bits of error=', 0p, g10.3,
',', 9x,
713 $
'N=', i6,
', JTYPE=', i6,
', IWA=', i5,
', IWB=', i5,
714 $
', IWX=', i5,
', IWY=', i5 )
716 9997 format( / 1x, a3,
' -- Complex Expert Eigenvalue/vector',
717 $
' problem driver' )
719 9996 format(
'Input Example' )
721 9995 format(
' Matrix types: ', / )
723 9994 format(
' TYPE 1: Da is diagonal, Db is identity, ',
724 $ /
' A = Y^(-H) Da X^(-1), B = Y^(-H) Db X^(-1) ',
725 $ /
' YH and X are left and right eigenvectors. ', / )
727 9993 format(
' TYPE 2: Da is quasi-diagonal, Db is identity, ',
728 $ /
' A = Y^(-H) Da X^(-1), B = Y^(-H) Db X^(-1) ',
729 $ /
' YH and X are left and right eigenvectors. ', / )
731 9992 format( /
' Tests performed: ', / 4x,
732 $
' a is alpha, b is beta, l is a left eigenvector, ', / 4x,
733 $
' r is a right eigenvector and ', a,
' means ', a,
'.',
734 $ /
' 1 = max | ( b A - a B )', a,
' l | / const.',
735 $ /
' 2 = max | ( b A - a B ) r | / const.',
736 $ /
' 3 = max ( Sest/Stru, Stru/Sest ) ',
737 $
' over all eigenvalues', /
738 $
' 4 = max( DIFest/DIFtru, DIFtru/DIFest ) ',
739 $
' over the 1st and 5th eigenvectors', / )
741 9991 format(
' Type=', i2,
',',
' IWA=', i2,
', IWB=', i2,
', IWX=',
742 $ i2,
', IWY=', i2,
', result ', i2,
' is', 0p, f8.2 )
744 9990 format(
' Type=', i2,
',',
' IWA=', i2,
', IWB=', i2,
', IWX=',
745 $ i2,
', IWY=', i2,
', result ', i2,
' is', 1p, e10.3 )
747 9989 format(
' Input example #', i2,
', matrix order=', i4,
',',
748 $
' result ', i2,
' is', 0p, f8.2 )
750 9988 format(
' Input example #', i2,
', matrix order=', i4,
',',
751 $
' result ', i2,
' is', 1p, e10.3 )
753 9987 format(
' CDRGVX: ', a,
' returned INFO=', i6,
'.', / 9x,
'N=',
754 $ i6,
', Input example #', i2,
')' )
756 9986 format(
' CDRGVX: ', a,
' Eigenvectors from ', a,
' incorrectly ',
757 $
'normalized.', /
' Bits of error=', 0p, g10.3,
',', 9x,
758 $
'N=', i6,
', Input Example #', i2,
')' )