pcsdpsubtst.f

Go to the documentation of this file.

      SUBROUTINE pcsdpsubtst( WKNOWN, UPLO, N, THRESH, ABSTOL, A, COPYA,
     $                        Z, IA, JA, DESCA, WIN, WNEW, IPREPAD,
     $                        IPOSTPAD, WORK, LWORK, RWORK, LRWORK,
     $                        LWORK1, IWORK, LIWORK, RESULT, TSTNRM,
     $                        QTQNRM, NOUT )
*
*  -- ScaLAPACK testing routine (version 1.7) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     February 28, 2000
*
*     .. Scalar Arguments ..
      LOGICAL            WKNOWN
      CHARACTER          UPLO
      INTEGER            IA, IPOSTPAD, IPREPAD, JA, LIWORK, LRWORK,
     $                   LWORK, LWORK1, N, NOUT, RESULT
      REAL               ABSTOL, QTQNRM, THRESH, TSTNRM
*     ..
*     .. Array Arguments ..
      INTEGER            DESCA( * ), IWORK( * )
      REAL               RWORK( * ), WIN( * ), WNEW( * )
      COMPLEX            A( * ), COPYA( * ), WORK( * ), Z( * )
*     ..
*
*  Purpose
*  =======
*
*  PCSDPSUBTST calls PCHEEVD and then tests the output of
*  PCHEEVD
*  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
*     PCHEEVD 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
*
*  UPLO    (global input) CHARACTER*1
*          Specifies whether the upper or lower triangular part of the
*          Hermitian 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) REAL
*          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) REAL
*          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. If eigenvectors are
*          desired later by inverse iteration ("PCSTEIN"),
*          "abstol" MUST NOT be bigger than ulp*|T|.
*
*  A       (local workspace) COMPLEX array
*          global dimension (N, N), local dimension (DESCA(DLEN_), NQ)
*            A is distributed in a block cyclic manner over both rows
*            and columns.
*            See PCHEEVD for a description of block cyclic layout.
*          The test matrix, which is then modified by PCHEEVD
*          A has already been padded front and back, use A(1+IPREPAD)
*
*  COPYA   (local input) COMPLEX array, dimension(N*N)
*          COPYA holds a copy of the original matrix A
*          identical in both form and content to A
*
*  Z       (local workspace) COMPLEX 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
*          PCSEPCHK and PCSEPQTQ.
*          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) REAL 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)  REAL array, dimension (N)
*          The eigenvalues as copmuted by this call to PCHEEVD
*          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)
*
*  WORK    (local workspace) COMPLEX 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.
*
*  RWORK   (local workspace) REAL array, dimension (LRWORK)
*          RWORK has already been padded front and back,
*          use RWORK(1+IPREPAD)
*
*  LRWORK   (local input) INTEGER
*          The actual length of the array RWORK after padding.
*
*  LWORK1  (local input) INTEGER
*          The amount of real workspace to pass to PCHEEVD
*
*  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 to PCHEEVD
*          RESULT = -3   =>  This process did not participate
*          RESULT = 0    =>  All tests passed
*          RESULT = 1    =>  ONe or more tests failed
*
*  TSTNRM  (global output) REAL
*          |AQ- QL| / (ABSTOL+EPS*|A|)*N
*
*  QTQNRM  (global output) REAL
*          |QTQ -I| / N*EPS
*
*     .. Parameters ..
*
      INTEGER            BLOCK_CYCLIC_2D, DLEN_, DTYPE_, CTXT_, M_, N_,
     $                   MB_, NB_, RSRC_, CSRC_, LLD_
      PARAMETER          ( BLOCK_CYCLIC_2D = 1, dlen_ = 9, dtype_ = 1,
     $                   ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
     $                   rsrc_ = 7, csrc_ = 8, lld_ = 9 )
      REAL               PADVAL, FIVE, NEGONE
      parameter( padval = 13.5285e+0, five = 5.0e+0,
     $                   negone = -1.0e+0 )
      COMPLEX            CPADVAL
      parameter( cpadval = ( 13.989e+0, 1.93e+0 ) )
      INTEGER            IPADVAL
      PARAMETER          ( IPADVAL = 927 )
      COMPLEX            CZERO, CONE, CNEGONE
      parameter( czero = 0.0e+0, cone = 1.0e+0,
     $                   cnegone = -1.0e+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, IAM, INFO, ISIZEHEEVD, ISIZEHEEVX,
     $                   ISIZESUBTST, ISIZETST, MYCOL, MYROW, NP, NPCOL,
     $                   NPROW, NQ, RES, RSIZECHK, RSIZEHEEVD,
     $                   RSIZEHEEVX, RSIZEQTQ, RSIZESUBTST, RSIZETST,
     $                   sizeheevd, sizeheevx, sizemqrleft,
     $                   sizemqrright, sizeqrf, sizesubtst, sizetms,
     $                   sizetst
      REAL               EPS, EPSNORMA, ERROR, MAXERROR, MINERROR, NORM,
     $                   NORMWIN, SAFMIN, ULP
*     ..
*     .. Local Arrays ..
      INTEGER            ITMP( 2 )
*     ..
*     .. External Functions ..
*
      INTEGER            NUMROC
      REAL               PCLANGE, PCLANHE, PSLAMCH
      EXTERNAL           NUMROC, PCLANGE, PCLANHE, PSLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           blacs_gridinfo, clacpy, igamn2d, igamx2d,
     $                   pcchekpad, pcfillpad, pcgemm, pcheevd, pclaset,
     $                   pclasizesep, pcsepchk, pichekpad, pifillpad,
     $                   pschekpad, psfillpad, slboot, sltimer
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max, min, real
*     ..
*     .. Executable Statements ..
*       This is just to keep ftnchek happy
      IF( block_cyclic_2d*csrc_*ctxt_*dlen_*dtype_*lld_*mb_*m_*nb_*n_*
     $    rsrc_.LT.0 )RETURN
*
      CALL pclasizesep( desca, iprepad, ipostpad, sizemqrleft,
     $                  sizemqrright, sizeqrf, sizetms, rsizeqtq,
     $                  rsizechk, sizeheevx, rsizeheevx, isizeheevx,
     $                  sizeheevd, rsizeheevd, isizeheevd, sizesubtst,
     $                  rsizesubtst, isizesubtst, sizetst, rsizetst,
     $                  isizetst )
*
      tstnrm = negone
      qtqnrm = negone
      eps = pslamch( desca( ctxt_ ), 'Eps' )
      safmin = pslamch( desca( ctxt_ ), 'Safe min' )
*
      normwin = safmin / eps
      IF( n.GE.1 )
     $   normwin = max( abs( win( 1+iprepad ) ),
     $             abs( win( n+iprepad ) ), normwin )
*
      DO 10 i = 1, lwork1, 1
         rwork( i+iprepad ) = 14.3e+0
   10 CONTINUE
      DO 20 i = 1, liwork, 1
         iwork( i ) = 14
   20 CONTINUE
      DO 30 i = 1, lwork, 1
         work( i+iprepad ) = ( 15.63e+0, 1.1e+0 )
   30 CONTINUE
*
      DO 40 i = 1, n
         wnew( i+iprepad ) = 3.14159e+0
   40 CONTINUE
*
      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 60
      result = 0
*
      np = numroc( n, desca( mb_ ), myrow, 0, nprow )
      nq = numroc( n, desca( nb_ ), mycol, 0, npcol )
*
      CALL clacpy( 'A', np, nq, copya, desca( lld_ ), a( 1+iprepad ),
     $             desca( lld_ ) )
*
      CALL pcfillpad( desca( ctxt_ ), np, nq, a, desca( lld_ ), iprepad,
     $                ipostpad, cpadval )
*
      CALL pcfillpad( desca( ctxt_ ), np, nq, z, desca( lld_ ), iprepad,
     $                ipostpad, cpadval+1.0e+0 )
*
      CALL psfillpad( desca( ctxt_ ), n, 1, wnew, n, iprepad, ipostpad,
     $                padval+2.0e+0 )
*
      CALL psfillpad( desca( ctxt_ ), lwork1, 1, rwork, lwork1, iprepad,
     $                ipostpad, padval+4.0e+0 )
*
      CALL pifillpad( desca( ctxt_ ), liwork, 1, iwork, liwork, iprepad,
     $                ipostpad, ipadval )
*
      CALL pcfillpad( desca( ctxt_ ), lwork, 1, work, lwork, iprepad,
     $                ipostpad, cpadval+4.1e+0 )
*
      CALL slboot
      CALL sltimer( 1 )
      CALL sltimer( 6 )
*
      CALL pcheevd( 'V', uplo, n, a( 1+iprepad ), ia, ja, desca,
     $              wnew( 1+iprepad ), z( 1+iprepad ), ia, ja, desca,
     $              work( 1+iprepad ), sizeheevd, rwork( 1+iprepad ),
     $              lwork1, iwork( 1+iprepad ), liwork, info )
      CALL sltimer( 6 )
      CALL sltimer( 1 )
*
      IF( thresh.LE.0 ) THEN
         result = 0
      ELSE
         CALL pcchekpad( desca( ctxt_ ), 'PCHEEVD-A', np, nq, a,
     $                   desca( lld_ ), iprepad, ipostpad, cpadval )
*
         CALL pcchekpad( desca( ctxt_ ), 'PCHEEVD-Z', np, nq, z,
     $                   desca( lld_ ), iprepad, ipostpad,
     $                   cpadval+1.0e+0 )
*
         CALL pschekpad( desca( ctxt_ ), 'PCHEEVD-WNEW', n, 1, wnew, n,
     $                   iprepad, ipostpad, padval+2.0e+0 )
*
         CALL pschekpad( desca( ctxt_ ), 'PCHEEVD-rWORK', lwork1, 1,
     $                   rwork, lwork1, iprepad, ipostpad,
     $                   padval+4.0e+0 )
*
         CALL pcchekpad( desca( ctxt_ ), 'PCHEEVD-WORK', lwork, 1, work,
     $                   lwork, iprepad, ipostpad, cpadval+4.1e+0 )
*
         CALL pichekpad( desca( ctxt_ ), 'PCHEEVD-IWORK', liwork, 1,
     $                   iwork, liwork, iprepad, ipostpad, ipadval )
*
*     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
.NE.         ELSE IF( INFO0 ) THEN
.EQ.            IF( IAM0 )
     $         WRITE( NOUT, FMT = 9996 )INFO
            RESULT = 1
         END IF
*
*     Compute eps * norm(A)
*
.EQ.         IF( N0 ) THEN
            EPSNORMA = EPS
         ELSE
            EPSNORMA = PCLANHE( 'i', UPLO, N, COPYA, IA, JA, DESCA,
     $                 RWORK )*EPS
         END IF
*
*     Note that a couple key variables get redefined in PCSEPCHK
*     as described by this table:
*
*     PCSEPTST name         PCSEPCHK name
*     -------------         -------------
*     COPYA                 A
*     Z                     Q
*     A                     C
*
*     Perform the |AQ - QE| test
*
         CALL PSFILLPAD( DESCA( CTXT_ ), RSIZECHK, 1, RWORK, RSIZECHK,
     $                   IPREPAD, IPOSTPAD, 4.3E+0 )
*
         CALL PCSEPCHK( N, N, COPYA, IA, JA, DESCA,
     $                  MAX( ABSTOL+EPSNORMA, SAFMIN ), THRESH,
     $                  Z( 1+IPREPAD ), IA, JA, DESCA, A( 1+IPREPAD ),
     $                  IA, JA, DESCA, WNEW( 1+IPREPAD ),
     $                  RWORK( 1+IPREPAD ), RSIZECHK, TSTNRM, RES )
*
         CALL PSCHEKPAD( DESCA( CTXT_ ), 'pcsdpchk-rwork', RSIZECHK, 1,
     $                   RWORK, RSIZECHK, IPREPAD, IPOSTPAD, 4.3E+0 )
*
.NE.         IF( RES0 ) THEN
            RESULT = 1
            WRITE( NOUT, FMT = 9995 )
         END IF
*
*     Perform the |QTQ - I| test
*
         CALL PSFILLPAD( DESCA( CTXT_ ), RSIZEQTQ, 1, RWORK, RSIZEQTQ,
     $                   IPREPAD, IPOSTPAD, 4.3E+0 )
*
*
         RES = 0
         ULP = PSLAMCH( DESCA( CTXT_ ), 'p' )
         CALL PCLASET( 'a', N, N, CZERO, CONE, A( 1+IPREPAD ), IA, JA,
     $                 DESCA )
         CALL PCGEMM( 'conjugate transpose', 'n', N, N, N, CNEGONE,
     $                Z( 1+IPREPAD ), IA, JA, DESCA, Z( 1+IPREPAD ), IA,
     $                JA, DESCA, CONE, A( 1+IPREPAD ), IA, JA, DESCA )
         NORM = PCLANGE( '1', N, N, A( 1+IPREPAD ), IA, JA, DESCA,
     $          WORK( 1+IPREPAD ) )
         QTQNRM = NORM / ( REAL( MAX( N, 1 ) )*ULP )
.GT.         IF( QTQNRMTHRESH ) THEN
            RES = 1
         END IF
         CALL PSCHEKPAD( DESCA( CTXT_ ), 'pcsepqtq-rwork', RSIZEQTQ, 1,
     $                   RWORK, RSIZEQTQ, IPREPAD, IPOSTPAD, 4.3E+0 )
*
.NE.         IF( RES0 ) THEN
            RESULT = 1
            WRITE( NOUT, FMT = 9994 )
         END IF
*
.NE.         IF( INFO0 ) THEN
.EQ.            IF( IAM0 )
     $         WRITE( NOUT, FMT = 9998 )INFO
            RESULT = 1
         END IF
*
.NE.         IF( INFO0 ) THEN
.EQ.            IF( IAM0 )
     $         WRITE( NOUT, FMT = 9998 )INFO
            RESULT = 1
         END IF
      END IF
*
*     Check to make sure that we have the right eigenvalues
*
.AND..GT.      IF( WKNOWN  N0 ) THEN
*
*     Find the largest difference between the computed
*     and expected eigenvalues
*
         MINERROR = NORMWIN
         MAXERROR = 0.0
*
         DO 50 I = 1, N
            ERROR = ABS( WIN( I+IPREPAD )-WNEW( I+IPREPAD ) )
            MAXERROR = MAX( MAXERROR, ERROR )
   50    CONTINUE
         MINERROR = MIN( MAXERROR, MINERROR )
*
.GT.         IF( MINERRORNORMWIN*FIVE*THRESH*EPS ) THEN
.EQ.            IF( IAM0 )
     $         WRITE( NOUT, FMT = 9997 )MINERROR, NORMWIN
            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 )
*
   60 CONTINUE
*
      RETURN
*
 9999 FORMAT( 'pcheevd returned info=', I7 )
 9998 FORMAT( 'pcsepqtq returned info=', I7 )
 9997 FORMAT( 'pcsdpsubtst minerror =', D11.2, ' normwin=', D11.2 )
 9996 FORMAT( 'pcheevd returned info=', I7,
     $      ' despite adequate workspace' )
 9995 FORMAT( 'pcheevd failed the |aq -qe| test' )
 9994 FORMAT( 'pcheevd failed the |qtq -i| test' )
*
*     End of PCSDPSUBTST
*
      END