Routine: PZHEEV()  File: SRC\pzheev.f

 
 
# lines: 634
  # code: 634
  # comment: 0
  # blank:0
# Variables:97
# Callers:0
# Callings:7
# Words:355
# Keywords:216
 

 

 
..
     .. Array Arguments ..
     ..
  Purpose
  =======
  PZHEEV computes selected eigenvalues and, optionally, eigenvectors
  of a real symmetric matrix A by calling the recommended sequence
  of ScaLAPACK routines.
  In its present form, PZHEEV assumes a homogeneous system and makes
  only spot checks of the consistency of the eigenvalues across the
  different processes.  Because of this, it is possible that a
  heterogeneous system may return incorrect results without any error
  messages.
  Notes
  =====
  A description vector is associated with each 2D block-cyclicly dis-
  tributed matrix.  This vector stores the information required to
  establish the mapping between a matrix entry and its corresponding
  process and memory location.
  In the following comments, the character _ should be read as
  "of the distributed matrix".  Let A be a generic term for any 2D
  block cyclicly distributed matrix.  Its description vector is DESCA:
  NOTATION        STORED IN      EXPLANATION
  --------------- -------------- --------------------------------------
  DTYPE_A(global) DESCA( DTYPE_) The descriptor type.
  CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
                                 the BLACS process grid A is distribu-
                                 ted over. The context itself is glo-
                                 bal, but the handle (the integer
                                 value) may vary.
  M_A    (global) DESCA( M_ )    The number of rows in the distributed
                                 matrix A.
  N_A    (global) DESCA( N_ )    The number of columns in the distri-
                                 buted matrix A.
  MB_A   (global) DESCA( MB_ )   The blocking factor used to distribute
                                 the rows of A.
  NB_A   (global) DESCA( NB_ )   The blocking factor used to distribute
                                 the columns of A.
  RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
                                 row of the matrix A is distributed.
  CSRC_A (global) DESCA( CSRC_ ) The process column over which the
                                 first column of A is distributed.
  LLD_A  (local)  DESCA( LLD_ )  The leading dimension of the local
                                 array storing the local blocks of the
                                 distributed matrix A.
                                 LLD_A >= MAX(1,LOCr(M_A)).
  Let K be the number of rows or columns of a distributed matrix,
  and assume that its process grid has dimension p x q.
  LOCr( K ) denotes the number of elements of K that a process
  would receive if K were distributed over the p processes of its
  process column.
  Similarly, LOCc( K ) denotes the number of elements of K that a
  process would receive if K were distributed over the q processes of
  its process row.
  The values of LOCr() and LOCc() may be determined via a call to the
  ScaLAPACK tool function, NUMROC:
          LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
          LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
  Arguments
  =========
     NP = the number of rows local to a given process.
     NQ = the number of columns local to a given process.
  JOBZ    (global input) CHARACTER*1
          Specifies whether or not to compute the eigenvectors:
          = 'N':  Compute eigenvalues only.
          = 'V':  Compute eigenvalues and eigenvectors.
  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
          The number of rows and columns of the matrix A.  N >= 0.
  A       (local input/workspace) block cyclic COMPLEX*16 array,
          global dimension (N, N), local dimension ( LLD_A,
          LOCc(JA+N-1) )
          On entry, the symmetric matrix A.  If UPLO = 'U', only the
          upper triangular part of A is used to define the elements of
          the symmetric matrix.  If UPLO = 'L', only the lower
          triangular part of A is used to define the elements of the
          symmetric matrix.
          On exit, the lower triangle (if UPLO='L') or the upper
          triangle (if UPLO='U') of A, including the diagonal, is
          destroyed.
  IA      (global input) INTEGER
          A's global row index, which points to the beginning of the
          submatrix which is to be operated on.
  JA      (global input) INTEGER
          A's global column index, which points to the beginning of
          the submatrix which is to be operated on.
  DESCA   (global and local input) INTEGER array of dimension DLEN_.
          The array descriptor for the distributed matrix A.
          If DESCA( CTXT_ ) is incorrect, PZHEEV cannot guarantee
          correct error reporting.
  W       (global output) DOUBLE PRECISION array, dimension (N)
          On normal exit, the first M entries contain the selected
          eigenvalues in ascending order.
  Z       (local output) COMPLEX*16 array,
          global dimension (N, N),
          local dimension (LLD_Z, LOCc(JZ+N-1))
          If JOBZ = 'V', then on normal exit the first M columns of Z
          contain the orthonormal eigenvectors of the matrix
          corresponding to the selected eigenvalues.
          If JOBZ = 'N', then Z is not referenced.
  IZ      (global input) INTEGER
          Z's global row index, which points to the beginning of the
          submatrix which is to be operated on.
  JZ      (global input) INTEGER
          Z's global column index, which points to the beginning of
          the submatrix which is to be operated on.
  DESCZ   (global and local input) INTEGER array of dimension DLEN_.
          The array descriptor for the distributed matrix Z.
          DESCZ( CTXT_ ) must equal DESCA( CTXT_ )
  WORK    (local workspace/output) COMPLEX*16 array,
          dimension (LWORK)
          On output, WORK(1) returns the workspace needed to guarantee
          completion.  If the input parameters are incorrect, WORK(1)
          may also be incorrect.
          If JOBZ='N' WORK(1) = minimal workspace for eigenvalues only.
          If JOBZ='V' WORK(1) = minimal workspace required to
             generate all the eigenvectors.
  LWORK   (local input) INTEGER
          See below for definitions of variables used to define LWORK.
          If no eigenvectors are requested (JOBZ = 'N') then
             LWORK >= MAX( NB*( NP0+1 ), 3 ) +3*N
          If eigenvectors are requested (JOBZ = 'V' ) then
          the amount of workspace required:
             LWORK >= (NP0 + NQ0 + NB)*NB + 3*N + N^2
          Variable definitions:
             NB = DESCA( MB_ ) = DESCA( NB_ ) =
                  DESCZ( MB_ ) = DESCZ( NB_ )
             NP0 = NUMROC( NN, NB, 0, 0, NPROW )
             NQ0 = NUMROC( MAX( N, NB, 2 ), NB, 0, 0, NPCOL )
          If LWORK = -1, the LWORK is global input and a workspace
          query is assumed; the routine only calculates the minimum
          size for the WORK array.  The required workspace is returned
          as the first element of WORK and no error message is issued
          by PXERBLA.
  RWORK   (local workspace/output) COMPLEX*16 array,
          dimension (LRWORK)
          On output RWORK(1) returns the
          DOUBLE PRECISION workspace needed to
          guarantee completion.  If the input parameters are incorrect,
          RWORK(1) may also be incorrect.
  LRWORK  (local input) INTEGER
          Size of RWORK array.
          If eigenvectors are desired (JOBZ = 'V') then
             LRWORK >= 2*N + 2*N-2
          If eigenvectors are not desired (JOBZ = 'N') then
             LRWORK >= 2*N
          If LRWORK = -1, the LRWORK is global input and a workspace
          query is assumed; the routine only calculates the minimum
          size for the RWORK array.  The required workspace is returned
          as the first element of RWORK and no error message is issued
          by PXERBLA.
  INFO    (global output) INTEGER
          = 0:  successful exit
          < 0:  If the i-th argument is an array and the j-entry had
                an illegal value, then INFO = -(i*100+j), if the i-th
                argument is a scalar and had an illegal value, then
                INFO = -i.
          > 0:  If INFO = 1 through N, the i(th) eigenvalue did not
                converge in ZSTEQR2 after a total of 30*N iterations.
                If INFO = N+1, then PZHEEV has detected heterogeneity
                by finding that eigenvalues were not identical across
                the process grid.  In this case, the accuracy of
                the results from PZHEEV cannot be guaranteed.
  Alignment requirements
  ======================
  The distributed submatrices A(IA:*, JA:*) and C(IC:IC+M-1,JC:JC+N-1)
  must verify some alignment properties, namely the following
  expressions should be true:
  ( MB_A.EQ.NB_A.EQ.MB_Z .AND. IROFFA.EQ.IROFFZ .AND. IROFFA.EQ.0 .AND.
    IAROW.EQ.IZROW )
  where
  IROFFA = MOD( IA-1, MB_A ) and ICOFFA = MOD( JA-1, NB_A ).
  =====================================================================
  Version 1.4 limitations:
     DESCA(MB_) = DESCA(NB_)
     DESCA(M_) = DESCZ(M_)
     DESCA(N_) = DESCZ(N_)
     DESCA(MB_) = DESCZ(MB_)
     DESCA(NB_) = DESCZ(NB_)
     DESCA(RSRC_) = DESCZ(RSRC_)
     .. Parameters ..
 
