pdsqpsubtst()

subroutine pdsqpsubtst	(	logical	wknown,
		character	jobz,
		character	uplo,
		integer	n,
		double precision	thresh,
		double precision	abstol,
		double precision, dimension( * )	a,
		double precision, dimension( * )	copya,
		double precision, dimension( * )	z,
		integer	ia,
		integer	ja,
		integer, dimension( * )	desca,
		double precision, dimension( * )	win,
		double precision, dimension( * )	wnew,
		integer	iprepad,
		integer	ipostpad,
		double precision, dimension( * )	work,
		integer	lwork,
		integer	lwork1,
		integer	result,
		double precision	tstnrm,
		double precision	qtqnrm,
		integer	nout
	)

Definition at line 3 of file pdsqpsubtst.f.

*
*  -- ScaLAPACK routine (version 1.7) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     November 15, 1997
*
*     .. Scalar Arguments ..
      LOGICAL            WKNOWN
      CHARACTER          JOBZ, UPLO
      INTEGER            IA, IPOSTPAD, IPREPAD, JA, LWORK, LWORK1, N,
     $                   NOUT, RESULT
      DOUBLE PRECISION   ABSTOL, QTQNRM, THRESH, TSTNRM
*     ..
*     .. Array Arguments ..
      INTEGER            DESCA( * )
      DOUBLE PRECISION   A( * ), COPYA( * ), WIN( * ), WNEW( * ), 
     $                   WORK( * ), Z( * )
*     ..
*
*  Purpose
*  =======
*
*  PDSQPSUBTST calls PDSYEV and then tests the output of
*  PDSYEV
*  If JOBZ = 'V' then the following two tests are performed:
*     |AQ -QL| / (abstol + eps * norm(A) ) < N*THRESH
*     |QT * Q - I| / eps * norm(A) < 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 as computed by
*     PDSYEV when eigenvectors are requested
*
*  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 to PDSQPSUBTST
*
*  UPLO    (global input) CHARACTER*1
*          Specifies whether the upper or lower triangular part of the
*          symmetric matrix A is stored:
*          = 'U':  Upper triangular
*          = 'L':  Lower triangular
*
*  N       (global input) INTEGER
*          Size of the matrix to be tested.  (global size)
*
*  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., 10 or 100.  In particular,
*          it should not depend on the precision (single vs. double)
*          or the size of the matrix.  It must be at least zero.
*
*  ABSTOL  (global input) DOUBLE PRECISION
*          The absolute tolerance for the eigenvalues. An
*          eigenvalue is considered to be located if it has
*          been determined to lie in an interval whose width
*          is "abstol" or less. If "abstol" is less than or equal
*          to zero, then ulp*|T| will be used, where |T| is
*          the 1-norm of the matrix.
*
*  A       (local workspace) DOUBLE PRECISION array
*          global dimension (N, N), local dimension (DESCA(DLEN_), NQ)
*          A is distributed in a block cyclic manner over both rows
*          and columns.
*          See PDSYEV for a description of block cyclic layout.
*          The test matrix, which is then modified by PDSYEV
*          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 eigenvalues as computed by this call to PDSYEV.
*          WNEW has already been padded front and back,
*          use WNEW(1+IPREPAD)
*
*  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 PDSYEV
*
*  RESULT  (global output) INTEGER
*          The result of this call to PDSYEV
*          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            BLOCK_CYCLIC_2D, DLEN_, DT_, CTXT_, M_, N_,
     $                   MB_, NB_, RSRC_, CSRC_, LLD_
      parameter( block_cyclic_2d = 1, dlen_ = 9, dt_ = 1,
     $                   ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
     $                   rsrc_ = 7, csrc_ = 8, lld_ = 9 )
      DOUBLE PRECISION   FIVE, NEGONE, PADVAL, ZERO
      parameter( padval = 13.5285d+0, five = 5.0d+0,
     $                   negone = -1.0d+0, zero = 0.0d+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, IAM, INFO, ISIZESUBTST, ISIZESYEVX,
     $                   ISIZETST, J, EIGS, MINSIZE, MQ, MYCOL, MYROW,
     $                   NP, NPCOL, NPROW, NQ, RESAQ, RESQTQ,
     $                   SIZECHK, SIZEMQRLEFT, SIZEMQRRIGHT, SIZEQRF,
     $                   SIZEQTQ, SIZESUBTST, SIZESYEV, SIZESYEVX,
     $                   SIZETMS, SIZETST,SIZESYEVD, ISIZESYEVD 
      DOUBLE PRECISION   EPS, EPSNORMA, ERROR, MAXERROR, MINERROR, 
     $                   NORMWIN, SAFMIN
*     ..
*     .. Local Arrays ..
      INTEGER            DESCZ( DLEN_ ), ITMP( 2 ),
     $                   IWORK( 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, pdlasizesqp, pdsepchk, pdsepqtq, 
     $                   pdsyev, slboot, sltimer
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max, min, mod
*     ..
*     .. Executable Statements ..
*       This is just to keep ftnchek happy
      IF( block_cyclic_2d*csrc_*ctxt_*dlen_*dt_*lld_*mb_*m_*nb_*n_*
     $    rsrc_.LT.0 )RETURN
      CALL pdlasizesqp( desca, iprepad, ipostpad, sizemqrleft,
     $                  sizemqrright, sizeqrf, sizetms, sizeqtq,
     $                  sizechk, sizesyevx, isizesyevx, sizesyev,
     $                  sizesyevd, isizesyevd, 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+iprepad ) ),
     $                  abs( win( n+iprepad ) ), normwin )
