pdseprsubtst.f

Go to the documentation of this file.

      SUBROUTINE pdseprsubtst( WKNOWN, JOBZ, RANGE, UPLO, N, VL, VU, IL,
     $                         IU, THRESH, ABSTOL, A, COPYA, Z, IA, JA,
     $                         DESCA, WIN, WNEW, IFAIL, ICLUSTR, GAP,
     $                         IPREPAD, IPOSTPAD, WORK, LWORK, LWORK1,
     $                         IWORK, LIWORK, RESULT, TSTNRM, QTQNRM,
     $                         NOUT )
*
*  -- ScaLAPACK routine (@(MODE)version *TBA*) --
*     University of California, Berkeley and
*     University of Tennessee, Knoxville. 
*     October 21, 2006
*
      IMPLICIT NONE
*
*     .. Scalar Arguments ..
      LOGICAL            WKNOWN
      CHARACTER          JOBZ, RANGE, UPLO
      INTEGER            IA, IL, IPOSTPAD, IPREPAD, IU, JA, LIWORK,
     $                   LWORK, LWORK1, N, NOUT, RESULT
      DOUBLE PRECISION   ABSTOL, QTQNRM, THRESH, TSTNRM, VL, VU
*     ..
*     .. Array Arguments ..
      INTEGER            DESCA( * ), ICLUSTR( * ), IFAIL( * ),
     $                   IWORK( * )
      DOUBLE PRECISION   A( * ), COPYA( * ), GAP( * ), WIN( * ),
     $                   WNEW( * ), WORK( * ), Z( * )