Display dynamic version Find AutoScroll Reload FontSize: - + Hide Comments Hide Blanks Frame FullScreen MailPrint

  
001        SUBROUTINE PZHEEV( JOBZ , UPLO , N , A , IA , JA , DESCA , W , Z , IZ , JZ ,
002       $DESCZ , WORK , LWORK , RWORK , LRWORK , INFO )
003  
004  *     -- ScaLAPACK routine(version 1.7) --
005  *     University of Tennessee , Knoxville , Oak Ridge National Laboratory ,
006  *     and University of California , Berkeley.
007  *     August 14 , 2001
008  
009  *     .. Scalar Arguments ..
010        CHARACTER JOBZ , UPLO
011        INTEGER IA , INFO , IZ , JA , JZ , LRWORK , LWORK , N
012        INTEGER BLOCK_CYCLIC_2D , DLEN_ , DTYPE_ , CTXT_ , M_ , N_ ,
013       $MB_ , NB_ , RSRC_ , CSRC_ , LLD_
014        PARAMETER( BLOCK_CYCLIC_2D = 1 , DLEN_ = 9 , DTYPE_ = 1 ,
015       $CTXT_ = 2 , M_ = 3 , N_ = 4 , MB_ = 5 , NB_ = 6 ,
016       $RSRC_ = 7 , CSRC_ = 8 , LLD_ = 9 )
017        DOUBLE PRECISION ZERO , ONE
018        PARAMETER( ZERO = 0.0D + 0 , ONE = 1.0D + 0 )
019        COMPLEX*16 CZERO , CONE
020        PARAMETER( CZERO =( 0.0D + 0 , 0.0D + 0 ) ,
021       $CONE =( 1.0D + 0 , 0.0D + 0 ) )
022        INTEGER ITHVAL
023        PARAMETER( ITHVAL = 10 )
024  *     ..
025  *     .. Local Scalars ..
026        LOGICAL LOWER , WANTZ
027        INTEGER CONTEXTC , CSRC_A , I , IACOL , IAROW , ICOFFA ,
028       $IINFO , INDD , INDE , INDRD , INDRE , INDRWORK ,
029       $INDTAU , INDWORK , INDWORK2 , IROFFA , IROFFZ ,
030       $ISCALE , IZROW , J , K , LDC , LLRWORK , LLWORK ,
031       $LRMIN , LRWMIN , LWMIN , MB_A , MB_Z , MYCOL ,
032       $MYPCOLC , MYPROWC , MYROW , NB , NB_A , NB_Z , NP0 ,
033       $NPCOL , NPCOLC , NPROCS , NPROW , NPROWC , NQ0 , NRC ,
034       $RSIZEZSTEQR2 , RSRC_A , RSRC_Z , SIZEPZHETRD ,
035       $SIZEPZUNMTR , SIZEZSTEQR2
036        DOUBLE PRECISION ANRM , BIGNUM , EPS , RMAX , RMIN , SAFMIN , SIGMA ,
037       $SMLNUM
038  *     ..
039  *     .. Local Arrays ..
040        INTEGER DESCQR( 10 ) , IDUM1( 3 ) , IDUM2( 3 )
041  *     ..
042  *     .. External Functions ..
043        LOGICAL LSAME
044        INTEGER INDXG2P , NUMROC , SL_GRIDRESHAPE
045        DOUBLE PRECISION PDLAMCH , PZLANHE
046        EXTERNAL LSAME , INDXG2P , NUMROC , SL_GRIDRESHAPE ,
047       $PDLAMCH , PZLANHE
048  *     ..
049  *     .. External Subroutines ..
050        EXTERNAL BLACS_GRIDEXIT , BLACS_GRIDINFO , CHK1MAT , DCOPY ,
051       $DESCINIT , DGAMN2D , DGAMX2D , DSCAL , PCHK1MAT ,
052       $PCHK2MAT , PXERBLA , PZELGET , PZGEMR2D , PZHETRD ,
053       $PZLASCL , PZLASET , PZUNMTR , ZSTEQR2  
054  *     ..
055  *     .. Intrinsic Functions ..
056        INTRINSIC ABS , DBLE , DCMPLX , ICHAR , INT , MAX , MIN , MOD ,
057       $SQRT
058  *     ..
059  *     .. Executable Statements ..
060  *     This is just to keep ftnchek and toolpack / 1 happy
061        IF( BLOCK_CYCLIC_2D*CSRC_*CTXT_*DLEN_*DTYPE_*LLD_*MB_*M_*NB_*N_*
062       $    RSRC_.LT.0 )RETURN
063  
064  *         Quick return
065  
066            IF( N.EQ.0 )
067       $        RETURN
068  
069  *             Test the input arguments.
070  
071                CALL BLACS_GRIDINFO( DESCA( CTXT_ ) , NPROW , NPCOL , MYROW , MYCOL )
072                INFO = 0
073  
074  *             Initialize pointer to some safe value
075  
076                INDTAU = 1
077                INDD = 1
078                INDE = 1
079                INDWORK = 1
080                INDWORK2 = 1
081  
082                INDRE = 1
083                INDRD = 1
084                INDRWORK = 1
085  
086                WANTZ = LSAME( JOBZ , 'V' )
087                IF( NPROW.EQ. - 1 ) THEN
088                    INFO = - ( 700 + CTXT_ )
089                ELSE IF( WANTZ ) THEN
090                    IF( DESCA( CTXT_ ).NE.DESCZ( CTXT_ ) ) THEN
091                        INFO = - ( 1200 + CTXT_ )
092                    END IF
093                END IF
094                IF( INFO.EQ.0 ) THEN
095                    CALL CHK1MAT( N , 3 , N , 3 , IA , JA , DESCA , 7 , INFO )
096                    IF( WANTZ )
097       $                CALL CHK1MAT( N , 3 , N , 3 , IZ , JZ , DESCZ , 12 , INFO )
098  
099                        IF( INFO.EQ.0 ) THEN
100  
101  *                         Get machine constants.
102  
103                            SAFMIN = PDLAMCH( DESCA( CTXT_ ) , 'Safe minimum' )
104                            EPS = PDLAMCH( DESCA( CTXT_ ) , 'Precision' )
105                            SMLNUM = SAFMIN / EPS
106                            BIGNUM = ONE / SMLNUM
107                            RMIN = SQRT( SMLNUM )
108                            RMAX = MIN( SQRT( BIGNUM ) , ONE / SQRT( SQRT( SAFMIN ) ) )
109  
110                            NPROCS = NPROW*NPCOL
111                            NB_A = DESCA( NB_ )
112                            MB_A = DESCA( MB_ )
113                            NB = NB_A
114                            LOWER = LSAME( UPLO , 'L' )
115  
116                            RSRC_A = DESCA( RSRC_ )
117                            CSRC_A = DESCA( CSRC_ )
118                            IROFFA = MOD( IA - 1 , MB_A )
119                            ICOFFA = MOD( JA - 1 , NB_A )
120                            IAROW = INDXG2P( 1 , NB_A , MYROW , RSRC_A , NPROW )
121                            IACOL = INDXG2P( 1 , MB_A , MYCOL , CSRC_A , NPCOL )
122                            NP0 = NUMROC( N + IROFFA , NB , MYROW , IAROW , NPROW )
123                            NQ0 = NUMROC( N + ICOFFA , NB , MYCOL , IACOL , NPCOL )
124                            IF( WANTZ ) THEN
125                                NB_Z = DESCZ( NB_ )
126                                MB_Z = DESCZ( MB_ )
127                                RSRC_Z = DESCZ( RSRC_ )
128                                IROFFZ = MOD( IZ - 1 , MB_A )
129                                IZROW = INDXG2P( 1 , NB_A , MYROW , RSRC_Z , NPROW )
130                            END IF
131  
132  *                         COMPLEX*16 work space for PZHETRD
133  
134                            CALL PZHETRD ( UPLO , N , A , IA , JA , DESCA , RWORK( INDD ) ,
135       $                    RWORK( INDE ) , WORK( INDTAU ) ,
136       $                    WORK( INDWORK ) , - 1 , IINFO )
137                            SIZEPZHETRD = INT( ABS( WORK( 1 ) ) )
138  
139  *                         COMPLEX*16 work space for PZUNMTR
140  
141                            IF( WANTZ ) THEN
142                                CALL PZUNMTR ( 'L' , UPLO , 'N' , N , N , A , IA , JA , DESCA ,
143       $                        WORK( INDTAU ) , Z , IZ , JZ , DESCZ ,
144       $                        WORK( INDWORK ) , - 1 , IINFO )
145                                SIZEPZUNMTR = INT( ABS( WORK( 1 ) ) )
146                            ELSE
147                                SIZEPZUNMTR = 0
148                            END IF
149  
150  *                         DOUBLE PRECISION work space for ZSTEQR2
151  
152                            IF( WANTZ ) THEN
153                                RSIZEZSTEQR2 = MIN( 1 , 2*N - 2 )
154                            ELSE
155                                RSIZEZSTEQR2 = 0
156                            END IF
157  
158  *                         Initialize the context of the single column distributed
159  *                         matrix required by ZSTEQR2. This specific distribution
160  *                         allows each process to do 1 / pth of the work updating matrix
161  *                         Q during ZSTEQR2 and achieve some parallelization to an
162  *                         otherwise serial subroutine.
163  
164                            LDC = 0
165                            IF( WANTZ ) THEN
166                                CONTEXTC = SL_GRIDRESHAPE( DESCA( CTXT_ ) , 0 , 1 , 1 ,
167       $                        NPROCS , 1 )
168                                CALL BLACS_GRIDINFO( CONTEXTC , NPROWC , NPCOLC , MYPROWC ,
169       $                        MYPCOLC )
170                                NRC = NUMROC( N , NB_A , MYPROWC , 0 , NPROCS )
171                                LDC = MAX( 1 , NRC )
172                                CALL DESCINIT( DESCQR , N , N , NB , NB , 0 , 0 , CONTEXTC , LDC ,
173       $                        INFO )
174                            END IF
175  
176  *                         COMPLEX*16 work space for ZSTEQR2
177  
178                            IF( WANTZ ) THEN
179                                SIZEZSTEQR2 = N*LDC
180                            ELSE
181                                SIZEZSTEQR2 = 0
182                            END IF
183  
184  *                         Set up pointers into the WORK array
185  
186                            INDTAU = 1
187                            INDD = INDTAU + N
188                            INDE = INDD + N
189                            INDWORK = INDE + N
190                            INDWORK2 = INDWORK + N*LDC
191                            LLWORK = LWORK - INDWORK + 1
192  
193  *                         Set up pointers into the RWORK array
194  
195                            INDRE = 1
196                            INDRD = INDRE + N
197                            INDRWORK = INDRD + N
198                            LLRWORK = LRWORK - INDRWORK + 1
199  
200  *                         Compute the total amount of space needed
201  
202                            LRWMIN = 2*N + RSIZEZSTEQR2
203                            LWMIN = 3*N + MAX( SIZEPZHETRD , SIZEPZUNMTR , SIZEZSTEQR2 )
204  
205                        END IF
206                        IF( INFO.EQ.0 ) THEN
207                            IF( .NOT.( WANTZ .OR. LSAME( JOBZ , 'N' ) ) ) THEN
208                                INFO = - 1
209                            ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO , 'U' ) ) ) THEN
210                                INFO = - 2
211                            ELSE IF( LWORK.LT.LWMIN .AND. LWORK.NE. - 1 ) THEN
212                                INFO = - 14
213                            ELSE IF( LRWORK.LT.LRWMIN .AND. LRWORK.NE. - 1 ) THEN
214                                INFO = - 16
215                            ELSE IF( IROFFA.NE.0 ) THEN
216                                INFO = - 5
217                            ELSE IF( DESCA( MB_ ).NE.DESCA( NB_ ) ) THEN
218                                INFO = - ( 700 + NB_ )
219                            END IF
220                            IF( WANTZ ) THEN
221                                IF( IROFFA.NE.IROFFZ ) THEN
222                                    INFO = - 10
223                                ELSE IF( IAROW.NE.IZROW ) THEN
224                                    INFO = - 10
225                                ELSE IF( DESCA( M_ ).NE.DESCZ( M_ ) ) THEN
226                                    INFO = - ( 1200 + M_ )
227                                ELSE IF( DESCA( N_ ).NE.DESCZ( N_ ) ) THEN
228                                    INFO = - ( 1200 + N_ )
229                                ELSE IF( DESCA( MB_ ).NE.DESCZ( MB_ ) ) THEN
230                                    INFO = - ( 1200 + MB_ )
231                                ELSE IF( DESCA( NB_ ).NE.DESCZ( NB_ ) ) THEN
232                                    INFO = - ( 1200 + NB_ )
233                                ELSE IF( DESCA( RSRC_ ).NE.DESCZ( RSRC_ ) ) THEN
234                                    INFO = - ( 1200 + RSRC_ )
235                                ELSE IF( DESCA( CTXT_ ).NE.DESCZ( CTXT_ ) ) THEN
236                                    INFO = - ( 1200 + CTXT_ )
237                                END IF
238                            END IF
239                        END IF
240                        IF( WANTZ ) THEN
241                            IDUM1( 1 ) = ICHAR( 'V' )
242                        ELSE
243                            IDUM1( 1 ) = ICHAR( 'N' )
244                        END IF
245                        IDUM2( 1 ) = 1
246                        IF( LOWER ) THEN
247                            IDUM1( 2 ) = ICHAR( 'L' )
248                        ELSE
249                            IDUM1( 2 ) = ICHAR( 'U' )
250                        END IF
251                        IDUM2( 2 ) = 2
252                        IF( LWORK.EQ. - 1 ) THEN
253                            IDUM1( 3 ) = - 1
254                        ELSE
255                            IDUM1( 3 ) = 1
256                        END IF
257                        IDUM2( 3 ) = 3
258                        IF( WANTZ ) THEN
259                            CALL PCHK2MAT( N , 3 , N , 3 , IA , JA , DESCA , 7 , N , 3 , N , 3 , IZ ,
260       $                    JZ , DESCZ , 12 , 3 , IDUM1 , IDUM2 , INFO )
261                        ELSE
262                            CALL PCHK1MAT( N , 3 , N , 3 , IA , JA , DESCA , 7 , 3 , IDUM1 ,
263       $                    IDUM2 , INFO )
264                        END IF
265                        WORK( 1 ) = DCMPLX( LWMIN )
266                        RWORK( 1 ) = DBLE( LRWMIN )
267                    END IF
268  
269                    IF( INFO.NE.0 ) THEN
270                        CALL PXERBLA( DESCA( CTXT_ ) , 'PZHEEV' , - INFO )
271                        IF( WANTZ )
272       $                    CALL BLACS_GRIDEXIT( CONTEXTC )
273                            RETURN
274                        ELSE IF( LWORK.EQ. - 1 .OR. LRWORK.EQ. - 1 ) THEN
275                            IF( WANTZ )
276       $                        CALL BLACS_GRIDEXIT( CONTEXTC )
277                                RETURN
278                            END IF
279  
280  *                         Scale matrix to allowable range , if necessary.
281  
282                            ISCALE = 0
283  
284                            ANRM = PZLANHE( 'M' , UPLO , N , A , IA , JA , DESCA ,
285       $                    RWORK( INDRWORK ) )
286  
287                            IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
288                                ISCALE = 1
289                                SIGMA = RMIN / ANRM
290                            ELSE IF( ANRM.GT.RMAX ) THEN
291                                ISCALE = 1
292                                SIGMA = RMAX / ANRM
293                            END IF
294  
295                            IF( ISCALE.EQ.1 ) THEN
296                                CALL PZLASCL ( UPLO , ONE , SIGMA , N , N , A , IA , JA , DESCA , IINFO )
297                            END IF
298  
299  *                         Reduce symmetric matrix to tridiagonal form.
300  
301                            CALL PZHETRD ( UPLO , N , A , IA , JA , DESCA , RWORK( INDRD ) ,
302       $                    RWORK( INDRE ) , WORK( INDTAU ) , WORK( INDWORK ) ,
303       $                    LLWORK , IINFO )
304  
305  *                         Copy the values of D , E to all processes.
306  
307                            DO 10 I = 1 , N
308                                CALL PZELGET( 'A' , ' ' , WORK( INDD + I - 1 ) , A , I + IA - 1 , I + JA - 1 ,
309       $                        DESCA )
310                                RWORK( INDRD + I - 1 ) = DBLE( WORK( INDD + I - 1 ) )
311     10                     CONTINUE
312                            IF( LSAME( UPLO , 'U' ) ) THEN
313                                DO 20 I = 1 , N - 1
314                                    CALL PZELGET( 'A' , ' ' , WORK( INDE + I - 1 ) , A , I + IA - 1 , I + JA ,
315       $                            DESCA )
316                                    RWORK( INDRE + I - 1 ) = DBLE( WORK( INDE + I - 1 ) )
317     20                         CONTINUE
318                            ELSE
319                                DO 30 I = 1 , N - 1
320                                    CALL PZELGET( 'A' , ' ' , WORK( INDE + I - 1 ) , A , I + IA , I + JA - 1 ,
321       $                            DESCA )
322                                    RWORK( INDRE + I - 1 ) = DBLE( WORK( INDE + I - 1 ) )
323     30                         CONTINUE
324                            END IF
325  
326                            IF( WANTZ ) THEN
327  
328                                CALL PZLASET ( 'Full' , N , N , CZERO , CONE , WORK( INDWORK ) , 1 , 1 ,
329       $                        DESCQR )
330  
331  *                             ZSTEQR2 is a modified version of LAPACK's CSTEQR. The
332  *                             modifications allow each process to perform partial updates
333  *                             to matrix Q.
334  
335                                CALL ZSTEQR2 ( 'I' , N , RWORK( INDRD ) , RWORK( INDRE ) ,
336       $                        WORK( INDWORK ) , LDC , NRC , RWORK( INDRWORK ) ,
337       $                        INFO )
338  
339                                CALL PZGEMR2D( N , N , WORK( INDWORK ) , 1 , 1 , DESCQR , Z , IA , JA ,
340       $                        DESCZ , CONTEXTC )
341  
342                                CALL PZUNMTR ( 'L' , UPLO , 'N' , N , N , A , IA , JA , DESCA ,
343       $                        WORK( INDTAU ) , Z , IZ , JZ , DESCZ ,
344       $                        WORK( INDWORK ) , LLWORK , IINFO )
345  
346                            ELSE
347  
348                                CALL ZSTEQR2 ( 'N' , N , RWORK( INDRD ) , RWORK( INDRE ) ,
349       $                        WORK( INDWORK ) , 1 , 1 , RWORK( INDRWORK ) , INFO )
350                            END IF
351  
352  *                         Copy eigenvalues from workspace to output array
353  
354                            CALL DCOPY( N , RWORK( INDD ) , 1 , W , 1 )
355  
356  *                         If matrix was scaled , then rescale eigenvalues appropriately.
357  
358                            IF( ISCALE.EQ.1 ) THEN
359                                CALL DSCAL( N , ONE / SIGMA , W , 1 )
360                            END IF
361  
362                            WORK( 1 ) = DBLE( LWMIN )
363  
364  *                         Free up resources
365  
366                            IF( WANTZ ) THEN
367                                CALL BLACS_GRIDEXIT( CONTEXTC )
368                            END IF
369  
370  *                         Compare every ith eigenvalue , or all if there are only a few ,
371  *                         across the process grid to check for heterogeneity.
372  
373                            IF( N.LE.ITHVAL ) THEN
374                                J = N
375                                K = 1
376                            ELSE
377                                J = N / ITHVAL
378                                K = ITHVAL
379                            END IF
380  
381                            LRMIN = INT( RWORK( 1 ) )
382                            INDTAU = 0
383                            INDE = INDTAU + J
384                            DO 40 I = 1 , J
385                                RWORK( I + INDTAU ) = W(( I - 1 )*K + 1 )
386                                RWORK( I + INDE ) = W(( I - 1 )*K + 1 )
387     40                     CONTINUE
388  
389                            CALL DGAMN2D( DESCA( CTXT_ ) , 'All' , ' ' , J , 1 , RWORK( 1 + INDTAU ) ,
390       $                    J , 1 , 1 , - 1 , - 1 , 0 )
391                            CALL DGAMX2D( DESCA( CTXT_ ) , 'All' , ' ' , J , 1 , RWORK( 1 + INDE ) ,
392       $                    J , 1 , 1 , - 1 , - 1 , 0 )
393  
394                            DO 50 I = 1 , J
395                                IF( INFO.EQ.0 .AND.( RWORK( I + INDTAU ) - RWORK( I + INDE ).NE.
396       $                        ZERO ) ) THEN
397                                INFO = N + 1
398                            END IF
399     50                     CONTINUE
400                            RWORK( 1 ) = LRMIN
401  
402                            RETURN
403  
404  *                         End of PZHEEV
405  
406                        END