*
*     Make sure that we aren't using information from previous calls
*
      DO 10 i = 1, lwork1, 1
         work( i+iprepad ) = 14.3d+0
   10 CONTINUE
*
      DO 30 i = 1, n
         wnew( i+iprepad ) = 3.14159d+0
   30 CONTINUE
*
      DO 40 i = 1, 2
         iwork( i ) = 0
   40 CONTINUE
*
      IF( lsame( jobz, 'N' ) ) THEN
         eigs = 0
      ELSE
         eigs = n
      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 )
*
      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
*
      np = numroc( n, desca( mb_ ), myrow, 0, nprow )
      nq = numroc( n, desca( nb_ ), mycol, 0, npcol )
      mq = numroc( eigs, desca( nb_ ), mycol, 0, npcol )
*
*     Find the amount of workspace needed with or without eigenvectors.
*
      CALL pdlasizesyev( jobz, n, desca, minsize )
*
      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.0d+0 )
*
      CALL pdfillpad( desca( ctxt_ ), n, 1, wnew, n, iprepad, ipostpad,
     $                padval+2.0d+0 )
*
      CALL pdfillpad( desca( ctxt_ ), lwork1, 1, work, lwork1, iprepad,
     $                ipostpad, padval+4.0d+0 )
*
*     Make sure that PDSYEV does not cheat (i.e. use answers
*     already computed.)
*
      DO 60 i = 1, n, 1
         DO 50 j = 1, eigs, 1
            CALL pdelset( z( 1+iprepad ), i, j, desca, 13.0d+0 )
   50    CONTINUE
   60 CONTINUE
*
      CALL slboot
      CALL sltimer( 1 )
      CALL sltimer( 6 )
      CALL pdsyev( jobz, uplo, n, a( 1+iprepad ), ia, ja, desca,
     $             wnew( 1+iprepad ), z( 1+iprepad ), ia, ja, desca,
     $             work( 1+iprepad ), lwork1, info )
      CALL sltimer( 6 )
      CALL sltimer( 1 )
*
      IF( thresh.LE.0 ) THEN
         result = 0
      ELSE
         CALL pdchekpad( desca( ctxt_ ), 'PDSYEV-A', np, nq, a,
     $                   desca( lld_ ), iprepad, ipostpad, padval )
*
         CALL pdchekpad( descz( ctxt_ ), 'PDSYEV-Z', np, mq, z,
     $                   descz( lld_ ), iprepad, ipostpad,
     $                   padval+1.0d+0 )
*
         CALL pdchekpad( desca( ctxt_ ), 'PDSYEV-WNEW', n, 1, wnew, n,
     $                   iprepad, ipostpad, padval+2.0d+0 )
*
         CALL pdchekpad( desca( ctxt_ ), 'PDSYEV-WORK', lwork1, 1,
     $                   work, lwork1, iprepad, ipostpad,
     $                   padval+4.0d+0 )
*
*     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 )
*
*
         IF( itmp( 1 ).NE.itmp( 2 ) ) THEN
            IF( iam.EQ.0 )
     $         WRITE( nout, fmt = * )
     $         'Different processes return different INFO'
            result = 1
         ELSE IF( info.NE.0 ) THEN
            IF( iam.EQ.0 ) THEN
               WRITE( nout, fmt = 9999 )info
               IF( info.EQ.(n+1) )
     $            WRITE( nout, fmt = 9994 )
               result = 1
            END IF
         ELSE IF( info.EQ.14 .AND. lwork1.GE.minsize ) THEN
            IF( iam.EQ.0 )
     $         WRITE( nout, fmt = 9996 )info
            result = 1
         END IF
*
         IF( result.EQ.0 .OR. info.GT.n ) THEN
*
*     Make sure that different processes return the same eigenvalues.
*     This is a more exhaustive check that provided by PDSYEV.
*
            DO 70 i = 1, n
               work( i ) = wnew( i+iprepad )
               work( i+n ) = wnew( i+iprepad )
 70         CONTINUE