*     ..
*
*  Purpose
*  =======
*
*  PDSEPRSUBTST calls PDSYEVR and then tests its output.
*  If JOBZ = 'V' then the following two tests are performed:
*     |AQ -QL| / (abstol + eps * norm(A) ) < N*THRESH
*     |QT * Q - I| / eps < N*THRESH
*  If WKNOWN then
*     we check to make sure that the eigenvalues match expectations
*     i.e. |WIN - WNEW(1+IPREPAD)| / (eps * |WIN|) < THRESH
*     where WIN is the array of eigenvalues computed.
*
*  Arguments
*  =========
*
*     NP = the number of rows local to a given process.
*     NQ = the number of columns local to a given process.
*
*  WKNOWN  (global input) INTEGER
*          .FALSE.:  WIN does not contain the eigenvalues
*          .TRUE.:   WIN does contain the eigenvalues
*
*  JOBZ    (global input) CHARACTER*1
*          Specifies whether or not to compute the eigenvectors:
*          = 'N':  Compute eigenvalues only.
*          = 'V':  Compute eigenvalues and eigenvectors.
*          Must be 'V' on first call.
*
*  RANGE   (global input) CHARACTER*1
*          = 'A': all eigenvalues will be found.
*          = 'V': all eigenvalues in the interval [VL,VU]
*                 will be found.
*          = 'I': the IL-th through IU-th eigenvalues will be found.
*          Must be 'A' on first call.
*
*  UPLO    (global input) CHARACTER*1
*          Specifies whether the upper or lower triangular part of the
*          matrix A is stored:
*          = 'U':  Upper triangular
*          = 'L':  Lower triangular
*
*  N       (global input) INTEGER
*          Size of the matrix to be tested.  (global size)
*
*  VL      (global input) DOUBLE PRECISION
*          If RANGE='V', the lower bound of the interval to be searched
*          for eigenvalues.  Not referenced if RANGE = 'A' or 'I'.
*
*  VU      (global input) DOUBLE PRECISION
*          If RANGE='V', the upper bound of the interval to be searched
*          for eigenvalues.  Not referenced if RANGE = 'A' or 'I'.
*
*  IL      (global input) INTEGER
*          If RANGE='I', the index (from smallest to largest) of the
*          smallest eigenvalue to be returned.  IL >= 1.
*          Not referenced if RANGE = 'A' or 'V'.
*
*  IU      (global input) INTEGER
*          If RANGE='I', the index (from smallest to largest) of the
*          largest eigenvalue to be returned.  min(IL,N) <= IU <= N.
*          Not referenced if RANGE = 'A' or 'V'.
*
*  THRESH  (global input) DOUBLE PRECISION
*          A test will count as "failed" if the "error", computed as
*          described below, exceeds THRESH.  Note that the error
*          is scaled to be O(1), so THRESH should be a reasonably
*          small multiple of 1, e.g., 100 or 250.  In particular,
*          it should not depend on the size of the matrix.  
*          It must be at least zero.
*
*  ABSTOL  (global input) DOUBLE PRECISION
*          The absolute tolerance for the residual test.
*
*  A       (local workspace) DOUBLE PRECISION array
*          global dimension (N, N), local dimension (DESCA(DLEN_), NQ)
*          The test matrix, which is subsequently overwritten.
*          A is distributed in a 2D-block cyclic manner over both rows
*          and columns.
*          A has already been padded front and back, use A(1+IPREPAD)
*
*  COPYA   (local input) DOUBLE PRECISION array, dimension(N*N)
*          COPYA holds a copy of the original matrix A
*          identical in both form and content to A
*
*  Z       (local workspace) DOUBLE PRECISION array, dim (N*N)
*          Z is distributed in the same manner as A
*          Z contains the eigenvector matrix
*          Z is used as workspace by the test routines
*          PDSEPCHK and PDSEPQTQ.
*          Z has already been padded front and back, use Z(1+IPREPAD)
*
*  IA      (global input) INTEGER
*          On entry, IA specifies the global row index of the submatrix
*          of the global matrix A, COPYA and Z to operate on.
*
*  JA      (global input) INTEGER
*          On entry, IA specifies the global column index of the submat
*          of the global matrix A, COPYA and Z to operate on.
*
*  DESCA   (global/local input) INTEGER array of dimension 8
*          The array descriptor for the matrix A, COPYA and Z.
*
*  WIN     (global input) DOUBLE PRECISION array, dimension (N)
*          If .not. WKNOWN, WIN is ignored on input
*          Otherwise, WIN() is taken as the standard by which the
*          eigenvalues are to be compared against.
*
*  WNEW    (global workspace)  DOUBLE PRECISION array, dimension (N)
*          The computed eigenvalues.
*          If JOBZ <> 'V' or RANGE <> 'A' these eigenvalues are
*          compared against those in WIN().
*          WNEW has already been padded front and back,
*          use WNEW(1+IPREPAD)
*
*  IFAIL   (global output) INTEGER array, dimension (N)
*          If JOBZ = 'V', then on normal exit, the first M elements of
*          IFAIL are zero.  If INFO > 0 on exit, then IFAIL contains the
*          indices of the eigenvectors that failed to converge.
*          If JOBZ = 'N', then IFAIL is not referenced.
*          IFAIL has already been padded front and back,
*          use IFAIL(1+IPREPAD)
*
*  ICLUSTR (global workspace) integer array, dimension (2*NPROW*NPCOL)
*
*  GAP     (global workspace) DOUBLE PRECISION array,
*          dimension (NPROW*NPCOL)
*
*  WORK    (local workspace) DOUBLE PRECISION array, dimension (LWORK)
*          WORK has already been padded front and back,
*          use WORK(1+IPREPAD)
*
*  LWORK   (local input) INTEGER
*          The actual length of the array WORK after padding.
*
*  LWORK1  (local input) INTEGER
*          The amount of real workspace to pass to the eigensolver.
*
*  IWORK   (local workspace) INTEGER array, dimension (LIWORK)
*          IWORK has already been padded front and back,
*          use IWORK(1+IPREPAD)
*
*  LIWORK  (local input) INTEGER
*          The length of the array IWORK after padding.
*
*  RESULT  (global output) INTEGER
*          The result of this call.
*          RESULT = -3   =>  This process did not participate
*          RESULT = 0    =>  All tests passed
*          RESULT = 1    =>  ONe or more tests failed
*
*  TSTNRM  (global output) DOUBLE PRECISION
*          |AQ- QL| / (ABSTOL+EPS*|A|)*N
*
*  QTQNRM  (global output) DOUBLE PRECISION
*          |QTQ -I| / N*EPS
*
*     .. Parameters ..
*
      INTEGER            DLEN_, CTXT_, M_, N_,
     $                   MB_, NB_, RSRC_, CSRC_, LLD_
      PARAMETER          ( DLEN_ = 9, 
     $                   ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
     $                   rsrc_ = 7, csrc_ = 8, lld_ = 9 )
      DOUBLE PRECISION   PADVAL, FIVE, NEGONE
      PARAMETER          ( PADVAL = 13.5285d0, five = 5.0d0,
     $                   negone = -1.0d0 )
      INTEGER            IPADVAL
      PARAMETER          ( IPADVAL = 927 )
*     ..
*     .. Local Scalars ..
      LOGICAL            MISSLARGEST, MISSSMALLEST
      INTEGER            I, IAM, INDIWRK, INFO, ISIZESUBTST, ISIZEEVR,
     $                   isizetst, j, m, maxeigs, maxil, maxiu, maxsize,
     $                   minil, mq, mycol, myil, myrow, nclusters, np,
     $                   npcol, nprow, nq, nz, oldil, oldiu, oldnz, res,
     $                   sizechk, sizemqrleft, sizemqrright, sizeqrf,
     $                   sizeqtq, sizesubtst, sizeevr, sizetms,
     $                   sizetst, valsize, vecsize
      DOUBLE PRECISION   EPS, EPSNORMA, ERROR, MAXERROR, MAXVU,
     $                   MINERROR, MINVL, NORMWIN, OLDVL, OLDVU, 
     $                   SAFMIN
*     ..
*     .. Local Arrays ..
      INTEGER            DESCZ( DLEN_ ), ISEED( 4 ), ITMP( 2 )
*     ..
*     .. External Functions ..
*
      LOGICAL            LSAME
      INTEGER            NUMROC
      DOUBLE PRECISION   PDLAMCH, PDLANSY
      EXTERNAL           LSAME, NUMROC, PDLAMCH, PDLANSY
*     ..
*     .. External Subroutines ..
      EXTERNAL           blacs_gridinfo, descinit, dgamn2d, dgamx2d,
     $                   dlacpy, igamn2d, igamx2d, pdchekpad, pdelset,
     $                   pdfillpad, pdlasizesepr, pdlasizesyevr,
     $                   pdsepchk, pdsepqtq, pdsyevr, pichekpad,
     $                   pifillpad, slboot, sltimer
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max, min, mod
*     ..
*     .. Executable Statements ..
*
      CALL pdlasizesepr( desca, iprepad, ipostpad, sizemqrleft,
     $                   sizemqrright, sizeqrf, sizetms, sizeqtq,
     $                   sizechk, sizeevr, isizeevr, sizesubtst,
     $                   isizesubtst, sizetst, isizetst )
*
      tstnrm = negone
      qtqnrm = negone
      eps = pdlamch( desca( ctxt_ ), 'Eps' )
      safmin = pdlamch( desca( ctxt_ ), 'Safe min' )
*
      normwin = safmin / eps
      IF( n.GE.1 )
     $   normwin = max( abs( win( 1 ) ), abs( win( n ) ), normwin )
*
*     Make sure that no information from previous calls is used
*
      nz = -13
      oldnz = nz
      oldil = il
      oldiu = iu
      oldvl = vl
      oldvu = vu
*
      DO 10 i = 1, lwork1, 1
         work( i+iprepad ) = 14.3d0
   10 CONTINUE
*
      DO 20 i = 1, liwork, 1
         iwork( i+iprepad ) = 14
   20 CONTINUE
*
      DO 30 i = 1, n
         wnew( i+iprepad ) = 3.14159d0
   30 CONTINUE
*
      iclustr( 1+iprepad ) = 139
*
      IF (lsame( range, 'V' ) ) THEN
*        WRITE(*,*) 'VL VU = ', VL, ' ', VU
      END IF
 
      IF( lsame( jobz, 'N' ) ) THEN
         maxeigs = 0
      ELSE
         IF( lsame( range, 'A' ) ) THEN
            maxeigs = n
         ELSE IF( lsame( range, 'I' ) ) THEN
            maxeigs = iu - il + 1
         ELSE
            minvl = vl - normwin*five*eps - abstol
            maxvu = vu + normwin*five*eps + abstol
*            WRITE(*,*) 'MINVL = ', MINVL, ' MAXVU = ', MAXVU
*            WRITE(*,*) 'WIN = ', WIN( 1 )
            minil = 1
            maxiu = 0
            DO 40 i = 1, n
               IF( win( i ).LT.minvl )
     $            minil = minil + 1
               IF( win( i ).LE.maxvu )
     $            maxiu = maxiu + 1
   40       CONTINUE
*
            maxeigs = maxiu - minil + 1
         END IF
      END IF
*
*
      CALL descinit( descz, desca( m_ ), desca( n_ ), desca( mb_ ),
     $               desca( nb_ ), desca( rsrc_ ), desca( csrc_ ),
     $               desca( ctxt_ ), desca( lld_ ), info )
*
      CALL blacs_gridinfo( desca( ctxt_ ), nprow, npcol, myrow, mycol )
      indiwrk = 1 + iprepad + nprow*npcol + 1
*
      iam = 1
      IF( myrow.EQ.0 .AND. mycol.EQ.0 )
     $   iam = 0
