Routine: PSSTEDC()  File: SRC\psstedc.f

 
 
# lines: 267
  # code: 267
  # comment: 0
  # blank:0
# Variables:46
# Callers:2
# Callings:2
# Words:169
# Keywords:113
 

 

 
..
     .. Array Arguments ..
     ..
  Purpose
  =======
  PSSTEDC computes all eigenvalues and eigenvectors of a
  symmetric tridiagonal matrix in parallel, using the divide and
  conquer algorithm.
  This code makes very mild assumptions about floating point
  arithmetic. It will work on machines with a guard digit in
  add/subtract, or on those binary machines without guard digits
  which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
  It could conceivably fail on hexadecimal or decimal machines
  without guard digits, but we know of none.  See SLAED3 for details.
  Arguments
  =========
  COMPZ   (input) CHARACTER*1
          = 'N':  Compute eigenvalues only.    (NOT IMPLEMENTED YET)
          = 'I':  Compute eigenvectors of tridiagonal matrix also.
          = 'V':  Compute eigenvectors of original dense symmetric
                  matrix also.  On entry, Z contains the orthogonal
                  matrix used to reduce the original matrix to
                  tridiagonal form.            (NOT IMPLEMENTED YET)
  N       (global input) INTEGER
          The order of the tridiagonal matrix T.  N >= 0.
  D       (global input/output) REAL array, dimension (N)
          On entry, the diagonal elements of the tridiagonal matrix.
          On exit, if INFO = 0, the eigenvalues in descending order.
  E       (global input/output) REAL array, dimension (N-1)
          On entry, the subdiagonal elements of the tridiagonal matrix.
          On exit, E has been destroyed.
  Q       (local output) REAL array,
          local dimension ( LLD_Q, LOCc(JQ+N-1))
          Q  contains the orthonormal eigenvectors of the symmetric
          tridiagonal matrix.
          On output, Q is distributed across the P processes in block
          cyclic format.
  IQ      (global input) INTEGER
          Q's global row index, which points to the beginning of the
          submatrix which is to be operated on.
  JQ      (global input) INTEGER
          Q's global column index, which points to the beginning of
          the submatrix which is to be operated on.
  DESCQ   (global and local input) INTEGER array of dimension DLEN_.
          The array descriptor for the distributed matrix Z.
  WORK    (local workspace/output) REAL array,
          dimension (LWORK)
          On output, WORK(1) returns the workspace needed.
  LWORK   (local input/output) INTEGER,
          the dimension of the array WORK.
          LWORK = 6*N + 2*NP*NQ
          NP = NUMROC( N, NB, MYROW, DESCQ( RSRC_ ), NPROW )
          NQ = NUMROC( N, NB, MYCOL, DESCQ( CSRC_ ), 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.
  IWORK   (local workspace/output) INTEGER array, dimension (LIWORK)
          On exit, if LIWORK > 0, IWORK(1) returns the optimal LIWORK.
  LIWORK  (input) INTEGER
          The dimension of the array IWORK.
          LIWORK = 2 + 7*N + 8*NPCOL
  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:  The algorithm failed to compute the INFO/(N+1) th
                eigenvalue while working on the submatrix lying in
                global rows and columns mod(INFO,N+1).
  Further Details
  ======= =======
  Contributed by Francoise Tisseur, University of Manchester.
  Reference:  F. Tisseur and J. Dongarra, "A Parallel Divide and
              Conquer Algorithm for the Symmetric Eigenvalue Problem
              on Distributed Memory Architectures",
              SIAM J. Sci. Comput., 6:20 (1999), pp. 2223--2236.
              (see also LAPACK Working Note 132)
                http://www.netlib.org/lapack/lawns/lawn132.ps
  =====================================================================
     .. Parameters ..
 
Display dynamic version Find AutoScroll Reload FontSize: - + Hide Comments Hide Blanks Frame FullScreen MailPrint

  
001        SUBROUTINE PSSTEDC( COMPZ , N , D , E , Q , IQ , JQ , DESCQ , WORK , LWORK ,
002       $IWORK , LIWORK , INFO )
003  
004  *     -- ScaLAPACK routine(version 1.7) --
005  *     University of Tennessee , Knoxville , Oak Ridge National Laboratory ,
006  *     and University of California , Berkeley.
007  *     March 13 , 2000
008  
009  *     .. Scalar Arguments ..
010        CHARACTER COMPZ
011        INTEGER INFO , IQ , JQ , LIWORK , 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        REAL ZERO , ONE
018        PARAMETER( ZERO = 0.0E + 0 , ONE = 1.0E + 0 )
019  *     ..
020  *     .. Local Scalars ..
021        LOGICAL LQUERY
022        INTEGER ICOFFQ , IIQ , IPQ , IQCOL , IQROW , IROFFQ , JJQ ,
023       $LDQ , LIWMIN , LWMIN , MYCOL , MYROW , NB , NP ,
024       $NPCOL , NPROW , NQ
025        REAL ORGNRM
026  *     ..
027  *     .. External Functions ..
028        LOGICAL LSAME
029        INTEGER INDXG2P , NUMROC
030        REAL SLANST
031        EXTERNAL INDXG2P , LSAME , NUMROC , SLANST
032  *     ..
033  *     .. External Subroutines ..
034        EXTERNAL BLACS_GRIDINFO , CHK1MAT , INFOG2L , PSLAED0 ,
035       $PSLASRT , PXERBLA , SLASCL , SSTEDC
036  *     ..
037  *     .. Intrinsic Functions ..
038        INTRINSIC MOD , REAL
039  *     ..
040  *     .. Executable Statements ..
041  
042  *     This is just to keep ftnchek and toolpack / 1 happy
043        IF( BLOCK_CYCLIC_2D*CSRC_*CTXT_*DLEN_*DTYPE_*LLD_*MB_*M_*NB_*N_*
044       $    RSRC_.LT.0 )RETURN
045  
046  *         Test the input parameters.
047  
048            CALL BLACS_GRIDINFO( DESCQ( CTXT_ ) , NPROW , NPCOL , MYROW , MYCOL )
049            LDQ = DESCQ( LLD_ )
050            NB = DESCQ( NB_ )
051            NP = NUMROC( N , NB , MYROW , DESCQ( RSRC_ ) , NPROW )
052            NQ = NUMROC( N , NB , MYCOL , DESCQ( CSRC_ ) , NPCOL )
053            INFO = 0
054            IF( NPROW.EQ. - 1 ) THEN
055                INFO = - ( 600 + CTXT_ )
056            ELSE
057                CALL CHK1MAT( N , 2 , N , 2 , IQ , JQ , DESCQ , 8 , INFO )
058                IF( INFO.EQ.0 ) THEN
059                    NB = DESCQ( NB_ )
060                    IROFFQ = MOD( IQ - 1 , DESCQ( MB_ ) )
061                    ICOFFQ = MOD( JQ - 1 , DESCQ( NB_ ) )
062                    IQROW = INDXG2P( IQ , NB , MYROW , DESCQ( RSRC_ ) , NPROW )
063                    IQCOL = INDXG2P( JQ , NB , MYCOL , DESCQ( CSRC_ ) , NPCOL )
064                    LWMIN = 6*N + 2*NP*NQ
065                    LIWMIN = 2 + 7*N + 8*NPCOL
066                    WORK( 1 ) = REAL( LWMIN )
067                    IWORK( 1 ) = LIWMIN
068                    LQUERY =( LWORK.EQ. - 1 .OR. LIWORK.EQ. - 1 )
069                    IF( .NOT.LSAME( COMPZ , 'I' ) ) THEN
070                        INFO = - 1
071                    ELSE IF( N.LT.0 ) THEN
072                        INFO = - 2
073                    ELSE IF( IROFFQ.NE.ICOFFQ .OR. ICOFFQ.NE.0 ) THEN
074                        INFO = - 5
075                    ELSE IF( DESCQ( MB_ ).NE.DESCQ( NB_ ) ) THEN
076                        INFO = - ( 700 + NB_ )
077                    ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
078                        INFO = - 10
079                    ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
080                        INFO = - 12
081                    END IF
082                END IF
083            END IF
084            IF( INFO.NE.0 ) THEN
085                CALL PXERBLA( DESCQ( CTXT_ ) , 'PSSTEDC' , - INFO )
086                RETURN
087            ELSE IF( LQUERY ) THEN
088                RETURN
089            END IF
090  
091  *         Quick return
092  
093            IF( N.EQ.0 )
094       $        GO TO 10
095                CALL INFOG2L( IQ , JQ , DESCQ , NPROW , NPCOL , MYROW , MYCOL , IIQ , JJQ ,
096       $        IQROW , IQCOL )
097                IF( N.EQ.1 ) THEN
098                    IF( MYROW.EQ.IQROW .AND. MYCOL.EQ.IQCOL )
099       $                Q( 1 ) = ONE
100                        GO TO 10
101                    END IF
102  
103  *                 If N is smaller than the minimum divide size NB , then
104  *                 solve the problem with the serial divide and conquer
105  *                 code locally.
106  
107                    IF( N.LE.NB ) THEN
108                        IF(( MYROW.EQ.IQROW ) .AND.( MYCOL.EQ.IQCOL ) ) THEN
109                            IPQ = IIQ + ( JJQ - 1 )*LDQ
110                            CALL SSTEDC( 'I' , N , D , E , Q( IPQ ) , LDQ , WORK , LWORK ,
111       $                    IWORK , LIWORK , INFO )
112                            IF( INFO.NE.0 ) THEN
113                                INFO =( N + 1 ) + N
114                                GO TO 10
115                            END IF
116                        END IF
117                        GO TO 10
118                    END IF
119  
120  *                 If P = NPROW*NPCOL = 1 , solve the problem with SSTEDC.
121  
122                    IF( NPCOL*NPROW.EQ.1 ) THEN
123                        IPQ = IIQ + ( JJQ - 1 )*LDQ
124                        CALL SSTEDC( 'I' , N , D , E , Q( IPQ ) , LDQ , WORK , LWORK , IWORK ,
125       $                LIWORK , INFO )
126                        GO TO 10
127                    END IF
128  
129  *                 Scale matrix to allowable range , if necessary.
130  
131                    ORGNRM = SLANST( 'M' , N , D , E )
132                    IF( ORGNRM.NE.ZERO ) THEN
133                        CALL SLASCL( 'G' , 0 , 0 , ORGNRM , ONE , N , 1 , D , N , INFO )
134                        CALL SLASCL( 'G' , 0 , 0 , ORGNRM , ONE , N - 1 , 1 , E , N - 1 , INFO )
135                    END IF
136  
137                    CALL PSLAED0 ( N , D , E , Q , IQ , JQ , DESCQ , WORK , IWORK , INFO )
138  
139  *                 Sort eigenvalues and corresponding eigenvectors
140  
141                    CALL PSLASRT ( 'I' , N , D , Q , IQ , JQ , DESCQ , WORK , LWORK , IWORK ,
142       $            LIWORK , INFO )
143  
144  *                 Scale back.
145  
146                    IF( ORGNRM.NE.ZERO )
147       $                CALL SLASCL( 'G' , 0 , 0 , ONE , ORGNRM , N , 1 , D , N , INFO )
148  
149     10 CONTINUE
150  
151        IF( LWORK.GT.0 )
152       $    WORK( 1 ) = REAL( LWMIN )
153            IF( LIWORK.GT.0 )
154       $        IWORK( 1 ) = LIWMIN
155                RETURN
156  
157  *             End of PSSTEDC
158  
159            END