!*==dgesdd.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b DGESDD
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download DGESDD + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT,
!                          WORK, LWORK, IWORK, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          JOBZ
!       INTEGER            INFO, LDA, LDU, LDVT, LWORK, M, N
!       ..
!       .. Array Arguments ..
!       INTEGER            IWORK( * )
!       DOUBLE PRECISION   A( LDA, * ), S( * ), U( LDU, * ),
!      $                   VT( LDVT, * ), WORK( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> DGESDD computes the singular value decomposition (SVD) of a real
!> M-by-N matrix A, optionally computing the left and right singular
!> vectors.  If singular vectors are desired, it uses a
!> divide-and-conquer algorithm.
!>
!> The SVD is written
!>
!>      A = U * SIGMA * transpose(V)
!>
!> where SIGMA is an M-by-N matrix which is zero except for its
!> min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and
!> V is an N-by-N orthogonal matrix.  The diagonal elements of SIGMA
!> are the singular values of A; they are real and non-negative, and
!> are returned in descending order.  The first min(m,n) columns of
!> U and V are the left and right singular vectors of A.
!>
!> Note that the routine returns VT = V**T, not V.
!>
!> The divide and conquer algorithm 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.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] JOBZ
!> \verbatim
!>          JOBZ is CHARACTER*1
!>          Specifies options for computing all or part of the matrix U:
!>          = 'A':  all M columns of U and all N rows of V**T are
!>                  returned in the arrays U and VT;
!>          = 'S':  the first min(M,N) columns of U and the first
!>                  min(M,N) rows of V**T are returned in the arrays U
!>                  and VT;
!>          = 'O':  If M >= N, the first N columns of U are overwritten
!>                  on the array A and all rows of V**T are returned in
!>                  the array VT;
!>                  otherwise, all columns of U are returned in the
!>                  array U and the first M rows of V**T are overwritten
!>                  in the array A;
!>          = 'N':  no columns of U or rows of V**T are computed.
!> \endverbatim
!>
!> \param[in] M
!> \verbatim
!>          M is INTEGER
!>          The number of rows of the input matrix A.  M >= 0.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The number of columns of the input matrix A.  N >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit,
!>          if JOBZ = 'O',  A is overwritten with the first N columns
!>                          of U (the left singular vectors, stored
!>                          columnwise) if M >= N;
!>                          A is overwritten with the first M rows
!>                          of V**T (the right singular vectors, stored
!>                          rowwise) otherwise.
!>          if JOBZ .ne. 'O', the contents of A are destroyed.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!> \endverbatim
!>
!> \param[out] S
!> \verbatim
!>          S is DOUBLE PRECISION array, dimension (min(M,N))
!>          The singular values of A, sorted so that S(i) >= S(i+1).
!> \endverbatim
!>
!> \param[out] U
!> \verbatim
!>          U is DOUBLE PRECISION array, dimension (LDU,UCOL)
!>          UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N;
!>          UCOL = min(M,N) if JOBZ = 'S'.
!>          If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M
!>          orthogonal matrix U;
!>          if JOBZ = 'S', U contains the first min(M,N) columns of U
!>          (the left singular vectors, stored columnwise);
!>          if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced.
!> \endverbatim
!>
!> \param[in] LDU
!> \verbatim
!>          LDU is INTEGER
!>          The leading dimension of the array U.  LDU >= 1; if
!>          JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M.
!> \endverbatim
!>
!> \param[out] VT
!> \verbatim
!>          VT is DOUBLE PRECISION array, dimension (LDVT,N)
!>          If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the
!>          N-by-N orthogonal matrix V**T;
!>          if JOBZ = 'S', VT contains the first min(M,N) rows of
!>          V**T (the right singular vectors, stored rowwise);
!>          if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced.
!> \endverbatim
!>
!> \param[in] LDVT
!> \verbatim
!>          LDVT is INTEGER
!>          The leading dimension of the array VT.  LDVT >= 1;
!>          if JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N;
!>          if JOBZ = 'S', LDVT >= min(M,N).
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK;
!> \endverbatim
!>
!> \param[in] LWORK
!> \verbatim
!>          LWORK is INTEGER
!>          The dimension of the array WORK. LWORK >= 1.
!>          If LWORK = -1, a workspace query is assumed.  The optimal
!>          size for the WORK array is calculated and stored in WORK(1),
!>          and no other work except argument checking is performed.
!>
!>          Let mx = max(M,N) and mn = min(M,N).
!>          If JOBZ = 'N', LWORK >= 3*mn + max( mx, 7*mn ).
!>          If JOBZ = 'O', LWORK >= 3*mn + max( mx, 5*mn*mn + 4*mn ).
!>          If JOBZ = 'S', LWORK >= 4*mn*mn + 7*mn.
!>          If JOBZ = 'A', LWORK >= 4*mn*mn + 6*mn + mx.
!>          These are not tight minimums in all cases; see comments inside code.
!>          For good performance, LWORK should generally be larger;
!>          a query is recommended.
!> \endverbatim
!>
!> \param[out] IWORK
!> \verbatim
!>          IWORK is INTEGER array, dimension (8*min(M,N))
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit.
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  DBDSDC did not converge, updating process failed.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date June 2016
!
!> \ingroup doubleGEsing
!
!> \par Contributors:
!  ==================
!>
!>     Ming Gu and Huan Ren, Computer Science Division, University of
!>     California at Berkeley, USA
!>
!  =====================================================================
      SUBROUTINE DGESDD(Jobz,M,N,A,Lda,S,U,Ldu,Vt,Ldvt,Work,Lwork,Iwork,&
     &                  Info)
      IMPLICIT NONE
!*--DGESDD222
!
!  -- LAPACK driver routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     June 2016
!
!     .. Scalar Arguments ..
      CHARACTER Jobz
      INTEGER Info , Lda , Ldu , Ldvt , Lwork , M , N