*
*     If this process is not involved in this test, bail out now
*
      result = -3
      IF( myrow.GE.nprow .OR. myrow.LT.0 )
     $   GO TO 150
      result = 0
*
      iseed( 1 ) = 1
*
      CALL pdlasizesyevr( wknown, range, n, desca, vl, vu, il, iu,
     $                    iseed, win, maxsize, vecsize, valsize )
*
      np = numroc( n, desca( mb_ ), myrow, 0, nprow )
      nq = numroc( n, desca( nb_ ), mycol, 0, npcol )
      mq = numroc( maxeigs, desca( nb_ ), mycol, 0, npcol )
*
      CALL dlacpy( 'A', np, nq, copya, desca( lld_ ), a( 1+iprepad ),
     $             desca( lld_ ) )
*
      CALL pdfillpad( desca( ctxt_ ), np, nq, a, desca( lld_ ), iprepad,
     $                ipostpad, padval )
*
      CALL pdfillpad( descz( ctxt_ ), np, mq, z, descz( lld_ ), iprepad,
     $                ipostpad, padval+1.0d0 )
*
*      WRITE(*,*) ' NP = ', NP, ' MQ = ', MQ, ' LDZ = ', DESCZ( LLD_ ),
*     $           ' IPREPAD = ', IPREPAD, ' IPOSTPAD = ', IPOSTPAD,
*     $           ' MAXEIGS = ', MAXEIGS
*      WRITE(*,*) ' PADZ( 1 ) = ', Z( 1 ), ' PADZ( 2 ) = ', Z( 2 ),
*     $           ' PADZ( 3 ) = ', Z( 3 ), ' PADZ( 4 ) = ', Z( 4 )
*
      CALL pdfillpad( desca( ctxt_ ), n, 1, wnew, n, iprepad, ipostpad,
     $                padval+2.0d0 )
*
      CALL pdfillpad( desca( ctxt_ ), nprow*npcol, 1, gap, nprow*npcol,
     $                iprepad, ipostpad, padval+3.0d0 )
*
      CALL pdfillpad( desca( ctxt_ ), lwork1, 1, work, lwork1, iprepad,
     $                ipostpad, padval+4.0d0 )
*
      CALL pifillpad( desca( ctxt_ ), liwork, 1, iwork, liwork, iprepad,
     $                ipostpad, ipadval )
*
      CALL pifillpad( desca( ctxt_ ), n, 1, ifail, n, iprepad, ipostpad,
     $                ipadval )
*
      CALL pifillpad( desca( ctxt_ ), 2*nprow*npcol, 1, iclustr,
     $                2*nprow*npcol, iprepad, ipostpad, ipadval )
*
*     Make sure that PDSYEVR does not cheat (i.e. use answers
*     already computed.)
*
      DO 60 i = 1, n, 1
         DO 50 j = 1, maxeigs, 1
            CALL pdelset( z( 1+iprepad ), i, j, desca, 13.0d0 )
   50    CONTINUE
   60 CONTINUE
*
*     Reset and start the timer
*
      CALL slboot
      CALL sltimer( 1 )
      CALL sltimer( 6 )
 
*********************************
*
*     Main call to PDSYEVR
*
      CALL pdsyevr( jobz, range, uplo, n, a( 1+iprepad ), ia, ja, desca,
     $              vl, vu, il, iu, m, nz, wnew( 1+iprepad ),
     $              z( 1+iprepad ), ia, ja, desca,
     $              work( 1+iprepad ), lwork1, iwork( 1+iprepad ),
     $              liwork, info )
*
*********************************
*
*     Stop timer
*
      CALL sltimer( 6 )
      CALL sltimer( 1 )
*
*     Indicate that there are no unresolved clusters. 
*     This is necessary so that the tester 
*     (adapted from the one originally made for PDSYEVX) 
*     works correctly.
      iclustr( 1+iprepad ) = 0
*
      IF( thresh.LE.0 ) THEN    
         result = 0 
      ELSE  
         CALL pdchekpad( desca( ctxt_ ), 'PDSYEVR-A', np, nq, a,
     $                   desca( lld_ ), iprepad, ipostpad, padval )
*
         CALL pdchekpad( descz( ctxt_ ), 'PDSYEVR-Z', np, mq, z,
     $                   descz( lld_ ), iprepad, ipostpad,
     $                   padval+1.0d0 )
*
         CALL pdchekpad( desca( ctxt_ ), 'PDSYEVR-WNEW', n, 1, wnew, n,
     $                   iprepad, ipostpad, padval+2.0d0 )
