*> \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 JOBZ = 'N',
*>            LWORK >= 3*min(M,N) + max(max(M,N),7*min(M,N)).
*>          If JOBZ = 'O',
*>            LWORK >= 3*min(M,N) +
*>                     max(max(M,N),5*min(M,N)*min(M,N)+4*min(M,N)).
*>          If JOBZ = 'S' or 'A'
*>            LWORK >= 3*min(M,N) +
*>                     max(max(M,N),4*min(M,N)*min(M,N)+3*min(M,N)+max(M,N)).
*>          For good performance, LWORK should generally be larger.
*>          If LWORK = -1 but other input arguments are legal, WORK(1)
*>          returns the optimal LWORK.
*> \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 September 2012
*
*> \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 )
*
*  -- LAPACK driver routine (version 3.4.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     September 2012
*
*     .. 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
      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
      INTEGER            ILAENV
      DOUBLE PRECISION   DLAMCH, DLANGE
      EXTERNAL           DLAMCH, DLANGE, ILAENV, LSAME
*     ..
*     .. 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.EQ.-1 )
*
      IF( .NOT.( WNTQA .OR. WNTQS .OR. WNTQO .OR. WNTQN ) ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -5
      ELSE IF( LDU.LT.1 .OR. ( WNTQAS .AND. LDU.LT.M ) .OR.
     $         ( WNTQO .AND. M.LT.N .AND. LDU.LT.M ) ) THEN
         INFO = -8
      ELSE IF( LDVT.LT.1 .OR. ( WNTQA .AND. LDVT.LT.N ) .OR.
     $         ( WNTQS .AND. LDVT.LT.MINMN ) .OR.
     $         ( WNTQO .AND. M.GE.N .AND. LDVT.LT.N ) ) THEN
         INFO = -10
      END IF
*
*     Compute workspace
*      (Note: Comments in the code beginning "Workspace:" describe the
*       minimal amount of workspace needed 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.EQ.0 ) THEN
         MINWRK = 1
         MAXWRK = 1
         IF( M.GE.N .AND. MINMN.GT.0 ) THEN
*
*           Compute space needed for DBDSDC
*
            MNTHR = INT( MINMN*11.0D0 / 6.0D0 )
            IF( WNTQN ) THEN
               BDSPAC = 7*N
            ELSE
               BDSPAC = 3*N*N + 4*N
            END IF
            IF( M.GE.MNTHR ) THEN
               IF( WNTQN ) THEN
*
*                 Path 1 (M much larger than N, JOBZ='N')
*
                  WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1,
     $                    -1 )
                  WRKBL = MAX( WRKBL, 3*N+2*N*
     $                    ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
                  MAXWRK = MAX( WRKBL, BDSPAC+N )
                  MINWRK = BDSPAC + N
               ELSE IF( WNTQO ) THEN
*
*                 Path 2 (M much larger than N, JOBZ='O')
*
                  WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M,
     $                    N, N, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+2*N*
     $                    ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+N*
     $                    ILAENV( 1, 'DORMBR', 'QLN', N, N, N, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+N*
     $                    ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
                  WRKBL = MAX( WRKBL, BDSPAC+3*N )
                  MAXWRK = WRKBL + 2*N*N
                  MINWRK = BDSPAC + 2*N*N + 3*N
               ELSE IF( WNTQS ) THEN
*
*                 Path 3 (M much larger than N, JOBZ='S')
*
                  WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M,
     $                    N, N, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+2*N*
     $                    ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+N*
     $                    ILAENV( 1, 'DORMBR', 'QLN', N, N, N, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+N*
     $                    ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
                  WRKBL = MAX( WRKBL, BDSPAC+3*N )
                  MAXWRK = WRKBL + N*N
                  MINWRK = BDSPAC + N*N + 3*N
               ELSE IF( WNTQA ) THEN
*
*                 Path 4 (M much larger than N, JOBZ='A')
*
                  WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'DORGQR', ' ', M,
     $                    M, N, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+2*N*
     $                    ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+N*
     $                    ILAENV( 1, 'DORMBR', 'QLN', N, N, N, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+N*
     $                    ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
                  WRKBL = MAX( WRKBL, BDSPAC+3*N )
                  MAXWRK = WRKBL + N*N
                  MINWRK = BDSPAC + N*N + 2*N + M
               END IF
            ELSE
*
*              Path 5 (M at least N, but not much larger)
*
               WRKBL = 3*N + ( M+N )*ILAENV( 1, 'DGEBRD', ' ', M, N, -1,
     $                 -1 )
               IF( WNTQN ) THEN
                  MAXWRK = MAX( WRKBL, BDSPAC+3*N )
                  MINWRK = 3*N + MAX( M, BDSPAC )
               ELSE IF( WNTQO ) THEN
                  WRKBL = MAX( WRKBL, 3*N+N*
     $                    ILAENV( 1, 'DORMBR', 'QLN', M, N, N, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+N*
     $                    ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
                  WRKBL = MAX( WRKBL, BDSPAC+3*N )
                  MAXWRK = WRKBL + M*N
                  MINWRK = 3*N + MAX( M, N*N+BDSPAC )
               ELSE IF( WNTQS ) THEN
                  WRKBL = MAX( WRKBL, 3*N+N*
     $                    ILAENV( 1, 'DORMBR', 'QLN', M, N, N, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+N*
     $                    ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
                  MAXWRK = MAX( WRKBL, BDSPAC+3*N )
                  MINWRK = 3*N + MAX( M, BDSPAC )
               ELSE IF( WNTQA ) THEN
                  WRKBL = MAX( WRKBL, 3*N+M*
     $                    ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+N*
     $                    ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
                  MAXWRK = MAX( MAXWRK, BDSPAC+3*N )
                  MINWRK = 3*N + MAX( M, BDSPAC )
               END IF
            END IF
         ELSE IF( MINMN.GT.0 ) THEN
*
*           Compute space needed for DBDSDC
*
            MNTHR = INT( MINMN*11.0D0 / 6.0D0 )
            IF( WNTQN ) THEN
               BDSPAC = 7*M
            ELSE
               BDSPAC = 3*M*M + 4*M
            END IF
            IF( N.GE.MNTHR ) THEN
               IF( WNTQN ) THEN
*
*                 Path 1t (N much larger than M, JOBZ='N')
*
                  WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1,
     $                    -1 )
                  WRKBL = MAX( WRKBL, 3*M+2*M*
     $                    ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
                  MAXWRK = MAX( WRKBL, BDSPAC+M )
                  MINWRK = BDSPAC + M
               ELSE IF( WNTQO ) THEN
*
*                 Path 2t (N much larger than M, JOBZ='O')
*
                  WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M,
     $                    N, M, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+2*M*
     $                    ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+M*
     $                    ILAENV( 1, 'DORMBR', 'QLN', M, M, M, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+M*
     $                    ILAENV( 1, 'DORMBR', 'PRT', M, M, M, -1 ) )
                  WRKBL = MAX( WRKBL, BDSPAC+3*M )
                  MAXWRK = WRKBL + 2*M*M
                  MINWRK = BDSPAC + 2*M*M + 3*M
               ELSE IF( WNTQS ) THEN
*
*                 Path 3t (N much larger than M, JOBZ='S')
*
                  WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M,
     $                    N, M, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+2*M*
     $                    ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+M*
     $                    ILAENV( 1, 'DORMBR', 'QLN', M, M, M, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+M*
     $                    ILAENV( 1, 'DORMBR', 'PRT', M, M, M, -1 ) )
                  WRKBL = MAX( WRKBL, BDSPAC+3*M )
                  MAXWRK = WRKBL + M*M
                  MINWRK = BDSPAC + M*M + 3*M
               ELSE IF( WNTQA ) THEN
*
*                 Path 4t (N much larger than M, JOBZ='A')
*
                  WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'DORGLQ', ' ', N,
     $                    N, M, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+2*M*
     $                    ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+M*
     $                    ILAENV( 1, 'DORMBR', 'QLN', M, M, M, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+M*
     $                    ILAENV( 1, 'DORMBR', 'PRT', M, M, M, -1 ) )
                  WRKBL = MAX( WRKBL, BDSPAC+3*M )
                  MAXWRK = WRKBL + M*M
                  MINWRK = BDSPAC + M*M + 3*M
               END IF
            ELSE
*
*              Path 5t (N greater than M, but not much larger)
*
               WRKBL = 3*M + ( M+N )*ILAENV( 1, 'DGEBRD', ' ', M, N, -1,
     $                 -1 )
               IF( WNTQN ) THEN
                  MAXWRK = MAX( WRKBL, BDSPAC+3*M )
                  MINWRK = 3*M + MAX( N, BDSPAC )
               ELSE IF( WNTQO ) THEN
                  WRKBL = MAX( WRKBL, 3*M+M*
     $                    ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+M*
     $                    ILAENV( 1, 'DORMBR', 'PRT', M, N, M, -1 ) )
                  WRKBL = MAX( WRKBL, BDSPAC+3*M )
                  MAXWRK = WRKBL + M*N
                  MINWRK = 3*M + MAX( N, M*M+BDSPAC )
               ELSE IF( WNTQS ) THEN
                  WRKBL = MAX( WRKBL, 3*M+M*
     $                    ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+M*
     $                    ILAENV( 1, 'DORMBR', 'PRT', M, N, M, -1 ) )
                  MAXWRK = MAX( WRKBL, BDSPAC+3*M )
                  MINWRK = 3*M + MAX( N, BDSPAC )
               ELSE IF( WNTQA ) THEN
                  WRKBL = MAX( WRKBL, 3*M+M*
     $                    ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+M*
     $                    ILAENV( 1, 'DORMBR', 'PRT', N, N, M, -1 ) )
                  MAXWRK = MAX( WRKBL, BDSPAC+3*M )
                  MINWRK = 3*M + MAX( N, BDSPAC )
               END IF
            END IF
         END IF
         MAXWRK = MAX( MAXWRK, MINWRK )
         WORK( 1 ) = MAXWRK
*
         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
            INFO = -12
         END IF
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGESDD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
         RETURN
      END IF
*
*     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 )
      ISCL = 0
      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
         ISCL = 1
         CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, IERR )
      ELSE IF( ANRM.GT.BIGNUM ) THEN
         ISCL = 1
         CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, IERR )
      END IF
*
      IF( M.GE.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.GE.MNTHR ) THEN
*
            IF( WNTQN ) THEN
*
*              Path 1 (M much larger than N, JOBZ='N')
*              No singular vectors to be computed
*
               ITAU = 1
               NWORK = ITAU + N
*
*              Compute A=Q*R
*              (Workspace: need 2*N, prefer N+N*NB)
*
               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 4*N, prefer 3*N+2*N*NB)
*
               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+BDSPAC)
*
               CALL DBDSDC( 'U', 'N', N, S, WORK( IE ), DUM, 1, DUM, 1,
     $                      DUM, IDUM, WORK( NWORK ), IWORK, INFO )
*
            ELSE IF( WNTQO ) THEN
*
*              Path 2 (M much larger than 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.GE.LDA*N+N*N+3*N+BDSPAC ) THEN
                  LDWRKR = LDA
               ELSE
                  LDWRKR = ( LWORK-N*N-3*N-BDSPAC ) / N
               END IF
               ITAU = IR + LDWRKR*N
               NWORK = ITAU + N
*
*              Compute A=Q*R
*              (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
               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+2*N, prefer N*N+N+N*NB)
*
               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 VT, copying result to WORK(IR)
*              (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
*
               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*N+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 2*N*N+3*N, prefer 2*N*N+2*N+N*NB)
*
               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 2*N*N, prefer N*N+M*N)
*
               DO 10 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 )
   10          CONTINUE
*
            ELSE IF( WNTQS ) THEN
*
*              Path 3 (M much larger than 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+2*N, prefer N*N+N+N*NB)
*
               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+2*N, prefer N*N+N+N*NB)
*
               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+4*N, prefer N*N+3*N+2*N*NB)
*
               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+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+3*N, prefer N*N+2*N+N*NB)
*
               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)
*
               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 )
*
            ELSE IF( WNTQA ) THEN
*
*              Path 4 (M much larger than 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+N+M, prefer N*N+N+M*NB)
*
               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+N+M, prefer N*N+N+M*NB)
               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+4*N, prefer N*N+3*N+2*N*NB)
*
               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*N+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+3*N, prefer N*N+2*N+N*NB)
*
               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)
*
               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 )
*
            END IF
*
         ELSE
*
*           M .LT. MNTHR
*
*           Path 5 (M at least 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+M, prefer 3*N+(M+N)*NB)
*
            CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
     $                   WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
     $                   IERR )
            IF( WNTQN ) THEN
*
*              Perform bidiagonal SVD, only computing singular values
*              (Workspace: need N+BDSPAC)
*
               CALL DBDSDC( 'U', 'N', N, S, WORK( IE ), DUM, 1, DUM, 1,
     $                      DUM, IDUM, WORK( NWORK ), IWORK, INFO )
            ELSE IF( WNTQO ) THEN
               IU = NWORK
               IF( LWORK.GE.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 )
               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
               END IF
               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 N+N*N+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 N*N+2*N, prefer N*N+N+N*NB)
*
               CALL DORMBR( 'P', 'R', 'T', N, N, N, A, LDA,
     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
     $                      LWORK-NWORK+1, IERR )
*
               IF( LWORK.GE.M*N+3*N+BDSPAC ) THEN
*
*                 Overwrite WORK(IU) by left singular vectors of A
*                 (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
                  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
*
*                 Generate Q in A
*                 (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
                  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 2*N*N, prefer N*N+M*N)
*
                  DO 20 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 )
   20             CONTINUE
               END IF
*
            ELSE IF( WNTQS ) THEN
*
*              Perform bidiagonal SVD, computing left singular vectors
*              of bidiagonal matrix in U and computing right singular
*              vectors of bidiagonal matrix in VT
*              (Workspace: need N+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, prefer 2*N+N*NB)
*
               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 )
            ELSE IF( WNTQA ) THEN
*
*              Perform bidiagonal SVD, computing left singular vectors
*              of bidiagonal matrix in U and computing right singular
*              vectors of bidiagonal matrix in VT
*              (Workspace: need N+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.GT.N ) THEN
                  CALL DLASET( 'F', M-N, M-N, ZERO, ONE, U( N+1, N+1 ),
     $                         LDU )
               END IF
*
*              Overwrite U by left singular vectors of A and VT
*              by right singular vectors of A
*              (Workspace: need N*N+2*N+M, prefer N*N+2*N+M*NB)
*
               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 )
            END IF
*
         END IF
*
      ELSE
*
*        A has more columns than rows. If A has sufficiently more
*        columns than rows, first reduce using the LQ decomposition (if
*        sufficient workspace available)
*
         IF( N.GE.MNTHR ) THEN
*
            IF( WNTQN ) THEN
*
*              Path 1t (N much larger than M, JOBZ='N')
*              No singular vectors to be computed
*
               ITAU = 1
               NWORK = ITAU + M
*
*              Compute A=L*Q
*              (Workspace: need 2*M, prefer M+M*NB)
*
               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 4*M, prefer 3*M+2*M*NB)
*
               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+BDSPAC)
*
               CALL DBDSDC( 'U', 'N', M, S, WORK( IE ), DUM, 1, DUM, 1,
     $                      DUM, IDUM, WORK( NWORK ), IWORK, INFO )
*
            ELSE IF( WNTQO ) THEN
*
*              Path 2t (N much larger than M, JOBZ='O')
*              M right singular vectors to be overwritten on A and
*              M left singular vectors to be computed in U
*
               IVT = 1
*
*              IVT is M by M
*
               IL = IVT + M*M
               IF( LWORK.GE.M*N+M*M+3*M+BDSPAC ) THEN
*
*                 WORK(IL) is M by N
*
                  LDWRKL = M
                  CHUNK = N
               ELSE
                  LDWRKL = M
                  CHUNK = ( LWORK-M*M ) / M
               END IF
               ITAU = IL + LDWRKL*M
               NWORK = ITAU + M
*
*              Compute A=L*Q
*              (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
               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+2*M, prefer M*M+M+M*NB)
*
               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+4*M, prefer M*M+3*M+2*M*NB)
*
               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*M+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 2*M*M+3*M, prefer 2*M*M+2*M+M*NB)
*
               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 2*M*M, prefer M*M+M*N)
*
               DO 30 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 )
   30          CONTINUE
*
            ELSE IF( WNTQS ) THEN
*
*              Path 3t (N much larger than 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+2*M, prefer M*M+M+M*NB)
*
               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+2*M, prefer M*M+M+M*NB)
*
               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), copying result to U
*              (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
*
               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+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+3*M, prefer M*M+2*M+M*NB)
*
               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)
*
               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 )
*
            ELSE IF( WNTQA ) THEN
*
*              Path 4t (N much larger than 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+2*M, prefer M*M+M+M*NB)
*
               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+2*M, prefer M*M+M+M*NB)
*
               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+4*M, prefer M*M+3*M+2*M*NB)
*
               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*M+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+3*M, prefer M*M+2*M+M*NB)
*
               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)
*
               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 )
*
            END IF
*
         ELSE
*
*           N .LT. MNTHR
*
*           Path 5t (N greater than 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+N, prefer 3*M+(M+N)*NB)
*
            CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
     $                   WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
     $                   IERR )
            IF( WNTQN ) THEN
*
*              Perform bidiagonal SVD, only computing singular values
*              (Workspace: need M+BDSPAC)
*
               CALL DBDSDC( 'L', 'N', M, S, WORK( IE ), DUM, 1, DUM, 1,
     $                      DUM, IDUM, WORK( NWORK ), IWORK, INFO )
            ELSE IF( WNTQO ) THEN
               LDWKVT = M
               IVT = NWORK
               IF( LWORK.GE.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
               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
               END IF
*
*              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+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 M*M+2*M, prefer M*M+M+M*NB)
*
               CALL DORMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
     $                      LWORK-NWORK+1, IERR )
*
               IF( LWORK.GE.M*N+3*M+BDSPAC ) THEN
*
*                 Overwrite WORK(IVT) by left singular vectors of A
*                 (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
                  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
*
*                 Generate P**T in A
*                 (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
                  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 2*M*M, prefer M*M+M*N)
*
                  DO 40 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 )
   40             CONTINUE
               END IF
            ELSE IF( WNTQS ) THEN
*
*              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+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, prefer 2*M+M*NB)
*
               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 )
            ELSE IF( WNTQA ) THEN
*
*              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+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.GT.M ) THEN
                  CALL DLASET( 'F', N-M, N-M, ZERO, ONE, VT( M+1, M+1 ),
     $                         LDVT )
               END IF
*
*              Overwrite U by left singular vectors of A and VT
*              by right singular vectors of A
*              (Workspace: need 2*M+N, prefer 2*M+N*NB)
*
               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 )
            END IF
*
         END IF
*
      END IF
*
*     Undo scaling if necessary
*
      IF( ISCL.EQ.1 ) THEN
         IF( ANRM.GT.BIGNUM )
     $      CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
     $                   IERR )
         IF( ANRM.LT.SMLNUM )
     $      CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
     $                   IERR )
      END IF
*
*     Return optimal workspace in WORK(1)
*
      WORK( 1 ) = MAXWRK
*
      RETURN
*
*     End of DGESDD
*
      END


Subroutine lambar(i1, i2, srt, siglab)
  Parameter (maxstr=150001)
  Common /aa/r(3, maxstr)
  Common /bb/p(3, maxstr)
  Common /cc/e(maxstr)
  Common /ee/id(maxstr), lb(maxstr)
  Save
  siglab = 1.E-06
  If (iabs(lb(i1))>=14 .And. iabs(lb(i1))<=17) Then
    eml = e(i1)
    emb = e(i2)
  Else
    eml = e(i2)
    emb = e(i1)
  End If
  pthr = srt**2 - eml**2 - emb**2
  If (pthr>0.) Then
    plab2 = (pthr/2./emb)**2 - eml**2
    If (plab2>0) Then
      plab = sqrt(plab2)
      siglab = 12. + 0.43/(plab**3.3)
      If (siglab>200.) siglab = 200.
    End If
  End If
  Return
End Subroutine lambar


!--------------------------------------------------------------------------------
!
!   optical properties averaged over power-law aggregate size distribution
!
!--------------------------------------------------------------------------------
program opacfractal_distribution_average
use types; use const
use omp_lib
implicit none
real(kind=dp),parameter :: mic2cm = 1.0e-4_dp
real(kind=dp),parameter :: cm2mic = 1.0e4_dp
integer :: i,j,ia,na,nang,nwl,unit
integer :: iqsca,iqcor,iqgeo,iquiet
real(kind=dp) :: r0,rmax,rmin,p,pn,k0,df,lmd,Cext,Csca,Cabsp,gsca,dphi
real(kind=dp) :: lnrmin,lnrmax,dlna,rhod,wn,dang,tot,tot2,mu1,mu2,dmu
real(kind=dp),allocatable,dimension(:)   :: kabs,ksca,g,ang
real(kind=dp),allocatable,dimension(:)   :: wl,refre,refim,kabsave,kscaave,gsave,ri,nd,mass
real(kind=dp),allocatable,dimension(:,:) :: Z11,Z12,Z22,Z33,Z34,Z44,Smat
real(kind=dp),allocatable,dimension(:,:) :: Z11ave,Z12ave,Z22ave,Z33ave,Z34ave,Z44ave
complex(kind=dp)::refrel

!--------------------------------------------------------------------------------
!       Input parameters
!--------------------------------------------------------------------------------
k0     = 1.04_dp            ! fractal pre-factor
df     = 1.90_dp            ! fractal dimension
r0     = 0.1_dp * mic2cm    ! monomer radius                        [cm]
rmin   = 0.3_dp * mic2cm    ! minimum volume-equivalent radius      [cm]
rmax   = 1.00_dp * mic2cm   ! maximum volume-equivalent radius      [cm]
p      = 3.50_dp            ! power-law index of size distribution
rhod   = 3.30_dp            ! material density                      [g/cm^3]
nang   = 91                 ! number of angle grids
nwl    = 100                ! number of wavelength in optical constant file
na     = 15                 ! number of grain radius bin
!--------------------------------------------------------------------------------
iqsca  = 3
iqcor  = 1
iqgeo  = 3
iquiet = 1

!--------------------------------------------------------------------------------
!       write message
!--------------------------------------------------------------------------------
call out_headerinfo(6,r0*cm2mic,rmin*cm2mic,rmax*cm2mic,p,k0,df,iqsca,iqcor,iqgeo,rhod)

!--------------------------------------------------------------------------------
!       allocate arrays
!--------------------------------------------------------------------------------

allocate(wl(1:nwl),refre(1:nwl),refim(1:nwl),kabsave(1:nwl),kscaave(1:nwl),gsave(1:nwl))
allocate(ri(1:na),nd(1:na),mass(1:na),kabs(1:na),ksca(1:na),g(1:na))
allocate(ang(1:2*nang-1),Smat(1:4,1:2*nang-1))
allocate(Z11(1:na,1:2*nang-1),Z12(1:na,1:2*nang-1),Z22(1:na,1:2*nang-1),&
         Z33(1:na,1:2*nang-1),Z34(1:na,1:2*nang-1),Z44(1:na,1:2*nang-1))
allocate(Z11ave(1:nwl,1:2*nang-1),Z12ave(1:nwl,1:2*nang-1),&
         Z22ave(1:nwl,1:2*nang-1),Z33ave(1:nwl,1:2*nang-1),&
         Z34ave(1:nwl,1:2*nang-1),Z44ave(1:nwl,1:2*nang-1))

!--------------------------------------------------------------------------------
!       Load optical constant
!--------------------------------------------------------------------------------
open(50,file="astrosil.lnk",status="old")
do i=1,3
    read(50,'()')
enddo
do i=1,nwl
    read(50,*) wl(i),refre(i),refim(i)
end do
close(50)
wl = wl * mic2cm

!--------------------------------------------------------------------------------
!       make size distribution
!--------------------------------------------------------------------------------
lnrmin = log(rmin)
lnrmax = log(rmax)
dlna   = (lnrmax-lnrmin) / real(na-1,kind=dp)
do ia=1,na
    ri(ia)   = exp(lnrmin+real(ia-1,kind=dp)*dlna)
    PN       = (ri(ia)/r0)**3.0
    mass(ia) = 4.0_dp * pi * r0 ** 3.0 * rhod * PN / 3.0_dp
    nd(ia)   = ri(ia)**(1.0-p)      ! logarithmic bin : n(a)dlna
end do
! Now, dlna = constant, so it is going to be omitted hereafter as it cancels out.
tot = 0.0_dp
do ia=1,na-1
    tot = tot + 0.5_dp * (mass(ia)*nd(ia)+mass(ia+1)*nd(ia+1))
enddo
nd = nd / tot

!--------------------------------------------------------------------------------
!       make angle mesh
!--------------------------------------------------------------------------------
dang  = halfpi/real(nang-1,kind=dp)
do j=1,2*nang-1
    ang(j)=dang*real(j-1,kind=dp)*r2d
end do

!--------------------------------------------------------------------------------
!       perform distribution average of optical properties
!--------------------------------------------------------------------------------
Z11ave  = 0.0_dp
Z12ave  = 0.0_dp
Z22ave  = 0.0_dp
Z33ave  = 0.0_dp
Z34ave  = 0.0_dp
Z44ave  = 0.0_dp
kabsave = 0.0_dp
kscaave = 0.0_dp
gsave   = 0.0_dp

do i=1,nwl

    print *, '... wavelength',i,'/',nwl

    Z11 = 0.0_dp
    Z12 = 0.0_dp
    Z22 = 0.0_dp
    Z33 = 0.0_dp
    Z34 = 0.0_dp
    Z44 = 0.0_dp
    refrel = cmplx(refre(i),refim(i))
    wn     = twopi/wl(i)
    !
    ! storing opacities and scattering matrix at each aggregate radius
    !
    !$OMP parallel do schedule (static,1)                   &
    !$OMP default(none)                                     &
    !$OMP shared(refrel,wn,ri,wl,mass,i,nang,na)            &
    !$OMP shared(kabs,ksca,g,Z11,Z12,Z22,Z33,Z34,Z44)       &
    !$OMP shared(lmd,r0,Df,k0,iqsca,iqcor,iqgeo,iquiet)     &
    !$OMP private(PN,Cext,Csca,Cabsp,Gsca,Smat,dphi)
    do ia=1,na

        PN = (ri(ia)/r0)**3.0
        call meanscatt(wl(i)*cm2mic,r0*cm2mic,PN,Df,k0,refrel,iqsca,iqcor,iqgeo,iquiet,nang,&
                        Cext,Csca,Cabsp,Gsca,Smat,dphi)

        kabs(ia) = Cabsp * mic2cm * mic2cm / mass(ia)
        ksca(ia) = Csca  * mic2cm * mic2cm / mass(ia)
        g(ia)    = Gsca
        do j=1,2*nang-1
            Z11(ia,j) = Smat(1,j) / mass(ia) / wn / wn
            Z12(ia,j) = Smat(2,j) / mass(ia) / wn / wn
            Z22(ia,j) = Z11(ia,j)
            Z33(ia,j) = Smat(3,j) / mass(ia) / wn / wn
            Z34(ia,j) = Smat(4,j) / mass(ia) / wn / wn
            Z44(ia,j) = Z33(ia,j)
        end do

    end do
    !$OMP end parallel do
    !
    ! opacities and scattering matrix averaging over the size distribution
    !
    do ia=1,na-1
        kabsave(i) = kabsave(i) + 0.5_dp * (kabs(ia)*mass(ia)*nd(ia)+&
               kabs(ia+1)*mass(ia+1)*nd(ia+1))
        kscaave(i) = kscaave(i) + 0.5_dp * (ksca(ia)*mass(ia)*nd(ia)+&
               ksca(ia+1)*mass(ia+1)*nd(ia+1))
        do j=1,2*nang-1
            Z11ave(i,j) = Z11ave(i,j) + 0.5_dp * (Z11(ia,j)*mass(ia)*nd(ia)+&
                             Z11(ia+1,j)*mass(ia+1)*nd(ia+1))
            Z12ave(i,j) = Z12ave(i,j) + 0.5_dp * (Z12(ia,j)*mass(ia)*nd(ia)+&
                             Z12(ia+1,j)*mass(ia+1)*nd(ia+1))
            Z22ave(i,j) = Z22ave(i,j) + 0.5_dp * (Z22(ia,j)*mass(ia)*nd(ia)+&
                             Z22(ia+1,j)*mass(ia+1)*nd(ia+1))
            Z33ave(i,j) = Z33ave(i,j) + 0.5_dp * (Z33(ia,j)*mass(ia)*nd(ia)+&
                             Z33(ia+1,j)*mass(ia+1)*nd(ia+1))
            Z34ave(i,j) = Z34ave(i,j) + 0.5_dp * (Z34(ia,j)*mass(ia)*nd(ia)+&
                             Z34(ia+1,j)*mass(ia+1)*nd(ia+1))
            Z44ave(i,j) = Z44ave(i,j) + 0.5_dp * (Z44(ia,j)*mass(ia)*nd(ia)+&
                             Z44(ia+1,j)*mass(ia+1)*nd(ia+1))
        enddo
    enddo
    !
    ! compute asymmetry parameter by integrating Z11
    !   in mu-space (RADMC-3D-like weightning)
    !
    tot  = 0.0_dp
    tot2 = 0.0_dp
    do j=1,2*nang-2
        mu1 = cos(ang(j)*d2r); mu2 = cos(ang(j+1)*d2r); dmu = twopi * (mu1-mu2)
        tot  = tot  + 0.5_dp * (Z11ave(i,j)+Z11ave(i,j+1)) * dmu
        tot2 = tot2 + 0.5_dp * (Z11ave(i,j)+Z11ave(i,j+1)) * dmu * 0.5_dp * (mu1 + mu2)
    enddo
    gsave(i) = tot2 / tot

enddo ! end wavelength loop

!--------------------------------------------------------------------------------
!       output results in format of RADMC-3D input file
!--------------------------------------------------------------------------------
print *, 'dustkapscatmat.inp'
unit = 10
open(unit,file='dustkapscatmat.inp',status='unknown')
call out_headerinfo(unit,r0*cm2mic,rmin*cm2mic,rmax*cm2mic,p,k0,df,iqsca,iqcor,iqgeo,rhod)
call out_radmc3d_format(unit,nwl,2*nang-1,wl,kabsave,kscaave,gsave,ang,&
            Z11ave,Z12ave,Z22ave,Z33ave,Z34ave,Z44ave)
close(unit)

deallocate(wl,refre,refim,ri,nd,mass)
deallocate(Smat,kabs,ksca,g,Z11,Z12,Z22,Z33,Z34,Z44)
deallocate(ang,kabsave,kscaave,gsave,Z11ave,Z12ave,Z22ave,Z33ave,Z34ave,Z44ave)

stop
end program opacfractal_distribution_average

!--------------------------------------------------------------------------------
!       output header information
!--------------------------------------------------------------------------------
subroutine out_headerinfo(unit,r0,rmin,rmax,p,k0,df,iqsca,iqcor,iqgeo,rhod)
use types
implicit none
integer::unit,iqsca,iqcor,iqgeo
real(kind=dp):: df,k0,r0,rmin,rmax,p,rhod

write(unit,'("# ================================================")')
write(unit,'("#              OPACFRACTAL v3.0                  ")')
write(unit,'("# ================================================")')
write(unit,'("# iqsca = ",I1," iqcor = ",I1," iqgeo = ",I1)') iqsca,iqcor,iqgeo
write(unit,'("# df           = ",1PE12.5)') df
write(unit,'("# k0           = ",1PE12.5)') k0
write(unit,'("# r0   [um]    = ",1PE12.5)') r0
write(unit,'("# rmin [um]    = ",1PE12.5)') rmin
write(unit,'("# rmax [um]    = ",1PE12.5)') rmax
write(unit,'("# powind       = ",1PE12.5)') p
write(unit,'("# rho (g/cm^3) = ",1PE12.5)') rhod

return
end subroutine out_headerinfo

!--------------------------------------------------------------------------------
!
!       output RADMC-3D input file
!
!--------------------------------------------------------------------------------
subroutine out_radmc3d_format(unit,nwl,nang,wl,kabs,ksca,g,ang,Z11,Z12,Z22,Z33,Z34,Z44)
use types; use const
implicit none
integer::i,j,nwl,nang,unit
real(kind=dp),parameter :: cm2mic = 1.0e4_dp
real(kind=dp),dimension(1:nwl)::wl,kabs,ksca,g
real(kind=dp),dimension(1:nwl,1:nang)::Z11,Z12,Z22,Z33,Z34,Z44
real(kind=dp)::ang(1:nang),tot,mu1,mu2,dmu,f

write(unit,*) 1       !ifotmat
write(unit,*) nwl     !number of wavelength
write(unit,*) nang    !number of anguler mesh
write(unit,*)
do i=1,nwl
    write(unit,'(1P4E18.8)') wl(i)*cm2mic,kabs(i),ksca(i),g(i)
end do
write(unit,*)
do j=1,nang
    write(unit,'(1PE18.8)') ang(j)
end do
write(unit,*)
do i=1,nwl
    tot = 0.0_dp
    ! mu-space integration of Z11 (as done in RADMC3D)
    do j=1,nang-1
        mu1 = cos(ang(j)*d2r); mu2 = cos(ang(j+1)*d2r); dmu=twopi*(mu1-mu2)
        tot = tot + 0.5_dp * ( Z11(i,j) + Z11(i,j+1) ) * dmu
    enddo
    ! Rescaling factor of Zij to match scattering opacity
    f = ksca(i) / tot
    do j=1,nang
        write(unit,'(1P6E18.8)') f*Z11(i,j),f*Z12(i,j),f*Z22(i,j),&
                                 f*Z33(i,j),f*Z34(i,j),f*Z44(i,j)
    end do
end do

return
end subroutine out_radmc3d_format


      double complex function F42me(psq,qsq,s,t)
c--- note: ordering of arguments to function is taken from, e.g.
c---       arXiV:0804.4149v3 (App. B) and not hep-ph/0607139 (Eq. 22)
      implicit none
c      include 'epinv.f'
c      include 'scale.f'
      double precision s,t,psq,qsq
c      double precision den
c      double complex qlI4
      double complex F31m,F42meF
c      integer ep
c      den=s*t-psq*qsq
c      F42me=czip
c      do ep=-2,0
c      F42me=F42me
c     . +den*epinv**(-ep)
c     . *qlI4(0d0,psq,0d0,qsq,s,t,0d0,0d0,0d0,0d0,musq,ep)
c      enddo

c--- NOTE: checked on 8/30/09 that this agrees with the expression above
      F42me=2d0*(F31m(s)+F31m(t)-F31m(psq)-F31m(qsq)
     .          +F42meF(psq,qsq,s,t))

      return
      end


!----------------------------------------------------------------------*
! SUBROUTINE SGPL                                                      *
! Authors: Daniel van Kraalingen                                       *
! Date   : 15-Sept-1994, Version: 1.0                                  *
! Purpose: This subroutine calculates assimilation at a single depth   *
!          in the canopy                                               *
!                                                                      *
! FORMAL PARAMETERS:  (I=input,O=output,C=control,IN=init,T=time)      *
! name   type meaning                                     units  class *
! ----   ---- -------                                     -----  ----- *
! CSLV    R4  Scattering coefficient of leaves for visible   -      I  *
!             radiation (PAR)                                          *
! AMAX1   R4  Assimilation rate at light saturation       kg CO2/   I  *
!                                                        ha leaf/h     *
! EFF1    R4  Initial light use efficiency               kg CO2/J/  I  *
!                                                       (ha/h/m2/s)    *
! ECPDF   R4  Extinction coefficient for diffuse light              I  *
! GAI     R4  Total green area                             ha/ha    I  *
! GAID    R4  Green area index above selected height       ha/ha    I  *
! SINB    R4  Sine of solar height                           -      I  *
! RDPDR   R4  Instantaneous flux of direct photo-          W/m2     O  *
!             synthetically active radiation (PAR)                     *
! RDPDF   R4  Instantaneous flux of diffuse photo-         W/m2     O  *
!             synthetically active irradiation (PAR)                   *
! GPL     R4  Instantaneous assimilation rate of          kg CO2/   O  *
!             leaves at depth GAI                        ha leaf/h     *
! RAPL    R4  Absorbed radiation at depth GAI            W/m2 leaf  O  *
!                                                                      *
! Fatal error checks: none                                             *
! Warnings          : none                                             *
! Subprograms called: SRDPRF                                           *
! File usage        : none                                             *
!----------------------------------------------------------------------*

      SUBROUTINE SGPL (CSLV , AMAX1, EFF1 ,ECPDF, GAI, GAID, SINB, &
                       RDPDR, RDPDF, GPL  , RAPL)
      IMPLICIT NONE

!     Formal parameters

      REAL CSLV,AMAX1,EFF1,ECPDF,GAI,GAID,SINB,RDPDR,RDPDF

!     Local parameters
      REAL AMAX2, EFF2