!     ..
!     .. Array Arguments ..
      INTEGER Iwork(*)
      DOUBLE PRECISION A(Lda,*) , S(*) , U(Ldu,*) , Vt(Ldvt,*) , Work(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ZERO , ONE
      PARAMETER (ZERO=0.0D0,ONE=1.0D0)
!     ..
!     .. Local Scalars ..
      LOGICAL lquery , wntqa , wntqas , wntqn , wntqo , wntqs
      INTEGER bdspac , blk , chunk , i , ie , ierr , il , ir , iscl ,   &
     &        itau , itaup , itauq , iu , ivt , ldwkvt , ldwrkl ,       &
     &        ldwrkr , ldwrku , maxwrk , minmn , minwrk , mnthr ,       &
     &        nwork , wrkbl
      INTEGER lwork_dgebrd_mn , lwork_dgebrd_mm , lwork_dgebrd_nn ,     &
     &        lwork_dgelqf_mn , lwork_dgeqrf_mn , lwork_dorgbr_p_mm ,   &
     &        lwork_dorgbr_q_nn , lwork_dorglq_mn , lwork_dorglq_nn ,   &
     &        lwork_dorgqr_mm , lwork_dorgqr_mn , lwork_dormbr_prt_mm , &
     &        lwork_dormbr_qln_mm , lwork_dormbr_prt_mn ,               &
     &        lwork_dormbr_qln_mn , lwork_dormbr_prt_nn ,               &
     &        lwork_dormbr_qln_nn
      DOUBLE PRECISION anrm , bignum , eps , smlnum
!     ..
!     .. Local Arrays ..
      INTEGER idum(1)
      DOUBLE PRECISION dum(1)
!     ..
!     .. External Subroutines ..
      EXTERNAL DBDSDC , DGEBRD , DGELQF , DGEMM , DGEQRF , DLACPY ,     &
     &         DLASCL , DLASET , DORGBR , DORGLQ , DORGQR , DORMBR ,    &
     &         XERBLA
!     ..
!     .. External Functions ..
      LOGICAL LSAME , DISNAN
      DOUBLE PRECISION DLAMCH , DLANGE
      EXTERNAL DLAMCH , DLANGE , LSAME , DISNAN
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC INT , MAX , MIN , SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      Info = 0
      minmn = MIN(M,N)
      wntqa = LSAME(Jobz,'A')
      wntqs = LSAME(Jobz,'S')
      wntqas = wntqa .OR. wntqs
      wntqo = LSAME(Jobz,'O')
      wntqn = LSAME(Jobz,'N')
      lquery = (Lwork==-1)
!
      IF ( .NOT.(wntqa .OR. wntqs .OR. wntqo .OR. wntqn) ) THEN
         Info = -1
      ELSEIF ( M<0 ) THEN
         Info = -2
      ELSEIF ( N<0 ) THEN
         Info = -3
      ELSEIF ( Lda<MAX(1,M) ) THEN
         Info = -5
      ELSEIF ( Ldu<1 .OR. (wntqas .AND. Ldu<M) .OR.                     &
     &         (wntqo .AND. M<N .AND. Ldu<M) ) THEN
         Info = -8
      ELSEIF ( Ldvt<1 .OR. (wntqa .AND. Ldvt<N) .OR.                    &
     &         (wntqs .AND. Ldvt<minmn) .OR.                            &
     &         (wntqo .AND. M>=N .AND. Ldvt<N) ) THEN
         Info = -10
      ENDIF
!
!     Compute workspace
!       Note: Comments in the code beginning "Workspace:" describe the
!       minimal amount of workspace allocated at that point in the code,
!       as well as the preferred amount for good performance.
!       NB refers to the optimal block size for the immediately
!       following subroutine, as returned by ILAENV.
!
      IF ( Info==0 ) THEN
         minwrk = 1
         maxwrk = 1
         bdspac = 0
         mnthr = INT(minmn*11.0D0/6.0D0)
         IF ( M>=N .AND. minmn>0 ) THEN
!
!           Compute space needed for DBDSDC
!
            IF ( wntqn ) THEN
!              dbdsdc needs only 4*N (or 6*N for uplo=L for LAPACK <= 3.6)
!              keep 7*N for backwards compatibility.
               bdspac = 7*N
            ELSE
               bdspac = 3*N*N + 4*N
            ENDIF
!
!           Compute space preferred for each routine
            CALL DGEBRD(M,N,dum(1),M,dum(1),dum(1),dum(1),dum(1),dum(1),&
     &                  -1,ierr)
            lwork_dgebrd_mn = INT(dum(1))
!
            CALL DGEBRD(N,N,dum(1),N,dum(1),dum(1),dum(1),dum(1),dum(1),&
     &                  -1,ierr)
            lwork_dgebrd_nn = INT(dum(1))
!
            CALL DGEQRF(M,N,dum(1),M,dum(1),dum(1),-1,ierr)
            lwork_dgeqrf_mn = INT(dum(1))
!
            CALL DORGBR('Q',N,N,N,dum(1),N,dum(1),dum(1),-1,ierr)
            lwork_dorgbr_q_nn = INT(dum(1))
!
            CALL DORGQR(M,M,N,dum(1),M,dum(1),dum(1),-1,ierr)
            lwork_dorgqr_mm = INT(dum(1))
!
            CALL DORGQR(M,N,N,dum(1),M,dum(1),dum(1),-1,ierr)
            lwork_dorgqr_mn = INT(dum(1))
!
            CALL DORMBR('P','R','T',N,N,N,dum(1),N,dum(1),dum(1),N,     &
     &                  dum(1),-1,ierr)
            lwork_dormbr_prt_nn = INT(dum(1))
!
            CALL DORMBR('Q','L','N',N,N,N,dum(1),N,dum(1),dum(1),N,     &
     &                  dum(1),-1,ierr)
            lwork_dormbr_qln_nn = INT(dum(1))
!
            CALL DORMBR('Q','L','N',M,N,N,dum(1),M,dum(1),dum(1),M,     &
     &                  dum(1),-1,ierr)
            lwork_dormbr_qln_mn = INT(dum(1))
!
            CALL DORMBR('Q','L','N',M,M,N,dum(1),M,dum(1),dum(1),M,     &
     &                  dum(1),-1,ierr)
            lwork_dormbr_qln_mm = INT(dum(1))
!
            IF ( M<mnthr ) THEN
!
!              Path 5 (M >= N, but not much larger)
!
               wrkbl = 3*N + lwork_dgebrd_mn
               IF ( wntqn ) THEN
!                 Path 5n (M >= N, jobz='N')
                  maxwrk = MAX(wrkbl,3*N+bdspac)
                  minwrk = 3*N + MAX(M,bdspac)
               ELSEIF ( wntqo ) THEN
!                 Path 5o (M >= N, jobz='O')
                  wrkbl = MAX(wrkbl,3*N+lwork_dormbr_prt_nn)
                  wrkbl = MAX(wrkbl,3*N+lwork_dormbr_qln_mn)
                  wrkbl = MAX(wrkbl,3*N+bdspac)
                  maxwrk = wrkbl + M*N
                  minwrk = 3*N + MAX(M,N*N+bdspac)
               ELSEIF ( wntqs ) THEN
!                 Path 5s (M >= N, jobz='S')
                  wrkbl = MAX(wrkbl,3*N+lwork_dormbr_qln_mn)
                  wrkbl = MAX(wrkbl,3*N+lwork_dormbr_prt_nn)
                  maxwrk = MAX(wrkbl,3*N+bdspac)
                  minwrk = 3*N + MAX(M,bdspac)
               ELSEIF ( wntqa ) THEN
!                 Path 5a (M >= N, jobz='A')
                  wrkbl = MAX(wrkbl,3*N+lwork_dormbr_qln_mm)
                  wrkbl = MAX(wrkbl,3*N+lwork_dormbr_prt_nn)
                  maxwrk = MAX(wrkbl,3*N+bdspac)
                  minwrk = 3*N + MAX(M,bdspac)
               ENDIF
            ELSEIF ( wntqn ) THEN
!
!                 Path 1 (M >> N, JOBZ='N')
!
               wrkbl = N + lwork_dgeqrf_mn
               wrkbl = MAX(wrkbl,3*N+lwork_dgebrd_nn)
               maxwrk = MAX(wrkbl,bdspac+N)
               minwrk = bdspac + N
            ELSEIF ( wntqo ) THEN
!
!                 Path 2 (M >> N, JOBZ='O')
!
               wrkbl = N + lwork_dgeqrf_mn
               wrkbl = MAX(wrkbl,N+lwork_dorgqr_mn)
               wrkbl = MAX(wrkbl,3*N+lwork_dgebrd_nn)
               wrkbl = MAX(wrkbl,3*N+lwork_dormbr_qln_nn)
               wrkbl = MAX(wrkbl,3*N+lwork_dormbr_prt_nn)
               wrkbl = MAX(wrkbl,3*N+bdspac)
               maxwrk = wrkbl + 2*N*N
               minwrk = bdspac + 2*N*N + 3*N
            ELSEIF ( wntqs ) THEN
!
!                 Path 3 (M >> N, JOBZ='S')
!
               wrkbl = N + lwork_dgeqrf_mn
               wrkbl = MAX(wrkbl,N+lwork_dorgqr_mn)
               wrkbl = MAX(wrkbl,3*N+lwork_dgebrd_nn)
               wrkbl = MAX(wrkbl,3*N+lwork_dormbr_qln_nn)
               wrkbl = MAX(wrkbl,3*N+lwork_dormbr_prt_nn)
               wrkbl = MAX(wrkbl,3*N+bdspac)
               maxwrk = wrkbl + N*N
               minwrk = bdspac + N*N + 3*N
            ELSEIF ( wntqa ) THEN
!
!                 Path 4 (M >> N, JOBZ='A')
!
               wrkbl = N + lwork_dgeqrf_mn
               wrkbl = MAX(wrkbl,N+lwork_dorgqr_mm)
               wrkbl = MAX(wrkbl,3*N+lwork_dgebrd_nn)
               wrkbl = MAX(wrkbl,3*N+lwork_dormbr_qln_nn)
               wrkbl = MAX(wrkbl,3*N+lwork_dormbr_prt_nn)
               wrkbl = MAX(wrkbl,3*N+bdspac)
               maxwrk = wrkbl + N*N
               minwrk = N*N + MAX(3*N+bdspac,N+M)
            ENDIF
         ELSEIF ( minmn>0 ) THEN
!
!           Compute space needed for DBDSDC
!
            IF ( wntqn ) THEN
!              dbdsdc needs only 4*N (or 6*N for uplo=L for LAPACK <= 3.6)
!              keep 7*N for backwards compatibility.
               bdspac = 7*M
            ELSE
               bdspac = 3*M*M + 4*M
            ENDIF
!
!           Compute space preferred for each routine
            CALL DGEBRD(M,N,dum(1),M,dum(1),dum(1),dum(1),dum(1),dum(1),&
     &                  -1,ierr)
            lwork_dgebrd_mn = INT(dum(1))
!
            CALL DGEBRD(M,M,A,M,S,dum(1),dum(1),dum(1),dum(1),-1,ierr)
            lwork_dgebrd_mm = INT(dum(1))
!
            CALL DGELQF(M,N,A,M,dum(1),dum(1),-1,ierr)
            lwork_dgelqf_mn = INT(dum(1))
!
            CALL DORGLQ(N,N,M,dum(1),N,dum(1),dum(1),-1,ierr)
            lwork_dorglq_nn = INT(dum(1))
!
            CALL DORGLQ(M,N,M,A,M,dum(1),dum(1),-1,ierr)
            lwork_dorglq_mn = INT(dum(1))
!
            CALL DORGBR('P',M,M,M,A,N,dum(1),dum(1),-1,ierr)
            lwork_dorgbr_p_mm = INT(dum(1))
!
            CALL DORMBR('P','R','T',M,M,M,dum(1),M,dum(1),dum(1),M,     &
     &                  dum(1),-1,ierr)
            lwork_dormbr_prt_mm = INT(dum(1))
!
            CALL DORMBR('P','R','T',M,N,M,dum(1),M,dum(1),dum(1),M,     &
     &                  dum(1),-1,ierr)
            lwork_dormbr_prt_mn = INT(dum(1))
!
            CALL DORMBR('P','R','T',N,N,M,dum(1),N,dum(1),dum(1),N,     &
     &                  dum(1),-1,ierr)
            lwork_dormbr_prt_nn = INT(dum(1))
!
            CALL DORMBR('Q','L','N',M,M,M,dum(1),M,dum(1),dum(1),M,     &
     &                  dum(1),-1,ierr)
            lwork_dormbr_qln_mm = INT(dum(1))
!
            IF ( N<mnthr ) THEN
!
!              Path 5t (N > M, but not much larger)
!
               wrkbl = 3*M + lwork_dgebrd_mn
               IF ( wntqn ) THEN
!                 Path 5tn (N > M, jobz='N')
                  maxwrk = MAX(wrkbl,3*M+bdspac)
                  minwrk = 3*M + MAX(N,bdspac)
               ELSEIF ( wntqo ) THEN
!                 Path 5to (N > M, jobz='O')
                  wrkbl = MAX(wrkbl,3*M+lwork_dormbr_qln_mm)
                  wrkbl = MAX(wrkbl,3*M+lwork_dormbr_prt_mn)
                  wrkbl = MAX(wrkbl,3*M+bdspac)
                  maxwrk = wrkbl + M*N
                  minwrk = 3*M + MAX(N,M*M+bdspac)
               ELSEIF ( wntqs ) THEN
!                 Path 5ts (N > M, jobz='S')
                  wrkbl = MAX(wrkbl,3*M+lwork_dormbr_qln_mm)
                  wrkbl = MAX(wrkbl,3*M+lwork_dormbr_prt_mn)
                  maxwrk = MAX(wrkbl,3*M+bdspac)
                  minwrk = 3*M + MAX(N,bdspac)
               ELSEIF ( wntqa ) THEN
!                 Path 5ta (N > M, jobz='A')
                  wrkbl = MAX(wrkbl,3*M+lwork_dormbr_qln_mm)
                  wrkbl = MAX(wrkbl,3*M+lwork_dormbr_prt_nn)
                  maxwrk = MAX(wrkbl,3*M+bdspac)
                  minwrk = 3*M + MAX(N,bdspac)
               ENDIF
            ELSEIF ( wntqn ) THEN
!
!                 Path 1t (N >> M, JOBZ='N')
!
               wrkbl = M + lwork_dgelqf_mn
               wrkbl = MAX(wrkbl,3*M+lwork_dgebrd_mm)
               maxwrk = MAX(wrkbl,bdspac+M)
               minwrk = bdspac + M
            ELSEIF ( wntqo ) THEN
!
!                 Path 2t (N >> M, JOBZ='O')
!
               wrkbl = M + lwork_dgelqf_mn
               wrkbl = MAX(wrkbl,M+lwork_dorglq_mn)
               wrkbl = MAX(wrkbl,3*M+lwork_dgebrd_mm)
               wrkbl = MAX(wrkbl,3*M+lwork_dormbr_qln_mm)
               wrkbl = MAX(wrkbl,3*M+lwork_dormbr_prt_mm)
               wrkbl = MAX(wrkbl,3*M+bdspac)
               maxwrk = wrkbl + 2*M*M
               minwrk = bdspac + 2*M*M + 3*M
            ELSEIF ( wntqs ) THEN
!
!                 Path 3t (N >> M, JOBZ='S')
!
               wrkbl = M + lwork_dgelqf_mn
               wrkbl = MAX(wrkbl,M+lwork_dorglq_mn)
               wrkbl = MAX(wrkbl,3*M+lwork_dgebrd_mm)
               wrkbl = MAX(wrkbl,3*M+lwork_dormbr_qln_mm)
               wrkbl = MAX(wrkbl,3*M+lwork_dormbr_prt_mm)
               wrkbl = MAX(wrkbl,3*M+bdspac)
               maxwrk = wrkbl + M*M
               minwrk = bdspac + M*M + 3*M
            ELSEIF ( wntqa ) THEN
!
!                 Path 4t (N >> M, JOBZ='A')
!
               wrkbl = M + lwork_dgelqf_mn
               wrkbl = MAX(wrkbl,M+lwork_dorglq_nn)
               wrkbl = MAX(wrkbl,3*M+lwork_dgebrd_mm)
               wrkbl = MAX(wrkbl,3*M+lwork_dormbr_qln_mm)
               wrkbl = MAX(wrkbl,3*M+lwork_dormbr_prt_mm)
               wrkbl = MAX(wrkbl,3*M+bdspac)
               maxwrk = wrkbl + M*M
               minwrk = M*M + MAX(3*M+bdspac,M+N)
            ENDIF
         ENDIF

         maxwrk = MAX(maxwrk,minwrk)
         Work(1) = maxwrk
!
         IF ( Lwork<minwrk .AND. .NOT.lquery ) Info = -12
      ENDIF
!
      IF ( Info/=0 ) THEN
         CALL XERBLA('DGESDD',-Info)
         RETURN
      ELSEIF ( lquery ) THEN
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( M==0 .OR. N==0 ) RETURN
!
!     Get machine constants
!
      eps = DLAMCH('P')
      smlnum = SQRT(DLAMCH('S'))/eps
      bignum = ONE/smlnum
!
!     Scale A if max element outside range [SMLNUM,BIGNUM]
!
      anrm = DLANGE('M',M,N,A,Lda,dum)
      IF ( DISNAN(anrm) ) THEN
         Info = -4
         RETURN
      ENDIF
      iscl = 0
      IF ( anrm>ZERO .AND. anrm<smlnum ) THEN
         iscl = 1
         CALL DLASCL('G',0,0,anrm,smlnum,M,N,A,Lda,ierr)
      ELSEIF ( anrm>bignum ) THEN
         iscl = 1
         CALL DLASCL('G',0,0,anrm,bignum,M,N,A,Lda,ierr)
      ENDIF
!
      IF ( M>=N ) THEN
!
!        A has at least as many rows as columns. If A has sufficiently
!        more rows than columns, first reduce using the QR
!        decomposition (if sufficient workspace available)
!
         IF ( M<mnthr ) THEN
!
!           M .LT. MNTHR
!
!           Path 5 (M >= N, but not much larger)
!           Reduce to bidiagonal form without QR decomposition
!
            ie = 1
            itauq = ie + N
            itaup = itauq + N
            nwork = itaup + N
!
!           Bidiagonalize A
!           Workspace: need   3*N [e, tauq, taup] + M        [work]
!           Workspace: prefer 3*N [e, tauq, taup] + (M+N)*NB [work]
!
            CALL DGEBRD(M,N,A,Lda,S,Work(ie),Work(itauq),Work(itaup),   &
     &                  Work(nwork),Lwork-nwork+1,ierr)
            IF ( wntqn ) THEN
!
!              Path 5n (M >= N, JOBZ='N')
!              Perform bidiagonal SVD, only computing singular values
!              Workspace: need   3*N [e, tauq, taup] + BDSPAC
!
               CALL DBDSDC('U','N',N,S,Work(ie),dum,1,dum,1,dum,idum,   &
     &                     Work(nwork),Iwork,Info)
            ELSEIF ( wntqo ) THEN
!              Path 5o (M >= N, JOBZ='O')
               iu = nwork
               IF ( Lwork>=M*N+3*N+bdspac ) THEN
!
!                 WORK( IU ) is M by N
!
                  ldwrku = M
                  nwork = iu + ldwrku*N
                  CALL DLASET('F',M,N,ZERO,ZERO,Work(iu),ldwrku)
!                 IR is unused; silence compile warnings
                  ir = -1
               ELSE
!
!                 WORK( IU ) is N by N
!
                  ldwrku = N
                  nwork = iu + ldwrku*N
!
!                 WORK(IR) is LDWRKR by N
!
                  ir = nwork
                  ldwrkr = (Lwork-N*N-3*N)/N
               ENDIF
               nwork = iu + ldwrku*N
!
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagonal matrix in WORK(IU) and computing right
!              singular vectors of bidiagonal matrix in VT
!              Workspace: need   3*N [e, tauq, taup] + N*N [U] + BDSPAC
!
               CALL DBDSDC('U','I',N,S,Work(ie),Work(iu),ldwrku,Vt,Ldvt,&
     &                     dum,idum,Work(nwork),Iwork,Info)
!
!              Overwrite VT by right singular vectors of A
!              Workspace: need   3*N [e, tauq, taup] + N*N [U] + N    [work]
!              Workspace: prefer 3*N [e, tauq, taup] + N*N [U] + N*NB [work]
!
               CALL DORMBR('P','R','T',N,N,N,A,Lda,Work(itaup),Vt,Ldvt, &
     &                     Work(nwork),Lwork-nwork+1,ierr)
!
               IF ( Lwork>=M*N+3*N+bdspac ) THEN
!
!                 Path 5o-fast
!                 Overwrite WORK(IU) by left singular vectors of A
!                 Workspace: need   3*N [e, tauq, taup] + M*N [U] + N    [work]
!                 Workspace: prefer 3*N [e, tauq, taup] + M*N [U] + N*NB [work]
!
                  CALL DORMBR('Q','L','N',M,N,N,A,Lda,Work(itauq),      &
     &                        Work(iu),ldwrku,Work(nwork),Lwork-nwork+1,&
     &                        ierr)
!
!                 Copy left singular vectors of A from WORK(IU) to A
!
                  CALL DLACPY('F',M,N,Work(iu),ldwrku,A,Lda)
               ELSE
!
!                 Path 5o-slow
!                 Generate Q in A
!                 Workspace: need   3*N [e, tauq, taup] + N*N [U] + N    [work]
!                 Workspace: prefer 3*N [e, tauq, taup] + N*N [U] + N*NB [work]
!
                  CALL DORGBR('Q',M,N,N,A,Lda,Work(itauq),Work(nwork),  &
     &                        Lwork-nwork+1,ierr)
!
!                 Multiply Q in A by left singular vectors of
!                 bidiagonal matrix in WORK(IU), storing result in
!                 WORK(IR) and copying to A
!                 Workspace: need   3*N [e, tauq, taup] + N*N [U] + NB*N [R]
!                 Workspace: prefer 3*N [e, tauq, taup] + N*N [U] + M*N  [R]
!
                  DO i = 1 , M , ldwrkr
                     chunk = MIN(M-i+1,ldwrkr)
                     CALL DGEMM('N','N',chunk,N,N,ONE,A(i,1),Lda,       &
     &                          Work(iu),ldwrku,ZERO,Work(ir),ldwrkr)
                     CALL DLACPY('F',chunk,N,Work(ir),ldwrkr,A(i,1),Lda)
                  ENDDO
               ENDIF
!
            ELSEIF ( wntqs ) THEN
!
!              Path 5s (M >= N, JOBZ='S')
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagonal matrix in U and computing right singular
!              vectors of bidiagonal matrix in VT
!              Workspace: need   3*N [e, tauq, taup] + BDSPAC
!
               CALL DLASET('F',M,N,ZERO,ZERO,U,Ldu)
               CALL DBDSDC('U','I',N,S,Work(ie),U,Ldu,Vt,Ldvt,dum,idum, &
     &                     Work(nwork),Iwork,Info)
!
!              Overwrite U by left singular vectors of A and VT
!              by right singular vectors of A
!              Workspace: need   3*N [e, tauq, taup] + N    [work]
!              Workspace: prefer 3*N [e, tauq, taup] + N*NB [work]
!
               CALL DORMBR('Q','L','N',M,N,N,A,Lda,Work(itauq),U,Ldu,   &
     &                     Work(nwork),Lwork-nwork+1,ierr)
               CALL DORMBR('P','R','T',N,N,N,A,Lda,Work(itaup),Vt,Ldvt, &
     &                     Work(nwork),Lwork-nwork+1,ierr)
            ELSEIF ( wntqa ) THEN
!
!              Path 5a (M >= N, JOBZ='A')
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagonal matrix in U and computing right singular
!              vectors of bidiagonal matrix in VT
!              Workspace: need   3*N [e, tauq, taup] + BDSPAC
!
               CALL DLASET('F',M,M,ZERO,ZERO,U,Ldu)
               CALL DBDSDC('U','I',N,S,Work(ie),U,Ldu,Vt,Ldvt,dum,idum, &
     &                     Work(nwork),Iwork,Info)
!
!              Set the right corner of U to identity matrix
!
               IF ( M>N ) CALL DLASET('F',M-N,M-N,ZERO,ONE,U(N+1,N+1),  &
     &                                Ldu)
!
!              Overwrite U by left singular vectors of A and VT
!              by right singular vectors of A
!              Workspace: need   3*N [e, tauq, taup] + M    [work]
!              Workspace: prefer 3*N [e, tauq, taup] + M*NB [work]
!
               CALL DORMBR('Q','L','N',M,M,N,A,Lda,Work(itauq),U,Ldu,   &
     &                     Work(nwork),Lwork-nwork+1,ierr)
               CALL DORMBR('P','R','T',N,N,M,A,Lda,Work(itaup),Vt,Ldvt, &
     &                     Work(nwork),Lwork-nwork+1,ierr)
            ENDIF
!
         ELSEIF ( wntqn ) THEN
!
!              Path 1 (M >> N, JOBZ='N')
!              No singular vectors to be computed
!
            itau = 1
            nwork = itau + N
!
!              Compute A=Q*R
!              Workspace: need   N [tau] + N    [work]
!              Workspace: prefer N [tau] + N*NB [work]
!
            CALL DGEQRF(M,N,A,Lda,Work(itau),Work(nwork),Lwork-nwork+1, &
     &                  ierr)
!
!              Zero out below R
!
            CALL DLASET('L',N-1,N-1,ZERO,ZERO,A(2,1),Lda)
            ie = 1
            itauq = ie + N
            itaup = itauq + N
            nwork = itaup + N
!
!              Bidiagonalize R in A
!              Workspace: need   3*N [e, tauq, taup] + N      [work]
!              Workspace: prefer 3*N [e, tauq, taup] + 2*N*NB [work]
!
            CALL DGEBRD(N,N,A,Lda,S,Work(ie),Work(itauq),Work(itaup),   &
     &                  Work(nwork),Lwork-nwork+1,ierr)
            nwork = ie + N
!
!              Perform bidiagonal SVD, computing singular values only
!              Workspace: need   N [e] + BDSPAC
!
            CALL DBDSDC('U','N',N,S,Work(ie),dum,1,dum,1,dum,idum,      &
     &                  Work(nwork),Iwork,Info)
!
         ELSEIF ( wntqo ) THEN
!
!              Path 2 (M >> N, JOBZ = 'O')
!              N left singular vectors to be overwritten on A and
!              N right singular vectors to be computed in VT
!
            ir = 1
!
!              WORK(IR) is LDWRKR by N
!
            IF ( Lwork>=Lda*N+N*N+3*N+bdspac ) THEN
               ldwrkr = Lda
            ELSE
               ldwrkr = (Lwork-N*N-3*N-bdspac)/N
            ENDIF
            itau = ir + ldwrkr*N
            nwork = itau + N
!
!              Compute A=Q*R
!              Workspace: need   N*N [R] + N [tau] + N    [work]
!              Workspace: prefer N*N [R] + N [tau] + N*NB [work]
!
            CALL DGEQRF(M,N,A,Lda,Work(itau),Work(nwork),Lwork-nwork+1, &
     &                  ierr)
!
!              Copy R to WORK(IR), zeroing out below it
!
            CALL DLACPY('U',N,N,A,Lda,Work(ir),ldwrkr)
            CALL DLASET('L',N-1,N-1,ZERO,ZERO,Work(ir+1),ldwrkr)
!
!              Generate Q in A
!              Workspace: need   N*N [R] + N [tau] + N    [work]
!              Workspace: prefer N*N [R] + N [tau] + N*NB [work]
!
            CALL DORGQR(M,N,N,A,Lda,Work(itau),Work(nwork),             &
     &                  Lwork-nwork+1,ierr)
            ie = itau
            itauq = ie + N
            itaup = itauq + N
            nwork = itaup + N
!
!              Bidiagonalize R in WORK(IR)
!              Workspace: need   N*N [R] + 3*N [e, tauq, taup] + N      [work]
!              Workspace: prefer N*N [R] + 3*N [e, tauq, taup] + 2*N*NB [work]
!
            CALL DGEBRD(N,N,Work(ir),ldwrkr,S,Work(ie),Work(itauq),     &
     &                  Work(itaup),Work(nwork),Lwork-nwork+1,ierr)
!
!              WORK(IU) is N by N
!
            iu = nwork
            nwork = iu + N*N
!
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagonal matrix in WORK(IU) and computing right
!              singular vectors of bidiagonal matrix in VT
!              Workspace: need   N*N [R] + 3*N [e, tauq, taup] + N*N [U] + BDSPAC
!
            CALL DBDSDC('U','I',N,S,Work(ie),Work(iu),N,Vt,Ldvt,dum,    &
     &                  idum,Work(nwork),Iwork,Info)
!
!              Overwrite WORK(IU) by left singular vectors of R
!              and VT by right singular vectors of R
!              Workspace: need   N*N [R] + 3*N [e, tauq, taup] + N*N [U] + N    [work]
!              Workspace: prefer N*N [R] + 3*N [e, tauq, taup] + N*N [U] + N*NB [work]
!
            CALL DORMBR('Q','L','N',N,N,N,Work(ir),ldwrkr,Work(itauq),  &
     &                  Work(iu),N,Work(nwork),Lwork-nwork+1,ierr)
            CALL DORMBR('P','R','T',N,N,N,Work(ir),ldwrkr,Work(itaup),  &
     &                  Vt,Ldvt,Work(nwork),Lwork-nwork+1,ierr)
!
!              Multiply Q in A by left singular vectors of R in
!              WORK(IU), storing result in WORK(IR) and copying to A
!              Workspace: need   N*N [R] + 3*N [e, tauq, taup] + N*N [U]
!              Workspace: prefer M*N [R] + 3*N [e, tauq, taup] + N*N [U]
!
            DO i = 1 , M , ldwrkr
               chunk = MIN(M-i+1,ldwrkr)
               CALL DGEMM('N','N',chunk,N,N,ONE,A(i,1),Lda,Work(iu),N,  &
     &                    ZERO,Work(ir),ldwrkr)
               CALL DLACPY('F',chunk,N,Work(ir),ldwrkr,A(i,1),Lda)
            ENDDO
!
         ELSEIF ( wntqs ) THEN
!
!              Path 3 (M >> N, JOBZ='S')
!              N left singular vectors to be computed in U and
!              N right singular vectors to be computed in VT
!
            ir = 1
!
!              WORK(IR) is N by N
!
            ldwrkr = N
            itau = ir + ldwrkr*N
            nwork = itau + N
!
!              Compute A=Q*R
!              Workspace: need   N*N [R] + N [tau] + N    [work]
!              Workspace: prefer N*N [R] + N [tau] + N*NB [work]
!
            CALL DGEQRF(M,N,A,Lda,Work(itau),Work(nwork),Lwork-nwork+1, &
     &                  ierr)
!
!              Copy R to WORK(IR), zeroing out below it
!
            CALL DLACPY('U',N,N,A,Lda,Work(ir),ldwrkr)
            CALL DLASET('L',N-1,N-1,ZERO,ZERO,Work(ir+1),ldwrkr)
!
!              Generate Q in A
!              Workspace: need   N*N [R] + N [tau] + N    [work]
!              Workspace: prefer N*N [R] + N [tau] + N*NB [work]
!
            CALL DORGQR(M,N,N,A,Lda,Work(itau),Work(nwork),             &
     &                  Lwork-nwork+1,ierr)
            ie = itau
            itauq = ie + N
            itaup = itauq + N
            nwork = itaup + N
!
!              Bidiagonalize R in WORK(IR)
!              Workspace: need   N*N [R] + 3*N [e, tauq, taup] + N      [work]
!              Workspace: prefer N*N [R] + 3*N [e, tauq, taup] + 2*N*NB [work]
!
            CALL DGEBRD(N,N,Work(ir),ldwrkr,S,Work(ie),Work(itauq),     &
     &                  Work(itaup),Work(nwork),Lwork-nwork+1,ierr)
!
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagoal matrix in U and computing right singular
!              vectors of bidiagonal matrix in VT
!              Workspace: need   N*N [R] + 3*N [e, tauq, taup] + BDSPAC
!
            CALL DBDSDC('U','I',N,S,Work(ie),U,Ldu,Vt,Ldvt,dum,idum,    &
     &                  Work(nwork),Iwork,Info)
!
!              Overwrite U by left singular vectors of R and VT
!              by right singular vectors of R
!              Workspace: need   N*N [R] + 3*N [e, tauq, taup] + N    [work]
!              Workspace: prefer N*N [R] + 3*N [e, tauq, taup] + N*NB [work]
!
            CALL DORMBR('Q','L','N',N,N,N,Work(ir),ldwrkr,Work(itauq),U,&
     &                  Ldu,Work(nwork),Lwork-nwork+1,ierr)
!
            CALL DORMBR('P','R','T',N,N,N,Work(ir),ldwrkr,Work(itaup),  &
     &                  Vt,Ldvt,Work(nwork),Lwork-nwork+1,ierr)
!
!              Multiply Q in A by left singular vectors of R in
!              WORK(IR), storing result in U
!              Workspace: need   N*N [R]
!
            CALL DLACPY('F',N,N,U,Ldu,Work(ir),ldwrkr)
            CALL DGEMM('N','N',M,N,N,ONE,A,Lda,Work(ir),ldwrkr,ZERO,U,  &
     &                 Ldu)
!
         ELSEIF ( wntqa ) THEN
!
!              Path 4 (M >> N, JOBZ='A')
!              M left singular vectors to be computed in U and
!              N right singular vectors to be computed in VT
!
            iu = 1
!
!              WORK(IU) is N by N
!
            ldwrku = N
            itau = iu + ldwrku*N
            nwork = itau + N
!
!              Compute A=Q*R, copying result to U
!              Workspace: need   N*N [U] + N [tau] + N    [work]
!              Workspace: prefer N*N [U] + N [tau] + N*NB [work]
!
            CALL DGEQRF(M,N,A,Lda,Work(itau),Work(nwork),Lwork-nwork+1, &
     &                  ierr)
            CALL DLACPY('L',M,N,A,Lda,U,Ldu)
!
!              Generate Q in U
!              Workspace: need   N*N [U] + N [tau] + M    [work]
!              Workspace: prefer N*N [U] + N [tau] + M*NB [work]
            CALL DORGQR(M,M,N,U,Ldu,Work(itau),Work(nwork),             &
     &                  Lwork-nwork+1,ierr)
!
!              Produce R in A, zeroing out other entries
!
            CALL DLASET('L',N-1,N-1,ZERO,ZERO,A(2,1),Lda)
            ie = itau
            itauq = ie + N
            itaup = itauq + N
            nwork = itaup + N
!
!              Bidiagonalize R in A
!              Workspace: need   N*N [U] + 3*N [e, tauq, taup] + N      [work]
!              Workspace: prefer N*N [U] + 3*N [e, tauq, taup] + 2*N*NB [work]
!
            CALL DGEBRD(N,N,A,Lda,S,Work(ie),Work(itauq),Work(itaup),   &
     &                  Work(nwork),Lwork-nwork+1,ierr)
!
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagonal matrix in WORK(IU) and computing right
!              singular vectors of bidiagonal matrix in VT
!              Workspace: need   N*N [U] + 3*N [e, tauq, taup] + BDSPAC
!
            CALL DBDSDC('U','I',N,S,Work(ie),Work(iu),N,Vt,Ldvt,dum,    &
     &                  idum,Work(nwork),Iwork,Info)
!
!              Overwrite WORK(IU) by left singular vectors of R and VT
!              by right singular vectors of R
!              Workspace: need   N*N [U] + 3*N [e, tauq, taup] + N    [work]
!              Workspace: prefer N*N [U] + 3*N [e, tauq, taup] + N*NB [work]
!
            CALL DORMBR('Q','L','N',N,N,N,A,Lda,Work(itauq),Work(iu),   &
     &                  ldwrku,Work(nwork),Lwork-nwork+1,ierr)
            CALL DORMBR('P','R','T',N,N,N,A,Lda,Work(itaup),Vt,Ldvt,    &
     &                  Work(nwork),Lwork-nwork+1,ierr)
!
!              Multiply Q in U by left singular vectors of R in
!              WORK(IU), storing result in A
!              Workspace: need   N*N [U]
!
            CALL DGEMM('N','N',M,N,N,ONE,U,Ldu,Work(iu),ldwrku,ZERO,A,  &
     &                 Lda)
!
!              Copy left singular vectors of A from A to U
!
            CALL DLACPY('F',M,N,A,Lda,U,Ldu)
!
         ENDIF
!
!
!        A has more columns than rows. If A has sufficiently more
!        columns than rows, first reduce using the LQ decomposition (if
!        sufficient workspace available)
!
      ELSEIF ( N>=mnthr ) THEN
!
         IF ( wntqn ) THEN
!
!              Path 1t (N >> M, JOBZ='N')
!              No singular vectors to be computed
!
            itau = 1
!
!
            nwork = itau + M
!
!              Compute A=L*Q
!              Workspace: need   M [tau] + M [work]
!              Workspace: prefer M [tau] + M*NB [work]
!
            CALL DGELQF(M,N,A,Lda,Work(itau),Work(nwork),Lwork-nwork+1, &
     &                  ierr)
!
!              Zero out above L
!
            CALL DLASET('U',M-1,M-1,ZERO,ZERO,A(1,2),Lda)
            ie = 1
            itauq = ie + M
            itaup = itauq + M
            nwork = itaup + M
!
!              Bidiagonalize L in A
!              Workspace: need   3*M [e, tauq, taup] + M      [work]
!              Workspace: prefer 3*M [e, tauq, taup] + 2*M*NB [work]
!
            CALL DGEBRD(M,M,A,Lda,S,Work(ie),Work(itauq),Work(itaup),   &
     &                  Work(nwork),Lwork-nwork+1,ierr)
            nwork = ie + M
!
!              Perform bidiagonal SVD, computing singular values only
!              Workspace: need   M [e] + BDSPAC
!
            CALL DBDSDC('U','N',M,S,Work(ie),dum,1,dum,1,dum,idum,      &
     &                  Work(nwork),Iwork,Info)
!
         ELSEIF ( wntqo ) THEN
!
!              Path 2t (N >> M, JOBZ='O')
!              M right singular vectors to be overwritten on A and
!              M left singular vectors to be computed in U
!
            ivt = 1
!
!              WORK(IVT) is M by M
!              WORK(IL)  is M by M; it is later resized to M by chunk for gemm
!
            il = ivt + M*M
            IF ( Lwork>=M*N+M*M+3*M+bdspac ) THEN
               ldwrkl = M
               chunk = N
            ELSE
               ldwrkl = M
               chunk = (Lwork-M*M)/M
            ENDIF
            itau = il + ldwrkl*M
            nwork = itau + M
!
!              Compute A=L*Q
!              Workspace: need   M*M [VT] + M*M [L] + M [tau] + M    [work]
!              Workspace: prefer M*M [VT] + M*M [L] + M [tau] + M*NB [work]
!
            CALL DGELQF(M,N,A,Lda,Work(itau),Work(nwork),Lwork-nwork+1, &
     &                  ierr)
!
!              Copy L to WORK(IL), zeroing about above it
!
            CALL DLACPY('L',M,M,A,Lda,Work(il),ldwrkl)
            CALL DLASET('U',M-1,M-1,ZERO,ZERO,Work(il+ldwrkl),ldwrkl)
!
!              Generate Q in A
!              Workspace: need   M*M [VT] + M*M [L] + M [tau] + M    [work]
!              Workspace: prefer M*M [VT] + M*M [L] + M [tau] + M*NB [work]
!
            CALL DORGLQ(M,N,M,A,Lda,Work(itau),Work(nwork),             &
     &                  Lwork-nwork+1,ierr)
            ie = itau
            itauq = ie + M
            itaup = itauq + M
            nwork = itaup + M
!
!              Bidiagonalize L in WORK(IL)
!              Workspace: need   M*M [VT] + M*M [L] + 3*M [e, tauq, taup] + M      [work]
!              Workspace: prefer M*M [VT] + M*M [L] + 3*M [e, tauq, taup] + 2*M*NB [work]
!
            CALL DGEBRD(M,M,Work(il),ldwrkl,S,Work(ie),Work(itauq),     &
     &                  Work(itaup),Work(nwork),Lwork-nwork+1,ierr)
!
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagonal matrix in U, and computing right singular
!              vectors of bidiagonal matrix in WORK(IVT)
!              Workspace: need   M*M [VT] + M*M [L] + 3*M [e, tauq, taup] + BDSPAC
!
            CALL DBDSDC('U','I',M,S,Work(ie),U,Ldu,Work(ivt),M,dum,idum,&
     &                  Work(nwork),Iwork,Info)
!
!              Overwrite U by left singular vectors of L and WORK(IVT)
!              by right singular vectors of L
!              Workspace: need   M*M [VT] + M*M [L] + 3*M [e, tauq, taup] + M    [work]
!              Workspace: prefer M*M [VT] + M*M [L] + 3*M [e, tauq, taup] + M*NB [work]
!
            CALL DORMBR('Q','L','N',M,M,M,Work(il),ldwrkl,Work(itauq),U,&
     &                  Ldu,Work(nwork),Lwork-nwork+1,ierr)
            CALL DORMBR('P','R','T',M,M,M,Work(il),ldwrkl,Work(itaup),  &
     &                  Work(ivt),M,Work(nwork),Lwork-nwork+1,ierr)
!
!              Multiply right singular vectors of L in WORK(IVT) by Q
!              in A, storing result in WORK(IL) and copying to A
!              Workspace: need   M*M [VT] + M*M [L]
!              Workspace: prefer M*M [VT] + M*N [L]
!              At this point, L is resized as M by chunk.
!
            DO i = 1 , N , chunk
               blk = MIN(N-i+1,chunk)
               CALL DGEMM('N','N',M,blk,M,ONE,Work(ivt),M,A(1,i),Lda,   &
     &                    ZERO,Work(il),ldwrkl)
               CALL DLACPY('F',M,blk,Work(il),ldwrkl,A(1,i),Lda)
            ENDDO
!
         ELSEIF ( wntqs ) THEN
!
!              Path 3t (N >> M, JOBZ='S')
!              M right singular vectors to be computed in VT and
!              M left singular vectors to be computed in U
!
            il = 1
!
!              WORK(IL) is M by M
!
            ldwrkl = M
            itau = il + ldwrkl*M
            nwork = itau + M
!
!              Compute A=L*Q
!              Workspace: need   M*M [L] + M [tau] + M    [work]
!              Workspace: prefer M*M [L] + M [tau] + M*NB [work]
!
            CALL DGELQF(M,N,A,Lda,Work(itau),Work(nwork),Lwork-nwork+1, &
     &                  ierr)
!
!              Copy L to WORK(IL), zeroing out above it
!
            CALL DLACPY('L',M,M,A,Lda,Work(il),ldwrkl)
            CALL DLASET('U',M-1,M-1,ZERO,ZERO,Work(il+ldwrkl),ldwrkl)
!
!              Generate Q in A
!              Workspace: need   M*M [L] + M [tau] + M    [work]
!              Workspace: prefer M*M [L] + M [tau] + M*NB [work]
!
            CALL DORGLQ(M,N,M,A,Lda,Work(itau),Work(nwork),             &
     &                  Lwork-nwork+1,ierr)
            ie = itau
            itauq = ie + M
            itaup = itauq + M
            nwork = itaup + M
!
!              Bidiagonalize L in WORK(IU).
!              Workspace: need   M*M [L] + 3*M [e, tauq, taup] + M      [work]
!              Workspace: prefer M*M [L] + 3*M [e, tauq, taup] + 2*M*NB [work]
!
            CALL DGEBRD(M,M,Work(il),ldwrkl,S,Work(ie),Work(itauq),     &
     &                  Work(itaup),Work(nwork),Lwork-nwork+1,ierr)
!
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagonal matrix in U and computing right singular
!              vectors of bidiagonal matrix in VT
!              Workspace: need   M*M [L] + 3*M [e, tauq, taup] + BDSPAC
!
            CALL DBDSDC('U','I',M,S,Work(ie),U,Ldu,Vt,Ldvt,dum,idum,    &
     &                  Work(nwork),Iwork,Info)
!
!              Overwrite U by left singular vectors of L and VT
!              by right singular vectors of L
!              Workspace: need   M*M [L] + 3*M [e, tauq, taup] + M    [work]
!              Workspace: prefer M*M [L] + 3*M [e, tauq, taup] + M*NB [work]
!
            CALL DORMBR('Q','L','N',M,M,M,Work(il),ldwrkl,Work(itauq),U,&
     &                  Ldu,Work(nwork),Lwork-nwork+1,ierr)
            CALL DORMBR('P','R','T',M,M,M,Work(il),ldwrkl,Work(itaup),  &
     &                  Vt,Ldvt,Work(nwork),Lwork-nwork+1,ierr)
!
!              Multiply right singular vectors of L in WORK(IL) by
!              Q in A, storing result in VT
!              Workspace: need   M*M [L]
!
            CALL DLACPY('F',M,M,Vt,Ldvt,Work(il),ldwrkl)
            CALL DGEMM('N','N',M,N,M,ONE,Work(il),ldwrkl,A,Lda,ZERO,Vt, &
     &                 Ldvt)
!
         ELSEIF ( wntqa ) THEN
!
!              Path 4t (N >> M, JOBZ='A')
!              N right singular vectors to be computed in VT and
!              M left singular vectors to be computed in U
!
            ivt = 1
!
!              WORK(IVT) is M by M
!
            ldwkvt = M
            itau = ivt + ldwkvt*M
            nwork = itau + M
!
!              Compute A=L*Q, copying result to VT
!              Workspace: need   M*M [VT] + M [tau] + M    [work]
!              Workspace: prefer M*M [VT] + M [tau] + M*NB [work]
!
            CALL DGELQF(M,N,A,Lda,Work(itau),Work(nwork),Lwork-nwork+1, &
     &                  ierr)
            CALL DLACPY('U',M,N,A,Lda,Vt,Ldvt)
!
!              Generate Q in VT
!              Workspace: need   M*M [VT] + M [tau] + N    [work]
!              Workspace: prefer M*M [VT] + M [tau] + N*NB [work]
!
            CALL DORGLQ(N,N,M,Vt,Ldvt,Work(itau),Work(nwork),           &
     &                  Lwork-nwork+1,ierr)
!
!              Produce L in A, zeroing out other entries
!
            CALL DLASET('U',M-1,M-1,ZERO,ZERO,A(1,2),Lda)
            ie = itau
            itauq = ie + M
            itaup = itauq + M
            nwork = itaup + M
!
!              Bidiagonalize L in A
!              Workspace: need   M*M [VT] + 3*M [e, tauq, taup] + M      [work]
!              Workspace: prefer M*M [VT] + 3*M [e, tauq, taup] + 2*M*NB [work]
!
            CALL DGEBRD(M,M,A,Lda,S,Work(ie),Work(itauq),Work(itaup),   &
     &                  Work(nwork),Lwork-nwork+1,ierr)
!
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagonal matrix in U and computing right singular
!              vectors of bidiagonal matrix in WORK(IVT)
!              Workspace: need   M*M [VT] + 3*M [e, tauq, taup] + BDSPAC
!
            CALL DBDSDC('U','I',M,S,Work(ie),U,Ldu,Work(ivt),ldwkvt,dum,&
     &                  idum,Work(nwork),Iwork,Info)
!
!              Overwrite U by left singular vectors of L and WORK(IVT)
!              by right singular vectors of L
!              Workspace: need   M*M [VT] + 3*M [e, tauq, taup]+ M    [work]
!              Workspace: prefer M*M [VT] + 3*M [e, tauq, taup]+ M*NB [work]
!
            CALL DORMBR('Q','L','N',M,M,M,A,Lda,Work(itauq),U,Ldu,      &
     &                  Work(nwork),Lwork-nwork+1,ierr)
            CALL DORMBR('P','R','T',M,M,M,A,Lda,Work(itaup),Work(ivt),  &
     &                  ldwkvt,Work(nwork),Lwork-nwork+1,ierr)
!
!              Multiply right singular vectors of L in WORK(IVT) by
!              Q in VT, storing result in A
!              Workspace: need   M*M [VT]
!
            CALL DGEMM('N','N',M,N,M,ONE,Work(ivt),ldwkvt,Vt,Ldvt,ZERO, &
     &                 A,Lda)
!
!              Copy right singular vectors of A from A to VT
!
            CALL DLACPY('F',M,N,A,Lda,Vt,Ldvt)
!
         ENDIF
!
      ELSE
!
!           N .LT. MNTHR
!
!           Path 5t (N > M, but not much larger)
!           Reduce to bidiagonal form without LQ decomposition
!
         ie = 1
         itauq = ie + M
         itaup = itauq + M
         nwork = itaup + M
!
!           Bidiagonalize A
!           Workspace: need   3*M [e, tauq, taup] + N        [work]
!           Workspace: prefer 3*M [e, tauq, taup] + (M+N)*NB [work]
!
         CALL DGEBRD(M,N,A,Lda,S,Work(ie),Work(itauq),Work(itaup),      &
     &               Work(nwork),Lwork-nwork+1,ierr)
         IF ( wntqn ) THEN
!
!              Path 5tn (N > M, JOBZ='N')
!              Perform bidiagonal SVD, only computing singular values
!              Workspace: need   3*M [e, tauq, taup] + BDSPAC
!
            CALL DBDSDC('L','N',M,S,Work(ie),dum,1,dum,1,dum,idum,      &
     &                  Work(nwork),Iwork,Info)
         ELSEIF ( wntqo ) THEN
!              Path 5to (N > M, JOBZ='O')
            ldwkvt = M
            ivt = nwork
            IF ( Lwork>=M*N+3*M+bdspac ) THEN
!
!                 WORK( IVT ) is M by N
!
               CALL DLASET('F',M,N,ZERO,ZERO,Work(ivt),ldwkvt)
               nwork = ivt + ldwkvt*N
!                 IL is unused; silence compile warnings
               il = -1
            ELSE
!
!                 WORK( IVT ) is M by M
!
               nwork = ivt + ldwkvt*M
               il = nwork
!
!                 WORK(IL) is M by CHUNK
!
               chunk = (Lwork-M*M-3*M)/M
            ENDIF
!
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagonal matrix in U and computing right singular
!              vectors of bidiagonal matrix in WORK(IVT)
!              Workspace: need   3*M [e, tauq, taup] + M*M [VT] + BDSPAC
!
            CALL DBDSDC('L','I',M,S,Work(ie),U,Ldu,Work(ivt),ldwkvt,dum,&
     &                  idum,Work(nwork),Iwork,Info)
!
!              Overwrite U by left singular vectors of A
!              Workspace: need   3*M [e, tauq, taup] + M*M [VT] + M    [work]
!              Workspace: prefer 3*M [e, tauq, taup] + M*M [VT] + M*NB [work]
!
            CALL DORMBR('Q','L','N',M,M,N,A,Lda,Work(itauq),U,Ldu,      &
     &                  Work(nwork),Lwork-nwork+1,ierr)
!
            IF ( Lwork>=M*N+3*M+bdspac ) THEN
!
!                 Path 5to-fast
!                 Overwrite WORK(IVT) by left singular vectors of A
!                 Workspace: need   3*M [e, tauq, taup] + M*N [VT] + M    [work]
!                 Workspace: prefer 3*M [e, tauq, taup] + M*N [VT] + M*NB [work]
!
               CALL DORMBR('P','R','T',M,N,M,A,Lda,Work(itaup),Work(ivt)&
     &                     ,ldwkvt,Work(nwork),Lwork-nwork+1,ierr)
!
!                 Copy right singular vectors of A from WORK(IVT) to A
!
               CALL DLACPY('F',M,N,Work(ivt),ldwkvt,A,Lda)
            ELSE
!
!                 Path 5to-slow
!                 Generate P**T in A
!                 Workspace: need   3*M [e, tauq, taup] + M*M [VT] + M    [work]
!                 Workspace: prefer 3*M [e, tauq, taup] + M*M [VT] + M*NB [work]
!
               CALL DORGBR('P',M,N,M,A,Lda,Work(itaup),Work(nwork),     &
     &                     Lwork-nwork+1,ierr)
!
!                 Multiply Q in A by right singular vectors of
!                 bidiagonal matrix in WORK(IVT), storing result in
!                 WORK(IL) and copying to A
!                 Workspace: need   3*M [e, tauq, taup] + M*M [VT] + M*NB [L]
!                 Workspace: prefer 3*M [e, tauq, taup] + M*M [VT] + M*N  [L]
!
               DO i = 1 , N , chunk
                  blk = MIN(N-i+1,chunk)
                  CALL DGEMM('N','N',M,blk,M,ONE,Work(ivt),ldwkvt,A(1,i)&
     &                       ,Lda,ZERO,Work(il),M)
                  CALL DLACPY('F',M,blk,Work(il),M,A(1,i),Lda)
               ENDDO
            ENDIF
         ELSEIF ( wntqs ) THEN
!
!              Path 5ts (N > M, JOBZ='S')
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagonal matrix in U and computing right singular
!              vectors of bidiagonal matrix in VT
!              Workspace: need   3*M [e, tauq, taup] + BDSPAC
!
            CALL DLASET('F',M,N,ZERO,ZERO,Vt,Ldvt)
            CALL DBDSDC('L','I',M,S,Work(ie),U,Ldu,Vt,Ldvt,dum,idum,    &
     &                  Work(nwork),Iwork,Info)
!
!              Overwrite U by left singular vectors of A and VT
!              by right singular vectors of A
!              Workspace: need   3*M [e, tauq, taup] + M    [work]
!              Workspace: prefer 3*M [e, tauq, taup] + M*NB [work]
!
            CALL DORMBR('Q','L','N',M,M,N,A,Lda,Work(itauq),U,Ldu,      &
     &                  Work(nwork),Lwork-nwork+1,ierr)
            CALL DORMBR('P','R','T',M,N,M,A,Lda,Work(itaup),Vt,Ldvt,    &
     &                  Work(nwork),Lwork-nwork+1,ierr)
         ELSEIF ( wntqa ) THEN
!
!              Path 5ta (N > M, JOBZ='A')
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagonal matrix in U and computing right singular
!              vectors of bidiagonal matrix in VT
!              Workspace: need   3*M [e, tauq, taup] + BDSPAC
!
            CALL DLASET('F',N,N,ZERO,ZERO,Vt,Ldvt)
            CALL DBDSDC('L','I',M,S,Work(ie),U,Ldu,Vt,Ldvt,dum,idum,    &
     &                  Work(nwork),Iwork,Info)
!
!              Set the right corner of VT to identity matrix
!
            IF ( N>M ) CALL DLASET('F',N-M,N-M,ZERO,ONE,Vt(M+1,M+1),    &
     &                             Ldvt)
!
!              Overwrite U by left singular vectors of A and VT
!              by right singular vectors of A
!              Workspace: need   3*M [e, tauq, taup] + N    [work]
!              Workspace: prefer 3*M [e, tauq, taup] + N*NB [work]
!
            CALL DORMBR('Q','L','N',M,M,N,A,Lda,Work(itauq),U,Ldu,      &
     &                  Work(nwork),Lwork-nwork+1,ierr)
            CALL DORMBR('P','R','T',N,N,M,A,Lda,Work(itaup),Vt,Ldvt,    &
     &                  Work(nwork),Lwork-nwork+1,ierr)
         ENDIF
!
!
      ENDIF
!
!     Undo scaling if necessary
!
      IF ( iscl==1 ) THEN
         IF ( anrm>bignum ) CALL DLASCL('G',0,0,bignum,anrm,minmn,1,S,  &
     &                                  minmn,ierr)
         IF ( anrm<smlnum ) CALL DLASCL('G',0,0,smlnum,anrm,minmn,1,S,  &
     &                                  minmn,ierr)
      ENDIF
!
!     Return optimal workspace in WORK(1)
!
      Work(1) = maxwrk
!
!
!     End of DGESDD
!
      END SUBROUTINE DGESDD


subroutine apply_pde_operator(t, q, output)

! For the PDE q_t = g(q), calculates g(q).
!
! Args:
!   t: Time at which the operator is evaluated.
!   q: PDE solution at time t.
!   output: g(q), calculated here.

    !$ use omp_lib
    implicit none

    integer :: mx, my, mbc, meqn
    double precision :: x_lower, y_lower, dx, dy
    common /claw_config/ mx, my, mbc, x_lower, y_lower, dx, dy, meqn

    double precision :: beta, kappa, delta, mu, right_film_height
    common /surfactant_config/ beta, kappa, delta, mu, right_film_height

    double precision, intent(in) :: t
    double precision, dimension(1-mbc:mx+mbc, 1-mbc:my+mbc, meqn), intent(in) :: q
    double precision, dimension(1-mbc:mx+mbc, 1-mbc:my+mbc, meqn), intent(out) :: output

    integer :: ix, iy
    double precision, dimension(2) :: lower_flux, upper_flux

    !$omp parallel do private(ix, lower_flux, upper_flux)
    do iy = 1, my
        do ix = 1, mx
            call compute_x_flux(ix, iy, lower_flux)
            call compute_x_flux(ix+1, iy, upper_flux)
            output(ix, iy, :) = -(upper_flux - lower_flux) / dx

            call compute_y_flux(ix, iy, lower_flux)
            call compute_y_flux(ix, iy+1, upper_flux)
            output(ix, iy, :) = output(ix, iy, :) - (upper_flux - lower_flux) / dy
        end do
    end do

    contains

    subroutine compute_x_flux(ix, iy, flux)
        implicit none
        integer, intent(in) :: ix, iy
        double precision, dimension(2), intent(out) :: flux
        double precision :: q1_face, q2_face, q2_x

        q1_face = (q(ix-1, iy, 1) + q(ix, iy, 1)) / 2.d0
        q2_face = (q(ix-1, iy, 2) + q(ix, iy, 2)) / 2.d0
        q2_x = (q(ix, iy, 2) - q(ix-1, iy, 2)) / dx

        flux(1) = -.5d0 * q1_face**2 * q2_x
        flux(2) = -q1_face * q2_face * q2_x
    end subroutine compute_x_flux

    subroutine compute_y_flux(ix, iy, flux)
        implicit none
        integer, intent(in) :: ix, iy
        double precision, dimension(2), intent(out) :: flux
        double precision :: q1_face, q2_face, q2_y

        q1_face = (q(ix, iy-1, 1) + q(ix, iy, 1)) / 2.d0
        q2_face = (q(ix, iy-1, 2) + q(ix, iy, 2)) / 2.d0
        q2_y = (q(ix, iy, 2) - q(ix, iy-1, 2)) / dy

        flux(1) = -.5d0 * q1_face**2 * q2_y
        flux(2) = -q1_face * q2_face * q2_y
    end subroutine compute_y_flux

end subroutine apply_pde_operator


!
! Copyright (C) 2001-2009 Quantum ESPRESSO group
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
MODULE zhpev_module

   IMPLICIT NONE
   SAVE

   PRIVATE

   PUBLIC :: pzhpev_drv, zhpev_drv
   PUBLIC :: pzheevd_drv

CONTAINS
   !
   !-------------------------------------------------------------------------
   SUBROUTINE pzhptrd( n, nrl, ap, lda, d, e, tau, nproc, me, comm )
     !-------------------------------------------------------------------------
      !
      !  Parallel MPI version of the LAPACK routine ZHPTRD
      !
      !     Carlo Cavazzoni (carlo.cavazzoni@cineca.it) -- CINECA
      !     Dicember 12, 1999
      !
      !  REFERENCES :
      !
      !     NUMERICAL RECIPES, THE ART OF SCIENTIFIC COMPUTING.
      !     W.H. PRESS, B.P. FLANNERY, S.A. TEUKOLSKY, AND W.T. VETTERLING,
      !     CAMBRIDGE UNIVERSITY PRESS, CAMBRIDGE.
      !
      !     PARALLEL NUMERICAL ALGORITHMS,
      !     T.L. FREEMAN AND C.PHILLIPS,
      !     PRENTICE HALL INTERNATIONAL (1992).
      !
      !     LAPACK routine (version 2.0) --
      !     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
      !     Courant Institute, Argonne National Lab, and Rice University
      !

     USE kinds,     ONLY : DP
     USE io_global, ONLY : stdout

      IMPLICIT NONE

!     .. __SCALAR Arguments ..
      INTEGER            LDA, N, NRL, NPROC, ME, comm
!     ..
!     .. Array Arguments ..
      REAL(DP)             D( * ), E( * )
      COMPLEX(DP)         AP(LDA, * ), TAU( * )
!     ..
!
!  Purpose
!  =======
!
!  PZHPTRD reduces a complex Hermitian distributed matrix AP  to
!  real symmetric tridiagonal form T by a unitary similarity
!  transformation: Q**H * A * Q = T.
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The order of the mglobal atrix AP.  N >= 0.
!
!  NRL     (input) INTEGER
!          The number of local rows of the matrix AP. NRL >= 0.
!
!  AP      (input/output) COMPLEX(DP) array, dimension (LDA,N)
!          On entry, the Hermitian matrix AP.
!          The rows of the matrix are distributed among processors
!          with blocking factor 1.
!              Example for NPROC = 4 :
!              ROW | PE
!              1   | 0
!              2   | 1
!              3   | 2
!              4   | 3
!              5   | 0
!              6   | 1
!              ..  | ..

!          On exit, the diagonal and first subdiagonal
!          of A are overwritten by the corresponding elements of the
!          tridiagonal matrix T, and the elements below the first
!          subdiagonal, with the array TAU, represent the unitary
!          matrix Q as a product of elementary reflectors;
!
!  LDA     (input) INTEGER
!          Leading dimension of the local matrix AP, LDA > NRL
!
!  D       (output) DOUBLE PRECISION array, dimension (N)
!          The diagonal elements of the tridiagonal matrix T:
!          D(i) = AP(i,i).
!
!  E       (output) DOUBLE PRECISION array, dimension (N-1)
!          The off-diagonal elements of the tridiagonal matrix T:
!          E(i) = A(i+1,i)
!
!  TAU     (output) COMPLEX(DP) array, dimension (N-1)
!          The __SCALAR factors of the elementary reflectors (see Further
!          Details).
!
!  NPROC   (input) INTEGER
!          Number of processors
!
!  ME      (input) INTEGER
!          Index of the local processor  ( 0, 1, 2, ..., NPROC-1 )

!
!  Further Details
!  ===============
!
!  the matrix Q is represented as a product of elementary
!  reflectors
!
!     Q = H(1) H(2) . . . H(n-1).
!
!  Each H(i) has the form
!
!     H(i) = I - tau * v * v'
!
!  where tau is a complex __SCALAR, and v is a complex vector with
!  v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,
!  overwriting A(i+2:n,i), and tau is stored in TAU(i).
!
!  =====================================================================
!
!     .. Parameters ..

      COMPLEX(DP)  ONE, ZERO, HALF
      PARAMETER   ( ONE = ( 1.0_DP, 0.0_DP ),ZERO = ( 0.0_DP, 0.0_DP ),  &
     &             HALF = ( 0.5_DP, 0.0_DP ) )
      REAL(DP)      RONE, RZERO
      PARAMETER   ( RONE = 1.0_DP, RZERO = 0.0_DP )

      INTEGER QI
      INTEGER IL(N+1)
      INTEGER OW(N+1)
      COMPLEX(DP) CTMP
      COMPLEX(DP) CTMPV(N+1)
      COMPLEX(DP) TAUL(N+1)
      COMPLEX(DP) APKI(N+1)
      REAL(DP)     TMP
      REAL(DP)     TMPV(N+1)

!     ..
!     .. Local __SCALARs ..
      INTEGER            J, I, I1, K, I2, NI1, JL
      INTEGER            KL, J1
      COMPLEX(DP)         ALPHA, TAUI
      INTEGER            KNT, IERR
      REAL(DP)             ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM
!     ..
!     .. External Subroutines ..
      EXTERNAL           zaxpy
      EXTERNAL           zdscal, zscal
!     ..
!     .. External Functions ..
      COMPLEX(DP)         zdotc
      EXTERNAL           zdotc
      REAL(DP)             DLAMCH, DLAPY3, DZNRM2
      COMPLEX(DP)         ZLADIV
      EXTERNAL           DLAMCH, DLAPY3, DZNRM2, ZLADIV
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          DABS, DBLE, AIMAG, SIGN
!
!     .. Executable Statements ..
!
!     Quick return if possible
!
      IF(N.LE.0) THEN
        RETURN
      END IF

      DO I = 1,N+1
        QI     = (I-1)/NPROC
        OW(I)  = MOD((I-1),NPROC)
        IF(ME .le. OW(I) ) then
          IL(I) = QI + 1
        ELSE
          IL(I) = QI
        END IF
      END DO
!
!        Reduce the lower triangle of A.
!
         IF (OW(1).EQ.ME) THEN
           AP( IL(1), 1 ) = DBLE( AP( IL(1), 1 ) )
         END IF

         DO I = 1, N - 1
!
!           Generate elementary reflector H(i) = I - tau * v * v'
!           to annihilate A(i+2:n,i)
!
            IF (OW(I+1).EQ.ME) THEN
              ALPHA = AP( IL(I+1), I )
            END IF

            CALL BCAST_REAL( ALPHA, 2, OW(I+1), comm )

            IF( (N-I).LE.0 ) THEN
              TAUI = RZERO
            ELSE
              IF(OW(I+2).EQ.ME) THEN
                I2 = IL(I+2)
              ELSE
                I2 = IL(I+2) + 1          ! I+2
              ENDIF
              NI1 = NRL - I2 + 1          ! N-I-1

              IF((N-I-1).GT.0) THEN
                IF( NI1 .GT. 0 ) THEN
                   XNORM = DZNRM2( NI1, AP( I2, I ), 1 )
                ELSE
                   XNORM = 0.0_DP
                END IF
                XNORM = XNORM ** 2
                CALL reduce_base_real( 1, xnorm, comm, -1 )
                XNORM = SQRT( xnorm )
              ELSE
                XNORM = 0.0_DP
              ENDIF

              ALPHR = DBLE( ALPHA )
              ALPHI = AIMAG( ALPHA )
              IF( XNORM.EQ.RZERO .AND. ALPHI.EQ.RZERO ) THEN
                TAUI = RZERO
              ELSE
                BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
                SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' )
                RSAFMN = RONE / SAFMIN
                IF( DABS( BETA ).LT.SAFMIN ) THEN
                  KNT = 0
   10             CONTINUE
                  KNT = KNT + 1

                  IF(NI1.GT.0) THEN
                    CALL zdscal( NI1, RSAFMN, AP( I2, I ), 1 )
                  ENDIF

                  BETA = BETA*RSAFMN
                  ALPHI = ALPHI*RSAFMN
                  ALPHR = ALPHR*RSAFMN
                  IF( DABS( BETA ).LT.SAFMIN ) GO TO 10

                  IF((N-I-1).GT.0) THEN
                    XNORM = DZNRM2( NI1, AP( I2, I ), 1 )
                    XNORM = XNORM ** 2
                    CALL reduce_base_real( 1, xnorm, comm, -1 )
                    XNORM = SQRT( XNORM )
                  ELSE
                    XNORM = 0.0_DP
                  ENDIF

                  ALPHA = CMPLX( ALPHR, ALPHI, KIND=DP )
                  BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
                  TAUI = CMPLX( (BETA-ALPHR)/BETA, -ALPHI/BETA, KIND=DP )
                  ALPHA = ZLADIV( ONE, ALPHA-BETA )

                  IF(NI1.GT.0) THEN
                    CALL zscal( NI1, ALPHA, AP( I2, I ), 1 )
                  ENDIF

                  ALPHA = BETA
                  DO J = 1, KNT
                    ALPHA = ALPHA*SAFMIN
                  END DO

                ELSE

                  TAUI = CMPLX( (BETA-ALPHR)/BETA, -ALPHI/BETA, KIND=DP )
                  ALPHA = ZLADIV( ONE, ALPHA-BETA )

                  IF(NI1.GT.0) THEN
                    CALL zscal( NI1, ALPHA, AP( I2, I ), 1 )
                  ENDIF

                  ALPHA = BETA
                END IF
              END IF
            ENDIF
!
            E( I ) = ALPHA
!
            IF( TAUI.NE.ZERO ) THEN
!
!              Apply H(i) from both sides to A(i+1:n,i+1:n)
!
               ! ... AP( I+1, I ) = ONE
               IF (OW(I+1).EQ.ME) THEN
                 AP( IL(I+1), I ) = ONE
               END IF
!
!              Compute  y := tau * A * v  storing y in TAU(i:n-1)
!

               ! ... broadcast A(K,I)
               IF(OW(I+1).EQ.ME) THEN
                 I1 = IL(I+1)
               ELSE
                 I1 = IL(I+1) + 1          ! I+2
               ENDIF

               DO J = I+1, N
                 CTMPV(J) = ZERO
               END DO
               DO JL = I1, NRL
                 J = ME + (JL-1)*NPROC + 1
                 CTMPV(J) = AP(JL,I)
               END DO
               CALL reduce_base_real_to( 2*(n - i) , ctmpv( i + 1 ), apki( i + 1 ), comm, -1 )
               DO J = I+1, N+1
                 TAU(J-1) = ZERO
               END DO
               DO JL = I1, NRL
                 J = ME + (JL-1)*NPROC + 1
                 TAU(J-1) = ZERO
                 DO K = I+1, J
                   TAU(J-1) = TAU(J-1) + TAUI * AP(JL,K) * APKI(K)
                 END DO
               END DO
               DO J = I+1, N
                 IF(OW(J+1).EQ.ME) THEN
                   J1 = IL(J+1)
                 ELSE
                   J1 = IL(J+1) + 1          ! I+2
                 ENDIF
                 DO KL = J1, NRL
                   K = ME + (KL-1)*NPROC + 1
                   TAU(J-1) = TAU(J-1) + TAUI * CONJG(AP(KL,J)) * APKI(K)
                 END DO
               END DO

               ! ... parallel sum TAU
               CALL reduce_base_real( 2*(n - i + 1), tau( i ), comm, -1 )
!
!              Compute  w := y - 1/2 * tau * (y'*v) * v
!
               ! ... ALPHA = -HALF*TAUI*zdotc(N-I,TAU(I),1,AP(I+1,I),1)

               JL = 1
               DO J = I, N
                 IF(OW(J+1).EQ.ME) THEN
                   TAUL(JL) = TAU(J)
                   JL = JL + 1
                 END IF
               END DO
               IF(OW(I+1).EQ.ME) THEN
                 I1 = IL(I+1)
               ELSE
                 I1 = IL(I+1) + 1          ! I+1
               ENDIF
               NI1 = NRL - I1 + 1          ! N-I
               IF ( NI1 > 0 ) THEN
                  ALPHA = -HALF*TAUI*zdotc(NI1,TAUL(1),1,AP(I1,I),1)
               ELSE
                  ALPHA = 0.0_DP
               END IF

               CALL reduce_base_real( 2, alpha, comm, -1 )

               IF ( NI1 > 0 ) CALL zaxpy(NI1,ALPHA,AP(I1,I),1,TAUL(1),1)

               JL = 1
               DO J = I, N
                 CTMPV(J) = ZERO
                 IF(OW(J+1).EQ.ME) THEN
                   CTMPV(J) = TAUL(JL)
                   JL = JL + 1
                 END IF
               END DO
               CALL reduce_base_real_to( 2*(n - i + 1) , ctmpv( i ), tau( i ), comm, -1 )

!
!              Apply the transformation as a rank-2 update:
!                 A := A - v * w' - w * v'
!
               ! ... broadcast A(K,I)
               IF(OW(I+1).EQ.ME) THEN
                 I1 = IL(I+1)
               ELSE
                 I1 = IL(I+1) + 1          ! I+2
               ENDIF

               DO J = I+1, N
                 CTMPV(J) = ZERO
               END DO
               DO JL = I1, NRL
                 J = ME + (JL-1)*NPROC + 1
                 CTMPV(J) = AP(JL,I)
               END DO
               CALL reduce_base_real_to( 2*(n - i) , ctmpv( i + 1 ), apki( i + 1 ), comm, -1 )

               DO K = I+1,N
                 DO JL = I1,NRL
                   J = ME + (JL-1)*NPROC + 1
                   AP(JL,K) = AP(JL,K) - ONE * AP(JL,I) * CONJG(TAU(K-1)) - &
     &                CONJG(ONE) * TAU(J-1) * CONJG(APKI(K))
                 END DO
               END DO
!
            END IF
            IF(OW(I+1).EQ.ME) THEN
              AP(IL(I+1),I) = E( I )
            END IF
            IF(OW(I).EQ.ME) THEN
              D( I ) = DBLE(AP( IL(I),I ))
            END IF
            CALL BCAST_REAL(D(I),1,OW(I),comm)
            TAU( I ) = TAUI
         END DO
         IF(OW(I).EQ.ME) THEN
            D( N ) = DBLE(AP( IL(I),I ))
         END IF
         CALL BCAST_REAL(D(N),1,OW(I),comm)
!
      RETURN

!
!     End of ZHPTRD
!
      END SUBROUTINE pzhptrd

!==----------------------------------------------==!

   SUBROUTINE pzupgtr( n, nrl, ap, lda, tau, q, ldq, nproc, me, comm)

     USE kinds,     ONLY : DP
     USE io_global, ONLY : stdout
!
!  Parallel MPI version of the LAPACK routine ZUPGTR
!
!     Carlo Cavazzoni (carlo.cavazzoni@cineca.it) -- CINECA
!     Dicember 12, 1999
!
!  REFERENCES :
!
!     NUMERICAL RECIPES, THE ART OF SCIENTIFIC COMPUTING.
!     W.H. PRESS, B.P. FLANNERY, S.A. TEUKOLSKY, AND W.T. VETTERLING,
!     CAMBRIDGE UNIVERSITY PRESS, CAMBRIDGE.
!
!     PARALLEL NUMERICAL ALGORITHMS,
!     T.L. FREEMAN AND C.PHILLIPS,
!     PRENTICE HALL INTERNATIONAL (1992).
!
!     LAPACK routine (version 2.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University

      IMPLICIT NONE

!
!     .. __SCALAR Arguments ..

      INTEGER            INFO, LDQ, N, LDA, NRL, NPROC, ME, comm
!     ..
!     .. Array Arguments ..
      COMPLEX(DP)         AP(LDA, * ), Q( LDQ, * ), TAU( * )
!     ..
!
!  Purpose
!  =======
!
!  PZUPGTR generates a complex unitary matrix Q which is defined as the
!  product of n-1 elementary reflectors H(i) of order n, as returned by
!  PZHPTRD :
!
!  Q = H(1) H(2) . . . H(n-1).
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The order of the mglobal atrix AP.  N >= 0.
!
!  NRL     (input) INTEGER
!          The number of local rows of the matrix AP. NRL >= 0.
!
!  AP      (input) COMPLEX(DP) array, dimension (LDA,N)
!          The vectors which define the elementary reflectors, as
!          returned by PZHPTRD.
!          The rows of the matrix are distributed among processors
!          with blocking factor 1.
!              Example for NPROC = 4 :
!              ROW | PE
!              1   | 0
!              2   | 1
!              3   | 2
!              4   | 3
!              5   | 0
!              6   | 1
!              ..  | ..
!
!  LDA     (input) INTEGER
!          Leading dimension of the local matrix AP, LDA > NRL
!
!  TAU     (input) COMPLEX(DP) array, dimension (N-1)
!          TAU(i) must contain the __SCALAR factor of the elementary
!          reflector H(i), as returned by PZHPTRD.
!
!  Q       (output) COMPLEX(DP) array, dimension (LDQ,N)
!          The N-by-N unitary matrix Q.
!          The rows of the matrix are distributed among processors
!          in the same way of the matrix AP
!
!  LDQ     (input) INTEGER
!          The leading dimension of the array Q. LDQ >= max(1,NRL).
!
!  NPROC   (input) INTEGER
!          Number of processors
!
!  ME      (input) INTEGER
!          Index of the local processor  ( 0, 1, 2, ..., NPROC-1 )
!
!  =====================================================================
!
!     .. Parameters ..

      COMPLEX(DP)         ONE, ZERO
      PARAMETER          ( ONE = (1.0_DP,0.0_DP), ZERO = (0.0_DP,0.0_DP) )

      !  change the following parameters to tune the performances
      !
      INTEGER, PARAMETER :: opt_zgemv = 40
      INTEGER, PARAMETER :: opt_zgerc = 40

      INTEGER QI
      INTEGER IL(N+1)
      INTEGER OW(N+1)
      COMPLEX(DP) CTMP
      COMPLEX(DP) WORK(N+1)

!     ..
!     .. Local __SCALARs ..
      INTEGER :: I, IINFO, J, K, JL, KL, J1, I1, I2, NI1, L, IERR
      INTEGER :: ibeg, iend, nr
      INTEGER, EXTERNAL :: ldim_cyclic, lind_cyclic
!     ..

!     .. Executable Statements ..
!
!     Test the input arguments
!
!     Quick return if possible
!
      IF( N == 0 ) THEN
        RETURN
      END IF

      nr = ldim_cyclic( n, nproc, me )
      !
      IF( nr /= nrl ) &
         CALL errore( " pzupgtr ", " inconsistent dimensions ", nrl )
      !
      ibeg = lind_cyclic( 1,  n, nproc, me )
      iend = lind_cyclic( nr, n, nproc, me )
!
      DO I = 1,N+1
        QI     = (I-1)/NPROC
        OW(I)  = MOD((I-1),NPROC)
        IF(ME .le. OW(I) ) then
          IL(I) = QI + 1
        ELSE
          IL(I) = QI
        END IF
      END DO
!
!        Unpack the vectors which define the elementary reflectors and
!        set the first row and column of Q equal to those of the unit
!        matrix
!
      IF(OW(1).EQ.ME) THEN
        Q( IL(1), 1 ) = ONE
        DO KL = 2, NRL
          Q( KL, 1 ) = ZERO
        END DO
        DO J = 2, N
          Q( IL(1), J ) = ZERO
        END DO
      ELSE
        DO KL = 1, NRL
          Q( KL, 1 ) = ZERO
        END DO
      ENDIF

      DO J = 2, N
        IF(OW(J+1).EQ.ME) THEN
          J1 = IL(J+1)
        ELSE
          J1 = IL(J+1) + 1
        ENDIF
        DO KL = J1, NRL
          Q( KL, J ) = AP( KL, J-1 )
        END DO
      END DO

      IF( N.GT.1 ) THEN
!
!           Generate Q(2:n,2:n)
!
        DO I = N-1, 1, -1
!
!         Apply H(i) to A(i:m,i:n) from the left
!
          IF( I.LT.(N-1) ) THEN

            IF(OW(I+1).EQ.ME) THEN
              Q( IL(I+1), I+1 ) = ONE
            END IF
!
!           Form  H * C
!
            IF( TAU(I).NE.ZERO ) THEN
!
!             w := C' * v
!
              IF(OW(I+1).EQ.ME) THEN
                I1 = IL(I+1)
              ELSE
                I1 = IL(I+1) + 1
              ENDIF
              !
              IF( N-1-I > OPT_ZGEMV ) THEN
                 IF( NRL-I1+1 > 0 ) THEN
                    CALL zgemv( 'C', NRL-I1+1, N-1-I, one, Q( I1, I+1+1 ), ldq, Q( I1, I+1 ), 1, zero, work, 1 )
                 ELSE
                    work( 1 : N-1-I ) = 0.0_DP
                 END IF
              ELSE
                 DO J = 1, N-1-I
                    CTMP = ZERO
                    DO KL = I1, NRL
                       CTMP = CTMP + CONJG( Q( KL, J+I+1 ) ) * Q( KL,I+1 )
                     END DO
                     WORK(J) = CTMP
                  END DO
              END IF

              CALL reduce_base_real( 2*(n - 1 - i), work, comm, -1 )
              !
              !  C := C - v * w'
              !
              IF( N-1-I > opt_zgerc ) THEN
                 IF( NRL-I1+1 > 0 ) THEN
                    CALL zgerc( NRL-I1+1, N-1-I, -TAU(I), Q(I1, I+1), 1, work, 1, Q( I1, 1+I+1 ), ldq )
                 END IF
              ELSE
                 DO J = 1, N-1-I
                   CTMP = -TAU(I) * CONJG( WORK( J ) )
                   DO KL = I1, NRL
                     Q( KL, J+I+1 ) = Q( KL, J+I+1 ) + CTMP * Q(KL, I+1)
                   END DO
                 END DO
              END IF
            END IF
          END IF

          IF( I.LT.(N-1) ) THEN
            IF(OW(I+2).EQ.ME) THEN
              I2 = IL(I+2)              ! I+2
            ELSE
              I2 = IL(I+2) + 1          ! local ind. of the first element > I+2
            ENDIF
            NI1 = NRL - I2 + 1          ! N-I-1
            IF ( NI1 > 0 ) CALL zscal( NI1, -TAU( I ), Q( I2, I+1 ), 1 )
          END IF

          IF(OW(I+1).EQ.ME) THEN
            Q( IL(I+1), I+1 ) = ONE - TAU( I )
          END IF
!
!             Set A(1:i-1,i) to zero
!
          DO L = 1, I - 1
            IF(OW(L+1).EQ.ME) THEN
              Q( IL(L+1), I+1 ) = ZERO
            END IF
          END DO
        END DO
      END IF

      RETURN

!
!     End of ZUPGTR
!
      END SUBROUTINE pzupgtr

!==----------------------------------------------==!

      SUBROUTINE pzsteqr( compz, n, nrl, d, e, z, ldz, nproc, me, comm )
!
!  Parallel MPI version of the LAPACK routine ZHPTRD
!
!     Carlo Cavazzoni (carlo.cavazzoni@cineca.it) -- CINECA
!     Dicember 12, 1999
!
!  REFERENCES :
!
!     NUMERICAL RECIPES, THE ART OF SCIENTIFIC COMPUTING.
!     W.H. PRESS, B.P. FLANNERY, S.A. TEUKOLSKY, AND W.T. VETTERLING,
!     CAMBRIDGE UNIVERSITY PRESS, CAMBRIDGE.
!
!     PARALLEL NUMERICAL ALGORITHMS,
!     T.L. FREEMAN AND C.PHILLIPS,
!     PRENTICE HALL INTERNATIONAL (1992).
!
!     LAPACK routine (version 2.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!
     USE kinds,     ONLY : DP
     USE io_global, ONLY : stdout

      IMPLICIT NONE

!     .. __SCALAR Arguments ..
      CHARACTER          COMPZ
      INTEGER            LDZ, N, NRL, NPROC, ME, comm
!     ..
!     .. Array Arguments ..
      REAL(DP)   D( * ), E( * )
      COMPLEX(DP)         Z( LDZ, * )
!     ..
!
!  Purpose
!  =======
!
!  PZSTEQR computes all eigenvalues and, optionally, eigenvectors of a
!  symmetric tridiagonal matrix using the implicit QL or QR method.
!  The eigenvectors of a full or band complex Hermitian matrix can also
!  be found if PZHPTRD has been used to reduce this
!  matrix to tridiagonal form.
!
!  Arguments
!  =========
!
!  COMPZ   (input) CHARACTER*1
!          = 'N':  Compute eigenvalues only.
!          = 'V':  Compute eigenvalues and eigenvectors of the original
!                  Hermitian matrix.  On entry, Z must contain the
!                  unitary matrix used to reduce the original matrix
!                  to tridiagonal form.
!          = 'I':  Compute eigenvalues and eigenvectors of the
!                  tridiagonal matrix.  Z is initialized to the identity
!                  matrix.
!
!  N       (input) INTEGER
!          The order of the mglobal atrix AP.  N >= 0.
!
!  NRL     (input) INTEGER
!          The number of local rows of the matrix AP. NRL >= 0.
!
!  D       (input/output) DOUBLE PRECISION array, dimension (N)
!          On entry, the diagonal elements of the tridiagonal matrix.
!          On exit, if INFO = 0, the eigenvalues in ascending order.
!
!  E       (input/output) DOUBLE PRECISION array, dimension (N-1)
!          On entry, the (n-1) subdiagonal elements of the tridiagonal
!          matrix.
!          On exit, E has been destroyed.
!
!  Z       (input/output) COMPLEX(DP) array, dimension (LDZ, N)
!          On entry, if  COMPZ = 'V', then Z contains the unitary
!          matrix used in the reduction to tridiagonal form.
!          On exit if COMPZ = 'V', Z contains the
!          orthonormal eigenvectors of the original Hermitian matrix,
!          and if COMPZ = 'I', Z contains the orthonormal eigenvectors
!          of the symmetric tridiagonal matrix.
!          If COMPZ = 'N', then Z is not referenced.
!          The rows of the matrix are distributed among processors
!          with blocking factor 1, i.e. for NPROC = 4 :
!              ROW Index | Processor index owning the row
!                    1   |    0
!                    2   |    1
!                    3   |    2
!                    4   |    3
!                    5   |    0
!                    6   |    1
!                    ..  |    ..
!
!  LDZ     (input) INTEGER
!          The leading dimension of the array Z.  LDZ >= 1, and if
!          eigenvectors are desired, then  LDZ >= max(1,NRL).
!
!  NPROC   (input) INTEGER
!          Number of processors
!
!  ME      (input) INTEGER
!          Index of the local processor  ( 0, 1, 2, ..., NPROC-1 )
!
!  =====================================================================
!
!     .. Parameters ..
      REAL(DP)  RZERO, RONE, TWO, THREE, CTEMP, STEMP
      PARAMETER          ( RZERO = 0.0_DP, RONE = 1.0_DP, TWO = 2.0_DP, &
     &                   THREE = 3.0_DP )
      COMPLEX(DP)         ZERO, ONE,ZTEMP
      PARAMETER          ( ZERO = ( 0.0_DP, 0.0_DP ), ONE = ( 1.0_DP, 0.0_DP ) )
      INTEGER            MAXIT
      PARAMETER          ( MAXIT = 30 )
!     ..

      INTEGER  :: QI, KL, INFO
      INTEGER  :: IL(N+1)
      INTEGER  :: OW(N+1)
      REAL(DP) :: WORK(2*N)
      REAL(DP) :: dvar(6)

!     .. Local __SCALARs ..
      INTEGER            I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND, &
     &                   LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1,   &
     &                   NM1, NMAXIT, IERR
      REAL(DP)   ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2,   &
     &                   S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      REAL(DP)   DLAMCH, DLANST, DLAPY2
      EXTERNAL           LSAME, DLAMCH, DLANST, DLAPY2
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLAE2, DLAEV2, DLARTG, DLASCL, DLASRT, XERBLA
      EXTERNAL           ZLASET, ZLASR, ZSWAP
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          DABS, MAX, SIGN, SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0

! DEBUG START
!      if( n > 400 ) then
!      write( 4000 + me, * ) LDZ, N, NRL, NPROC, ME, comm
!      do i = 1, n
!         write( 4000 + me, * ) d( i )
!      end do
!      do i = 1, n
!         write( 4000 + me, * ) e( i )
!      end do
!      do j = 1, n
!      do i = 1, nrl
!         write( 4000 + me, * ) z( i, j )
!      end do
!      end do
!      close( 4000 + me )
!      call mpi_barrier( comm, i )
!      stop 'qui'
!      end if
! DEBUG END

!
      IF( LSAME( COMPZ, 'N' ) ) THEN
         ICOMPZ = 0
      ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
         ICOMPZ = 1
      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
         ICOMPZ = 2
      ELSE
         ICOMPZ = -1
      END IF
      IF( ICOMPZ.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( (LDZ.LT.1) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX(1,NRL) ) ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZSTEQR', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF(N.LE.0) THEN
        RETURN
      END IF
!
      DO I = 1,N+1
        QI     = (I-1)/NPROC
        OW(I)  = MOD((I-1),NPROC)
        IF(ME .le. OW(I) ) then
          IL(I) = QI + 1
        ELSE
          IL(I) = QI
        END IF
      END DO

      IF( N.EQ.1 ) THEN
         IF( ICOMPZ.EQ.2 .AND. OW(1).EQ.ME ) Z( IL(1), 1 ) = ONE
         RETURN
      END IF
!
!     Determine the unit roundoff and over/underflow thresholds.
!     We ensure that all procs have the same data!
!
      EPS = DLAMCH( 'E' )
      EPS2 = EPS**2
      SAFMIN = DLAMCH( 'S' )
      SAFMAX = RONE / SAFMIN
      SSFMAX = SQRT( SAFMAX ) / THREE
      SSFMIN = SQRT( SAFMIN ) / EPS2
      !
      dvar(1) = EPS
      dvar(2) = EPS2
      dvar(3) = SAFMIN
      dvar(4) = SAFMAX
      dvar(5) = SSFMAX
      dvar(6) = SSFMIN
      !
      CALL BCAST_REAL( dvar, 6, 0, comm )
      !
      EPS     = dvar(1)
      EPS2    = dvar(2)
      SAFMIN  = dvar(3)
      SAFMAX  = dvar(4)
      SSFMAX  = dvar(5)
      SSFMIN  = dvar(6)
!
!     Compute the eigenvalues and eigenvectors of the tridiagonal
!     matrix.
!
      IF( ICOMPZ.EQ.2 ) THEN
        CALL ZLASET( 'Full', NRL, N, ZERO, ZERO, Z, LDZ )
        DO J = 1, N
          IF(OW(J).EQ.ME) THEN
            Z( IL(J), J ) = ONE
          END IF
        END DO
      END IF
!
      NMAXIT = N*MAXIT
      JTOT = 0
!
!     Determine where the matrix splits and choose QL or QR iteration
!     for each block, according to whether top or bottom diagonal
!     element is smaller.
!
      L1 = 1
      NM1 = N - 1
!
   10 CONTINUE

      IF( L1 .GT. N )   GO TO 160

      IF( L1 .GT. 1 )   E( L1-1 ) = RZERO

      IF( me == 0 ) THEN

         IF( L1.LE.NM1 ) THEN
            DO M = L1, NM1
               TST = DABS( E( M ) )
               IF( TST .EQ. RZERO )        GO TO 30
               IF( TST .LE. ( SQRT(DABS(D(M)))*SQRT(DABS(D(M+1))) ) * EPS ) THEN
                  E( M ) = RZERO
                  GO TO 30
               END IF
            END DO
         END IF
         M = N
!
   30    CONTINUE

      END IF

      CALL BCAST_REAL( e( l1 ), nm1-l1+1, 0, comm )
      CALL BCAST_INTEGER( m, 1, 0, comm )

      L = L1
      LSV = L
      LEND = M
      LENDSV = LEND
      L1 = M + 1
      IF( LEND.EQ.L )  GO TO 10
!
!     Scale submatrix in rows and columns L to LEND
!
      ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) )
      ISCALE = 0
      IF( ANORM.EQ.RZERO )   GO TO 10
      IF( ANORM.GT.SSFMAX ) THEN
         ISCALE = 1
         CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, INFO )
         CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, INFO )
      ELSE IF( ANORM.LT.SSFMIN ) THEN
         ISCALE = 2
         CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, INFO )
         CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, INFO )
      END IF
!
!     Choose between QL and QR iteration
!
      IF( DABS( D( LEND ) ).LT.DABS( D( L ) ) ) THEN
         LEND = LSV
         L = LENDSV
      END IF
!
      IF( LEND.GT.L ) THEN
!
!        QL Iteration
!
!        Look for small subdiagonal element.
!
   40    CONTINUE

         IF( me == 0 ) THEN

            IF( L.NE.LEND ) THEN
               LENDM1 = LEND - 1
               DO M = L, LENDM1
                  TST = DABS( E( M ) )**2
                  IF( TST.LE.( EPS2*DABS(D(M)) )*DABS(D(M+1))+ SAFMIN )GO TO 60
               END DO
            END IF
!
            M = LEND
!
   60       CONTINUE

         END IF

         CALL BCAST_INTEGER( m, 1, 0, comm )

         IF( M.LT.LEND )  E( M ) = RZERO
         P = D( L )
         IF( M.EQ.L ) THEN
!
!        Eigenvalue found.
!
            D( L ) = P
            L = L + 1
            IF( L.LE.LEND )   GO TO 40
            GO TO 140
         END IF
!
!        If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
!        to compute its eigensystem.
!
         IF( M.EQ.L+1 ) THEN
            IF( ICOMPZ.GT.0 ) THEN
               CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S )
               WORK( L ) = C
               WORK( N-1+L ) = S
               CTEMP = WORK( L )
               STEMP = WORK( N-1+L )
               IF( ( CTEMP.NE.RONE ) .OR. ( STEMP.NE.RZERO ) ) THEN
                  DO KL = 1, NRL
                     ZTEMP = Z( KL, 1+L )
                     Z( KL, 1+L ) = CTEMP*ZTEMP - STEMP*Z( KL, L )
                     Z( KL, L )   = STEMP*ZTEMP + CTEMP*Z( KL, L )
                  END DO
               END IF
            ELSE
               CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 )
            END IF
            D( L ) = RT1
            D( L+1 ) = RT2
            E( L ) = RZERO
            L = L + 2
            IF( L.LE.LEND )     GO TO 40
            GO TO 140
         END IF
!
         IF( JTOT.EQ.NMAXIT )   GO TO 140
         JTOT = JTOT + 1
!
!        Form shift.
!
         !
         ! iteration is performed on one processor and results broadcast
         ! to all others to prevent potential problems if all processors
         ! do not behave in exactly the same way (even with the same data!)
         !
         if ( me == 0 ) then

            G = ( D( L+1 )-P ) / ( TWO*E( L ) )
            R = DLAPY2( G, RONE )
            G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) )
!
            S = RONE
            C = RONE
            P = RZERO
!
!        Inner loop
!
            MM1 = M - 1
            DO I = MM1, L, -1
               F = S*E( I )
               B = C*E( I )
               CALL DLARTG( G, F, C, S, R )
               IF( I.NE.M-1 )  E( I+1 ) = R
               G = D( I+1 ) - P
               R = ( D( I )-G )*S + TWO*C*B
               P = S*R
               D( I+1 ) = G + P
               G = C*R - B
!
!           If eigenvectors are desired, then save rotations.
!
               IF( ICOMPZ.GT.0 ) THEN
                  WORK( I ) = C
                  WORK( N-1+I ) = -S
               END IF
            END DO
            D( L ) = D( L ) - P
            E( L ) = G
         END IF
         CALL BCAST_REAL( d( L ), m - l + 1, 0, comm )
         CALL BCAST_REAL( e( L ), m - l + 1, 0, comm )
!
!        If eigenvectors are desired, then apply saved rotations.
!
         IF( ICOMPZ.GT.0 ) THEN
           CALL BCAST_REAL( work, 2*n, 0, comm )
           DO J = M - L + 1 - 1, 1, -1
             CTEMP =  WORK( L + J -1)
             STEMP =  WORK( N-1+L + J-1)
             IF( ( CTEMP.NE.RONE ) .OR. ( STEMP.NE.RZERO ) ) THEN
               DO KL = 1, NRL
                 ZTEMP = Z( KL, J+1+L-1 )
                 Z( KL, J+1+L-1 ) = CTEMP*ZTEMP - STEMP*Z( KL, J+L-1 )
                 Z( KL, J+L-1 ) = STEMP*ZTEMP + CTEMP*Z( KL, J+L-1 )
               END DO
             END IF
           END DO
         END IF
!
         GO TO 40
!
      ELSE
!
!        QR Iteration
!
!        Look for small superdiagonal element.
!
   90    CONTINUE

         IF( me == 0 ) THEN

            IF( L.NE.LEND ) THEN
               LENDP1 = LEND + 1
               DO 100 M = L, LENDP1, -1
                  TST = DABS( E( M-1 ) )**2
                  IF( TST.LE.(EPS2*DABS(D(M)))*DABS(D(M-1))+ SAFMIN )GO TO 110
  100          CONTINUE
            END IF
!
            M = LEND
!
  110       CONTINUE

         END IF

         CALL BCAST_INTEGER( m, 1, 0, comm )

         IF( M.GT.LEND )   E( M-1 ) = RZERO
         P = D( L )
         IF( M.EQ.L ) THEN
!
!        Eigenvalue found.
!
            D( L ) = P
            L = L - 1
            IF( L.GE.LEND )   GO TO 90
            GO TO 140
         END IF
!
!        If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
!        to compute its eigensystem.
!
         IF( M.EQ.L-1 ) THEN
            IF( ICOMPZ.GT.0 ) THEN
               CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S )
               WORK( M ) = C
               WORK( N-1+M ) = S
               CTEMP = WORK( M )
               STEMP = WORK( N-1+M )
               IF( ( CTEMP.NE.RONE ) .OR. ( STEMP.NE.RZERO ) ) THEN
                  DO KL = 1, NRL
                     ZTEMP = Z( KL, L)
                     Z( KL, L )   = CTEMP*ZTEMP - STEMP*Z( KL, L-1 )
                     Z( KL, L-1 ) = STEMP*ZTEMP + CTEMP*Z( KL, L-1 )
                  END DO
               END IF
            ELSE
               CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 )
            END IF
            D( L-1 ) = RT1
            D( L ) = RT2
            E( L-1 ) = RZERO
            L = L - 2
            IF( L.GE.LEND )    GO TO 90
            GO TO 140
         END IF
!
         IF( JTOT.EQ.NMAXIT )  GO TO 140
         JTOT = JTOT + 1
!
!        Form shift.
!
         !
         ! iteration is performed on one processor and results broadcast
         ! to all others to prevent potential problems if all processors
         ! do not behave in exactly the same way (even with the same data!)
         !
         if ( me == 0 ) then

            G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) )
            R = DLAPY2( G, RONE )
            G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) )
!
            S = RONE
            C = RONE
            P = RZERO
!
!        Inner loop
!
            LM1 = L - 1
            DO I = M, LM1
               F = S*E( I )
               B = C*E( I )
               CALL DLARTG( G, F, C, S, R )
               IF( I.NE.M )     E( I-1 ) = R
               G = D( I ) - P
               R = ( D( I+1 )-G )*S + TWO*C*B
               P = S*R
               D( I ) = G + P
               G = C*R - B
!
!           If eigenvectors are desired, then save rotations.
!
               IF( ICOMPZ.GT.0 ) THEN
                  WORK( I ) = C
                  WORK( N-1+I ) = S
               END IF
            END DO
            D( L ) = D( L ) - P
            E( LM1 ) = G
         END IF
         CALL BCAST_REAL( d(M), L - M + 1, 0, comm)
         CALL BCAST_REAL( e(M), L - M + 1, 0, comm )
!
!        If eigenvectors are desired, then apply saved rotations.
!
         IF( ICOMPZ.GT.0 ) THEN
           CALL BCAST_REAL(work,2*n,0,comm)
            DO J = 1, L - M
               CTEMP = WORK( M+J-1 )
               STEMP = WORK( N-1+M+J-1 )
               IF( ( CTEMP.NE.RONE ) .OR. ( STEMP.NE.RZERO ) ) THEN
                  DO KL = 1, NRL
                     ZTEMP = Z( KL, J+M )
                     Z( KL, J+M )   = CTEMP*ZTEMP - STEMP*Z(KL, J+M-1)
                     Z( KL, J+M-1 ) = STEMP*ZTEMP + CTEMP*Z(KL, J+M-1)
                  END DO
               END IF
            END DO
         END IF
!
         GO TO 90
!
      END IF
!
!     Undo scaling if necessary
!
  140 CONTINUE

      IF( ISCALE.EQ.1 ) THEN
         CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1, &
     &                D( LSV ), N, INFO )
         CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ), &
     &                N, INFO )
      ELSE IF( ISCALE.EQ.2 ) THEN
         CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1, &
     &                D( LSV ), N, INFO )
         CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ), &
     &                N, INFO )
      END IF
!
!     Check for no convergence to an eigenvalue after a total
!     of N*MAXIT iterations.
!
      IF( JTOT .EQ. NMAXIT ) THEN
         DO 150 I = 1, N - 1
            IF( E( I ) .NE. RZERO )  INFO = INFO + 1
  150    CONTINUE
         WRITE(6,*) 'WARNING pzsteqr, convergence not achieved INFO = ', INFO
         RETURN
      END IF
      GO TO 10
!
!     Order eigenvalues and eigenvectors.
!
  160 CONTINUE

      IF( ICOMPZ.EQ.0 ) THEN
!
!        Use Quick Sort
!
         CALL DLASRT( 'I', N, D, INFO )
!
      ELSE
!
!        Use Selection Sort to minimize swaps of eigenvectors
!
         DO 180 II = 2, N
            I = II - 1
            K = I
            P = D( I )
            DO 170 J = II, N
               IF( D( J ).LT.P ) THEN
                  K = J
                  P = D( J )
               END IF
  170       CONTINUE
            IF( K.NE.I ) THEN
               D( K ) = D( I )
               D( I ) = P
               CALL ZSWAP( NRL, Z( 1, I ), 1, Z( 1, K ), 1 )
            END IF
  180    CONTINUE
      END IF

      RETURN
!
!     End of ZSTEQR
!
      END SUBROUTINE pzsteqr

!==----------------------------------------------==!

   SUBROUTINE zhpev_drv( JOBZ, UPLO, N, AP, W, Z, LDZ )

     USE kinds,     ONLY : DP
     USE io_global, ONLY : stdout

        IMPLICIT NONE

        CHARACTER ::       JOBZ, UPLO
        INTEGER   ::       IOPT, INFO, LDZ, N
        COMPLEX(DP) ::  AP( * ), Z( LDZ, * )
        REAL(DP) ::  W( * )
        REAL(DP), ALLOCATABLE :: RWORK(:)
        COMPLEX(DP), ALLOCATABLE :: ZWORK(:)

        ALLOCATE( rwork( MAX(1, 3*n-2) ), zwork( MAX(1, 2*n-1)) )
        CALL ZHPEV(jobz, uplo, n, ap, w, z, ldz, zwork, rwork, INFO)
        DEALLOCATE( rwork, zwork )
        IF( info .NE. 0 ) THEN
          CALL errore( ' dspev_drv ', ' diagonalization failed ',info )
        END IF
        RETURN
   END SUBROUTINE zhpev_drv

!==----------------------------------------------==!

   SUBROUTINE pzhpev_drv( jobz, ap, lda, w, z, ldz, &
                          nrl, n, nproc, mpime, comm )

     USE kinds,     ONLY : DP

     IMPLICIT NONE
     CHARACTER :: JOBZ
     INTEGER, INTENT(IN) :: lda, ldz, nrl, n, nproc, mpime
     INTEGER, INTENT(IN) :: comm
     COMPLEX(DP) :: ap( lda, * ), z( ldz, * )
     REAL(DP) :: w( * )
     REAL(DP), ALLOCATABLE :: rwork( : )
     COMPLEX(DP), ALLOCATABLE :: cwork( : )
     !
     ALLOCATE( rwork( n ) )
     ALLOCATE( cwork( n ) )
     !
     CALL pzhptrd( n, nrl, ap, lda, w, rwork, cwork, nproc, mpime, comm)

     IF( jobz == 'V' .OR. jobz == 'v' ) THEN
        CALL pzupgtr( n, nrl, ap, lda, cwork, z, ldz, nproc, mpime, comm)
     END IF

     CALL pzsteqr( jobz, n, nrl, w, rwork, z, ldz, nproc, mpime, comm)

     DEALLOCATE( cwork )
     DEALLOCATE( rwork )

     RETURN
   END SUBROUTINE pzhpev_drv

!==----------------------------------------------==!

  SUBROUTINE pzheevd_drv( tv, n, nb, h, w, ortho_cntx )

     USE kinds,     ONLY : DP

     IMPLICIT NONE

     LOGICAL, INTENT(IN)  :: tv
       ! if tv is true compute eigenvalues and eigenvectors (not used)
     INTEGER, INTENT(IN)  :: nb, n, ortho_cntx
       ! nb = block size, n = matrix size, ortho_cntx = BLACS context
     COMPLEX(DP) :: h(:,:)
       ! input:  h = matrix to be diagonalized
       ! output: h = eigenvectors
     REAL(DP) :: w(:)
       ! output: w = eigenvalues

     COMPLEX(DP) :: ztmp( 4 )
     REAL(DP)    :: rtmp( 4 )
     INTEGER     :: itmp( 4 )
     COMPLEX(DP), ALLOCATABLE :: work(:)
     COMPLEX(DP), ALLOCATABLE :: v(:,:)
     REAL(DP),    ALLOCATABLE :: rwork(:)
     INTEGER,     ALLOCATABLE :: iwork(:)
     INTEGER     :: LWORK, LRWORK, LIWORK
     INTEGER     :: desch( 10 ), info
     CHARACTER   :: jobv
     !
     IF( tv ) THEN
        ALLOCATE( v( SIZE( h, 1 ), SIZE( h, 2 ) ) )
        jobv = 'V'
     ELSE
        CALL errore( ' pzheevd_drv ', ' pzheevd does not compute eigenvalue only ', ABS( info ) )
     END IF

     CALL descinit( desch, n, n, nb, nb, 0, 0, ortho_cntx, SIZE( h, 1 ) , info )

     lwork = -1
     lrwork = -1
     liwork = -1
     CALL PZHEEVD( 'V', 'L', n, h, 1, 1, desch, w, v, 1, 1, &
                   desch, ztmp, LWORK, rtmp, LRWORK, itmp, LIWORK, INFO )

     IF( info /= 0 ) CALL errore( ' cdiaghg ', ' PZHEEVD ', ABS( info ) )

     lwork = INT( REAL(ztmp(1)) ) + 1
     lrwork = INT( rtmp(1) ) + 1
     liwork = itmp(1) + 1

     ALLOCATE( work( lwork ) )
     ALLOCATE( rwork( lrwork ) )
     ALLOCATE( iwork( liwork ) )

     CALL PZHEEVD( 'V', 'L', n, h, 1, 1, desch, w, v, 1, 1, &
                   desch, work, LWORK, rwork, LRWORK, iwork, LIWORK, INFO )

     IF( info /= 0 ) CALL errore( ' cdiaghg ', ' PZHEEVD ', ABS( info ) )

     IF( tv ) h = v

     DEALLOCATE( work )
     DEALLOCATE( rwork )
     DEALLOCATE( iwork )
     IF( ALLOCATED( v ) ) DEALLOCATE( v )
     RETURN
  END SUBROUTINE pzheevd_drv

END MODULE zhpev_module