*
         CALL pdchekpad( desca( ctxt_ ), 'PDSYEVR-GAP', nprow*npcol, 1,
     $                   gap, nprow*npcol, iprepad, ipostpad,
     $                   padval+3.0d0 )
*
         CALL pdchekpad( desca( ctxt_ ), 'PDSYEVR-WORK', lwork1, 1,
     $                   work, lwork1, iprepad, ipostpad,
     $                   padval+4.0d0 )
*
         CALL pichekpad( desca( ctxt_ ), 'PDSYEVR-IWORK', liwork, 1,
     $                   iwork, liwork, iprepad, ipostpad, ipadval )
*
        CALL pichekpad( desca( ctxt_ ), 'pdsyevr-ifail', N, 1, IFAIL,
     $                   N, IPREPAD, IPOSTPAD, IPADVAL )
*
         CALL PICHEKPAD( DESCA( CTXT_ ), 'pdsyevr-iclustr',
     $                   2*NPROW*NPCOL, 1, ICLUSTR, 2*NPROW*NPCOL,
     $                   IPREPAD, IPOSTPAD, IPADVAL )
*
*        If we now know the spectrum, we can potentially reduce MAXSIZE.
*
         IF( LSAME( RANGE, 'a' ) ) THEN
            CALL PDLASIZESYEVR( .TRUE., RANGE, N, DESCA, VL, VU, IL, IU,
     $                          ISEED, WNEW( 1+IPREPAD ), MAXSIZE,
     $                          VECSIZE, VALSIZE )
         END IF
*
*        Check INFO
*        Make sure that all processes return the same value of INFO
*
         ITMP( 1 ) = INFO
         ITMP( 2 ) = INFO
*
         CALL IGAMN2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, ITMP, 1, 1, 1,
     $                 -1, -1, 0 )
         CALL IGAMX2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, ITMP( 2 ), 1, 1,
     $                 1, -1, -1, 0 )
*
*
.NE.         IF( ITMP( 1 )ITMP( 2 ) ) THEN
.EQ.            IF( IAM0 )
     $         WRITE( NOUT, FMT = * )
     $         'different processes return different info'
            RESULT = 1
.EQ..OR..GT..OR..LT.         ELSE IF( MOD( INFO, 2 )1  INFO7  INFO0 )
     $             THEN
.EQ.            IF( IAM0 )
     $         WRITE( NOUT, FMT = 9999 )INFO
            RESULT = 1
.EQ..AND..GE.         ELSE IF( MOD( INFO / 2, 2 )1  LWORK1MAXSIZE ) THEN
.EQ.            IF( IAM0 )
     $         WRITE( NOUT, FMT = 9996 )INFO
            RESULT = 1
.EQ..AND..GE.         ELSE IF( MOD( INFO / 4, 2 )1  LWORK1VECSIZE ) THEN
.EQ.            IF( IAM0 )
     $         WRITE( NOUT, FMT = 9996 )INFO
            RESULT = 1
         END IF
*
         IF( LSAME( JOBZ, 'v.AND..NE.' )  ( ICLUSTR( 1+IPREPAD )
.AND..NE.     $       0 )  ( MOD( INFO / 2, 2 )1 ) ) THEN
.EQ.            IF( IAM0 )
     $         WRITE( NOUT, FMT = 9995 )
            RESULT = 1
         END IF
*
*        Check M
*
.LT..OR..GT.         IF( ( M0 )  ( MN ) ) THEN
.EQ.            IF( IAM0 )
     $         WRITE( NOUT, FMT = 9994 )
               WRITE( NOUT,*) 'm = ', M, '\n', 'n = ', N
            RESULT = 1
         ELSE IF( LSAME( RANGE, 'a.AND..NE.' )  ( MN ) ) THEN
.EQ.            IF( IAM0 )
     $         WRITE( NOUT, FMT = 9993 )
            RESULT = 1
         ELSE IF( LSAME( RANGE, 'i.AND..NE.' )  ( MIU-IL+1 ) ) THEN
.EQ.            IF( IAM0 ) THEN
               WRITE( NOUT, FMT = 9992 )
               WRITE( NOUT,*) 'il = ', IL, ' iu = ', IU, ' m = ', M
            END IF
            RESULT = 1
         ELSE IF( LSAME( JOBZ, 'v.AND.' ) 
.NOT.     $            ( ( LSAME( RANGE, 'v.AND..NE.' ) ) )  ( MNZ ) )
     $             THEN