*
            CALL dgamn2d( desca( ctxt_ ), 'a', ' ', n, 1, work, n, 1,
     $                    1, -1, -1, 0 )
            CALL dgamx2d( desca( ctxt_ ), 'a', ' ', n, 1,
     $                    work( 1+n ), n, 1, 1, -1, -1, 0 )
*
            DO 80 i = 1, n
*
               IF( abs( work( i )-work( n+i ) ).GT.zero ) THEN
                  IF( iam.EQ.0 ) 
     $                 WRITE( nout, fmt = 9995 )
                  result = 1
                  GO TO 90
               END IF
 80         CONTINUE
 90         CONTINUE
         END IF
*
         CALL igamx2d( desca( ctxt_ ), 'a', ' ', 1, 1, result, 1, 1, 1,
     $                 -1, -1, 0 )
*
*     Compute eps * norm(A)
*
         IF( n.EQ.0 ) THEN
            epsnorma = eps
         ELSE
            epsnorma = pdlansy( 'I', uplo, n, copya, ia, ja, desca,
     $                 work )*eps
         END IF
*
*     Note that a couple key variables get redefined in PDSEPCHK
*     as described by this table:
*
*     PDSEPTST name         PDSEPCHK name
*     -------------         -------------
*     COPYA                 A
*     Z                     Q
*     A                     C
*
*
         IF( lsame( jobz, 'V' ) ) THEN
*
*     Perform the |AQ - QE| test
*
            CALL pdfillpad( desca( ctxt_ ), sizechk, 1, work, sizechk,
     $                      iprepad, ipostpad, 4.3d+0 )
*
            resaq = 0
*
            CALL pdsepchk( n, n, 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, resaq )
*
            CALL pdchekpad( desca( ctxt_ ), 'PDSEPCHK-WORK', sizechk, 1,
     $                      work, sizechk, iprepad, ipostpad, 4.3d+0 )
*
            IF( resaq.NE.0 ) THEN
               result = 1
               WRITE( nout, fmt = 9993 )
            END IF
*
*     Perform the |QTQ - I| test
*
            CALL pdfillpad( desca( ctxt_ ), sizeqtq, 1, work, sizeqtq,
     $                      iprepad, ipostpad, 4.3d+0 )
*
            resqtq = 0
*
            CALL pdsepqtq( n, n, thresh, z( 1+iprepad ), ia, ja, descz,
     $                     a( 1+iprepad ), ia, ja, desca,
     $                     iwork( 1 ), iwork( 1 ), work( 1 ),
     $                     work( iprepad+1 ), sizeqtq, qtqnrm, info,
     $                     resqtq )
*
            CALL pdchekpad( desca( ctxt_ ), 'PDSEPQTQ-WORK', sizeqtq, 1,
     $                      work, sizeqtq, iprepad, ipostpad, 4.3d+0 )
*
            IF( resqtq.NE.0 ) THEN
               result = 1
               WRITE( nout, fmt = 9992 )
            END IF
*
            IF( info.NE.0 ) THEN
               IF( iam.EQ.0 )
     $              WRITE( nout, fmt = 9998 )info
               result = 1
            END IF
         END IF
*
*     Check to make sure that we have the right eigenvalues
*
         IF( wknown .AND. n.GT.0 ) THEN
*
*     Find the largest difference between the computed
*     and expected eigenvalues
*
            minerror = normwin
            maxerror = 0
*
            DO 140 i = 1, n
               error = abs( win( i+iprepad )-wnew( i+iprepad ) )
               maxerror = max( maxerror, error )
 140        CONTINUE
            minerror = min( maxerror, minerror )
*
            IF( minerror.GT.normwin*five*thresh*eps ) THEN
               IF( iam.EQ.0 )
     $              WRITE( nout, fmt = 9997 )minerror, normwin
               result = 1
            END IF
         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( 'PDSYEV returned INFO=', i7 )
 9998 FORMAT( 'PDSEPQTQ in PDSQPSUBTST returned INFO=', i7 )
 9997 FORMAT( 'PDSQPSUBTST minerror =', d11.2, ' normwin=', d11.2 )
 9996 FORMAT( 'PDSYEV returned INFO=', i7,
     $      ' despite adequate workspace' )
 9995 FORMAT( 'Different processes return different eigenvalues' )
 9994 FORMAT( 'Heterogeneity detected by PDSYEV' )
 9993 FORMAT( 'PDSYEV failed the |AQ -QE| test' )
 9992 FORMAT( 'PDSYEV failed the |QTQ -I| test' )
*
*     End of PDSQPSUBTST
*

Here is the call graph for this function:

Here is the caller graph for this function: