ScaLAPACK  2.0.2
ScaLAPACK: Scalable Linear Algebra PACKage
pzheev.f
Go to the documentation of this file.
00001       SUBROUTINE PZHEEV( JOBZ, UPLO, N, A, IA, JA, DESCA, W, Z, IZ, JZ,
00002      $                   DESCZ, WORK, LWORK, RWORK, LRWORK, INFO )
00003 *
00004 *  -- ScaLAPACK routine (version 1.7) --
00005 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
00006 *     and University of California, Berkeley.
00007 *     August 14, 2001 
00008 *
00009 *     .. Scalar Arguments ..
00010       CHARACTER          JOBZ, UPLO
00011       INTEGER            IA, INFO, IZ, JA, JZ, LRWORK, LWORK, N
00012 *     ..
00013 *     .. Array Arguments ..
00014       INTEGER            DESCA( * ), DESCZ( * )
00015       DOUBLE PRECISION   RWORK( * ), W( * )
00016       COMPLEX*16         A( * ), WORK( * ), Z( * )
00017 *     ..
00018 *
00019 *  Purpose
00020 *  =======
00021 *
00022 *  PZHEEV computes selected eigenvalues and, optionally, eigenvectors
00023 *  of a complex Hermitian matrix A by calling the recommended sequence
00024 *  of ScaLAPACK routines.
00025 *
00026 *  In its present form, PZHEEV assumes a homogeneous system and makes
00027 *  only spot checks of the consistency of the eigenvalues across the
00028 *  different processes.  Because of this, it is possible that a
00029 *  heterogeneous system may return incorrect results without any error
00030 *  messages.
00031 *
00032 *  Notes
00033 *  =====
00034 *  A description vector is associated with each 2D block-cyclicly dis-
00035 *  tributed matrix.  This vector stores the information required to
00036 *  establish the mapping between a matrix entry and its corresponding
00037 *  process and memory location.
00038 *
00039 *  In the following comments, the character _ should be read as
00040 *  "of the distributed matrix".  Let A be a generic term for any 2D
00041 *  block cyclicly distributed matrix.  Its description vector is DESCA:
00042 *
00043 *  NOTATION        STORED IN      EXPLANATION
00044 *  --------------- -------------- --------------------------------------
00045 *  DTYPE_A(global) DESCA( DTYPE_) The descriptor type.
00046 *  CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
00047 *                                 the BLACS process grid A is distribu-
00048 *                                 ted over. The context itself is glo-
00049 *                                 bal, but the handle (the integer
00050 *                                 value) may vary.
00051 *  M_A    (global) DESCA( M_ )    The number of rows in the distributed
00052 *                                 matrix A.
00053 *  N_A    (global) DESCA( N_ )    The number of columns in the distri-
00054 *                                 buted matrix A.
00055 *  MB_A   (global) DESCA( MB_ )   The blocking factor used to distribute
00056 *                                 the rows of A.
00057 *  NB_A   (global) DESCA( NB_ )   The blocking factor used to distribute
00058 *                                 the columns of A.
00059 *  RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
00060 *                                 row of the matrix A is distributed.
00061 *  CSRC_A (global) DESCA( CSRC_ ) The process column over which the
00062 *                                 first column of A is distributed.
00063 *  LLD_A  (local)  DESCA( LLD_ )  The leading dimension of the local
00064 *                                 array storing the local blocks of the
00065 *                                 distributed matrix A.
00066 *                                 LLD_A >= MAX(1,LOCr(M_A)).
00067 *
00068 *  Let K be the number of rows or columns of a distributed matrix,
00069 *  and assume that its process grid has dimension p x q.
00070 *  LOCr( K ) denotes the number of elements of K that a process
00071 *  would receive if K were distributed over the p processes of its
00072 *  process column.
00073 *  Similarly, LOCc( K ) denotes the number of elements of K that a
00074 *  process would receive if K were distributed over the q processes of
00075 *  its process row.
00076 *  The values of LOCr() and LOCc() may be determined via a call to the
00077 *  ScaLAPACK tool function, NUMROC:
00078 *          LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
00079 *          LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
00080 *
00081 *  Arguments
00082 *  =========
00083 *
00084 *     NP = the number of rows local to a given process.
00085 *     NQ = the number of columns local to a given process.
00086 *
00087 *  JOBZ    (global input) CHARACTER*1
00088 *          Specifies whether or not to compute the eigenvectors:
00089 *          = 'N':  Compute eigenvalues only.
00090 *          = 'V':  Compute eigenvalues and eigenvectors.
00091 *
00092 *  UPLO    (global input) CHARACTER*1
00093 *          Specifies whether the upper or lower triangular part of the
00094 *          Hermitian matrix A is stored:
00095 *          = 'U':  Upper triangular
00096 *          = 'L':  Lower triangular
00097 *
00098 *  N       (global input) INTEGER
00099 *          The number of rows and columns of the matrix A.  N >= 0.
00100 *
00101 *  A       (local input/workspace) block cyclic COMPLEX*16 array,
00102 *          global dimension (N, N), local dimension ( LLD_A,
00103 *          LOCc(JA+N-1) )
00104 *
00105 *          On entry, the Hermitian matrix A.  If UPLO = 'U', only the
00106 *          upper triangular part of A is used to define the elements of
00107 *          the Hermitian matrix.  If UPLO = 'L', only the lower
00108 *          triangular part of A is used to define the elements of the
00109 *          Hermitian matrix.
00110 *
00111 *          On exit, the lower triangle (if UPLO='L') or the upper
00112 *          triangle (if UPLO='U') of A, including the diagonal, is
00113 *          destroyed.
00114 *
00115 *  IA      (global input) INTEGER
00116 *          A's global row index, which points to the beginning of the
00117 *          submatrix which is to be operated on.
00118 *
00119 *  JA      (global input) INTEGER
00120 *          A's global column index, which points to the beginning of
00121 *          the submatrix which is to be operated on.
00122 *
00123 *  DESCA   (global and local input) INTEGER array of dimension DLEN_.
00124 *          The array descriptor for the distributed matrix A.
00125 *          If DESCA( CTXT_ ) is incorrect, PZHEEV cannot guarantee
00126 *          correct error reporting.
00127 *
00128 *  W       (global output) DOUBLE PRECISION array, dimension (N)
00129 *          If INFO=0, the eigenvalues in ascending order.
00130 *
00131 *  Z       (local output) COMPLEX*16 array,
00132 *          global dimension (N, N),
00133 *          local dimension (LLD_Z, LOCc(JZ+N-1))
00134 *          If JOBZ = 'V', then on normal exit the first M columns of Z
00135 *          contain the orthonormal eigenvectors of the matrix
00136 *          corresponding to the selected eigenvalues.
00137 *          If JOBZ = 'N', then Z is not referenced.
00138 *
00139 *  IZ      (global input) INTEGER
00140 *          Z's global row index, which points to the beginning of the
00141 *          submatrix which is to be operated on.
00142 *
00143 *  JZ      (global input) INTEGER
00144 *          Z's global column index, which points to the beginning of
00145 *          the submatrix which is to be operated on.
00146 *
00147 *  DESCZ   (global and local input) INTEGER array of dimension DLEN_.
00148 *          The array descriptor for the distributed matrix Z.
00149 *          DESCZ( CTXT_ ) must equal DESCA( CTXT_ )
00150 *
00151 *  WORK    (local workspace/output) COMPLEX*16 array,
00152 *          dimension (LWORK)
00153 *          On output, WORK(1) returns the workspace needed to guarantee
00154 *          completion.  If the input parameters are incorrect, WORK(1)
00155 *          may also be incorrect.
00156 *
00157 *          If JOBZ='N' WORK(1) = minimal workspace for eigenvalues only.
00158 *          If JOBZ='V' WORK(1) = minimal workspace required to
00159 *             generate all the eigenvectors.
00160 *
00161 *
00162 *  LWORK   (local input) INTEGER
00163 *          See below for definitions of variables used to define LWORK.
00164 *          If no eigenvectors are requested (JOBZ = 'N') then
00165 *             LWORK >= MAX( NB*( NP0+1 ), 3 ) +3*N
00166 *          If eigenvectors are requested (JOBZ = 'V' ) then
00167 *          the amount of workspace required:
00168 *             LWORK >= (NP0 + NQ0 + NB)*NB + 3*N + N^2
00169 *
00170 *          Variable definitions:
00171 *             NB = DESCA( MB_ ) = DESCA( NB_ ) =
00172 *                  DESCZ( MB_ ) = DESCZ( NB_ )
00173 *             NP0 = NUMROC( NN, NB, 0, 0, NPROW )
00174 *             NQ0 = NUMROC( MAX( N, NB, 2 ), NB, 0, 0, NPCOL )
00175 *
00176 *          If LWORK = -1, the LWORK is global input and a workspace
00177 *          query is assumed; the routine only calculates the minimum
00178 *          size for the WORK array.  The required workspace is returned
00179 *          as the first element of WORK and no error message is issued
00180 *          by PXERBLA.
00181 *
00182 *  RWORK   (local workspace/output) COMPLEX*16 array,
00183 *          dimension (LRWORK)
00184 *          On output RWORK(1) returns the
00185 *          DOUBLE PRECISION workspace needed to
00186 *          guarantee completion.  If the input parameters are incorrect,
00187 *          RWORK(1) may also be incorrect.
00188 *
00189 *  LRWORK  (local input) INTEGER
00190 *          Size of RWORK array.
00191 *          If eigenvectors are desired (JOBZ = 'V') then
00192 *             LRWORK >= 2*N + 2*N-2
00193 *          If eigenvectors are not desired (JOBZ = 'N') then
00194 *             LRWORK >= 2*N
00195 *
00196 *          If LRWORK = -1, the LRWORK is global input and a workspace
00197 *          query is assumed; the routine only calculates the minimum
00198 *          size for the RWORK array.  The required workspace is returned
00199 *          as the first element of RWORK and no error message is issued
00200 *          by PXERBLA.
00201 *
00202 *  INFO    (global output) INTEGER
00203 *          = 0:  successful exit
00204 *          < 0:  If the i-th argument is an array and the j-entry had
00205 *                an illegal value, then INFO = -(i*100+j), if the i-th
00206 *                argument is a scalar and had an illegal value, then
00207 *                INFO = -i.
00208 *          > 0:  If INFO = 1 through N, the i(th) eigenvalue did not
00209 *                converge in ZSTEQR2 after a total of 30*N iterations.
00210 *                If INFO = N+1, then PZHEEV has detected heterogeneity
00211 *                by finding that eigenvalues were not identical across
00212 *                the process grid.  In this case, the accuracy of
00213 *                the results from PZHEEV cannot be guaranteed.
00214 *
00215 *  Alignment requirements
00216 *  ======================
00217 *
00218 *  The distributed submatrices A(IA:*, JA:*) and C(IC:IC+M-1,JC:JC+N-1)
00219 *  must verify some alignment properties, namely the following
00220 *  expressions should be true:
00221 *
00222 *  ( MB_A.EQ.NB_A.EQ.MB_Z .AND. IROFFA.EQ.IROFFZ .AND. IROFFA.EQ.0 .AND.
00223 *    IAROW.EQ.IZROW )
00224 *  where
00225 *  IROFFA = MOD( IA-1, MB_A ) and ICOFFA = MOD( JA-1, NB_A ).
00226 *
00227 *  =====================================================================
00228 *
00229 *  Version 1.4 limitations:
00230 *     DESCA(MB_) = DESCA(NB_)
00231 *     DESCA(M_) = DESCZ(M_)
00232 *     DESCA(N_) = DESCZ(N_)
00233 *     DESCA(MB_) = DESCZ(MB_)
00234 *     DESCA(NB_) = DESCZ(NB_)
00235 *     DESCA(RSRC_) = DESCZ(RSRC_)
00236 *
00237 *     .. Parameters ..
00238       INTEGER            BLOCK_CYCLIC_2D, DLEN_, DTYPE_, CTXT_, M_, N_,
00239      $                   MB_, NB_, RSRC_, CSRC_, LLD_
00240       PARAMETER          ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
00241      $                   CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
00242      $                   RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
00243       DOUBLE PRECISION   ZERO, ONE
00244       PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
00245       COMPLEX*16         CZERO, CONE
00246       PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ),
00247      $                   CONE = ( 1.0D+0, 0.0D+0 ) )
00248       INTEGER            ITHVAL
00249       PARAMETER          ( ITHVAL = 10 )
00250 *     ..
00251 *     .. Local Scalars ..
00252       LOGICAL            LOWER, WANTZ
00253       INTEGER            CONTEXTC, CSRC_A, I, IACOL, IAROW, ICOFFA,
00254      $                   IINFO, INDD, INDE, INDRD, INDRE, INDRWORK,
00255      $                   INDTAU, INDWORK, INDWORK2, IROFFA, IROFFZ,
00256      $                   ISCALE, IZROW, J, K, LDC, LLRWORK, LLWORK,
00257      $                   LRMIN, LRWMIN, LWMIN, MB_A, MB_Z, MYCOL,
00258      $                   MYPCOLC, MYPROWC, MYROW, NB, NB_A, NB_Z, NP0,
00259      $                   NPCOL, NPCOLC, NPROCS, NPROW, NPROWC, NQ0, NRC,
00260      $                   RSIZEZSTEQR2, RSRC_A, RSRC_Z, SIZEPZHETRD,
00261      $                   SIZEPZUNMTR, SIZEZSTEQR2
00262       DOUBLE PRECISION   ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
00263      $                   SMLNUM
00264 *     ..
00265 *     .. Local Arrays ..
00266       INTEGER            DESCQR( 10 ), IDUM1( 3 ), IDUM2( 3 )
00267 *     ..
00268 *     .. External Functions ..
00269       LOGICAL            LSAME
00270       INTEGER            INDXG2P, NUMROC, SL_GRIDRESHAPE
00271       DOUBLE PRECISION   PDLAMCH, PZLANHE
00272       EXTERNAL           LSAME, INDXG2P, NUMROC, SL_GRIDRESHAPE,
00273      $                   PDLAMCH, PZLANHE
00274 *     ..
00275 *     .. External Subroutines ..
00276       EXTERNAL           BLACS_GRIDEXIT, BLACS_GRIDINFO, CHK1MAT, DCOPY,
00277      $                   DESCINIT, DGAMN2D, DGAMX2D, DSCAL, PCHK1MAT,
00278      $                   PCHK2MAT, PXERBLA, PZELGET, PZGEMR2D, PZHETRD,
00279      $                   PZLASCL, PZLASET, PZUNMTR, ZSTEQR2
00280 *     ..
00281 *     .. Intrinsic Functions ..
00282       INTRINSIC          ABS, DBLE, DCMPLX, ICHAR, INT, MAX, MIN, MOD,
00283      $                   SQRT
00284 *     ..
00285 *     .. Executable Statements ..
00286 *       This is just to keep ftnchek and toolpack/1 happy
00287       IF( BLOCK_CYCLIC_2D*CSRC_*CTXT_*DLEN_*DTYPE_*LLD_*MB_*M_*NB_*N_*
00288      $    RSRC_.LT.0 )RETURN
00289 *
00290 *     Quick return
00291 *
00292       IF( N.EQ.0 )
00293      $   RETURN
00294 *
00295 *     Test the input arguments.
00296 *
00297       CALL BLACS_GRIDINFO( DESCA( CTXT_ ), NPROW, NPCOL, MYROW, MYCOL )
00298       INFO = 0
00299 *
00300 *     Initialize pointer to some safe value
00301 *
00302       INDTAU = 1
00303       INDD = 1
00304       INDE = 1
00305       INDWORK = 1
00306       INDWORK2 = 1
00307 *
00308       INDRE = 1
00309       INDRD = 1
00310       INDRWORK = 1
00311 *
00312       WANTZ = LSAME( JOBZ, 'V' )
00313       IF( NPROW.EQ.-1 ) THEN
00314          INFO = -( 700+CTXT_ )
00315       ELSE IF( WANTZ ) THEN
00316          IF( DESCA( CTXT_ ).NE.DESCZ( CTXT_ ) ) THEN
00317             INFO = -( 1200+CTXT_ )
00318          END IF
00319       END IF
00320       IF( INFO.EQ.0 ) THEN
00321          CALL CHK1MAT( N, 3, N, 3, IA, JA, DESCA, 7, INFO )
00322          IF( WANTZ )
00323      $      CALL CHK1MAT( N, 3, N, 3, IZ, JZ, DESCZ, 12, INFO )
00324 *
00325          IF( INFO.EQ.0 ) THEN
00326 *
00327 *           Get machine constants.
00328 *
00329             SAFMIN = PDLAMCH( DESCA( CTXT_ ), 'Safe minimum' )
00330             EPS = PDLAMCH( DESCA( CTXT_ ), 'Precision' )
00331             SMLNUM = SAFMIN / EPS
00332             BIGNUM = ONE / SMLNUM
00333             RMIN = SQRT( SMLNUM )
00334             RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
00335 *
00336             NPROCS = NPROW*NPCOL
00337             NB_A = DESCA( NB_ )
00338             MB_A = DESCA( MB_ )
00339             NB = NB_A
00340             LOWER = LSAME( UPLO, 'L' )
00341 *
00342             RSRC_A = DESCA( RSRC_ )
00343             CSRC_A = DESCA( CSRC_ )
00344             IROFFA = MOD( IA-1, MB_A )
00345             ICOFFA = MOD( JA-1, NB_A )
00346             IAROW = INDXG2P( 1, NB_A, MYROW, RSRC_A, NPROW )
00347             IACOL = INDXG2P( 1, MB_A, MYCOL, CSRC_A, NPCOL )
00348             NP0 = NUMROC( N+IROFFA, NB, MYROW, IAROW, NPROW )
00349             NQ0 = NUMROC( N+ICOFFA, NB, MYCOL, IACOL, NPCOL )
00350             IF( WANTZ ) THEN
00351                NB_Z = DESCZ( NB_ )
00352                MB_Z = DESCZ( MB_ )
00353                RSRC_Z = DESCZ( RSRC_ )
00354                IROFFZ = MOD( IZ-1, MB_A )
00355                IZROW = INDXG2P( 1, NB_A, MYROW, RSRC_Z, NPROW )
00356             ELSE
00357                IROFFZ = 0
00358                IZROW = 0
00359             END IF
00360 *
00361 *           COMPLEX*16 work space for PZHETRD
00362 *
00363             CALL PZHETRD( UPLO, N, A, IA, JA, DESCA, RWORK( INDD ),
00364      $                    RWORK( INDE ), WORK( INDTAU ),
00365      $                    WORK( INDWORK ), -1, IINFO )
00366             SIZEPZHETRD = INT( ABS( WORK( 1 ) ) )
00367 *
00368 *           COMPLEX*16 work space for PZUNMTR
00369 *
00370             IF( WANTZ ) THEN
00371                CALL PZUNMTR( 'L', UPLO, 'N', N, N, A, IA, JA, DESCA,
00372      $                       WORK( INDTAU ), Z, IZ, JZ, DESCZ,
00373      $                       WORK( INDWORK ), -1, IINFO )
00374                SIZEPZUNMTR = INT( ABS( WORK( 1 ) ) )
00375             ELSE
00376                SIZEPZUNMTR = 0
00377             END IF
00378 *
00379 *           DOUBLE PRECISION work space for ZSTEQR2
00380 *
00381             IF( WANTZ ) THEN
00382                RSIZEZSTEQR2 = MIN( 1, 2*N-2 )
00383             ELSE
00384                RSIZEZSTEQR2 = 0
00385             END IF
00386 *
00387 *           Initialize the context of the single column distributed
00388 *           matrix required by ZSTEQR2. This specific distribution
00389 *           allows each process to do 1/pth of the work updating matrix
00390 *           Q during ZSTEQR2 and achieve some parallelization to an
00391 *           otherwise serial subroutine.
00392 *
00393             LDC = 0
00394             IF( WANTZ ) THEN
00395                CONTEXTC = SL_GRIDRESHAPE( DESCA( CTXT_ ), 0, 1, 1,
00396      $                    NPROCS, 1 )
00397                CALL BLACS_GRIDINFO( CONTEXTC, NPROWC, NPCOLC, MYPROWC,
00398      $                              MYPCOLC )
00399                NRC = NUMROC( N, NB_A, MYPROWC, 0, NPROCS )
00400                LDC = MAX( 1, NRC )
00401                CALL DESCINIT( DESCQR, N, N, NB, NB, 0, 0, CONTEXTC, LDC,
00402      $                        INFO )
00403             END IF
00404 *
00405 *           COMPLEX*16 work space for ZSTEQR2
00406 *
00407             IF( WANTZ ) THEN
00408                SIZEZSTEQR2 = N*LDC
00409             ELSE
00410                SIZEZSTEQR2 = 0
00411             END IF
00412 *
00413 *           Set up pointers into the WORK array
00414 *
00415             INDTAU = 1
00416             INDD = INDTAU + N
00417             INDE = INDD + N
00418             INDWORK = INDE + N
00419             INDWORK2 = INDWORK + N*LDC
00420             LLWORK = LWORK - INDWORK + 1
00421 *
00422 *           Set up pointers into the RWORK array
00423 *
00424             INDRE = 1
00425             INDRD = INDRE + N
00426             INDRWORK = INDRD + N
00427             LLRWORK = LRWORK - INDRWORK + 1
00428 *
00429 *           Compute the total amount of space needed
00430 *
00431             LRWMIN = 2*N + RSIZEZSTEQR2
00432             LWMIN = 3*N + MAX( SIZEPZHETRD, SIZEPZUNMTR, SIZEZSTEQR2 )
00433 *
00434          END IF
00435          IF( INFO.EQ.0 ) THEN
00436             IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
00437                INFO = -1
00438             ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
00439                INFO = -2
00440             ELSE IF( LWORK.LT.LWMIN .AND. LWORK.NE.-1 ) THEN
00441                INFO = -14
00442             ELSE IF( LRWORK.LT.LRWMIN .AND. LRWORK.NE.-1 ) THEN
00443                INFO = -16
00444             ELSE IF( IROFFA.NE.0 ) THEN
00445                INFO = -5
00446             ELSE IF( DESCA( MB_ ).NE.DESCA( NB_ ) ) THEN
00447                INFO = -( 700+NB_ )
00448             END IF
00449             IF( WANTZ ) THEN
00450                IF( IROFFA.NE.IROFFZ ) THEN
00451                   INFO = -10
00452                ELSE IF( IAROW.NE.IZROW ) THEN
00453                   INFO = -10
00454                ELSE IF( DESCA( M_ ).NE.DESCZ( M_ ) ) THEN
00455                   INFO = -( 1200+M_ )
00456                ELSE IF( DESCA( N_ ).NE.DESCZ( N_ ) ) THEN
00457                   INFO = -( 1200+N_ )
00458                ELSE IF( DESCA( MB_ ).NE.DESCZ( MB_ ) ) THEN
00459                   INFO = -( 1200+MB_ )
00460                ELSE IF( DESCA( NB_ ).NE.DESCZ( NB_ ) ) THEN
00461                   INFO = -( 1200+NB_ )
00462                ELSE IF( DESCA( RSRC_ ).NE.DESCZ( RSRC_ ) ) THEN
00463                   INFO = -( 1200+RSRC_ )
00464                ELSE IF( DESCA( CTXT_ ).NE.DESCZ( CTXT_ ) ) THEN
00465                   INFO = -( 1200+CTXT_ )
00466                END IF
00467             END IF
00468          END IF
00469          IF( WANTZ ) THEN
00470             IDUM1( 1 ) = ICHAR( 'V' )
00471          ELSE
00472             IDUM1( 1 ) = ICHAR( 'N' )
00473          END IF
00474          IDUM2( 1 ) = 1
00475          IF( LOWER ) THEN
00476             IDUM1( 2 ) = ICHAR( 'L' )
00477          ELSE
00478             IDUM1( 2 ) = ICHAR( 'U' )
00479          END IF
00480          IDUM2( 2 ) = 2
00481          IF( LWORK.EQ.-1 ) THEN
00482             IDUM1( 3 ) = -1
00483          ELSE
00484             IDUM1( 3 ) = 1
00485          END IF
00486          IDUM2( 3 ) = 3
00487          IF( WANTZ ) THEN
00488             CALL PCHK2MAT( N, 3, N, 3, IA, JA, DESCA, 7, N, 3, N, 3, IZ,
00489      $                     JZ, DESCZ, 12, 3, IDUM1, IDUM2, INFO )
00490          ELSE
00491             CALL PCHK1MAT( N, 3, N, 3, IA, JA, DESCA, 7, 3, IDUM1,
00492      $                     IDUM2, INFO )
00493          END IF
00494          WORK( 1 ) = DCMPLX( LWMIN )
00495          RWORK( 1 ) = DBLE( LRWMIN )
00496       END IF
00497 *
00498       IF( INFO.NE.0 ) THEN
00499          CALL PXERBLA( DESCA( CTXT_ ), 'PZHEEV', -INFO )
00500          IF( WANTZ )
00501      $      CALL BLACS_GRIDEXIT( CONTEXTC )
00502          RETURN
00503       ELSE IF( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 ) THEN
00504          IF( WANTZ )
00505      $      CALL BLACS_GRIDEXIT( CONTEXTC )
00506          RETURN
00507       END IF
00508 *
00509 *     Scale matrix to allowable range, if necessary.
00510 *
00511       ISCALE = 0
00512 *
00513       ANRM = PZLANHE( 'M', UPLO, N, A, IA, JA, DESCA,
00514      $       RWORK( INDRWORK ) )
00515 *
00516 *
00517       IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
00518          ISCALE = 1
00519          SIGMA = RMIN / ANRM
00520       ELSE IF( ANRM.GT.RMAX ) THEN
00521          ISCALE = 1
00522          SIGMA = RMAX / ANRM
00523       END IF
00524 *
00525       IF( ISCALE.EQ.1 ) THEN
00526          CALL PZLASCL( UPLO, ONE, SIGMA, N, N, A, IA, JA, DESCA, IINFO )
00527       END IF
00528 *
00529 *     Reduce Hermitian matrix to tridiagonal form.
00530 *
00531       CALL PZHETRD( UPLO, N, A, IA, JA, DESCA, RWORK( INDRD ),
00532      $              RWORK( INDRE ), WORK( INDTAU ), WORK( INDWORK ),
00533      $              LLWORK, IINFO )
00534 *
00535 *     Copy the values of D, E to all processes.
00536 *
00537       DO 10 I = 1, N
00538          CALL PZELGET( 'A', ' ', WORK( INDD+I-1 ), A, I+IA-1, I+JA-1,
00539      $                 DESCA )
00540          RWORK( INDRD+I-1 ) = DBLE( WORK( INDD+I-1 ) )
00541    10 CONTINUE
00542       IF( LSAME( UPLO, 'U' ) ) THEN
00543          DO 20 I = 1, N - 1
00544             CALL PZELGET( 'A', ' ', WORK( INDE+I-1 ), A, I+IA-1, I+JA,
00545      $                    DESCA )
00546             RWORK( INDRE+I-1 ) = DBLE( WORK( INDE+I-1 ) )
00547    20    CONTINUE
00548       ELSE
00549          DO 30 I = 1, N - 1
00550             CALL PZELGET( 'A', ' ', WORK( INDE+I-1 ), A, I+IA, I+JA-1,
00551      $                    DESCA )
00552             RWORK( INDRE+I-1 ) = DBLE( WORK( INDE+I-1 ) )
00553    30    CONTINUE
00554       END IF
00555 *
00556       IF( WANTZ ) THEN
00557 *
00558          CALL PZLASET( 'Full', N, N, CZERO, CONE, WORK( INDWORK ), 1, 1,
00559      $                 DESCQR )
00560 *
00561 *        ZSTEQR2 is a modified version of LAPACK's CSTEQR.  The
00562 *        modifications allow each process to perform partial updates
00563 *        to matrix Q.
00564 *
00565          CALL ZSTEQR2( 'I', N, RWORK( INDRD ), RWORK( INDRE ),
00566      $                 WORK( INDWORK ), LDC, NRC, RWORK( INDRWORK ),
00567      $                 INFO )
00568 *
00569          CALL PZGEMR2D( N, N, WORK( INDWORK ), 1, 1, DESCQR, Z, IA, JA,
00570      $                  DESCZ, CONTEXTC )
00571 *
00572          CALL PZUNMTR( 'L', UPLO, 'N', N, N, A, IA, JA, DESCA,
00573      $                 WORK( INDTAU ), Z, IZ, JZ, DESCZ,
00574      $                 WORK( INDWORK ), LLWORK, IINFO )
00575 *
00576       ELSE
00577 *
00578          CALL ZSTEQR2( 'N', N, RWORK( INDRD ), RWORK( INDRE ),
00579      $                 WORK( INDWORK ), 1, 1, RWORK( INDRWORK ), INFO )
00580       END IF
00581 *
00582 *     Copy eigenvalues from workspace to output array
00583 *
00584       CALL DCOPY( N, RWORK( INDD ), 1, W, 1 )
00585 *
00586 *     If matrix was scaled, then rescale eigenvalues appropriately.
00587 *
00588       IF( ISCALE.EQ.1 ) THEN
00589          CALL DSCAL( N, ONE / SIGMA, W, 1 )
00590       END IF
00591 *
00592       WORK( 1 ) = DBLE( LWMIN )
00593 *
00594 *     Free up resources
00595 *
00596       IF( WANTZ ) THEN
00597          CALL BLACS_GRIDEXIT( CONTEXTC )
00598       END IF
00599 *
00600 *     Compare every ith eigenvalue, or all if there are only a few,
00601 *     across the process grid to check for heterogeneity.
00602 *
00603       IF( N.LE.ITHVAL ) THEN
00604          J = N
00605          K = 1
00606       ELSE
00607          J = N / ITHVAL
00608          K = ITHVAL
00609       END IF
00610 *
00611       LRMIN = INT( RWORK( 1 ) )
00612       INDTAU = 0
00613       INDE = INDTAU + J
00614       DO 40 I = 1, J
00615          RWORK( I+INDTAU ) = W( ( I-1 )*K+1 )
00616          RWORK( I+INDE ) = W( ( I-1 )*K+1 )
00617    40 CONTINUE
00618 *
00619       CALL DGAMN2D( DESCA( CTXT_ ), 'All', ' ', J, 1, RWORK( 1+INDTAU ),
00620      $              J, 1, 1, -1, -1, 0 )
00621       CALL DGAMX2D( DESCA( CTXT_ ), 'All', ' ', J, 1, RWORK( 1+INDE ),
00622      $              J, 1, 1, -1, -1, 0 )
00623 *
00624       DO 50 I = 1, J
00625          IF( INFO.EQ.0 .AND. ( RWORK( I+INDTAU )-RWORK( I+INDE ).NE.
00626      $       ZERO ) ) THEN
00627             INFO = N + 1
00628          END IF
00629    50 CONTINUE
00630       RWORK( 1 ) = LRMIN
00631 *
00632       RETURN
00633 *
00634 *     End of PZHEEV
00635 *
00636       END