.EQ.            IF( IAM0 )
     $         WRITE( NOUT, FMT = 9991 )
            RESULT = 1
         END IF
*
*        Check NZ
*
         IF( LSAME( JOBZ, 'v' ) ) THEN
            IF( LSAME( RANGE, 'v' ) ) THEN
.GT.               IF( NZM ) THEN
.EQ.                  IF( IAM0 )
     $               WRITE( NOUT, FMT = 9990 )
                  RESULT = 1
               END IF
.LT..AND..NE.               IF( NZM  MOD( INFO / 4, 2 )1 ) THEN
.EQ.                  IF( IAM0 )
     $               WRITE( NOUT, FMT = 9989 )
                  RESULT = 1
               END IF
            ELSE
.NE.               IF( NZM ) THEN
.EQ.                  IF( IAM0 )
     $               WRITE( NOUT, FMT = 9988 )
                  RESULT = 1
               END IF
            END IF
         END IF
.EQ.         IF( RESULT0 ) THEN
*
*           Make sure that all processes return the same # of eigenvalues
*
            ITMP( 1 ) = M
            ITMP( 2 ) = M
*
            CALL IGAMN2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, ITMP, 1, 1, 1,
     $                    -1, -1, 0 )
            CALL IGAMX2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, ITMP( 2 ), 1,
     $                    1, 1, -1, -1, 0 )
*
.NE.            IF( ITMP( 1 )ITMP( 2 ) ) THEN
.EQ.               IF( IAM0 )
     $            WRITE( NOUT, FMT = 9987 )
               RESULT = 1
            ELSE
*
*              Ensure that different processes return the same eigenvalues
*
               DO 70 I = 1, M
                  WORK( I ) = WNEW( I+IPREPAD )
                  WORK( I+M ) = WNEW( I+IPREPAD )
   70          CONTINUE
*
               CALL DGAMN2D( DESCA( CTXT_ ), 'a', ' ', M, 1, WORK, M, 1,
     $                       1, -1, -1, 0 )
               CALL DGAMX2D( DESCA( CTXT_ ), 'a', ' ', M, 1,
     $                       WORK( 1+M ), M, 1, 1, -1, -1, 0 )
*
               DO 80 I = 1, M
.EQ..AND.                  IF( RESULT0  ( ABS( WORK( I )-WORK( M+
.GT.     $                I ) )FIVE*EPS*ABS( WORK( I ) ) ) ) THEN
.EQ.                     IF( IAM0 )
     $                  WRITE( NOUT, FMT = 9986 )
                     RESULT = 1
                  END IF
   80          CONTINUE
            END IF
         END IF
*
*        Make sure that all processes return the same # of clusters
*
         IF( LSAME( JOBZ, 'v' ) ) THEN
            NCLUSTERS = 0
            DO 90 I = 0, NPROW*NPCOL - 1
.EQ.               IF( ICLUSTR( 1+IPREPAD+2*I )0 )
     $            GO TO 100
               NCLUSTERS = NCLUSTERS + 1
   90       CONTINUE
  100       CONTINUE
            ITMP( 1 ) = NCLUSTERS
            ITMP( 2 ) = NCLUSTERS
*
            CALL IGAMN2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, ITMP, 1, 1, 1,
     $                    -1, -1, 0 )
            CALL IGAMX2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, ITMP( 2 ), 1,
     $                    1, 1, -1, -1, 0 )
*
.NE.            IF( ITMP( 1 )ITMP( 2 ) ) THEN
.EQ.               IF( IAM0 )
     $            WRITE( NOUT, FMT = 9985 )
               RESULT = 1
            ELSE
*
*              Make sure that different processes return the same clusters
*
               DO 110 I = 1, NCLUSTERS
                  IWORK( INDIWRK+I ) = ICLUSTR( I+IPREPAD )
                  IWORK( INDIWRK+I+NCLUSTERS ) = ICLUSTR( I+IPREPAD )
  110          CONTINUE
               CALL IGAMN2D( DESCA( CTXT_ ), 'a', ' ', NCLUSTERS*2+1, 1,
     $                       IWORK( INDIWRK+1 ), NCLUSTERS*2+1, 1, 1,
     $                       -1, -1, 0 )
               CALL IGAMX2D( DESCA( CTXT_ ), 'a', ' ', NCLUSTERS*2+1, 1,
     $                       IWORK( INDIWRK+1+NCLUSTERS ),
     $                       NCLUSTERS*2+1, 1, 1, -1, -1, 0 )