!     Gauss parameters
      INTEGER IGSN
      PARAMETER (IGSN=3)
      REAL GSX(IGSN), GSW(IGSN)

!     Miscellaneous
      REAL RAPSHL, RAPPPL, RAPSLL, FSLLA
      REAL GPSHL , GPSLL , TMPR1 , GPL  ,RAPL
      INTEGER I1

      SAVE         ! TAOLI

!     Gauss weights for three point Gauss
      DATA GSX /0.112702, 0.500000, 0.887298/
      DATA GSW /0.277778, 0.444444, 0.277778/

!     Selection of depth of canopy, canopy assimilation is set to zero

      CALL SRDPRF (GAID,CSLV,SINB,ECPDF,RDPDR,RDPDF, &
                   RAPSHL,RAPPPL,FSLLA)

!     Get photosynthesis parameters from user routine
      CALL GPPARGET (GAI,GAID,AMAX1,EFF1,AMAX2,EFF2)

!     Assimilation of shaded leaf area
      IF (AMAX2.GT.0.) THEN
         GPSHL = AMAX2 * (1.-EXP (-RAPSHL*EFF2/AMAX2))
      ELSE
         GPSHL = 0.
      END IF

!     Assimilation of sunlit leaf area

      GPSLL  = 0.
      RAPSLL = 0.
      DO I1=1,IGSN
         TMPR1 = RAPSHL + RAPPPL * GSX(I1)
         IF (AMAX2.GT.0.) THEN
            GPSLL = GPSLL + AMAX2 * (1.-EXP(-TMPR1*EFF2/AMAX2)) * GSW(I1)
         ELSE
            GPSLL = 0.
         END IF
         RAPSLL = RAPSLL + TMPR1 * GSW(I1)
      END DO

!     Local assimilation rate (GPL) and rate of
!     absorption of PAR by canopy (RAPL)
      GPL  = FSLLA * GPSLL  + (1.-FSLLA) * GPSHL
      RAPL = FSLLA * RAPSLL + (1.-FSLLA) * RAPSHL

      RETURN
      END


c  tpsplinb -- dmc 20 Jan 1999
c
c  set up coefficients for bicubic spline with following BC's:
c  * 1st (x) dimension BCs under user control
c  * derivatives periodic in second & third coordinates
c
      subroutine tpsplinb(x,inx,th,inth,ph,inph,fspl,inf4,inf5,
     >                    ibcxmin,bcxmin,ibcxmax,bcxmax,inb1,
     >                    wk,nwk,ilinx,ilinth,ilinph,ier)
c
      implicit NONE
      integer inx,inth,inph,inf4,inf5,nwk,inb1
      real x(inx),th(inth),ph(inph)
      real fspl(4,4,4,inf4,inf5,inph),wk(nwk)
      integer ibcxmin,ibcxmax
      real bcxmin(inb1,inph),bcxmax(inb1,inph)
      integer ilinx,ilinth,ilinph,ier
