Routine: PDSYEV()  File: SRC\pdsyev.f

 
 
# lines: 578
  # code: 578
  # comment: 0
  # blank:0
# Variables:94
# Callers:0
# Callings:7
# Words:317
# Keywords:197
 

 

 
..
     .. Array Arguments ..
     ..
  Purpose
  =======
  PDSYEV computes all eigenvalues and, optionally, eigenvectors
  of a real symmetric matrix A by calling the recommended sequence
  of ScaLAPACK routines.
  In its present form, PDSYEV assumes a homogeneous system and makes
  no checks for consistency of the eigenvalues or eigenvectors 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 DOUBLE PRECISION 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, PDSYEV 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) DOUBLE PRECISION 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) DOUBLE PRECISION array,
          dimension (LWORK)
          Version 1.0:  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=optimal amount of workspace
          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 >= 5*N + SIZESYTRD + 1
          where
             SIZESYTRD = The workspace requirement for PDSYTRD
                         and is MAX( NB * ( NP +1 ), 3 * NB )
          If eigenvectors are requested (JOBZ = 'V' ) then
             the amount of workspace required to guarantee that all
             eigenvectors are computed is:
             QRMEM = 2*N-2
             LWMIN = 5*N + N*LDC + MAX( SIZEMQRLEFT, QRMEM ) + 1
          Variable definitions:
             NB = DESCA( MB_ ) = DESCA( NB_ ) =
                  DESCZ( MB_ ) = DESCZ( NB_ )
             NN = MAX( N, NB, 2 )
             DESCA( RSRC_ ) = DESCA( RSRC_ ) = DESCZ( RSRC_ ) =
                              DESCZ( CSRC_ ) = 0
             NP = NUMROC( NN, NB, 0, 0, NPROW )
             NQ = NUMROC( MAX( N, NB, 2 ), NB, 0, 0, NPCOL )
             NRC = NUMROC( N, NB, MYPROWC, 0, NPROCS)
             LDC = MAX( 1, NRC )
             SIZEMQRLEFT = The workspace requirement for PDORMTR
                           when it's SIDE argument is 'L'.
          With MYPROWC defined when a new context is created as:
             CALL BLACS_GET( DESCA( CTXT_ ), 0, CONTEXTC )
             CALL BLACS_GRIDINIT( CONTEXTC, 'R', NPROCS, 1 )
             CALL BLACS_GRIDINFO( CONTEXTC, NPROWC, NPCOLC, MYPROWC,
                                  MYPCOLC )
          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.
  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 DSTEQR2 after a total of 30*N iterations.
                If INFO = N+1, then PDSYEV has detected heterogeneity
                by finding that eigenvalues were not identical across
                the process grid.  In this case, the accuracy of
                the results from PDSYEV cannot be guaranteed.
  Alignment requirements
  ======================
  The distributed submatrices A(IA:*, JA:*) and Z(IZ:IZ+M-1,JZ:JZ+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 PDSYEV( JOBZ , UPLO , N , A , IA , JA , DESCA , W ,
002       $Z , IZ , JZ , DESCZ , WORK , LWORK , INFO )
003  
004  *     -- ScaLAPACK routine(version 1.7) --
005  *     University of Tennessee , Knoxville , Oak Ridge National Laboratory ,
006  *     and University of California , Berkeley.
007  *     May 25 , 2001
008  
009  *     .. Scalar Arguments ..
010        CHARACTER JOBZ , UPLO
011        INTEGER IA , INFO , IZ , JA , JZ , 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 FIVE , ONE , TEN , ZERO
018        PARAMETER( ZERO = 0.0D + 0 , ONE = 1.0D + 0 ,
019       $TEN = 10.0D + 0 , FIVE = 5.0D + 0 )
020        INTEGER IERREIN , IERRCLS , IERRSPC , IERREBZ , ITHVAL
021        PARAMETER( IERREIN = 1 , IERRCLS = 2 , IERRSPC = 4 ,
022       $IERREBZ = 8 , ITHVAL = 10 )
023  *     ..
024  *     .. Local Scalars ..
025        LOGICAL LOWER , WANTZ
026        INTEGER CONTEXTC , CSRC_A , I , IACOL , IAROW , ICOFFA ,
027       $IINFO , INDD , INDD2 , INDE , INDE2 , INDTAU ,
028       $INDWORK , INDWORK2 , IROFFA , IROFFZ , ISCALE ,
029       $IZROW , J , K , LDC , LLWORK , LWMIN , MB_A , MB_Z ,
030       $MYCOL , MYPCOLC , MYPROWC , MYROW , NB , NB_A , NB_Z ,
031       $NP , NPCOL , NPCOLC , NPROCS , NPROW , NPROWC , NQ ,
032       $NRC , QRMEM , RSRC_A , RSRC_Z , SIZEMQRLEFT ,
033       $SIZESYTRD
034        DOUBLE PRECISION ANRM , BIGNUM , EPS , RMAX , RMIN , SAFMIN , SIGMA ,
035       $SMLNUM
036  *     ..
037  *     .. Local Arrays ..
038        INTEGER DESCQR( 9 ) , IDUM1( 3 ) , IDUM2( 3 )
039  *     ..
040  *     .. External Functions ..
041        LOGICAL LSAME
042        INTEGER INDXG2P , NUMROC , SL_GRIDRESHAPE
043        DOUBLE PRECISION PDLAMCH , PDLANSY
044        EXTERNAL LSAME , NUMROC , PDLAMCH , PDLANSY ,
045       $SL_GRIDRESHAPE
046  *     ..
047  *     .. External Subroutines ..
048        EXTERNAL BLACS_GRIDEXIT , BLACS_GRIDINFO , CHK1MAT , DCOPY ,
049       $DESCINIT , DSCAL , DSTEQR2 , PCHK1MAT , PCHK2MAT ,
050       $PDELGET , PDGEMR2D , PDLASCL , PDLASET , PDORMTR ,
051       $PDSYTRD , PXERBLA
052  *     ..
053  *     .. Intrinsic Functions ..
054        INTRINSIC ABS , DBLE , ICHAR , MAX , MIN , MOD , SQRT , INT
055  *     ..
056  *     .. Executable Statements ..
057  *     This is just to keep ftnchek and toolpack / 1 happy
058        IF( BLOCK_CYCLIC_2D*CSRC_*CTXT_*DLEN_*DTYPE_*LLD_*MB_*M_*NB_*N_*
059       $    RSRC_.LT.0 )RETURN
060  
061  *         Quick return
062  
063            IF( N.EQ.0 ) RETURN
064  
065  *         Test the input arguments.
066  
067            CALL BLACS_GRIDINFO( DESCA( CTXT_ ) , NPROW , NPCOL , MYROW , MYCOL )
068            INFO = 0
069  
070            WANTZ = LSAME( JOBZ , 'V' )
071            IF( NPROW.EQ. - 1 ) THEN
072                INFO = - ( 700 + CTXT_ )
073            ELSE IF( WANTZ ) THEN
074                IF( DESCA( CTXT_ ).NE.DESCZ( CTXT_ ) ) THEN
075                    INFO = - ( 1200 + CTXT_ )
076                END IF
077            END IF
078            IF( INFO .EQ. 0 ) THEN
079                CALL CHK1MAT( N , 3 , N , 3 , IA , JA , DESCA , 7 , INFO )
080                IF( WANTZ )
081       $            CALL CHK1MAT( N , 3 , N , 3 , IZ , JZ , DESCZ , 12 , INFO )
082  
083                    IF( INFO.EQ.0 ) THEN
084  
085  *                     Get machine constants.
086  
087                        SAFMIN = PDLAMCH( DESCA( CTXT_ ) , 'Safe minimum' )
088                        EPS = PDLAMCH( DESCA( CTXT_ ) , 'Precision' )
089                        SMLNUM = SAFMIN / EPS
090                        BIGNUM = ONE / SMLNUM
091                        RMIN = SQRT( SMLNUM )
092                        RMAX = MIN( SQRT( BIGNUM ) , ONE / SQRT( SQRT( SAFMIN ) ) )
093  
094                        NPROCS = NPROW*NPCOL
095                        NB_A = DESCA( NB_ )
096                        MB_A = DESCA( MB_ )
097                        NB = NB_A
098                        LOWER = LSAME( UPLO , 'L' )
099  
100                        RSRC_A = DESCA( RSRC_ )
101                        CSRC_A = DESCA( CSRC_ )
102                        IROFFA = MOD( IA - 1 , MB_A )
103                        ICOFFA = MOD( JA - 1 , NB_A )
104                        IAROW = INDXG2P( 1 , NB_A , MYROW , RSRC_A , NPROW )
105                        IACOL = INDXG2P( 1 , MB_A , MYCOL , CSRC_A , NPCOL )
106                        NP = NUMROC( N + IROFFA , NB , MYROW , IAROW , NPROW )
107                        NQ = NUMROC( N + ICOFFA , NB , MYCOL , IACOL , NPCOL )
108  
109                        IF( WANTZ ) THEN
110                            NB_Z = DESCZ( NB_ )
111                            MB_Z = DESCZ( MB_ )
112                            RSRC_Z = DESCZ( RSRC_ )
113                            IROFFZ = MOD( IZ - 1 , MB_A )
114                            IZROW = INDXG2P( 1 , NB_A , MYROW , RSRC_Z , NPROW )
115                            SIZEMQRLEFT = MAX(( NB_A*( NB_A - 1 ) ) / 2 ,( NP + NQ )*
116       $                    NB_A ) + NB_A*NB_A
117                        ELSE
118                            SIZEMQRLEFT = 0
119                        END IF
120                        SIZESYTRD = MAX( NB * ( NP + 1 ) , 3 * NB )
121  
122  *                     Initialize the context of the single column distributed
123  *                     matrix required by DSTEQR2. This specific distribution
124  *                     allows each process to do 1 / pth of the work updating matrix
125  *                     Q during DSTEQR2 and achieve some parallelization to an
126  *                     otherwise serial subroutine.
127  
128                        LDC = 0
129                        IF( WANTZ ) THEN
130                            CONTEXTC = SL_GRIDRESHAPE( DESCA( CTXT_ ) , 0 , 1 , 1 ,
131       $                    NPROCS , 1 )
132                            CALL BLACS_GRIDINFO( CONTEXTC , NPROWC , NPCOLC , MYPROWC ,
133       $                    MYPCOLC )
134                            NRC = NUMROC( N , NB_A , MYPROWC , 0 , NPROCS)
135                            LDC = MAX( 1 , NRC )
136                            CALL DESCINIT( DESCQR , N , N , NB , NB , 0 , 0 , CONTEXTC ,
137       $                    LDC , INFO )
138                        END IF
139  
140  *                     Set up pointers into the WORK array
141  
142                        INDTAU = 1
143                        INDE = INDTAU + N
144                        INDD = INDE + N
145                        INDD2 = INDD + N
146                        INDE2 = INDD2 + N
147                        INDWORK = INDE2 + N
148                        INDWORK2 = INDWORK + N*LDC
149                        LLWORK = LWORK - INDWORK + 1
150  
151  *                     Compute the total amount of space needed
152  
153                        QRMEM = 2*N - 2
154                        IF( WANTZ ) THEN
155                            LWMIN = 5*N + N*LDC + MAX( SIZEMQRLEFT , QRMEM ) + 1
156                        ELSE
157                            LWMIN = 5*N + SIZESYTRD + 1
158                        END IF
159  
160                    END IF
161                    IF( INFO.EQ.0 ) THEN
162                        IF( .NOT.( WANTZ .OR. LSAME( JOBZ , 'N' ) ) ) THEN
163                            INFO = - 1
164                        ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO , 'U' ) ) ) THEN
165                            INFO = - 2
166                        ELSE IF( LWORK.LT.LWMIN .AND. LWORK.NE. - 1 ) THEN
167                            INFO = - 14
168                        ELSE IF( IROFFA.NE.0 ) THEN
169                            INFO = - 5
170                        ELSE IF( DESCA( MB_ ).NE.DESCA( NB_ ) ) THEN
171                            INFO = - ( 700 + NB_ )
172                        END IF
173                        IF( WANTZ ) THEN
174                            IF( IROFFA.NE.IROFFZ ) THEN
175                                INFO = - 10
176                            ELSE IF( IAROW.NE.IZROW ) THEN
177                                INFO = - 10
178                            ELSE IF( DESCA( M_ ).NE.DESCZ( M_ ) ) THEN
179                                INFO = - ( 1200 + M_ )
180                            ELSE IF( DESCA( N_ ).NE.DESCZ( N_ ) ) THEN
181                                INFO = - ( 1200 + N_ )
182                            ELSE IF( DESCA( MB_ ).NE.DESCZ( MB_ ) ) THEN
183                                INFO = - ( 1200 + MB_ )
184                            ELSE IF( DESCA( NB_ ).NE.DESCZ( NB_ ) ) THEN
185                                INFO = - ( 1200 + NB_ )
186                            ELSE IF( DESCA( RSRC_ ).NE.DESCZ( RSRC_ ) ) THEN
187                                INFO = - ( 1200 + RSRC_ )
188                            ELSE IF( DESCA( CTXT_ ).NE.DESCZ( CTXT_ ) ) THEN
189                                INFO = - ( 1200 + CTXT_ )
190                            ENDIF
191                        END IF
192                    END IF
193                    IF( WANTZ ) THEN
194                        IDUM1( 1 ) = ICHAR( 'V' )
195                    ELSE
196                        IDUM1( 1 ) = ICHAR( 'N' )
197                    END IF
198                    IDUM2( 1 ) = 1
199                    IF( LOWER ) THEN
200                        IDUM1( 2 ) = ICHAR( 'L' )
201                    ELSE
202                        IDUM1( 2 ) = ICHAR( 'U' )
203                    END IF
204                    IDUM2( 2 ) = 2
205                    IF( LWORK.EQ. - 1 ) THEN
206                        IDUM1( 3 ) = - 1
207                    ELSE
208                        IDUM1( 3 ) = 1
209                    END IF
210                    IDUM2( 3 ) = 3
211                    IF( LSAME( JOBZ , 'V' ) ) THEN
212                        CALL PCHK2MAT( N , 3 , N , 3 , IA , JA , DESCA , 7 , N , 3 , N , 3 ,
213       $                IZ , JZ , DESCZ , 12 , 3 , IDUM1 , IDUM2 , INFO )
214                    ELSE
215                        CALL PCHK1MAT( N , 3 , N , 3 , IA , JA , DESCA , 7 , 3 , IDUM1 ,
216       $                IDUM2 , INFO )
217                    END IF
218  
219  *                 Write the required workspace for lwork queries.
220  
221                    WORK( 1 ) = DBLE( LWMIN )
222                END IF
223  
224                IF( INFO.NE.0 ) THEN
225                    CALL PXERBLA( DESCA( CTXT_ ) , 'PDSYEV' , - INFO )
226                    IF( WANTZ ) CALL BLACS_GRIDEXIT( CONTEXTC )
227                        RETURN
228                    ELSE IF( LWORK .EQ. - 1 ) THEN
229                        IF( WANTZ ) CALL BLACS_GRIDEXIT( CONTEXTC )
230                            RETURN
231                        END IF
232  
233  *                     Scale matrix to allowable range , if necessary.
234  
235                        ISCALE = 0
236  
237                        ANRM = PDLANSY( 'M' , UPLO , N , A , IA , JA , DESCA , WORK( INDWORK ) )
238  
239                        IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
240                            ISCALE = 1
241                            SIGMA = RMIN / ANRM
242                        ELSE IF( ANRM.GT.RMAX ) THEN
243                            ISCALE = 1
244                            SIGMA = RMAX / ANRM
245                        END IF
246  
247                        IF( ISCALE.EQ.1 ) THEN
248                            CALL PDLASCL ( UPLO , ONE , SIGMA , N , N , A , IA , JA , DESCA , IINFO )
249                        END IF
250  
251  *                     Reduce symmetric matrix to tridiagonal form.
252  
253                        CALL PDSYTRD ( UPLO , N , A , IA , JA , DESCA , WORK( INDD ) ,
254       $                WORK( INDE ) , WORK( INDTAU ) , WORK( INDWORK ) ,
255       $                LLWORK , IINFO )
256  
257  *                     Copy the values of D , E to all processes.
258  
259                        DO 10 I = 1 , N
260                            CALL PDELGET( 'A' , ' ' , WORK(INDD2 + I - 1) , A ,
261       $                    I + IA - 1 , I + JA - 1 , DESCA )
262   10                   CONTINUE
263                        IF( LSAME( UPLO , 'U') ) THEN
264                            DO 20 I = 1 , N - 1
265                                CALL PDELGET( 'A' , ' ' , WORK(INDE2 + I - 1) , A ,
266       $                        I + IA - 1 , I + JA , DESCA )
267   20                       CONTINUE
268                        ELSE
269                            DO 30 I = 1 , N - 1
270                                CALL PDELGET( 'A' , ' ' , WORK(INDE2 + I - 1) , A ,
271       $                        I + IA , I + JA - 1 , DESCA )
272   30                       CONTINUE
273                        ENDIF
274  
275                        IF( WANTZ ) THEN
276  
277                            CALL PDLASET ( 'Full' , N , N , ZERO , ONE , WORK( INDWORK ) , 1 , 1 ,
278       $                    DESCQR )
279  
280  *                         DSTEQR2 is a modified version of LAPACK's DSTEQR. The
281  *                         modifications allow each process to perform partial updates
282  *                         to matrix Q.
283  
284                            CALL DSTEQR2 ( 'I' , N , WORK( INDD2 ) , WORK( INDE2 ) ,
285       $                    WORK( INDWORK ) , LDC , NRC , WORK( INDWORK2 ) ,
286       $                    INFO )
287  
288                            CALL PDGEMR2D( N , N , WORK( INDWORK ) , 1 , 1 , DESCQR , Z , IA , JA ,
289       $                    DESCZ , CONTEXTC )
290  
291                            CALL PDORMTR ( 'L' , UPLO , 'N' , N , N , A , IA , JA , DESCA ,
292       $                    WORK( INDTAU ) , Z , IZ , JZ , DESCZ ,
293       $                    WORK( INDWORK ) , LLWORK , IINFO )
294  
295                        ELSE
296  
297                            CALL DSTEQR2 ( 'N' , N , WORK( INDD2 ) , WORK( INDE2 ) ,
298       $                    WORK( INDWORK ) , 1 , 1 , WORK( INDWORK2 ) ,
299       $                    INFO )
300                        ENDIF
301  
302  *                     Copy eigenvalues from workspace to output array
303  
304                        CALL DCOPY( N , WORK( INDD2 ) , 1 , W , 1 )
305  
306  *                     If matrix was scaled , then rescale eigenvalues appropriately.
307  
308                        IF( ISCALE .EQ. 1 ) THEN
309                            CALL DSCAL( N , ONE / SIGMA , W , 1 )
310                        END IF
311  
312  *                     Free up resources
313  
314                        IF( WANTZ ) THEN
315                            CALL BLACS_GRIDEXIT( CONTEXTC )
316                        END IF
317  
318  *                     Compare every ith eigenvalue , or all if there are only a few ,
319  *                     across the process grid to check for heterogeneity.
320  
321                        IF( N.LE.ITHVAL ) THEN
322                            J = N
323                            K = 1
324                        ELSE
325                            J = N / ITHVAL
326                            K = ITHVAL
327                        END IF
328  
329                        DO 40 I = 1 , J
330                            WORK( I + INDTAU ) = W((I - 1)*K + 1 )
331                            WORK( I + INDE ) = W((I - 1)*K + 1 )
332   40                   CONTINUE
333  
334                        CALL DGAMN2D( DESCA( CTXT_ ) , 'a' , ' ' , J , 1 , WORK( 1 + INDTAU ) ,
335       $                J , 1 , 1 , - 1 , - 1 , 0 )
336                        CALL DGAMX2D( DESCA( CTXT_ ) , 'a' , ' ' , J , 1 , WORK( 1 + INDE ) ,
337       $                J , 1 , 1 , - 1 , - 1 , 0 )
338  
339                        DO 50 I = 1 , J
340                            IF( INFO.EQ.0 .AND.( WORK( I + INDTAU ) - WORK( I + INDE )
341       $                        .NE. ZERO ) )THEN
342                                INFO = N + 1
343                            END IF
344   50                   CONTINUE
345  
346                        RETURN
347  
348  *                     End of PDSYEV
349  
350                    END