*
               DO 120 I = 1, NCLUSTERS
.EQ..AND..NE.                  IF( RESULT0  IWORK( INDIWRK+I )
     $                IWORK( INDIWRK+NCLUSTERS+I ) ) THEN
.EQ.                     IF( IAM0 )
     $                  WRITE( NOUT, FMT = 9984 )
                     RESULT = 1
                  END IF
  120          CONTINUE
*
.NE.               IF( ICLUSTR( 1+IPREPAD+NCLUSTERS*2 )0 ) THEN
.EQ.                  IF( IAM0 )
     $               WRITE( NOUT, FMT = 9983 )
                  RESULT = 1
               END IF
            END IF
         END IF
*
         CALL IGAMX2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, RESULT, 1, 1, 1,
     $                 -1, -1, 0 )
.NE.         IF( RESULT0 )
     $      GO TO 150
*
*        Compute eps * norm(A)
*
.EQ.         IF( N0 ) THEN
            EPSNORMA = EPS
         ELSE
            EPSNORMA = PDLANSY( 'i', UPLO, N, COPYA, IA, JA, DESCA,
     $                 WORK )*EPS
         END IF
*
         IF( LSAME( JOBZ, 'v' ) ) THEN
*
*           Perform the |A Z - Z W| test
*
            CALL PDFILLPAD( DESCA( CTXT_ ), SIZECHK, 1, WORK, SIZECHK,
     $                      IPREPAD, IPOSTPAD, 4.3D0 )
*
            CALL PDSEPCHK( N, NZ, COPYA, IA, JA, DESCA,
     $                     MAX( ABSTOL+EPSNORMA, SAFMIN ), THRESH,
     $                     Z( 1+IPREPAD ), IA, JA, DESCZ,
     $                     A( 1+IPREPAD ), IA, JA, DESCA,
     $                     WNEW( 1+IPREPAD ), WORK( 1+IPREPAD ),
     $                     SIZECHK, TSTNRM, RES )
*
            CALL PDCHEKPAD( DESCA( CTXT_ ), 'pdsepchk-work', SIZECHK, 1,
     $                      WORK, SIZECHK, IPREPAD, IPOSTPAD, 4.3D0 )
*
.NE.            IF( RES0 )
     $         RESULT = 1
*
*           Perform the |QTQ - I| test
*
            CALL PDFILLPAD( DESCA( CTXT_ ), SIZEQTQ, 1, WORK, SIZEQTQ,
     $                      IPREPAD, IPOSTPAD, 4.3D0 )
*
*
            CALL PDSEPQTQ( N, NZ, THRESH, Z( 1+IPREPAD ), IA, JA, DESCZ,
     $                     A( 1+IPREPAD ), IA, JA, DESCA,
     $                     IWORK( 1+IPREPAD+1 ), ICLUSTR( 1+IPREPAD ),
     $                     GAP( 1+IPREPAD ), WORK( IPREPAD+1 ), SIZEQTQ,
     $                     QTQNRM, INFO, RES )
*
            CALL PDCHEKPAD( DESCA( CTXT_ ), 'pdsepqtq-work', SIZEQTQ, 1,
     $                      WORK, SIZEQTQ, IPREPAD, IPOSTPAD, 4.3D0 )
*
.NE.            IF( RES0 )
     $         RESULT = 1
*
.NE.            IF( INFO0 ) THEN
.EQ.               IF( IAM0 )
     $            WRITE( NOUT, FMT = 9998 )INFO
               RESULT = 1
            END IF
         END IF
*
*        Check to make sure that the right eigenvalues have been obtained
*
         IF( WKNOWN ) THEN
*           Set up MYIL if necessary
            MYIL = IL
*
            IF( LSAME( RANGE, 'v' ) ) THEN
               MYIL = 1
               MINIL = 1
               MAXIL = N - M + 1
            ELSE
               IF( LSAME( RANGE, 'a' ) ) THEN
                  MYIL = 1
               END IF
               MINIL = MYIL
               MAXIL = MYIL
            END IF
*
*           Find the largest difference between the computed
*           and expected eigenvalues
*
            MINERROR = NORMWIN
*
            DO 140 MYIL = MINIL, MAXIL
               MAXERROR = 0
*
*              Make sure that we aren't skipping any important eigenvalues
*
               MISSSMALLEST = .TRUE.
.NOT.               IF( LSAME( RANGE, 'v.OR..EQ.' )  ( MYIL1 ) )
     $            MISSSMALLEST = .FALSE.