c
c  input:
c    x(1...inx) -- abscissae, first dimension of data
c   th(1...inth) -- abscissae, second (periodic) dimension of data
c   ph(1...inph) -- abscissae, third (periodic) dimension of data
c   fspl(1,1,1,1..inx,1..inth,1..inph) -- function values
c   inf4 -- fspl dimensioning, inf4.ge.inx required.
c   inf5 -- fspl dimensioning, inf5.ge.inth required.
c
c  boundary conditions input:
c   ibcxmin -- indicator for boundary condition at x(1):
c    bcxmin(...) -- boundary condition data
c     =0 -- use "not a knot", bcxmin(...) ignored
c     =1 -- match slope, specified at x(1),th(ith),ph(iph) by bcxmin(ith,iph)
c     =2 -- match 2nd derivative, specified at x(1),th(ith),ph(iph)
c           by bcxmin(ith,iph
c     =3 -- boundary condition is slope=0 (df/dx=0) at x(1), all th(j)
c     =4 -- boundary condition is d2f/dx2=0 at x(1), all th(j)
c     =5 -- match 1st derivative to 1st divided difference
c     =6 -- match 2nd derivative to 2nd divided difference
c     =7 -- match 3rd derivative to 3rd divided difference
c           (for more detailed definition of BCs 5-7, see the
c           comments of subroutine mkspline)
c   NOTE bcxmin(...) referenced ONLY if ibcxmin=1 or ibcxmin=2
c
c   ibcxmax -- indicator for boundary condition at x(nx):
c    bcxmax(...) -- boundary condition data
c     (interpolation as with ibcxmin, bcxmin)
c
c  output:
c   fspl(*,*,*,1..inx,1..inth,1..inph) -- bicubic spline coeffs (4x4)
c   ...fspl(1,1,1,*,*,*) is not replaced.
c
c   ilinx -- =1 on output if x(inx) pts are nearly evenly spaced (tol=1e-3)
c   ilinth-- =1 on output if th(inth) evenly spaced (tol=1e-3)
c   ilinph-- =1 on output if ph(inph) evenly spaced (tol=1e-3)
c
c   ier -- completion code, 0 for normal
c
c  workspace:
c   wk -- must be at least 5*max(inx,inth,inph) large
c  nwk -- size of workspace
c
c---------------------------------
c  compute tricubic spline of 3d function, given values at the
c  grid crossing points, f(1,1,1,i,j,k)=f(x(i),th(j),ph(k)).
c
c  on evaluation:  for point x btw x(i) and x(i+1), dx=x-x(i)
c                       and th btw th(j) and th(j+1), dt=th-th(j),
c                       and ph btw ph(k) and ph(k+1), dp=ph-ph(k),
c
c      spline =
c        f(1,1,1,i,j,k)+dx*f(2,1,1,i,j,k)+dx2*f(3,1,1,i,j,k)+dx3*f(4,1,1,i,j,k)
c  +dt*(f(1,2,1,i,j,k)+dx*f(2,2,1,i,j,k)+dx2*f(3,2,1,i,j,k)+dx3*f(4,2,1,i,j,k))
c +dt2*(f(1,3,1,i,j,k)+dx*f(2,3,1,i,j,k)+dx2*f(3,3,1,i,j,k)+dx3*f(4,3,1,i,j,k))
c +dt3*(f(1,4,1,i,j,k)+dx*f(2,4,1,i,j,k)+dx2*f(3,4,1,i,j,k)+dx3*f(4,4,1,i,j,k))
c        +dp*(
c        f(1,1,2,i,j,k)+dx*f(2,1,2,i,j,k)+dx2*f(3,1,2,i,j,k)+dx3*f(4,1,2,i,j,k)
c  +dt*(f(1,2,2,i,j,k)+dx*f(2,2,2,i,j,k)+dx2*f(3,2,2,i,j,k)+dx3*f(4,2,2,i,j,k))
c +dt2*(f(1,3,2,i,j,k)+dx*f(2,3,2,i,j,k)+dx2*f(3,3,2,i,j,k)+dx3*f(4,3,2,i,j,k))
c +dt3*(f(1,4,2,i,j,k)+dx*f(2,4,2,i,j,k)+dx2*f(3,4,2,i,j,k)+dx3*f(4,4,2,i,j,k)))
c        +dp2*(
c        f(1,1,3,i,j,k)+dx*f(2,1,3,i,j,k)+dx2*f(3,1,3,i,j,k)+dx3*f(4,1,3,i,j,k)
c  +dt*(f(1,2,3,i,j,k)+dx*f(2,2,3,i,j,k)+dx2*f(3,2,3,i,j,k)+dx3*f(4,2,3,i,j,k))
c +dt2*(f(1,3,3,i,j,k)+dx*f(2,3,3,i,j,k)+dx2*f(3,3,3,i,j,k)+dx3*f(4,3,3,i,j,k))
c +dt3*(f(1,4,3,i,j,k)+dx*f(2,4,3,i,j,k)+dx2*f(3,4,3,i,j,k)+dx3*f(4,4,3,i,j,k)))
c        +dp3*(
c        f(1,1,4,i,j,k)+dx*f(2,1,4,i,j,k)+dx2*f(3,1,4,i,j,k)+dx3*f(4,1,4,i,j,k)
c  +dt*(f(1,2,4,i,j,k)+dx*f(2,2,4,i,j,k)+dx2*f(3,2,4,i,j,k)+dx3*f(4,2,4,i,j,k))
c +dt2*(f(1,3,4,i,j,k)+dx*f(2,3,4,i,j,k)+dx2*f(3,3,4,i,j,k)+dx3*f(4,3,4,i,j,k))
c +dt3*(f(1,4,4,i,j,k)+dx*f(2,4,4,i,j,k)+dx2*f(3,4,4,i,j,k)+dx3*f(4,4,4,i,j,k)))
c
c      where dx2=dx**2 and dx3=dx**3.
c      where dt2=dt**2 and dt3=dt**3.
c      where dp2=dp**2 and dp3=dp**3.
c
c---------------------------------
      integer ierx,ierth,ierph
      real zdumx(inx)
c---------------------------------
c
      ier=0
      if(nwk.lt.5*max(inx,inth,inph)) then
         write(6,'('' ?tpsplinb:  workspace too small.'')')
         ier=1
      endif
      if(inx.lt.2) then
         write(6,'('' ?tpsplinb:  at least 2 x points required.'')')
         ier=1
      endif
      if(inth.lt.2) then
         write(6,'('' ?tpsplinb:  need at least 2 theta points.'')')
         ier=1
      endif
      if(inph.lt.2) then
         write(6,'('' ?tpsplinb:  need at least 2 phi points.'')')
         ier=1
      endif
c
      if((ibcxmin.eq.1).or.(ibcxmax.eq.1).or.(ibcxmin.eq.2).or.
     >   (ibcxmax.eq.2)) then
         if(inb1.lt.inth) then
            ier=1
            write(6,
     >'('' ?tpsplinb:  1st dim of bcxmin/max arrays .lt. inth'')')
         endif
      endif
c
      call ibc_ck(ibcxmin,'tpsplinb','xmin',0,7,ier)
      call ibc_ck(ibcxmax,'tpsplinb','xmax',0,7,ier)
c
c  check ilinx & x vector
c
      call splinck(x,inx,ilinx,1.0e-3,ierx)
      if(ierx.ne.0) ier=2
c
      if(ier.eq.2) then
         write(6,'('' ?tpsplinb:  x axis not strict ascending'')')
      endif
c
c  check ilinth & th vector
c
      call splinck(th,inth,ilinth,1.0e-3,ierth)
      if(ierth.ne.0) ier=3
c
      if(ier.eq.3) then
         write(6,'('' ?tpsplinb:  theta axis not strict ascending'')')
      endif
c
c  check ilinth & th vector
c
      call splinck(ph,inph,ilinph,1.0e-3,ierph)
      if(ierph.ne.0) ier=4
c
      if(ier.eq.4) then
         write(6,'('' ?tpsplinb:  phi axis not strict ascending'')')
      endif
c
      if(ier.ne.0) return
c
c------------------------------------
c
      call tcspline(x,inx,th,inth,ph,inph,fspl,inf4,inf5,
     >   ibcxmin,bcxmin,ibcxmax,bcxmax,inb1,
     >   -1,zdumx,-1,zdumx,inx,
     >   -1,zdumx,-1,zdumx,inx,
     >   wk,nwk,ilinx,ilinth,ilinph,ier)
c
      return
      end


*DECK R9LGMC
      FUNCTION R9LGMC (X)
C***BEGIN PROLOGUE  R9LGMC
C***SUBSIDIARY
C***PURPOSE  Compute the log Gamma correction factor so that
C            LOG(GAMMA(X)) = LOG(SQRT(2*PI)) + (X-.5)*LOG(X) - X
C            + R9LGMC(X).
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7E
C***TYPE      SINGLE PRECISION (R9LGMC-S, D9LGMC-D, C9LGMC-C)
C***KEYWORDS  COMPLETE GAMMA FUNCTION, CORRECTION TERM, FNLIB,
C             LOG GAMMA, LOGARITHM, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Compute the log gamma correction factor for X .GE. 10.0 so that
C  LOG (GAMMA(X)) = LOG(SQRT(2*PI)) + (X-.5)*LOG(X) - X + R9LGMC(X)
C
C Series for ALGM       on the interval  0.          to  1.00000D-02
C                                        with weighted error   3.40E-16
C                                         log weighted error  15.47
C                               significant figures required  14.39
C                                    decimal places required  15.86
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CSEVL, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770801  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900720  Routine changed from user-callable to subsidiary.  (WRB)
C***END PROLOGUE  R9LGMC
      DIMENSION ALGMCS(6)
      LOGICAL FIRST
      SAVE ALGMCS, NALGM, XBIG, XMAX, FIRST
      DATA ALGMCS( 1) /    .1666389480 45186E0 /
      DATA ALGMCS( 2) /   -.0000138494 817606E0 /
      DATA ALGMCS( 3) /    .0000000098 108256E0 /
      DATA ALGMCS( 4) /   -.0000000000 180912E0 /
      DATA ALGMCS( 5) /    .0000000000 000622E0 /
      DATA ALGMCS( 6) /   -.0000000000 000003E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  R9LGMC
      IF (FIRST) THEN
         NALGM = INITS (ALGMCS, 6, R1MACH(3))
         XBIG = 1.0/SQRT(R1MACH(3))
         XMAX = EXP (MIN(LOG(R1MACH(2)/12.0), -LOG(12.0*R1MACH(1))) )
      ENDIF
      FIRST = .FALSE.
C
      IF (X .LT. 10.0) CALL XERMSG ('SLATEC', 'R9LGMC',
     +   'X MUST BE GE 10', 1, 2)
      IF (X.GE.XMAX) GO TO 20
C
      R9LGMC = 1.0/(12.0*X)
      IF (X.LT.XBIG) R9LGMC = CSEVL (2.0*(10./X)**2-1., ALGMCS, NALGM)/X
      RETURN
C
 20   R9LGMC = 0.0
      CALL XERMSG ('SLATEC', 'R9LGMC', 'X SO BIG R9LGMC UNDERFLOWS', 2,
     +   1)
      RETURN
C
      END


c
c input:              * ****** **** ****** *******
      subroutine coda(y,jstart,jend,xnoise,xfactor,jcoda,r,jerr)
c output:                                          +++++ ++++
c
c  November 1989, trying to determine coda lengths
c  at UNR in a manner consistent with former practice.
c  Given the array Y; Fit an exponential on the samples
c  between JSTART and JEND.  Fit an exponential to RMS
c  estimates (window length NRMS) in this range.  Return
c  as JCODA the sample number at which this exponential
c  attains an amplitude twice XNOISE, the pre-event noise
c  estimate.  JERR = 0 if procedure works.  XFACTOR
c  defines the "end" of the coda.  The subroutine tries
c  to find the point at which the coda has fallen to a
c  level which is "xfactor" times the amplitude of the
c  pre-event noise.  Experimentation shows that good numbers
c  appear to be to compute the averages over 300 points
c  and to take the start of the coda for the calculation
c  to be well back of the S wave, and certainly back of
c  anyplace where the record is clipped.  For UNR, in order
c  to produce numbers similar to those obtained on the
c  PING system, it seems that XFACTOR should be about 6.
c
      real x(256),yy(256)
      real*4 y(*)
      nave = 300
      n = jend - jstart - 1
c     write(6,*) 'n = ',n
      if(n.lt.500)then
        jerr=-2
        return
      endif
c
      call rms(y,jstart + nave/2+1,nave,temp1)
      call rms(y,jend   - nave/2+1,nave,temp2)
      yy(1) = alog(temp1)
      yy(2) = alog(temp2)
      x(1) = float(jstart+nave/2+1)
      x(2) = float(jend-nave/2-1)
      noffs = nave/2 + 1
      nr = 2
      samps = float(jend-jstart-nave)
c     write(6,*) 'samps = ',samps
c
c  This many iterations seems to give enough stability
c
      do j=1,6
        dx = samps/float(2**(j))
        ncells = 2**j
        npercell = (n-nave)/ncells
        do k=1,2**(j-1)
          nr = nr+1
          index = jstart + noffs + (2*k-1)*npercell
          x(nr) = float(index)
          call rms(y,index,nave,temp)
          yy(nr) = alog(temp)
        enddo
      enddo
      call lstsqr(x,yy,nr,b,a,r)
      arg = xfactor*xnoise
      if(arg.le.0.)then
        write(6,*)' Cannot compute coda, arg not positive: ',arg
        return
      endif
      jcoda = int( (alog(arg) - b)/a )
      jerr = 0
      return
      end


    SUBROUTINE kep_silanczos(n,imax,its,ijob,v,bv,alpha,beta,theta,y,m)
    IMPLICIT NONE
    INTEGER :: n,imax,its,ijob,m
    DOUBLE PRECISION :: v,bv,alpha,beta,theta,y
!
    DIMENSION :: alpha(imax),theta(imax)
    DIMENSION :: beta(0:imax)
    DIMENSION :: y(IMAX,IMAX)
    DIMENSION :: v(n,imax+1)
    DIMENSION :: bv(n,0:imax+1)
!
!   Local arguments
    INTEGER :: i,j,k,info,seed
    DOUBLE PRECISION :: dtmp,sub,work
!
    DIMENSION :: sub(IMAX-1)
    DIMENSION :: work(2*IMAX-2)
!
!-----------------------------------------------------------------------
!   Initialize
    IF(its.EQ.1) THEN
        IF(ijob.EQ.1) THEN
            bv(:,0) = 0.0D0
!           bv(1):=random vector
            seed=1
            CALL kep_randnum(seed,n,bv(:,1))
            bv(:,1)=bv(:,1)*2.0D0-1.0D0
!           Return to the caller for matvec v(1):=B*bv(1) >>>>>>>>>>>>>>
            ijob=2
            RETURN
        END IF
!>>>>>>>Return from the caller after matvec v(1):=B*bv(1)
        IF(ijob.EQ.2) THEN
!          beta(0):=|| v(1) ||_B^(-1)
            CALL kep_innpro(n,v(:,1),bv(:,1),dtmp)
            IF(dtmp.LE.0.0D0) THEN
                WRITE(6,*) &
                & 'Subroutine kep_silanczos: Error in B^(-1)-inner product'
                WRITE(6,*) 'beta(0) =', dtmp
                STOP
            END IF
            beta(0)=DSQRT(dtmp)
            ijob=10
        END IF
    END IF
!
!-----------------------------------------------------------------------
!   Main loop
    DO j=its,its
        IF(ijob.EQ.10) THEN
!           Normalize
            v(:,j)=v(:,j)/beta(j-1)
            bv(:,j)=bv(:,j)/beta(j-1)
!           Return to the caller to solve linear equation >>>>>>>>>>>>>>
!               bv(j+1):=(A-sigma*B)^(-1)*v(j+1),
!               (A-sigma*B)*bv(j+1)=v(j+1) for bv(j+1)
            ijob=20
            RETURN
        END IF
!>>>>>>>Return from the caller after solving linear equation
        IF(ijob.EQ.20) THEN
!           Orthgonalize (Modified Gram-Schmidt)
!           bv(j+1):=bv(j+1)-B*v(j-1)*beta(j-1)
            bv(:,j+1)=bv(:,j+1)-bv(:,j-1)*beta(j-1)
!           alpha(j):=(v(j),bv(j+1))
            CALL kep_innpro(n,v(:,j),bv(:,j+1),dtmp)
            alpha(j)=dtmp
!           bv(j+1):=bv(j+1)-B*v(j)*alpha(j)
            bv(:,j+1)=bv(:,j+1)-bv(:,j)*alpha(j)
!           Fully reorthogonalize (Modified Gram-Schmidt)
            DO k=1,j
!               dtmp:=(v(k),bv(j+1))
                CALL kep_innpro(n,v(:,k),bv(:,j+1),dtmp)
!               bv(j+1):=bv(j+1)-BV(k)*dtmp
                bv(:,j+1)=bv(:,j+1)-bv(:,k)*dtmp
            END DO
!           alpha(j):=alpha(j)+dtmp
            alpha(j)=alpha(j)+dtmp
!           Return to the caller for matvec bv(j+1):=B*v(j) >>>>>>>>>>>>
            ijob=30
            RETURN
        END IF
!>>>>>>>Return from the caller after matvec bv(j+1):=B*v(j)
        IF(ijob.EQ.30) THEN
!           beta(j):=|| v(j+1) ||_B^(-1)
            CALL kep_innpro(n,v(:,j+1),bv(:,j+1),dtmp)
            IF(dtmp.LE.0.0D0) THEN
                WRITE(6,*) 'Subroutine kep_silanczos: Error in B^(-1)-inner product'
                WRITE(6,*) 'j =', j, ',  beta(j) =', dtmp
                STOP
            END IF
            beta(j)=DSQRT(dtmp)
!           Eigenpair of tridiagonal matrix by LAPACK
!           Skip computation when subspace is smaller than m
            IF(j.GE.m) THEN
                theta(1:j) = alpha(1:j)
                sub(1:j-1) = beta(1:j-1)
                CALL dstev('V',j,theta,sub,y,imax,work,info)
                IF(info.NE.0) THEN
                    WRITE(6,*) 'Subroutine kep_silanczos: Error in LAPACK dstev routine'
                    WRITE(6,*) 'j =', j, ',  info =', info
                    STOP
                END IF
            END IF
            ijob=10
        END IF
    END DO
!
!-----------------------------------------------------------------------
    its=its+1
    RETURN
    END SUBROUTINE kep_silanczos


      SUBROUTINE TGLOC06(NTARGS,TARGNAME,NPARMS,PARMS,SCPOS,
     *                KSYSNAT,KCENNAT,TARGPOS,LUERR,IERR)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C THIS ROUTINE IS PART OF THE TOSS TARGET LOCATION PACKAGE, TGLOC.  IT
C COMPUTES THE POSITION VECTOR(IN LOCAL ORBITAL COORDINATES) OF A
C HORIZON POINT DEFINED BY ITS ALTITUDE ABOVE THE EARTH AND ITS AZIMUTH
C IN LOCAL ORBITAL COORDINATES.  NOTE THAT A SPHERICAL EARTH IS ASSUMED.
C
C
C VAR     DIM    TYPE I/O DESCRIPTION
C ---     ---    ---- --- -----------
C
C NTARGS   1      I*4  I  NUMBER OF TARGETS TO BE PROCESSED.
C                         IF ZERO OR NEGATIVE, NONE ARE PROCESSED.
C
C TARGNAME NTARGS CH*16 I TARGET NAMES;  USED FOR ERROR MESSAGES,
C                         OTHERWISE THE NAME HAS NO SIGNIFICANCE.
C
C NPARMS   1      I*4  I  THE NUMBER OF PARAMETERS SUPPLIED IN THE PARMS
C                         ARRAY.  MUST BE 3 OR GREATER.
C
C PARMS           R*8  I  SAME AS TGLOC'S DESCRIPTION OF PARMS FOR
C    NPARMS,NTARGS        TARGET TYPE 6.
C
C SCPOS    3      R*8  I  THE SPACECRAFT POSITION VECTOR.  COORDINATE
C                         SYSTEM IS GEOCENTRIC, MEAN EARTH EQUATOR AND
C                         EQUINOX OF 1950.0;  IN KM.
C
C KSYSNAT  1      I*4  O  IDENTIFIES THE NATURAL COORDINATE SYSTEM'S
C                         ORIENTATION.  IS SET TO 12 TO INDICATE THE
C                         ORIENTATION IS LOCAL ORBITAL.
C
C KCENNAT  1      I*4  O  IDENTIFIES THE NATURAL COORDINATE SYSTEM'S
C                         ORIGIN.  IS SET TO 3 TO INDICATE THE ORIGIN IS
C                         AT THE SPACECRAFT; IE, AT SCPOS.
C
C TARGPOS 3,NTARGS R*8 O  TARGPOS(-,I) IS THE POSITION VECTOR OF THE
C                         I'TH TARGET.  IN GEOCENTRIC MEAN EARTH
C                         EQUATOR AND EQUINOX OF 1950.0;  IN KM.
C
C LUERR    1      I*4   I FORTRAN UNIT NUMBER FOR ERROR MESSAGES.
C                          = 0/NEGATIVE, NO MESSAGES POSSIBLE.
C
C IERR     1      I*4   O ERROR RETURN FLAG.
C                          = 0, NO ERROR.
C                          = OTHERWISE, ERROR.
C
C***********************************************************************
C
C BY C PETRUZZO, GSFC/742, 8/85.
C        MODIFIED....
C
C***********************************************************************
C
      REAL*8 PARMS(NPARMS,1),SCPOS(3),TARGPOS(3,1),TPOS(3)
      REAL*8 HALFPI/ 1.570796326794897D0 /
      CHARACTER*16 TARGNAME(1)
C
      IERR = 0
      KSYSNAT = 12    ! ORIENTATION IS LOCAL ORBITAL
      KCENNAT = 3     ! ORIGIN IS AT THE S/C
      IF(NTARGS.LE.0) GO TO 9999
C
C GET TARGET POSITION VECTOR IN 'NATURAL' SYSTEM. SPHERICAL EARTH.
C
      REARTH = CONST(53)
      EFLAT =  CONST(59)
      RAD =    FNORM(SCPOS)     ! S/C DISTANCE FROM EARTH CENTER
C
      DO 1000 ITARG = 1,NTARGS
C
      CALL TGLOC06A(NPARMS,PARMS(1,ITARG),TARGNAME(ITARG),
     *         LUERR,IERR1)
      IF(IERR1.NE.0) THEN
        IERR = 1
        TARGPOS(1,ITARG) = 'ERROR'
        TARGPOS(2,ITARG) = 'ERROR'
        TARGPOS(3,ITARG) = 'ERROR'
        GO TO 1000
        END IF
C
      AZ =     PARMS(1,ITARG)
      ALT =    PARMS(2,ITARG)
      FLAT =   PARMS(3,ITARG)
      IF(FLAT.NE.0.D0) FLAT = EFLAT
C
C SPHERICAL EARTH
C
      IF(FLAT.EQ.0.D0) THEN
        SINEL = (REARTH+ALT)/RAD
        IF(SINEL.GE.0.D0 .AND. SINEL.LE.1.D0) THEN
          EL = HALFPI-DASIN( SINEL )  !ELEVATION IN LOCAL ORBITAL COORDS
          DIST = DSQRT( RAD**2 - (REARTH+ALT)**2 )  !DISTANCE TO HORIZON
          CALL XYZSPH(1,AZ,EL,DIST,TPOS,1.D0)
        ELSE
          IERR = 1
          TARGPOS(1,ITARG) = 'ERROR'
          TARGPOS(2,ITARG) = 'ERROR'
          TARGPOS(3,ITARG) = 'ERROR'
          IF(LUERR.GT.0) WRITE(LUERR,1001) RAD-REARTH,ALT
 1001     FORMAT(/,' TGLOC06 ERROR. S/C IS BELOW HORIZON ALTITUDE'/,
     *             '     S/C ALT=',G16.8,' HORIZON ALT=',G16.8/)
          GO TO 1000
          END IF
        END IF
C
C OBLATE EARTH
C
      IF(FLAT.NE.0.D0) THEN
        STOP 'TGLOC06.  ERROR END.  OBLATE EARTH NOT AVAILABLE.'
        END IF
C
      TARGPOS(1,ITARG) = TPOS(1)
      TARGPOS(2,ITARG) = TPOS(2)
      TARGPOS(3,ITARG) = TPOS(3)
C
 1000 CONTINUE
C
 9999 CONTINUE
      RETURN
      END


module module_constants
  implicit none

! Calculation details
  double precision, parameter                 :: kb = 3.1668114d-6
  double precision, parameter                 :: ha2eV = 27.21d0
  double precision, parameter                 :: eV2ha = 1.0d0/27.21d0
  double precision, parameter                 :: ang2bohr = 1.889725989d0
  double precision, parameter                 :: pi = 3.14159265359d0
  double precision, parameter                 :: hardness(1:18) = (/ &
                                                                  0.236306505d0, &
                                                                  0.461040059d0, &
                                                                  0.087269386d0, &
                                                                  0.128511577d0, &
                                                                  0.169753767d0, &
                                                                  0.210988607d0, &
                                                                  0.245586182d0, &
                                                                  0.293472988d0, &
                                                                  0.334674752d0, &
                                                                  0.375975744d0, &
                                                                  0.089823594d0, &
                                                                  0.110790151d0, &
                                                                  0.131749357d0, &
                                                                  0.152704888d0, &
                                                                  0.173678795d0, &
                                                                  0.194634326d0, &
                                                                  0.215589857d0, &
                                                                  0.236552738d0 /)

contains

!#############################################
!#             Get Core Charge
!#############################################
subroutine coreq(El,Q)
  implicit none
  character(len=2), intent(in)                :: El
  integer, intent(out)                        :: Q

  if(El == 'H')then
    Q = 1
  elseif(El == 'He')then
    Q = 2
  elseif(El == 'Li')then
    Q = 3
  elseif(El == 'Be')then
    Q = 4
  elseif(El == 'B')then
    Q = 5
  elseif(El == 'C')then
    Q = 6
  elseif(El == 'N')then
    Q = 7
  elseif(El == 'O')then
    Q = 8
  elseif(El == 'F')then
    Q = 9
  elseif(El == 'Ne')then
    Q = 10
  elseif(El == 'Na')then
    Q = 11
  elseif(El == 'Mg')then
    Q = 12
  elseif(El == 'Al')then
    Q = 13
  elseif(El == 'Si')then
    Q = 14
  elseif(El == 'P')then
    Q = 15
  elseif(El == 'S')then
    Q = 16
  elseif(El == 'Cl')then
    Q = 17
  elseif(El == 'Ar')then
    Q = 18
  else
    write(*,*) "  !Error: Element ", El, " not found!"
  endif

end subroutine coreq

!#############################################
!#            Get Atomic Radius
!#############################################
subroutine arad(El,Rad)
  implicit none
  character, intent(in)                       :: El
  double precision, intent(out)               :: Rad

  if(El == 'H')then
    Rad = 1.0015547741d0
  elseif(El == 'He')then
    Rad = 0.585815056d0
  elseif(El == 'Li')then
    Rad = 3.155842401d0
  elseif(El == 'Be')then
    Rad = 2.116493107d0
  elseif(El == 'B')then
    Rad = 1.64406161d0
  elseif(El == 'C')then
    Rad = 1.266116412d0
  elseif(El == 'N')then
    Rad = 1.058246554d0
  elseif(El == 'O')then
    Rad = 0.907068475d0
  elseif(El == 'F')then
    Rad = 0.793684915d0
  elseif(El == 'Ne')then
    Rad = 0.718095876d0
  elseif(El == 'Na')then
    Rad = 3.5904796544504d0
  elseif(El == 'Mg')then
    Rad = 2.7401028941858d0
  elseif(El == 'Al')then
    Rad = 2.2298768380271d0
  elseif(El == 'Si')then
    Rad = 2.0975960086526d0
  elseif(El == 'P')then
    Rad = 1.8519316112428d0
  elseif(El == 'S')then
    Rad = 1.6629589978507d0
  elseif(El == 'Cl')then
    Rad = 1.4928836457978d0
  elseif(El == 'Ar')then
    Rad = 1.3417055550841d0
  else
    write(*,*) "  !Error: Element ", El, " not found!"
  endif

end subroutine arad

end module module_constants


  !$omp parallel private(ii , jj, r, ind, tmp_a, tmp )&
  !$omp default( shared )
  !$omp do schedule( dynamic )
  DO jj=1,np ! The packmat (Sij) needs to be in column order for lapack's SPPTRF.
     DO ii=jj,np
        ind=(jj-1)*(np+1)+ii-jj+1-(jj*(jj-1))/2
        if ( ii == jj ) THEN
           Sij(ind,:)=Sii(ii,:)
        ELSE
           r=SQRT ( (y( iy(ii) )-y( iy(jj) ))**2+( z(iz(ii)) - z( iz(jj) ))**2 )
           IF ( CoefExp /=0. ) THEN
              tmp_a=-1*coef_a*(2.*r/(z(iz(ii))+z(iz(jj))))**coefExp
           ENDIF
           IF ( tmp_b==0. ) THEN
              tmp=(tmp_a*2*r/(u(ii)+u(jj)))*f
           ELSE
              tmp=(tmp_a*r)*SQRT(f2/((u(ii)+u(jj))/2.)**2+tmp_b)
           ENDIF
           Sij(ind,:)=EXP(tmp)*Sii_sqrt(ii,:)*Sii_sqrt(jj,:)
        ENDIF
     ENDDO
  ENDDO
  !$omp end do
  !$omp end parallel
  !print *, 'end coh'


! { dg-do compile }
! { dg-options "-ffrontend-optimize -fdump-tree-original" }
! PR 69154 - inlined matmul used to cause an ICE inside a WHERE.
MODULE m_numeric_tools
 INTEGER, PARAMETER :: dp=8
CONTAINS
subroutine llsfit_svd(xx,yy,sigma,nfuncs,funcs,chisq,par,var,cov,info)
 real(dp),intent(in) :: xx(:),yy(:),sigma(:)
 real(dp),dimension(SIZE(xx)) :: bb,sigm1
 real(dp) :: tmp(nfuncs)
 real(dp),allocatable :: work(:),Vt(:,:),U(:,:),S(:)
 real(dp),dimension(3,3) :: a, b, c
 WHERE (S>TOL_*MAXVAL(S))
  tmp=MATMUL(bb,U)/S
 END WHERE
 call random_number(a)
 call random_number(b)
 c = matmul(a,b)
end subroutine llsfit_svd

END MODULE m_numeric_tools
! { dg-final { scan-tree-dump-times "matmul_r8" 1 "original" } }


! This subroutine is used to caculate Hamiltonian for
! ribbon system .
! with magnetic field along x direction

! History
!        4/15/2010 by Quansheng Wu
  subroutine ham_ribbon_b(bmag,k,Hamk_ribbon)

     use para
     implicit none

! loop index
     integer :: i1,j1,i2,j2

! wave vector in 2d
     real(Dp), intent(in) :: k
     real(dp), intent(in) :: bmag

! Hamiltonian of slab system
     complex(Dp),intent(out) ::Hamk_ribbon(Num_wann*nslab1*nslab2,Num_wann*nslab1*nslab2)

     complex(Dp) :: Hij(Num_wann,Num_wann)

     integer :: ir

     integer :: ia, ib, ic
     integer :: new_ia, new_ib, new_ic

     real(dp) :: kdotr
     real(dp) :: phase
     complex(dp) :: ratio
     complex(dp) :: fac

     real(dp) :: xyz1(3)
     real(dp) :: xyz2(3)

     Hamk_ribbon=0.0d0

     ! i1,j1 row index
     do i1=1,nslab1
     do j1=1,nslab2

     ! i2,j2 column index
     do i2=1,nslab1
     do j2=1,nslab2

        Hij= zzero

        ! summation over R
        do ir=1, nrpts
           ia= irvec(1, ir)
           ib= irvec(2, ir)
           ic= irvec(3, ir)
           new_ia= ia
           new_ib= ib
           new_ic= ic

           xyz1(1)= 0
           xyz1(2)= dble(i1)
           xyz1(3)= dble(j1)

           xyz2(1)= dble(ia)
           xyz2(2)= dble(i2)
           xyz2(3)= dble(j2)

           ! B along x direction
          !phase= Bmag*(xyz2(3)+xyz1(3))*(xyz2(2)-xyz1(2))/2d0
          !fac= cos(phase)+ zi*sin(phase)

           ! B along z direction
           phase=-Bmag*(xyz2(3)+xyz1(3))*(xyz2(1)-xyz1(1))/2d0
           fac= cos(phase)+ zi*sin(phase)

           kdotr= k*real(new_ia)
           ratio= cos(2d0*pi*kdotr)+ zi*sin(2d0*pi*kdotr)
           if (new_ib.eq.i2-i1.and.new_ic.eq.j2-j1)then
              Hij= Hij+ Hmnr(:, :, ir)/real(ndegen(ir))*fac*ratio
           endif

        enddo

       if (abs(i2-i1).le.ijmax.and.abs(j2-j1).le.ijmax)then
         Hamk_ribbon((i1-1)*nslab2*Num_wann+(j1-1)*Num_wann+1: &
                     (i1-1)*nslab2*Num_wann+(j1-1)*Num_wann+Num_wann,&
                     (i2-1)*nslab2*Num_wann+(j2-1)*Num_wann+1: &
                     (i2-1)*nslab2*Num_wann+(j2-1)*Num_wann+Num_wann )&
         = Hij

       endif

     enddo
     enddo
     enddo
     enddo

  return
  end


      subroutine compute_jsxx(n_PHI2,n_PI2,n_U,n_a2,Nx,res)
      implicit none
      integer i
      integer Nx
      real*8 n_PHI2(Nx)
      real*8 n_PI2(Nx)
      real*8 n_U(Nx)
      real*8 n_a2(Nx)
      real*8 res(Nx)
      real*8 qb
      do i=1, Nx, 1
      qb = 0.5000000000000000D0 * n_PI2(i) + 0.5000000000000000D0 * n_PH
     #I2(i) - 0.5000000000000000D0 * n_a2(i) * n_U(i)
      res(i)=qb
      end do
      END