.AND..LT.               IF( MISSSMALLEST  ( WIN( MYIL-1 )VL+NORMWIN*
     $             FIVE*THRESH*EPS ) )MISSSMALLEST = .FALSE.
               MISSLARGEST = .TRUE.
.NOT.               IF( LSAME( RANGE, 'v.OR..EQ.' )  ( MYILMAXIL ) )
     $            MISSLARGEST = .FALSE.
.AND..GT.               IF( MISSLARGEST  ( WIN( MYIL+M )VU-NORMWIN*FIVE*
     $             THRESH*EPS ) )MISSLARGEST = .FALSE.
.NOT.               IF( MISSSMALLEST ) THEN
.NOT.                  IF( MISSLARGEST ) THEN
*
*                    Make sure that the eigenvalues that we report are OK
*
                     DO 130 I = 1, M
*                        WRITE(*,*) 'WIN WNEW = ', WIN( I+MYIL-1 ),
*     $                             WNEW( I+IPREPAD ) 
                        ERROR = ABS( WIN( I+MYIL-1 )-WNEW( I+IPREPAD ) )
                        MAXERROR = MAX( MAXERROR, ERROR )
  130                CONTINUE
*
                     MINERROR = MIN( MAXERROR, MINERROR )
                  END IF
               END IF
  140       CONTINUE
*
*           If JOBZ = 'V' and RANGE='A', we might be comparing
*           against our estimate of what the eigenvalues ought to
*           be, rather than comparing against what was computed
*           last time around, so we have to be more generous.
*
            IF( LSAME( JOBZ, 'v.AND.' )  LSAME( RANGE, 'a' ) ) THEN
.GT.               IF( MINERRORNORMWIN*FIVE*FIVE*THRESH*EPS ) THEN
.EQ.                  IF( IAM0 )
     $               WRITE( NOUT, FMT = 9997 )MINERROR, NORMWIN
                  RESULT = 1
               END IF
            ELSE
.GT.               IF( MINERRORNORMWIN*FIVE*THRESH*EPS ) THEN
.EQ.                  IF( IAM0 )
     $               WRITE( NOUT, FMT = 9997 )MINERROR, NORMWIN
                  RESULT = 1
               END IF
            END IF
         END IF
*
*        Make sure that the IL, IU, VL and VU were not altered
*
.NE..OR..NE..OR..NE..OR..NE.         IF( ILOLDIL  IUOLDIU  VLOLDVL  VU
     $       OLDVU ) THEN
.EQ.            IF( IAM0 )
     $         WRITE( NOUT, FMT = 9982 )
            RESULT = 1
         END IF
*
         IF( LSAME( JOBZ, 'n.AND..NE.' )  ( NZOLDNZ ) ) THEN
.EQ.            IF( IAM0 )
     $         WRITE( NOUT, FMT = 9981 )
            RESULT = 1
         END IF
*
      END IF
*
*     All processes should report the same result
*
      CALL IGAMX2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, RESULT, 1, 1, 1, -1,
     $              -1, 0 )
*
  150 CONTINUE
*
      RETURN
*
 9999 FORMAT( 'pdsyevr returned info=', I7 )
 9998 FORMAT( 'pdsepqtq returned info=', i7 )
 9997 FORMAT( 'PDSEPRSUBTST minerror =', d11.2, ' normwin=', d11.2 )
 9996 FORMAT( 'PDSYEVR returned INFO=', i7,
     $      ' despite adequate workspace' )
 9995 FORMAT( .NE..NE.'ICLUSTR(1)0 but mod(INFO/2,2)1' )
 9994 FORMAT( 'M not in the range 0 to N' )
 9993 FORMAT( 'M not equal to N' )
 9992 FORMAT( 'M not equal to IU-IL+1' )
 9991 FORMAT( 'M not equal to NZ' )
 9990 FORMAT( 'NZ > M' )
 9989 FORMAT( 'NZ < M' )
 9988 FORMAT( 'NZ not equal to M' )
 9987 FORMAT( 'Different processes return different values for M' )
 9986 FORMAT( 'Different processes return different eigenvalues' )
 9985 FORMAT( 'Different processes return ',
     $      'different numbers of clusters' )
 9984 FORMAT( 'Different processes return different clusters' )
 9983 FORMAT( 'ICLUSTR not zero terminated' )
 9982 FORMAT( 'IL, IU, VL or VU altered by PDSYEVR' )
 9981 FORMAT( 'NZ altered by PDSYEVR with JOBZ=N' )
*
*     End of PDSEPRSUBTST
*
      END