!*==sgejsv.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b SGEJSV
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download SGEJSV + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE SGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP,
!                          M, N, A, LDA, SVA, U, LDU, V, LDV,
!                          WORK, LWORK, IWORK, INFO )
!
!       .. Scalar Arguments ..
!       IMPLICIT    NONE
!       INTEGER     INFO, LDA, LDU, LDV, LWORK, M, N
!       ..
!       .. Array Arguments ..
!       REAL        A( LDA, * ), SVA( N ), U( LDU, * ), V( LDV, * ),
!      $            WORK( LWORK )
!       INTEGER     IWORK( * )
!       CHARACTER*1 JOBA, JOBP, JOBR, JOBT, JOBU, JOBV
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> SGEJSV computes the singular value decomposition (SVD) of a real M-by-N
!> matrix [A], where M >= N. The SVD of [A] is written as
!>
!>              [A] = [U] * [SIGMA] * [V]^t,
!>
!> where [SIGMA] is an N-by-N (M-by-N) matrix which is zero except for its N
!> diagonal elements, [U] is an M-by-N (or M-by-M) orthonormal matrix, and
!> [V] is an N-by-N orthogonal matrix. The diagonal elements of [SIGMA] are
!> the singular values of [A]. The columns of [U] and [V] are the left and
!> the right singular vectors of [A], respectively. The matrices [U] and [V]
!> are computed and stored in the arrays U and V, respectively. The diagonal
!> of [SIGMA] is computed and stored in the array SVA.
!> SGEJSV can sometimes compute tiny singular values and their singular vectors much
!> more accurately than other SVD routines, see below under Further Details.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] JOBA
!> \verbatim
!>          JOBA is CHARACTER*1
!>         Specifies the level of accuracy:
!>       = 'C': This option works well (high relative accuracy) if A = B * D,
!>              with well-conditioned B and arbitrary diagonal matrix D.
!>              The accuracy cannot be spoiled by COLUMN scaling. The
!>              accuracy of the computed output depends on the condition of
!>              B, and the procedure aims at the best theoretical accuracy.
!>              The relative error max_{i=1:N}|d sigma_i| / sigma_i is
!>              bounded by f(M,N)*epsilon* cond(B), independent of D.
!>              The input matrix is preprocessed with the QRF with column
!>              pivoting. This initial preprocessing and preconditioning by
!>              a rank revealing QR factorization is common for all values of
!>              JOBA. Additional actions are specified as follows:
!>       = 'E': Computation as with 'C' with an additional estimate of the
!>              condition number of B. It provides a realistic error bound.
!>       = 'F': If A = D1 * C * D2 with ill-conditioned diagonal scalings
!>              D1, D2, and well-conditioned matrix C, this option gives
!>              higher accuracy than the 'C' option. If the structure of the
!>              input matrix is not known, and relative accuracy is
!>              desirable, then this option is advisable. The input matrix A
!>              is preprocessed with QR factorization with FULL (row and
!>              column) pivoting.
!>       = 'G': Computation as with 'F' with an additional estimate of the
!>              condition number of B, where A=D*B. If A has heavily weighted
!>              rows, then using this condition number gives too pessimistic
!>              error bound.
!>       = 'A': Small singular values are the noise and the matrix is treated
!>              as numerically rank deficient. The error in the computed
!>              singular values is bounded by f(m,n)*epsilon*||A||.
!>              The computed SVD A = U * S * V^t restores A up to
!>              f(m,n)*epsilon*||A||.
!>              This gives the procedure the licence to discard (set to zero)
!>              all singular values below N*epsilon*||A||.
!>       = 'R': Similar as in 'A'. Rank revealing property of the initial
!>              QR factorization is used do reveal (using triangular factor)
!>              a gap sigma_{r+1} < epsilon * sigma_r in which case the
!>              numerical RANK is declared to be r. The SVD is computed with
!>              absolute error bounds, but more accurately than with 'A'.
!> \endverbatim
!>
!> \param[in] JOBU
!> \verbatim
!>          JOBU is CHARACTER*1
!>         Specifies whether to compute the columns of U:
!>       = 'U': N columns of U are returned in the array U.
!>       = 'F': full set of M left sing. vectors is returned in the array U.
!>       = 'W': U may be used as workspace of length M*N. See the description
!>              of U.
!>       = 'N': U is not computed.
!> \endverbatim
!>
!> \param[in] JOBV
!> \verbatim
!>          JOBV is CHARACTER*1
!>         Specifies whether to compute the matrix V:
!>       = 'V': N columns of V are returned in the array V; Jacobi rotations
!>              are not explicitly accumulated.
!>       = 'J': N columns of V are returned in the array V, but they are
!>              computed as the product of Jacobi rotations. This option is
!>              allowed only if JOBU .NE. 'N', i.e. in computing the full SVD.
!>       = 'W': V may be used as workspace of length N*N. See the description
!>              of V.
!>       = 'N': V is not computed.
!> \endverbatim
!>
!> \param[in] JOBR
!> \verbatim
!>          JOBR is CHARACTER*1
!>         Specifies the RANGE for the singular values. Issues the licence to
!>         set to zero small positive singular values if they are outside
!>         specified range. If A .NE. 0 is scaled so that the largest singular
!>         value of c*A is around SQRT(BIG), BIG=SLAMCH('O'), then JOBR issues
!>         the licence to kill columns of A whose norm in c*A is less than
!>         SQRT(SFMIN) (for JOBR = 'R'), or less than SMALL=SFMIN/EPSLN,
!>         where SFMIN=SLAMCH('S'), EPSLN=SLAMCH('E').
!>       = 'N': Do not kill small columns of c*A. This option assumes that
!>              BLAS and QR factorizations and triangular solvers are
!>              implemented to work in that range. If the condition of A
!>              is greater than BIG, use SGESVJ.
!>       = 'R': RESTRICTED range for sigma(c*A) is [SQRT(SFMIN), SQRT(BIG)]
!>              (roughly, as described above). This option is recommended.
!>                                             ===========================
!>         For computing the singular values in the FULL range [SFMIN,BIG]
!>         use SGESVJ.
!> \endverbatim
!>
!> \param[in] JOBT
!> \verbatim
!>          JOBT is CHARACTER*1
!>         If the matrix is square then the procedure may determine to use
!>         transposed A if A^t seems to be better with respect to convergence.
!>         If the matrix is not square, JOBT is ignored. This is subject to
!>         changes in the future.
!>         The decision is based on two values of entropy over the adjoint
!>         orbit of A^t * A. See the descriptions of WORK(6) and WORK(7).
!>       = 'T': transpose if entropy test indicates possibly faster
!>         convergence of Jacobi process if A^t is taken as input. If A is
!>         replaced with A^t, then the row pivoting is included automatically.
!>       = 'N': do not speculate.
!>         This option can be used to compute only the singular values, or the
!>         full SVD (U, SIGMA and V). For only one set of singular vectors
!>         (U or V), the caller should provide both U and V, as one of the
!>         matrices is used as workspace if the matrix A is transposed.
!>         The implementer can easily remove this constraint and make the
!>         code more complicated. See the descriptions of U and V.
!> \endverbatim
!>
!> \param[in] JOBP
!> \verbatim
!>          JOBP is CHARACTER*1
!>         Issues the licence to introduce structured perturbations to drown
!>         denormalized numbers. This licence should be active if the
!>         denormals are poorly implemented, causing slow computation,
!>         especially in cases of fast convergence (!). For details see [1,2].
!>         For the sake of simplicity, this perturbations are included only
!>         when the full SVD or only the singular values are requested. The
!>         implementer/user can easily add the perturbation for the cases of
!>         computing one set of singular vectors.
!>       = 'P': introduce perturbation
!>       = 'N': do not perturb
!> \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. M >= N >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!> \endverbatim
!>
!> \param[out] SVA
!> \verbatim
!>          SVA is REAL array, dimension (N)
!>          On exit,
!>          - For WORK(1)/WORK(2) = ONE: The singular values of A. During the
!>            computation SVA contains Euclidean column norms of the
!>            iterated matrices in the array A.
!>          - For WORK(1) .NE. WORK(2): The singular values of A are
!>            (WORK(1)/WORK(2)) * SVA(1:N). This factored form is used if
!>            sigma_max(A) overflows or if small singular values have been
!>            saved from underflow by scaling the input matrix A.
!>          - If JOBR='R' then some of the singular values may be returned
!>            as exact zeros obtained by "set to zero" because they are
!>            below the numerical rank threshold or are denormalized numbers.
!> \endverbatim
!>
!> \param[out] U
!> \verbatim
!>          U is REAL array, dimension ( LDU, N )
!>          If JOBU = 'U', then U contains on exit the M-by-N matrix of
!>                         the left singular vectors.
!>          If JOBU = 'F', then U contains on exit the M-by-M matrix of
!>                         the left singular vectors, including an ONB
!>                         of the orthogonal complement of the Range(A).
!>          If JOBU = 'W'  .AND. (JOBV = 'V' .AND. JOBT = 'T' .AND. M = N),
!>                         then U is used as workspace if the procedure
!>                         replaces A with A^t. In that case, [V] is computed
!>                         in U as left singular vectors of A^t and then
!>                         copied back to the V array. This 'W' option is just
!>                         a reminder to the caller that in this case U is
!>                         reserved as workspace of length N*N.
!>          If JOBU = 'N'  U is not referenced, unless JOBT='T'.
!> \endverbatim
!>
!> \param[in] LDU
!> \verbatim
!>          LDU is INTEGER
!>          The leading dimension of the array U,  LDU >= 1.
!>          IF  JOBU = 'U' or 'F' or 'W',  then LDU >= M.
!> \endverbatim
!>
!> \param[out] V
!> \verbatim
!>          V is REAL array, dimension ( LDV, N )
!>          If JOBV = 'V', 'J' then V contains on exit the N-by-N matrix of
!>                         the right singular vectors;
!>          If JOBV = 'W', AND (JOBU = 'U' AND JOBT = 'T' AND M = N),
!>                         then V is used as workspace if the pprocedure
!>                         replaces A with A^t. In that case, [U] is computed
!>                         in V as right singular vectors of A^t and then
!>                         copied back to the U array. This 'W' option is just
!>                         a reminder to the caller that in this case V is
!>                         reserved as workspace of length N*N.
!>          If JOBV = 'N'  V is not referenced, unless JOBT='T'.
!> \endverbatim
!>
!> \param[in] LDV
!> \verbatim
!>          LDV is INTEGER
!>          The leading dimension of the array V,  LDV >= 1.
!>          If JOBV = 'V' or 'J' or 'W', then LDV >= N.
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is REAL array, dimension (LWORK)
!>          On exit,
!>          WORK(1) = SCALE = WORK(2) / WORK(1) is the scaling factor such
!>                    that SCALE*SVA(1:N) are the computed singular values
!>                    of A. (See the description of SVA().)
!>          WORK(2) = See the description of WORK(1).
!>          WORK(3) = SCONDA is an estimate for the condition number of
!>                    column equilibrated A. (If JOBA = 'E' or 'G')
!>                    SCONDA is an estimate of SQRT(||(R^t * R)^(-1)||_1).
!>                    It is computed using SPOCON. It holds
!>                    N^(-1/4) * SCONDA <= ||R^(-1)||_2 <= N^(1/4) * SCONDA
!>                    where R is the triangular factor from the QRF of A.
!>                    However, if R is truncated and the numerical rank is
!>                    determined to be strictly smaller than N, SCONDA is
!>                    returned as -1, thus indicating that the smallest
!>                    singular values might be lost.
!>
!>          If full SVD is needed, the following two condition numbers are
!>          useful for the analysis of the algorithm. They are provided for
!>          a developer/implementer who is familiar with the details of
!>          the method.
!>
!>          WORK(4) = an estimate of the scaled condition number of the
!>                    triangular factor in the first QR factorization.
!>          WORK(5) = an estimate of the scaled condition number of the
!>                    triangular factor in the second QR factorization.
!>          The following two parameters are computed if JOBT = 'T'.
!>          They are provided for a developer/implementer who is familiar
!>          with the details of the method.
!>
!>          WORK(6) = the entropy of A^t*A :: this is the Shannon entropy
!>                    of diag(A^t*A) / Trace(A^t*A) taken as point in the
!>                    probability simplex.
!>          WORK(7) = the entropy of A*A^t.
!> \endverbatim
!>
!> \param[in] LWORK
!> \verbatim
!>          LWORK is INTEGER
!>          Length of WORK to confirm proper allocation of work space.
!>          LWORK depends on the job:
!>
!>          If only SIGMA is needed ( JOBU = 'N', JOBV = 'N' ) and
!>            -> .. no scaled condition estimate required (JOBE = 'N'):
!>               LWORK >= max(2*M+N,4*N+1,7). This is the minimal requirement.
!>               ->> For optimal performance (blocked code) the optimal value
!>               is LWORK >= max(2*M+N,3*N+(N+1)*NB,7). Here NB is the optimal
!>               block size for DGEQP3 and DGEQRF.
!>               In general, optimal LWORK is computed as
!>               LWORK >= max(2*M+N,N+LWORK(DGEQP3),N+LWORK(DGEQRF), 7).
!>            -> .. an estimate of the scaled condition number of A is
!>               required (JOBA='E', 'G'). In this case, LWORK is the maximum
!>               of the above and N*N+4*N, i.e. LWORK >= max(2*M+N,N*N+4*N,7).
!>               ->> For optimal performance (blocked code) the optimal value
!>               is LWORK >= max(2*M+N,3*N+(N+1)*NB, N*N+4*N, 7).
!>               In general, the optimal length LWORK is computed as
!>               LWORK >= max(2*M+N,N+LWORK(DGEQP3),N+LWORK(DGEQRF),
!>                                                     N+N*N+LWORK(DPOCON),7).
!>
!>          If SIGMA and the right singular vectors are needed (JOBV = 'V'),
!>            -> the minimal requirement is LWORK >= max(2*M+N,4*N+1,7).
!>            -> For optimal performance, LWORK >= max(2*M+N,3*N+(N+1)*NB,7),
!>               where NB is the optimal block size for DGEQP3, DGEQRF, DGELQ,
!>               DORMLQ. In general, the optimal length LWORK is computed as
!>               LWORK >= max(2*M+N,N+LWORK(DGEQP3), N+LWORK(DPOCON),
!>                       N+LWORK(DGELQ), 2*N+LWORK(DGEQRF), N+LWORK(DORMLQ)).
!>
!>          If SIGMA and the left singular vectors are needed
!>            -> the minimal requirement is LWORK >= max(2*M+N,4*N+1,7).
!>            -> For optimal performance:
!>               if JOBU = 'U' :: LWORK >= max(2*M+N,3*N+(N+1)*NB,7),
!>               if JOBU = 'F' :: LWORK >= max(2*M+N,3*N+(N+1)*NB,N+M*NB,7),
!>               where NB is the optimal block size for DGEQP3, DGEQRF, DORMQR.
!>               In general, the optimal length LWORK is computed as
!>               LWORK >= max(2*M+N,N+LWORK(DGEQP3),N+LWORK(DPOCON),
!>                        2*N+LWORK(DGEQRF), N+LWORK(DORMQR)).
!>               Here LWORK(DORMQR) equals N*NB (for JOBU = 'U') or
!>               M*NB (for JOBU = 'F').
!>
!>          If the full SVD is needed: (JOBU = 'U' or JOBU = 'F') and
!>            -> if JOBV = 'V'
!>               the minimal requirement is LWORK >= max(2*M+N,6*N+2*N*N).
!>            -> if JOBV = 'J' the minimal requirement is
!>               LWORK >= max(2*M+N, 4*N+N*N,2*N+N*N+6).
!>            -> For optimal performance, LWORK should be additionally
!>               larger than N+M*NB, where NB is the optimal block size
!>               for DORMQR.
!> \endverbatim
!>
!> \param[out] IWORK
!> \verbatim
!>          IWORK is INTEGER array, dimension (M+3*N).
!>          On exit,
!>          IWORK(1) = the numerical rank determined after the initial
!>                     QR factorization with pivoting. See the descriptions
!>                     of JOBA and JOBR.
!>          IWORK(2) = the number of the computed nonzero singular values
!>          IWORK(3) = if nonzero, a warning message:
!>                     If IWORK(3) = 1 then some of the column norms of A
!>                     were denormalized floats. The requested high accuracy
!>                     is not warranted by the data.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>           < 0:  if INFO = -i, then the i-th argument had an illegal value.
!>           = 0:  successful exit;
!>           > 0:  SGEJSV  did not converge in the maximal allowed number
!>                 of sweeps. The computed values may be inaccurate.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date June 2016
!
!> \ingroup realGEsing
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  SGEJSV implements a preconditioned Jacobi SVD algorithm. It uses SGEQP3,
!>  SGEQRF, and SGELQF as preprocessors and preconditioners. Optionally, an
!>  additional row pivoting can be used as a preprocessor, which in some
!>  cases results in much higher accuracy. An example is matrix A with the
!>  structure A = D1 * C * D2, where D1, D2 are arbitrarily ill-conditioned
!>  diagonal matrices and C is well-conditioned matrix. In that case, complete
!>  pivoting in the first QR factorizations provides accuracy dependent on the
!>  condition number of C, and independent of D1, D2. Such higher accuracy is
!>  not completely understood theoretically, but it works well in practice.
!>  Further, if A can be written as A = B*D, with well-conditioned B and some
!>  diagonal D, then the high accuracy is guaranteed, both theoretically and
!>  in software, independent of D. For more details see [1], [2].
!>     The computational range for the singular values can be the full range
!>  ( UNDERFLOW,OVERFLOW ), provided that the machine arithmetic and the BLAS
!>  & LAPACK routines called by SGEJSV are implemented to work in that range.
!>  If that is not the case, then the restriction for safe computation with
!>  the singular values in the range of normalized IEEE numbers is that the
!>  spectral condition number kappa(A)=sigma_max(A)/sigma_min(A) does not
!>  overflow. This code (SGEJSV) is best used in this restricted range,
!>  meaning that singular values of magnitude below ||A||_2 / SLAMCH('O') are
!>  returned as zeros. See JOBR for details on this.
!>     Further, this implementation is somewhat slower than the one described
!>  in [1,2] due to replacement of some non-LAPACK components, and because
!>  the choice of some tuning parameters in the iterative part (SGESVJ) is
!>  left to the implementer on a particular machine.
!>     The rank revealing QR factorization (in this code: SGEQP3) should be
!>  implemented as in [3]. We have a new version of SGEQP3 under development
!>  that is more robust than the current one in LAPACK, with a cleaner cut in
!>  rank deficient cases. It will be available in the SIGMA library [4].
!>  If M is much larger than N, it is obvious that the initial QRF with
!>  column pivoting can be preprocessed by the QRF without pivoting. That
!>  well known trick is not used in SGEJSV because in some cases heavy row
!>  weighting can be treated with complete pivoting. The overhead in cases
!>  M much larger than N is then only due to pivoting, but the benefits in
!>  terms of accuracy have prevailed. The implementer/user can incorporate
!>  this extra QRF step easily. The implementer can also improve data movement
!>  (matrix transpose, matrix copy, matrix transposed copy) - this
!>  implementation of SGEJSV uses only the simplest, naive data movement.
!> \endverbatim
!
!> \par Contributors:
!  ==================
!>
!>  Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)
!
!> \par References:
!  ================
!>
!> \verbatim
!>
!> [1] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm I.
!>     SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1322-1342.
!>     LAPACK Working note 169.
!> [2] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm II.
!>     SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1343-1362.
!>     LAPACK Working note 170.
!> [3] Z. Drmac and Z. Bujanovic: On the failure of rank-revealing QR
!>     factorization software - a case study.
!>     ACM Trans. Math. Softw. Vol. 35, No 2 (2008), pp. 1-28.
!>     LAPACK Working note 176.
!> [4] Z. Drmac: SIGMA - mathematical software library for accurate SVD, PSV,
!>     QSVD, (H,K)-SVD computations.
!>     Department of Mathematics, University of Zagreb, 2008.
!> \endverbatim
!
!>  \par Bugs, examples and comments:
!   =================================
!>
!>  Please report all bugs and send interesting examples and/or comments to
!>  drmac@math.hr. Thank you.
!>
!  =====================================================================
      SUBROUTINE SGEJSV(Joba,Jobu,Jobv,Jobr,Jobt,Jobp,M,N,A,Lda,Sva,U,  &
     &                  Ldu,V,Ldv,Work,Lwork,Iwork,Info)
!
!  -- LAPACK computational routine (version 3.7.1) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     June 2016
!
!     .. Scalar Arguments ..
      IMPLICIT NONE
!*--SGEJSV486
      INTEGER Info , Lda , Ldu , Ldv , Lwork , M , N
!     ..
!     .. Array Arguments ..
      REAL A(Lda,*) , Sva(N) , U(Ldu,*) , V(Ldv,*) , Work(Lwork)
      INTEGER Iwork(*)
      CHARACTER*1 Joba , Jobp , Jobr , Jobt , Jobu , Jobv
!     ..
!
!  ===========================================================================
!
!     .. Local Parameters ..
      REAL ZERO , ONE
      PARAMETER (ZERO=0.0E0,ONE=1.0E0)
!     ..
!     .. Local Scalars ..
      REAL aapp , aaqq , aatmax , aatmin , big , big1 , cond_ok ,       &
     &     condr1 , condr2 , entra , entrat , epsln , maxprj , scalem , &
     &     sconda , sfmin , small , temp1 , uscal1 , uscal2 , xsc
      INTEGER ierr , n1 , nr , numrank , p , q , warning
      LOGICAL almort , defr , errest , goscal , jracc , kill , lsvec ,  &
     &        l2aber , l2kill , l2pert , l2rank , l2tran , noscal ,     &
     &        rowpiv , rsvec , transp
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , ALOG , MAX , MIN , FLOAT , NINT , SIGN , SQRT
!     ..
!     .. External Functions ..
      REAL SLAMCH , SNRM2
      INTEGER ISAMAX
      LOGICAL LSAME
      EXTERNAL ISAMAX , LSAME , SLAMCH , SNRM2
!     ..
!     .. External Subroutines ..
      EXTERNAL SCOPY , SGELQF , SGEQP3 , SGEQRF , SLACPY , SLASCL ,     &
     &         SLASET , SLASSQ , SLASWP , SORGQR , SORMLQ , SORMQR ,    &
     &         SPOCON , SSCAL , SSWAP , STRSM , XERBLA
!
      EXTERNAL SGESVJ
!     ..
!
!     Test the input arguments
!
      lsvec = LSAME(Jobu,'U') .OR. LSAME(Jobu,'F')
      jracc = LSAME(Jobv,'J')
      rsvec = LSAME(Jobv,'V') .OR. jracc
      rowpiv = LSAME(Joba,'F') .OR. LSAME(Joba,'G')
      l2rank = LSAME(Joba,'R')
      l2aber = LSAME(Joba,'A')
      errest = LSAME(Joba,'E') .OR. LSAME(Joba,'G')
      l2tran = LSAME(Jobt,'T')
      l2kill = LSAME(Jobr,'R')
      defr = LSAME(Jobr,'N')
      l2pert = LSAME(Jobp,'P')
!
      IF ( .NOT.(rowpiv .OR. l2rank .OR. l2aber .OR. errest .OR.        &
     &     LSAME(Joba,'C')) ) THEN
         Info = -1
      ELSEIF ( .NOT.(lsvec .OR. LSAME(Jobu,'N') .OR. LSAME(Jobu,'W')) ) &
     &         THEN
         Info = -2
      ELSEIF ( .NOT.(rsvec .OR. LSAME(Jobv,'N') .OR. LSAME(Jobv,'W'))   &
     &         .OR. (jracc .AND. (.NOT.lsvec)) ) THEN
         Info = -3
      ELSEIF ( .NOT.(l2kill .OR. defr) ) THEN
         Info = -4
      ELSEIF ( .NOT.(l2tran .OR. LSAME(Jobt,'N')) ) THEN
         Info = -5
      ELSEIF ( .NOT.(l2pert .OR. LSAME(Jobp,'N')) ) THEN
         Info = -6
      ELSEIF ( M<0 ) THEN
         Info = -7
      ELSEIF ( (N<0) .OR. (N>M) ) THEN
         Info = -8
      ELSEIF ( Lda<M ) THEN
         Info = -10
      ELSEIF ( lsvec .AND. (Ldu<M) ) THEN
         Info = -13
      ELSEIF ( rsvec .AND. (Ldv<N) ) THEN
         Info = -15
      ELSEIF ( (.NOT.(lsvec .OR. rsvec .OR. errest) .AND.               &
     &         (Lwork<MAX(7,4*N+1,2*M+N))) .OR.                         &
     &         (.NOT.(lsvec .OR. rsvec) .AND. errest .AND.              &
     &         (Lwork<MAX(7,4*N+N*N,2*M+N))) .OR.                       &
     &         (lsvec .AND. (.NOT.rsvec) .AND.                          &
     &         (Lwork<MAX(7,2*M+N,4*N+1))) .OR.                         &
     &         (rsvec .AND. (.NOT.lsvec) .AND.                          &
     &         (Lwork<MAX(7,2*M+N,4*N+1))) .OR.                         &
     &         (lsvec .AND. rsvec .AND. (.NOT.jracc) .AND.              &
     &         (Lwork<MAX(2*M+N,6*N+2*N*N))) .OR.                       &
     &         (lsvec .AND. rsvec .AND. jracc .AND.                     &
     &         Lwork<MAX(2*M+N,4*N+N*N,2*N+N*N+6)) ) THEN
         Info = -17
      ELSE
!        #:)
         Info = 0
      ENDIF
!
      IF ( Info/=0 ) THEN
!       #:(
         CALL XERBLA('SGEJSV',-Info)
         RETURN
      ENDIF
!
!     Quick return for void matrix (Y3K safe)
! #:)
      IF ( (M==0) .OR. (N==0) ) THEN
         Iwork(1:3) = 0
         Work(1:7) = 0
         RETURN
      ENDIF
!
!     Determine whether the matrix U should be M x N or M x M
!
      IF ( lsvec ) THEN
         n1 = N
         IF ( LSAME(Jobu,'F') ) n1 = M
      ENDIF
!
!     Set numerical parameters
!
!!    NOTE: Make sure SLAMCH() does not fail on the target architecture.
!
      epsln = SLAMCH('Epsilon')
      sfmin = SLAMCH('SafeMinimum')
      small = sfmin/epsln
      big = SLAMCH('O')
!     BIG   = ONE / SFMIN
!
!     Initialize SVA(1:N) = diag( ||A e_i||_2 )_1^N
!
!(!)  If necessary, scale SVA() to protect the largest norm from
!     overflow. It is possible that this scaling pushes the smallest
!     column norm left from the underflow threshold (extreme case).
!
      scalem = ONE/SQRT(FLOAT(M)*FLOAT(N))
      noscal = .TRUE.
      goscal = .TRUE.
      DO p = 1 , N
         aapp = ZERO
         aaqq = ONE
         CALL SLASSQ(M,A(1,p),1,aapp,aaqq)
         IF ( aapp>big ) THEN
            Info = -9
            CALL XERBLA('SGEJSV',-Info)
            RETURN
         ENDIF
         aaqq = SQRT(aaqq)
         IF ( (aapp<(big/aaqq)) .AND. noscal ) THEN
            Sva(p) = aapp*aaqq
         ELSE
            noscal = .FALSE.
            Sva(p) = aapp*(aaqq*scalem)
            IF ( goscal ) THEN
               goscal = .FALSE.
               CALL SSCAL(p-1,scalem,Sva,1)
            ENDIF
         ENDIF
      ENDDO
!
      IF ( noscal ) scalem = ONE
!
      aapp = ZERO
      aaqq = big
      DO p = 1 , N
         aapp = MAX(aapp,Sva(p))
         IF ( Sva(p)/=ZERO ) aaqq = MIN(aaqq,Sva(p))
      ENDDO
!
!     Quick return for zero M x N matrix
! #:)
      IF ( aapp==ZERO ) THEN
         IF ( lsvec ) CALL SLASET('G',M,n1,ZERO,ONE,U,Ldu)
         IF ( rsvec ) CALL SLASET('G',N,N,ZERO,ONE,V,Ldv)
         Work(1) = ONE
         Work(2) = ONE
         IF ( errest ) Work(3) = ONE
         IF ( lsvec .AND. rsvec ) THEN
            Work(4) = ONE
            Work(5) = ONE
         ENDIF
         IF ( l2tran ) THEN
            Work(6) = ZERO
            Work(7) = ZERO
         ENDIF
         Iwork(1) = 0
         Iwork(2) = 0
         Iwork(3) = 0
         RETURN
      ENDIF
!
!     Issue warning if denormalized column norms detected. Override the
!     high relative accuracy request. Issue licence to kill columns
!     (set them to zero) whose norm is less than sigma_max / BIG (roughly).
! #:(
      warning = 0
      IF ( aaqq<=sfmin ) THEN
         l2rank = .TRUE.
         l2kill = .TRUE.
         warning = 1
      ENDIF
!
!     Quick return for one-column matrix
! #:)
      IF ( N==1 ) THEN
!
         IF ( lsvec ) THEN
            CALL SLASCL('G',0,0,Sva(1),scalem,M,1,A(1,1),Lda,ierr)
            CALL SLACPY('A',M,1,A,Lda,U,Ldu)
!           computing all M left singular vectors of the M x 1 matrix
            IF ( n1/=N ) THEN
               CALL SGEQRF(M,N,U,Ldu,Work,Work(N+1),Lwork-N,ierr)
               CALL SORGQR(M,n1,1,U,Ldu,Work,Work(N+1),Lwork-N,ierr)
               CALL SCOPY(M,A(1,1),1,U(1,1),1)
            ENDIF
         ENDIF
         IF ( rsvec ) V(1,1) = ONE
         IF ( Sva(1)<(big*scalem) ) THEN
            Sva(1) = Sva(1)/scalem
            scalem = ONE
         ENDIF
         Work(1) = ONE/scalem
         Work(2) = ONE
         IF ( Sva(1)/=ZERO ) THEN
            Iwork(1) = 1
            IF ( (Sva(1)/scalem)>=sfmin ) THEN
               Iwork(2) = 1
            ELSE
               Iwork(2) = 0
            ENDIF
         ELSE
            Iwork(1) = 0
            Iwork(2) = 0
         ENDIF
         Iwork(3) = 0
         IF ( errest ) Work(3) = ONE
         IF ( lsvec .AND. rsvec ) THEN
            Work(4) = ONE
            Work(5) = ONE
         ENDIF
         IF ( l2tran ) THEN
            Work(6) = ZERO
            Work(7) = ZERO
         ENDIF
         RETURN
!
      ENDIF
!
      transp = .FALSE.
      l2tran = l2tran .AND. (M==N)
!
      aatmax = -ONE
      aatmin = big
      IF ( rowpiv .OR. l2tran ) THEN
!
!     Compute the row norms, needed to determine row pivoting sequence
!     (in the case of heavily row weighted A, row pivoting is strongly
!     advised) and to collect information needed to compare the
!     structures of A * A^t and A^t * A (in the case L2TRAN.EQ..TRUE.).
!
         IF ( l2tran ) THEN
            DO p = 1 , M
               xsc = ZERO
               temp1 = ONE
               CALL SLASSQ(N,A(p,1),Lda,xsc,temp1)
!              SLASSQ gets both the ell_2 and the ell_infinity norm
!              in one pass through the vector
               Work(M+N+p) = xsc*scalem
               Work(N+p) = xsc*(scalem*SQRT(temp1))
               aatmax = MAX(aatmax,Work(N+p))
               IF ( Work(N+p)/=ZERO ) aatmin = MIN(aatmin,Work(N+p))
            ENDDO
         ELSE
            DO p = 1 , M
               Work(M+N+p) = scalem*ABS(A(p,ISAMAX(N,A(p,1),Lda)))
               aatmax = MAX(aatmax,Work(M+N+p))
               aatmin = MIN(aatmin,Work(M+N+p))
            ENDDO
         ENDIF
!
      ENDIF
!
!     For square matrix A try to determine whether A^t  would be  better
!     input for the preconditioned Jacobi SVD, with faster convergence.
!     The decision is based on an O(N) function of the vector of column
!     and row norms of A, based on the Shannon entropy. This should give
!     the right choice in most cases when the difference actually matters.
!     It may fail and pick the slower converging side.
!
      entra = ZERO
      entrat = ZERO
      IF ( l2tran ) THEN
!
         xsc = ZERO
         temp1 = ONE
         CALL SLASSQ(N,Sva,1,xsc,temp1)
         temp1 = ONE/temp1
!
         entra = ZERO
         DO p = 1 , N
            big1 = ((Sva(p)/xsc)**2)*temp1
            IF ( big1/=ZERO ) entra = entra + big1*ALOG(big1)
         ENDDO
         entra = -entra/ALOG(FLOAT(N))
!
!        Now, SVA().^2/Trace(A^t * A) is a point in the probability simplex.
!        It is derived from the diagonal of  A^t * A.  Do the same with the
!        diagonal of A * A^t, compute the entropy of the corresponding
!        probability distribution. Note that A * A^t and A^t * A have the
!        same trace.
!
         entrat = ZERO
         DO p = N + 1 , N + M
            big1 = ((Work(p)/xsc)**2)*temp1
            IF ( big1/=ZERO ) entrat = entrat + big1*ALOG(big1)
         ENDDO
         entrat = -entrat/ALOG(FLOAT(M))
!
!        Analyze the entropies and decide A or A^t. Smaller entropy
!        usually means better input for the algorithm.
!
         transp = (entrat<entra)
!
!        If A^t is better than A, transpose A.
!
         IF ( transp ) THEN
!           In an optimal implementation, this trivial transpose
!           should be replaced with faster transpose.
            DO p = 1 , N - 1
               DO q = p + 1 , N
                  temp1 = A(q,p)
                  A(q,p) = A(p,q)
                  A(p,q) = temp1
               ENDDO
            ENDDO
            DO p = 1 , N
               Work(M+N+p) = Sva(p)
               Sva(p) = Work(N+p)
            ENDDO
            temp1 = aapp
            aapp = aatmax
            aatmax = temp1
            temp1 = aaqq
            aaqq = aatmin
            aatmin = temp1
            kill = lsvec
            lsvec = rsvec
            rsvec = kill
            IF ( lsvec ) n1 = N
!
            rowpiv = .TRUE.
         ENDIF
!
      ENDIF
!     END IF L2TRAN
!
!     Scale the matrix so that its maximal singular value remains less
!     than SQRT(BIG) -- the matrix is scaled so that its maximal column
!     has Euclidean norm equal to SQRT(BIG/N). The only reason to keep
!     SQRT(BIG) instead of BIG is the fact that SGEJSV uses LAPACK and
!     BLAS routines that, in some implementations, are not capable of
!     working in the full interval [SFMIN,BIG] and that they may provoke
!     overflows in the intermediate results. If the singular values spread
!     from SFMIN to BIG, then SGESVJ will compute them. So, in that case,
!     one should use SGESVJ instead of SGEJSV.
!
      big1 = SQRT(big)
      temp1 = SQRT(big/FLOAT(N))
!
      CALL SLASCL('G',0,0,aapp,temp1,N,1,Sva,N,ierr)
      IF ( aaqq>(aapp*sfmin) ) THEN
         aaqq = (aaqq/aapp)*temp1
      ELSE
         aaqq = (aaqq*temp1)/aapp
      ENDIF
      temp1 = temp1*scalem
      CALL SLASCL('G',0,0,aapp,temp1,M,N,A,Lda,ierr)
!
!     To undo scaling at the end of this procedure, multiply the
!     computed singular values with USCAL2 / USCAL1.
!
      uscal1 = temp1
      uscal2 = aapp
!
      IF ( l2kill ) THEN
!        L2KILL enforces computation of nonzero singular values in
!        the restricted range of condition number of the initial A,
!        sigma_max(A) / sigma_min(A) approx. SQRT(BIG)/SQRT(SFMIN).
         xsc = SQRT(sfmin)
      ELSE
         xsc = small
!
!        Now, if the condition number of A is too big,
!        sigma_max(A) / sigma_min(A) .GT. SQRT(BIG/N) * EPSLN / SFMIN,
!        as a precaution measure, the full SVD is computed using SGESVJ
!        with accumulated Jacobi rotations. This provides numerically
!        more robust computation, at the cost of slightly increased run
!        time. Depending on the concrete implementation of BLAS and LAPACK
!        (i.e. how they behave in presence of extreme ill-conditioning) the
!        implementor may decide to remove this switch.
         IF ( (aaqq<SQRT(sfmin)) .AND. lsvec .AND. rsvec )              &
     &        jracc = .TRUE.
!
      ENDIF
      IF ( aaqq<xsc ) THEN
         DO p = 1 , N
            IF ( Sva(p)<xsc ) THEN
               CALL SLASET('A',M,1,ZERO,ZERO,A(1,p),Lda)
               Sva(p) = ZERO
            ENDIF
         ENDDO
      ENDIF
!
!     Preconditioning using QR factorization with pivoting
!
      IF ( rowpiv ) THEN
!        Optional row permutation (Bjoerck row pivoting):
!        A result by Cox and Higham shows that the Bjoerck's
!        row pivoting combined with standard column pivoting
!        has similar effect as Powell-Reid complete pivoting.
!        The ell-infinity norms of A are made nonincreasing.
         DO p = 1 , M - 1
            q = ISAMAX(M-p+1,Work(M+N+p),1) + p - 1
            Iwork(2*N+p) = q
            IF ( p/=q ) THEN
               temp1 = Work(M+N+p)
               Work(M+N+p) = Work(M+N+q)
               Work(M+N+q) = temp1
            ENDIF
         ENDDO
         CALL SLASWP(N,A,Lda,1,M-1,Iwork(2*N+1),1)
      ENDIF
!
!     End of the preparation phase (scaling, optional sorting and
!     transposing, optional flushing of small columns).
!
!     Preconditioning
!
!     If the full SVD is needed, the right singular vectors are computed
!     from a matrix equation, and for that we need theoretical analysis
!     of the Businger-Golub pivoting. So we use SGEQP3 as the first RR QRF.
!     In all other cases the first RR QRF can be chosen by other criteria
!     (eg speed by replacing global with restricted window pivoting, such
!     as in SGEQPX from TOMS # 782). Good results will be obtained using
!     SGEQPX with properly (!) chosen numerical parameters.
!     Any improvement of SGEQP3 improves overall performance of SGEJSV.
!
!     A * P1 = Q1 * [ R1^t 0]^t:
      DO p = 1 , N
!        .. all columns are free columns
         Iwork(p) = 0
      ENDDO
      CALL SGEQP3(M,N,A,Lda,Iwork,Work,Work(N+1),Lwork-N,ierr)
!
!     The upper triangular matrix R1 from the first QRF is inspected for
!     rank deficiency and possibilities for deflation, or possible
!     ill-conditioning. Depending on the user specified flag L2RANK,
!     the procedure explores possibilities to reduce the numerical
!     rank by inspecting the computed upper triangular factor. If
!     L2RANK or L2ABER are up, then SGEJSV will compute the SVD of
!     A + dA, where ||dA|| <= f(M,N)*EPSLN.
!
      nr = 1
      IF ( l2aber ) THEN
!        Standard absolute error bound suffices. All sigma_i with
!        sigma_i < N*EPSLN*||A|| are flushed to zero. This is an
!        aggressive enforcement of lower numerical rank by introducing a
!        backward error of the order of N*EPSLN*||A||.
         temp1 = SQRT(FLOAT(N))*epsln
         DO p = 2 , N
            IF ( ABS(A(p,p))<(temp1*ABS(A(1,1))) ) EXIT
            nr = nr + 1
         ENDDO
      ELSEIF ( l2rank ) THEN
!        .. similarly as above, only slightly more gentle (less aggressive).
!        Sudden drop on the diagonal of R1 is used as the criterion for
!        close-to-rank-deficient.
         temp1 = SQRT(sfmin)
         DO p = 2 , N
            IF ( (ABS(A(p,p))<(epsln*ABS(A(p-1,p-1)))) .OR.             &
     &           (ABS(A(p,p))<small) .OR.                               &
     &           (l2kill .AND. (ABS(A(p,p))<temp1)) ) EXIT
            nr = nr + 1
         ENDDO
!
      ELSE
!        The goal is high relative accuracy. However, if the matrix
!        has high scaled condition number the relative accuracy is in
!        general not feasible. Later on, a condition number estimator
!        will be deployed to estimate the scaled condition number.
!        Here we just remove the underflowed part of the triangular
!        factor. This prevents the situation in which the code is
!        working hard to get the accuracy not warranted by the data.
         temp1 = SQRT(sfmin)
         DO p = 2 , N
            IF ( (ABS(A(p,p))<small) .OR.                               &
     &           (l2kill .AND. (ABS(A(p,p))<temp1)) ) EXIT
            nr = nr + 1
         ENDDO
!
      ENDIF
!
      almort = .FALSE.
      IF ( nr==N ) THEN
         maxprj = ONE
         DO p = 2 , N
            temp1 = ABS(A(p,p))/Sva(Iwork(p))
            maxprj = MIN(maxprj,temp1)
         ENDDO
         IF ( maxprj**2>=ONE-FLOAT(N)*epsln ) almort = .TRUE.
      ENDIF
!
!
      sconda = -ONE
      condr1 = -ONE
      condr2 = -ONE
!
      IF ( errest ) THEN
         IF ( N==nr ) THEN
            IF ( rsvec ) THEN
!              .. V is available as workspace
               CALL SLACPY('U',N,N,A,Lda,V,Ldv)
               DO p = 1 , N
                  temp1 = Sva(Iwork(p))
                  CALL SSCAL(p,ONE/temp1,V(1,p),1)
               ENDDO
               CALL SPOCON('U',N,V,Ldv,ONE,temp1,Work(N+1),             &
     &                     Iwork(2*N+M+1),ierr)
            ELSEIF ( lsvec ) THEN
!              .. U is available as workspace
               CALL SLACPY('U',N,N,A,Lda,U,Ldu)
               DO p = 1 , N
                  temp1 = Sva(Iwork(p))
                  CALL SSCAL(p,ONE/temp1,U(1,p),1)
               ENDDO
               CALL SPOCON('U',N,U,Ldu,ONE,temp1,Work(N+1),             &
     &                     Iwork(2*N+M+1),ierr)
            ELSE
               CALL SLACPY('U',N,N,A,Lda,Work(N+1),N)
               DO p = 1 , N
                  temp1 = Sva(Iwork(p))
                  CALL SSCAL(p,ONE/temp1,Work(N+(p-1)*N+1),1)
               ENDDO
!           .. the columns of R are scaled to have unit Euclidean lengths.
               CALL SPOCON('U',N,Work(N+1),N,ONE,temp1,Work(N+N*N+1),   &
     &                     Iwork(2*N+M+1),ierr)
            ENDIF
            sconda = ONE/SQRT(temp1)
!           SCONDA is an estimate of SQRT(||(R^t * R)^(-1)||_1).
!           N^(-1/4) * SCONDA <= ||R^(-1)||_2 <= N^(1/4) * SCONDA
         ELSE
            sconda = -ONE
         ENDIF
      ENDIF
!
      l2pert = l2pert .AND. (ABS(A(1,1)/A(nr,nr))>SQRT(big1))
!     If there is no violent scaling, artificial perturbation is not needed.
!
!     Phase 3:
!
      IF ( .NOT.(rsvec .OR. lsvec) ) THEN
!
!         Singular Values only
!
!         .. transpose A(1:NR,1:N)
         DO p = 1 , MIN(N-1,nr)
            CALL SCOPY(N-p,A(p,p+1),Lda,A(p+1,p),1)
         ENDDO
!
!        The following two DO-loops introduce small relative perturbation
!        into the strict upper triangle of the lower triangular matrix.
!        Small entries below the main diagonal are also changed.
!        This modification is useful if the computing environment does not
!        provide/allow FLUSH TO ZERO underflow, for it prevents many
!        annoying denormalized numbers in case of strongly scaled matrices.
!        The perturbation is structured so that it does not introduce any
!        new perturbation of the singular values, and it does not destroy
!        the job done by the preconditioner.
!        The licence for this perturbation is in the variable L2PERT, which
!        should be .FALSE. if FLUSH TO ZERO underflow is active.
!
         IF ( .NOT.almort ) THEN
!
            IF ( l2pert ) THEN
!              XSC = SQRT(SMALL)
               xsc = epsln/FLOAT(N)
               DO q = 1 , nr
                  temp1 = xsc*ABS(A(q,q))
                  DO p = 1 , N
                     IF ( ((p>q) .AND. (ABS(A(p,q))<=temp1)) .OR.       &
     &                    (p<q) ) A(p,q) = SIGN(temp1,A(p,q))
                  ENDDO
               ENDDO
            ELSE
               CALL SLASET('U',nr-1,nr-1,ZERO,ZERO,A(1,2),Lda)
            ENDIF
!
!            .. second preconditioning using the QR factorization
!
            CALL SGEQRF(N,nr,A,Lda,Work,Work(N+1),Lwork-N,ierr)
!
!           .. and transpose upper to lower triangular
            DO p = 1 , nr - 1
               CALL SCOPY(nr-p,A(p,p+1),Lda,A(p+1,p),1)
            ENDDO
!
         ENDIF
!
!           Row-cyclic Jacobi SVD algorithm with column pivoting
!
!           .. again some perturbation (a "background noise") is added
!           to drown denormals
         IF ( l2pert ) THEN
!              XSC = SQRT(SMALL)
            xsc = epsln/FLOAT(N)
            DO q = 1 , nr
               temp1 = xsc*ABS(A(q,q))
               DO p = 1 , nr
                  IF ( ((p>q) .AND. (ABS(A(p,q))<=temp1)) .OR. (p<q) )  &
     &                 A(p,q) = SIGN(temp1,A(p,q))
               ENDDO
            ENDDO
         ELSE
            CALL SLASET('U',nr-1,nr-1,ZERO,ZERO,A(1,2),Lda)
         ENDIF
!
!           .. and one-sided Jacobi rotations are started on a lower
!           triangular matrix (plus perturbation which is ignored in
!           the part which destroys triangular form (confusing?!))
!
         CALL SGESVJ('L','NoU','NoV',nr,nr,A,Lda,Sva,N,V,Ldv,Work,Lwork,&
     &               Info)
!
         scalem = Work(1)
         numrank = NINT(Work(2))
!
!
      ELSEIF ( rsvec .AND. (.NOT.lsvec) ) THEN
!
!        -> Singular Values and Right Singular Vectors <-
!
         IF ( almort ) THEN
!
!           .. in this case NR equals N
            DO p = 1 , nr
               CALL SCOPY(N-p+1,A(p,p),Lda,V(p,p),1)
            ENDDO
            CALL SLASET('Upper',nr-1,nr-1,ZERO,ZERO,V(1,2),Ldv)
!
            CALL SGESVJ('L','U','N',N,nr,V,Ldv,Sva,nr,A,Lda,Work,Lwork, &
     &                  Info)
            scalem = Work(1)
            numrank = NINT(Work(2))

         ELSE
!
!        .. two more QR factorizations ( one QRF is not enough, two require
!        accumulated product of Jacobi rotations, three are perfect )
!
            CALL SLASET('Lower',nr-1,nr-1,ZERO,ZERO,A(2,1),Lda)
            CALL SGELQF(nr,N,A,Lda,Work,Work(N+1),Lwork-N,ierr)
            CALL SLACPY('Lower',nr,nr,A,Lda,V,Ldv)
            CALL SLASET('Upper',nr-1,nr-1,ZERO,ZERO,V(1,2),Ldv)
            CALL SGEQRF(nr,nr,V,Ldv,Work(N+1),Work(2*N+1),Lwork-2*N,    &
     &                  ierr)
            DO p = 1 , nr
               CALL SCOPY(nr-p+1,V(p,p),Ldv,V(p,p),1)
            ENDDO
            CALL SLASET('Upper',nr-1,nr-1,ZERO,ZERO,V(1,2),Ldv)
!
            CALL SGESVJ('Lower','U','N',nr,nr,V,Ldv,Sva,nr,U,Ldu,       &
     &                  Work(N+1),Lwork-N,Info)
            scalem = Work(N+1)
            numrank = NINT(Work(N+2))
            IF ( nr<N ) THEN
               CALL SLASET('A',N-nr,nr,ZERO,ZERO,V(nr+1,1),Ldv)
               CALL SLASET('A',nr,N-nr,ZERO,ZERO,V(1,nr+1),Ldv)
               CALL SLASET('A',N-nr,N-nr,ZERO,ONE,V(nr+1,nr+1),Ldv)
            ENDIF
!
            CALL SORMLQ('Left','Transpose',N,N,nr,A,Lda,Work,V,Ldv,     &
     &                  Work(N+1),Lwork-N,ierr)
!
         ENDIF
!
         DO p = 1 , N
            CALL SCOPY(N,V(p,1),Ldv,A(Iwork(p),1),Lda)
         ENDDO
         CALL SLACPY('All',N,N,A,Lda,V,Ldv)
!
         IF ( transp ) CALL SLACPY('All',N,N,V,Ldv,U,Ldu)
!
      ELSEIF ( lsvec .AND. (.NOT.rsvec) ) THEN
!
!        .. Singular Values and Left Singular Vectors                 ..
!
!        .. second preconditioning step to avoid need to accumulate
!        Jacobi rotations in the Jacobi iterations.
         DO p = 1 , nr
            CALL SCOPY(N-p+1,A(p,p),Lda,U(p,p),1)
         ENDDO
         CALL SLASET('Upper',nr-1,nr-1,ZERO,ZERO,U(1,2),Ldu)
!
         CALL SGEQRF(N,nr,U,Ldu,Work(N+1),Work(2*N+1),Lwork-2*N,ierr)
!
         DO p = 1 , nr - 1
            CALL SCOPY(nr-p,U(p,p+1),Ldu,U(p+1,p),1)
         ENDDO
         CALL SLASET('Upper',nr-1,nr-1,ZERO,ZERO,U(1,2),Ldu)
!
         CALL SGESVJ('Lower','U','N',nr,nr,U,Ldu,Sva,nr,A,Lda,Work(N+1),&
     &               Lwork-N,Info)
         scalem = Work(N+1)
         numrank = NINT(Work(N+2))
!
         IF ( nr<M ) THEN
            CALL SLASET('A',M-nr,nr,ZERO,ZERO,U(nr+1,1),Ldu)
            IF ( nr<n1 ) THEN
               CALL SLASET('A',nr,n1-nr,ZERO,ZERO,U(1,nr+1),Ldu)
               CALL SLASET('A',M-nr,n1-nr,ZERO,ONE,U(nr+1,nr+1),Ldu)
            ENDIF
         ENDIF
!
         CALL SORMQR('Left','No Tr',M,n1,N,A,Lda,Work,U,Ldu,Work(N+1),  &
     &               Lwork-N,ierr)
!
         IF ( rowpiv ) CALL SLASWP(n1,U,Ldu,1,M-1,Iwork(2*N+1),-1)
!
         DO p = 1 , n1
            xsc = ONE/SNRM2(M,U(1,p),1)
            CALL SSCAL(M,xsc,U(1,p),1)
         ENDDO
!
         IF ( transp ) CALL SLACPY('All',N,N,U,Ldu,V,Ldv)
!
      ELSE
!
!        .. Full SVD ..
!
         IF ( jracc ) THEN
!
!        This branch deploys a preconditioned Jacobi SVD with explicitly
!        accumulated rotations. It is included as optional, mainly for
!        experimental purposes. It does perform well, and can also be used.
!        In this implementation, this branch will be automatically activated
!        if the  condition number sigma_max(A) / sigma_min(A) is predicted
!        to be greater than the overflow threshold. This is because the
!        a posteriori computation of the singular vectors assumes robust
!        implementation of BLAS and some LAPACK procedures, capable of working
!        in presence of extreme values. Since that is not always the case, ...
!
            DO p = 1 , nr
               CALL SCOPY(N-p+1,A(p,p),Lda,V(p,p),1)
            ENDDO
!
            IF ( l2pert ) THEN
               xsc = SQRT(small/epsln)
               DO q = 1 , nr
                  temp1 = xsc*ABS(V(q,q))
                  DO p = 1 , N
                     IF ( (p>q) .AND. (ABS(V(p,q))<=temp1) .OR. (p<q) ) &
     &                    V(p,q) = SIGN(temp1,V(p,q))
                     IF ( p<q ) V(p,q) = -V(p,q)
                  ENDDO
               ENDDO
            ELSE
               CALL SLASET('U',nr-1,nr-1,ZERO,ZERO,V(1,2),Ldv)
            ENDIF

            CALL SGEQRF(N,nr,V,Ldv,Work(N+1),Work(2*N+1),Lwork-2*N,ierr)
            CALL SLACPY('L',N,nr,V,Ldv,Work(2*N+1),N)
!
            DO p = 1 , nr
               CALL SCOPY(nr-p+1,V(p,p),Ldv,U(p,p),1)
            ENDDO

            IF ( l2pert ) THEN
               xsc = SQRT(small/epsln)
               DO q = 2 , nr
                  DO p = 1 , q - 1
                     temp1 = xsc*MIN(ABS(U(p,p)),ABS(U(q,q)))
                     U(p,q) = -SIGN(temp1,U(q,p))
                  ENDDO
               ENDDO
            ELSE
               CALL SLASET('U',nr-1,nr-1,ZERO,ZERO,U(1,2),Ldu)
            ENDIF

            CALL SGESVJ('L','U','V',nr,nr,U,Ldu,Sva,N,V,Ldv,            &
     &                  Work(2*N+N*nr+1),Lwork-2*N-N*nr,Info)
            scalem = Work(2*N+N*nr+1)
            numrank = NINT(Work(2*N+N*nr+2))

            IF ( nr<N ) THEN
               CALL SLASET('A',N-nr,nr,ZERO,ZERO,V(nr+1,1),Ldv)
               CALL SLASET('A',nr,N-nr,ZERO,ZERO,V(1,nr+1),Ldv)
               CALL SLASET('A',N-nr,N-nr,ZERO,ONE,V(nr+1,nr+1),Ldv)
            ENDIF

            CALL SORMQR('L','N',N,N,nr,Work(2*N+1),N,Work(N+1),V,Ldv,   &
     &                  Work(2*N+N*nr+nr+1),Lwork-2*N-N*nr-nr,ierr)
!
!           Permute the rows of V using the (column) permutation from the
!           first QRF. Also, scale the columns to make them unit in
!           Euclidean norm. This applies to all cases.
!
            temp1 = SQRT(FLOAT(N))*epsln
            DO q = 1 , N
               DO p = 1 , N
                  Work(2*N+N*nr+nr+Iwork(p)) = V(p,q)
               ENDDO
               DO p = 1 , N
                  V(p,q) = Work(2*N+N*nr+nr+p)
               ENDDO
               xsc = ONE/SNRM2(N,V(1,q),1)
               IF ( (xsc<(ONE-temp1)) .OR. (xsc>(ONE+temp1)) )          &
     &              CALL SSCAL(N,xsc,V(1,q),1)
            ENDDO
!
!           At this moment, V contains the right singular vectors of A.
!           Next, assemble the left singular vector matrix U (M x N).
!
            IF ( nr<M ) THEN
               CALL SLASET('A',M-nr,nr,ZERO,ZERO,U(nr+1,1),Ldu)
               IF ( nr<n1 ) THEN
                  CALL SLASET('A',nr,n1-nr,ZERO,ZERO,U(1,nr+1),Ldu)
                  CALL SLASET('A',M-nr,n1-nr,ZERO,ONE,U(nr+1,nr+1),Ldu)
               ENDIF
            ENDIF
!
            CALL SORMQR('Left','No Tr',M,n1,N,A,Lda,Work,U,Ldu,Work(N+1)&
     &                  ,Lwork-N,ierr)
!
            IF ( rowpiv ) CALL SLASWP(n1,U,Ldu,1,M-1,Iwork(2*N+1),-1)
!
         ELSEIF ( .NOT.almort ) THEN
!
!           Second Preconditioning Step (QRF [with pivoting])
!           Note that the composition of TRANSPOSE, QRF and TRANSPOSE is
!           equivalent to an LQF CALL. Since in many libraries the QRF
!           seems to be better optimized than the LQF, we do explicit
!           transpose and use the QRF. This is subject to changes in an
!           optimized implementation of SGEJSV.
!
            DO p = 1 , nr
               CALL SCOPY(N-p+1,A(p,p),Lda,V(p,p),1)
            ENDDO
!
!           .. the following two loops perturb small entries to avoid
!           denormals in the second QR factorization, where they are
!           as good as zeros. This is done to avoid painfully slow
!           computation with denormals. The relative size of the perturbation
!           is a parameter that can be changed by the implementer.
!           This perturbation device will be obsolete on machines with
!           properly implemented arithmetic.
!           To switch it off, set L2PERT=.FALSE. To remove it from  the
!           code, remove the action under L2PERT=.TRUE., leave the ELSE part.
!           The following two loops should be blocked and fused with the
!           transposed copy above.
!
            IF ( l2pert ) THEN
               xsc = SQRT(small)
               DO q = 1 , nr
                  temp1 = xsc*ABS(V(q,q))
                  DO p = 1 , N
                     IF ( (p>q) .AND. (ABS(V(p,q))<=temp1) .OR. (p<q) ) &
     &                    V(p,q) = SIGN(temp1,V(p,q))
                     IF ( p<q ) V(p,q) = -V(p,q)
                  ENDDO
               ENDDO
            ELSE
               CALL SLASET('U',nr-1,nr-1,ZERO,ZERO,V(1,2),Ldv)
            ENDIF
!
!           Estimate the row scaled condition number of R1
!           (If R1 is rectangular, N > NR, then the condition number
!           of the leading NR x NR submatrix is estimated.)
!
            CALL SLACPY('L',nr,nr,V,Ldv,Work(2*N+1),nr)
            DO p = 1 , nr
               temp1 = SNRM2(nr-p+1,Work(2*N+(p-1)*nr+p),1)
               CALL SSCAL(nr-p+1,ONE/temp1,Work(2*N+(p-1)*nr+p),1)
            ENDDO
            CALL SPOCON('Lower',nr,Work(2*N+1),nr,ONE,temp1,            &
     &                  Work(2*N+nr*nr+1),Iwork(M+2*N+1),ierr)
            condr1 = ONE/SQRT(temp1)
!           .. here need a second opinion on the condition number
!           .. then assume worst case scenario
!           R1 is OK for inverse <=> CONDR1 .LT. FLOAT(N)
!           more conservative    <=> CONDR1 .LT. SQRT(FLOAT(N))
!
            cond_ok = SQRT(FLOAT(nr))
![TP]       COND_OK is a tuning parameter.

            IF ( condr1<cond_ok ) THEN
!              .. the second QRF without pivoting. Note: in an optimized
!              implementation, this QRF should be implemented as the QRF
!              of a lower triangular matrix.
!              R1^t = Q2 * R2
               CALL SGEQRF(N,nr,V,Ldv,Work(N+1),Work(2*N+1),Lwork-2*N,  &
     &                     ierr)
!
               IF ( l2pert ) THEN
                  xsc = SQRT(small)/epsln
                  DO p = 2 , nr
                     DO q = 1 , p - 1
                        temp1 = xsc*MIN(ABS(V(p,p)),ABS(V(q,q)))
                        IF ( ABS(V(q,p))<=temp1 ) V(q,p)                &
     &                       = SIGN(temp1,V(q,p))
                     ENDDO
                  ENDDO
               ENDIF
!
               IF ( nr/=N ) CALL SLACPY('A',N,nr,V,Ldv,Work(2*N+1),N)
!              .. save ...
!
!           .. this transposed copy should be better than naive
               DO p = 1 , nr - 1
                  CALL SCOPY(nr-p,V(p,p+1),Ldv,V(p+1,p),1)
               ENDDO
!
               condr2 = condr1
!
            ELSE
!
!              .. ill-conditioned case: second QRF with pivoting
!              Note that windowed pivoting would be equally good
!              numerically, and more run-time efficient. So, in
!              an optimal implementation, the next call to SGEQP3
!              should be replaced with eg. CALL SGEQPX (ACM TOMS #782)
!              with properly (carefully) chosen parameters.
!
!              R1^t * P2 = Q2 * R2
               DO p = 1 , nr
                  Iwork(N+p) = 0
               ENDDO
               CALL SGEQP3(N,nr,V,Ldv,Iwork(N+1),Work(N+1),Work(2*N+1), &
     &                     Lwork-2*N,ierr)
!*               CALL SGEQRF( N, NR, V, LDV, WORK(N+1), WORK(2*N+1),
!*     $              LWORK-2*N, IERR )
               IF ( l2pert ) THEN
                  xsc = SQRT(small)
                  DO p = 2 , nr
                     DO q = 1 , p - 1
                        temp1 = xsc*MIN(ABS(V(p,p)),ABS(V(q,q)))
                        IF ( ABS(V(q,p))<=temp1 ) V(q,p)                &
     &                       = SIGN(temp1,V(q,p))
                     ENDDO
                  ENDDO
               ENDIF
!
               CALL SLACPY('A',N,nr,V,Ldv,Work(2*N+1),N)
!
               IF ( l2pert ) THEN
                  xsc = SQRT(small)
                  DO p = 2 , nr
                     DO q = 1 , p - 1
                        temp1 = xsc*MIN(ABS(V(p,p)),ABS(V(q,q)))
                        V(p,q) = -SIGN(temp1,V(q,p))
                     ENDDO
                  ENDDO
               ELSE
                  CALL SLASET('L',nr-1,nr-1,ZERO,ZERO,V(2,1),Ldv)
               ENDIF
!              Now, compute R2 = L3 * Q3, the LQ factorization.
               CALL SGELQF(nr,nr,V,Ldv,Work(2*N+N*nr+1),                &
     &                     Work(2*N+N*nr+nr+1),Lwork-2*N-N*nr-nr,ierr)
!              .. and estimate the condition number
               CALL SLACPY('L',nr,nr,V,Ldv,Work(2*N+N*nr+nr+1),nr)
               DO p = 1 , nr
                  temp1 = SNRM2(p,Work(2*N+N*nr+nr+p),nr)
                  CALL SSCAL(p,ONE/temp1,Work(2*N+N*nr+nr+p),nr)
               ENDDO
               CALL SPOCON('L',nr,Work(2*N+N*nr+nr+1),nr,ONE,temp1,     &
     &                     Work(2*N+N*nr+nr+nr*nr+1),Iwork(M+2*N+1),    &
     &                     ierr)
               condr2 = ONE/SQRT(temp1)
!
!                 .. save the Householder vectors used for Q3
!                 (this overwrites the copy of R2, as it will not be
!                 needed in this branch, but it does not overwritte the
!                 Huseholder vectors of Q2.).
!                 .. and the rest of the information on Q3 is in
!                 WORK(2*N+N*NR+1:2*N+N*NR+N)
               IF ( condr2>=cond_ok )                                   &
     &              CALL SLACPY('U',nr,nr,V,Ldv,Work(2*N+1),N)
!
            ENDIF
!
            IF ( l2pert ) THEN
               xsc = SQRT(small)
               DO q = 2 , nr
                  temp1 = xsc*V(q,q)
                  DO p = 1 , q - 1
!                    V(p,q) = - SIGN( TEMP1, V(q,p) )
                     V(p,q) = -SIGN(temp1,V(p,q))
                  ENDDO
               ENDDO
            ELSE
               CALL SLASET('U',nr-1,nr-1,ZERO,ZERO,V(1,2),Ldv)
            ENDIF
!
!        Second preconditioning finished; continue with Jacobi SVD
!        The input matrix is lower trinagular.
!
!        Recover the right singular vectors as solution of a well
!        conditioned triangular matrix equation.
!
            IF ( condr1<cond_ok ) THEN
!
               CALL SGESVJ('L','U','N',nr,nr,V,Ldv,Sva,nr,U,Ldu,        &
     &                     Work(2*N+N*nr+nr+1),Lwork-2*N-N*nr-nr,Info)
               scalem = Work(2*N+N*nr+nr+1)
               numrank = NINT(Work(2*N+N*nr+nr+2))
               DO p = 1 , nr
                  CALL SCOPY(nr,V(1,p),1,U(1,p),1)
                  CALL SSCAL(nr,Sva(p),V(1,p),1)
               ENDDO

!        .. pick the right matrix equation and solve it
!
               IF ( nr==N ) THEN
! :))             .. best case, R1 is inverted. The solution of this matrix
!                 equation is Q2*V2 = the product of the Jacobi rotations
!                 used in SGESVJ, premultiplied with the orthogonal matrix
!                 from the second QR factorization.
                  CALL STRSM('L','U','N','N',nr,nr,ONE,A,Lda,V,Ldv)
               ELSE
!                 .. R1 is well conditioned, but non-square. Transpose(R2)
!                 is inverted to get the product of the Jacobi rotations
!                 used in SGESVJ. The Q-factor from the second QR
!                 factorization is then built in explicitly.
                  CALL STRSM('L','U','T','N',nr,nr,ONE,Work(2*N+1),N,V, &
     &                       Ldv)
                  IF ( nr<N ) THEN
                     CALL SLASET('A',N-nr,nr,ZERO,ZERO,V(nr+1,1),Ldv)
                     CALL SLASET('A',nr,N-nr,ZERO,ZERO,V(1,nr+1),Ldv)
                     CALL SLASET('A',N-nr,N-nr,ZERO,ONE,V(nr+1,nr+1),   &
     &                           Ldv)
                  ENDIF
                  CALL SORMQR('L','N',N,N,nr,Work(2*N+1),N,Work(N+1),V, &
     &                        Ldv,Work(2*N+N*nr+nr+1),Lwork-2*N-N*nr-nr,&
     &                        ierr)
               ENDIF
!
            ELSEIF ( condr2<cond_ok ) THEN
!
! :)           .. the input matrix A is very likely a relative of
!              the Kahan matrix :)
!              The matrix R2 is inverted. The solution of the matrix equation
!              is Q3^T*V3 = the product of the Jacobi rotations (appplied to
!              the lower triangular L3 from the LQ factorization of
!              R2=L3*Q3), pre-multiplied with the transposed Q3.
               CALL SGESVJ('L','U','N',nr,nr,V,Ldv,Sva,nr,U,Ldu,        &
     &                     Work(2*N+N*nr+nr+1),Lwork-2*N-N*nr-nr,Info)
               scalem = Work(2*N+N*nr+nr+1)
               numrank = NINT(Work(2*N+N*nr+nr+2))
               DO p = 1 , nr
                  CALL SCOPY(nr,V(1,p),1,U(1,p),1)
                  CALL SSCAL(nr,Sva(p),U(1,p),1)
               ENDDO
               CALL STRSM('L','U','N','N',nr,nr,ONE,Work(2*N+1),N,U,Ldu)
!              .. apply the permutation from the second QR factorization
               DO q = 1 , nr
                  DO p = 1 , nr
                     Work(2*N+N*nr+nr+Iwork(N+p)) = U(p,q)
                  ENDDO
                  DO p = 1 , nr
                     U(p,q) = Work(2*N+N*nr+nr+p)
                  ENDDO
               ENDDO
               IF ( nr<N ) THEN
                  CALL SLASET('A',N-nr,nr,ZERO,ZERO,V(nr+1,1),Ldv)
                  CALL SLASET('A',nr,N-nr,ZERO,ZERO,V(1,nr+1),Ldv)
                  CALL SLASET('A',N-nr,N-nr,ZERO,ONE,V(nr+1,nr+1),Ldv)
               ENDIF
               CALL SORMQR('L','N',N,N,nr,Work(2*N+1),N,Work(N+1),V,Ldv,&
     &                     Work(2*N+N*nr+nr+1),Lwork-2*N-N*nr-nr,ierr)
            ELSE
!              Last line of defense.
! #:(          This is a rather pathological case: no scaled condition
!              improvement after two pivoted QR factorizations. Other
!              possibility is that the rank revealing QR factorization
!              or the condition estimator has failed, or the COND_OK
!              is set very close to ONE (which is unnecessary). Normally,
!              this branch should never be executed, but in rare cases of
!              failure of the RRQR or condition estimator, the last line of
!              defense ensures that SGEJSV completes the task.
!              Compute the full SVD of L3 using SGESVJ with explicit
!              accumulation of Jacobi rotations.
               CALL SGESVJ('L','U','V',nr,nr,V,Ldv,Sva,nr,U,Ldu,        &
     &                     Work(2*N+N*nr+nr+1),Lwork-2*N-N*nr-nr,Info)
               scalem = Work(2*N+N*nr+nr+1)
               numrank = NINT(Work(2*N+N*nr+nr+2))
               IF ( nr<N ) THEN
                  CALL SLASET('A',N-nr,nr,ZERO,ZERO,V(nr+1,1),Ldv)
                  CALL SLASET('A',nr,N-nr,ZERO,ZERO,V(1,nr+1),Ldv)
                  CALL SLASET('A',N-nr,N-nr,ZERO,ONE,V(nr+1,nr+1),Ldv)
               ENDIF
               CALL SORMQR('L','N',N,N,nr,Work(2*N+1),N,Work(N+1),V,Ldv,&
     &                     Work(2*N+N*nr+nr+1),Lwork-2*N-N*nr-nr,ierr)
!
               CALL SORMLQ('L','T',nr,nr,nr,Work(2*N+1),N,              &
     &                     Work(2*N+N*nr+1),U,Ldu,Work(2*N+N*nr+nr+1),  &
     &                     Lwork-2*N-N*nr-nr,ierr)
               DO q = 1 , nr
                  DO p = 1 , nr
                     Work(2*N+N*nr+nr+Iwork(N+p)) = U(p,q)
                  ENDDO
                  DO p = 1 , nr
                     U(p,q) = Work(2*N+N*nr+nr+p)
                  ENDDO
               ENDDO
!
            ENDIF
!
!           Permute the rows of V using the (column) permutation from the
!           first QRF. Also, scale the columns to make them unit in
!           Euclidean norm. This applies to all cases.
!
            temp1 = SQRT(FLOAT(N))*epsln
            DO q = 1 , N
               DO p = 1 , N
                  Work(2*N+N*nr+nr+Iwork(p)) = V(p,q)
               ENDDO
               DO p = 1 , N
                  V(p,q) = Work(2*N+N*nr+nr+p)
               ENDDO
               xsc = ONE/SNRM2(N,V(1,q),1)
               IF ( (xsc<(ONE-temp1)) .OR. (xsc>(ONE+temp1)) )          &
     &              CALL SSCAL(N,xsc,V(1,q),1)
            ENDDO
!           At this moment, V contains the right singular vectors of A.
!           Next, assemble the left singular vector matrix U (M x N).
            IF ( nr<M ) THEN
               CALL SLASET('A',M-nr,nr,ZERO,ZERO,U(nr+1,1),Ldu)
               IF ( nr<n1 ) THEN
                  CALL SLASET('A',nr,n1-nr,ZERO,ZERO,U(1,nr+1),Ldu)
                  CALL SLASET('A',M-nr,n1-nr,ZERO,ONE,U(nr+1,nr+1),Ldu)
               ENDIF
            ENDIF
!
!           The Q matrix from the first QRF is built into the left singular
!           matrix U. This applies to all cases.
!
            CALL SORMQR('Left','No_Tr',M,n1,N,A,Lda,Work,U,Ldu,Work(N+1)&
     &                  ,Lwork-N,ierr)

!           The columns of U are normalized. The cost is O(M*N) flops.
            temp1 = SQRT(FLOAT(M))*epsln
            DO p = 1 , nr
               xsc = ONE/SNRM2(M,U(1,p),1)
               IF ( (xsc<(ONE-temp1)) .OR. (xsc>(ONE+temp1)) )          &
     &              CALL SSCAL(M,xsc,U(1,p),1)
            ENDDO
!
!           If the initial QRF is computed with row pivoting, the left
!           singular vectors must be adjusted.
!
            IF ( rowpiv ) CALL SLASWP(n1,U,Ldu,1,M-1,Iwork(2*N+1),-1)
!
         ELSE
!
!        .. the initial matrix A has almost orthogonal columns and
!        the second QRF is not needed
!
            CALL SLACPY('Upper',N,N,A,Lda,Work(N+1),N)
            IF ( l2pert ) THEN
               xsc = SQRT(small)
               DO p = 2 , N
                  temp1 = xsc*Work(N+(p-1)*N+p)
                  DO q = 1 , p - 1
                     Work(N+(q-1)*N+p) = -SIGN(temp1,Work(N+(p-1)*N+q))
                  ENDDO
               ENDDO
            ELSE
               CALL SLASET('Lower',N-1,N-1,ZERO,ZERO,Work(N+2),N)
            ENDIF
!
            CALL SGESVJ('Upper','U','N',N,N,Work(N+1),N,Sva,N,U,Ldu,    &
     &                  Work(N+N*N+1),Lwork-N-N*N,Info)
!
            scalem = Work(N+N*N+1)
            numrank = NINT(Work(N+N*N+2))
            DO p = 1 , N
               CALL SCOPY(N,Work(N+(p-1)*N+1),1,U(1,p),1)
               CALL SSCAL(N,Sva(p),Work(N+(p-1)*N+1),1)
            ENDDO
!
            CALL STRSM('Left','Upper','NoTrans','No UD',N,N,ONE,A,Lda,  &
     &                 Work(N+1),N)
            DO p = 1 , N
               CALL SCOPY(N,Work(N+p),N,V(Iwork(p),1),Ldv)
            ENDDO
            temp1 = SQRT(FLOAT(N))*epsln
            DO p = 1 , N
               xsc = ONE/SNRM2(N,V(1,p),1)
               IF ( (xsc<(ONE-temp1)) .OR. (xsc>(ONE+temp1)) )          &
     &              CALL SSCAL(N,xsc,V(1,p),1)
            ENDDO
!
!           Assemble the left singular vector matrix U (M x N).
!
            IF ( N<M ) THEN
               CALL SLASET('A',M-N,N,ZERO,ZERO,U(N+1,1),Ldu)
               IF ( N<n1 ) THEN
                  CALL SLASET('A',N,n1-N,ZERO,ZERO,U(1,N+1),Ldu)
                  CALL SLASET('A',M-N,n1-N,ZERO,ONE,U(N+1,N+1),Ldu)
               ENDIF
            ENDIF
            CALL SORMQR('Left','No Tr',M,n1,N,A,Lda,Work,U,Ldu,Work(N+1)&
     &                  ,Lwork-N,ierr)
            temp1 = SQRT(FLOAT(M))*epsln
            DO p = 1 , n1
               xsc = ONE/SNRM2(M,U(1,p),1)
               IF ( (xsc<(ONE-temp1)) .OR. (xsc>(ONE+temp1)) )          &
     &              CALL SSCAL(M,xsc,U(1,p),1)
            ENDDO
!
            IF ( rowpiv ) CALL SLASWP(n1,U,Ldu,1,M-1,Iwork(2*N+1),-1)
!
!
         ENDIF
!
!
!        end of the  >> almost orthogonal case <<  in the full SVD
!
         IF ( transp ) THEN
!           .. swap U and V because the procedure worked on A^t
            DO p = 1 , N
               CALL SSWAP(N,U(1,p),1,V(1,p),1)
            ENDDO
         ENDIF
!
      ENDIF
!     end of the full SVD
!
!     Undo scaling, if necessary (and possible)
!
      IF ( uscal2<=(big/Sva(1))*uscal1 ) THEN
         CALL SLASCL('G',0,0,uscal1,uscal2,nr,1,Sva,N,ierr)
         uscal1 = ONE
         uscal2 = ONE
      ENDIF
!
      IF ( nr<N ) THEN
         DO p = nr + 1 , N
            Sva(p) = ZERO
         ENDDO
      ENDIF
!
      Work(1) = uscal2*scalem
      Work(2) = uscal1
      IF ( errest ) Work(3) = sconda
      IF ( lsvec .AND. rsvec ) THEN
         Work(4) = condr1
         Work(5) = condr2
      ENDIF
      IF ( l2tran ) THEN
         Work(6) = entra
         Work(7) = entrat
      ENDIF
!
      Iwork(1) = nr
      Iwork(2) = numrank
      Iwork(3) = warning
!
!     ..
!     .. END OF SGEJSV
!     ..
      END SUBROUTINE SGEJSV


c
c
c     "crystal" is a utility program which converts between
c     fractional and Cartesian coordinates, and can generate
c     full unit cells from asymmetric units
c
c
      subroutine crystal(n,name,valence,x,y,z)
      implicit none

      integer mxatm
      parameter (mxatm=1000)
      integer n
      integer iout
      integer valence(mxatm)
      double precision radian
      parameter (radian=57.295780d0)
      double precision alpha,beta,gamma
      double precision adim,bdim,cdim
      double precision aleng(3),bleng(3),cleng(3)
      double precision x(mxatm),y(mxatm),z(mxatm)
      logical orthogonal,triclinic
      character*4 name(mxatm)
c
      call cell(adim,bdim,cdim,alpha,beta,gamma)
c
c
      iout = 6

      orthogonal = .false.
      triclinic = .false.

      if (alpha.eq. 90.0d0 .and. beta .eq. 90.0d0
     $    .and. gamma.eq.90.0d0) then
         orthogonal = .true.
      else
         triclinic = .true.
      end if
c
c     determina as coordenadas de cada crystal system
c
      if (orthogonal) then
         aleng(1) = adim
         aleng(2) = 0.0d0
         aleng(3) = 0.0d0
         bleng(1) = 0.0d0
         bleng(2) = bdim
         bleng(3) = 0.0d0
         cleng(1) = 0.0d0
         cleng(2) = 0.0d0
         cleng(3) = cdim
      else if (triclinic) then
         aleng(1) = adim*sin(alpha/radian)
         aleng(2) = adim*cos(alpha/radian)
         aleng(3) = 0.0d0
         bleng(1) = bdim*cos(gamma/radian)
         bleng(2) = bdim*sin(gamma/radian)
         bleng(3) = 0.0d0
         cleng(1) = 0.0d0
         cleng(2) = 0.0d0
         cleng(3) = cdim
      end if
c
c     print out the initial cell dimensions to be used
c
      write (iout,10) adim,bdim,cdim,alpha,beta,gamma
  10  format (/,'Unit Cell Dimensions :'
     $        /,'      a    =',f10.4,
     $        /,'      b    =',f10.4,
     $        /,'      c    =',f10.4,
     $        /,'      alpha =',f10.4,
     $        /,'      beta  =',f10.4,
     $        /,'      gamma =',f10.4)
c
c     replicate the unit cell to make a block of unit cells
c
      call replicate
     $       (n,name,valence,x,y,z,aleng,bleng,cleng)
c
c
      return
      end
c
      subroutine replicate
     $           (n,name,valence,x,y,z,aleng,bleng,cleng)
      implicit none

      integer mxatm
      parameter (mxatm=1000)
      integer i,n,nunit   !nunit number of atoms in unit cell  PEML
      integer valence(mxatm)
      character*4 name(mxatm)
      double precision aleng(3),bleng(3),cleng(3)
      double precision x(mxatm),y(mxatm),z(mxatm)
c
c     translate along XX
c
      nunit = n
      do i = 1, nunit
         n = n + 1
         x(n) = x(i) + aleng(1)
         y(n) = y(i) + aleng(2)
         z(n) = z(i) + aleng(3)

         name(n) = name(i)
         valence(n) = valence(i)

      end do
c
c     translate along YY
c
      do i = 1, nunit
         n = n + 1
         x(n) = x(i) + bleng(1)
         y(n) = y(i) + bleng(2)
         z(n) = z(i) + bleng(3)
         name(n) = name(i)
         valence(n) = valence(i)
      end do
c
c     translate along XY
c
      do i = 1, nunit
         n = n + 1
         x(n) = x(i) + aleng(1) + bleng(1)
         y(n) = y(i) + aleng(2) + bleng(2)
         z(n) = z(i) + aleng(3) + bleng(3)
         name(n) = name(i)
         valence(n) = valence(i)
      end do

      return
      end


RECURSIVE SUBROUTINE PDESource(S,Q)
  IMPLICIT NONE
    INTEGER, PARAMETER :: nDim = 3                   ! The number of space dimensions
    INTEGER, PARAMETER :: nVar = 59                           ! The number of variables of the PDE system
    INTEGER, PARAMETER :: nParam=0
    INTEGER, PARAMETER :: d=3
  !USE MainVariables, :ONLY:  nVar,nDim,EQN
  !USE iso_c_binding
  TYPE, bind(C) :: tEquations
      REAL(8)    :: gamma, Pi, c0, g = 9.81, friction = 1.0
      REAL(8)    :: CCZ4k1=0.1, CCZ4k2=0.1, CCZ4k3=0.1, CCZ4eta=1.0, CCZ4itau=1.0, CCZ4f=0.1, CCZ4g, CCZ4xi=0.1, CCZ4e=1, CCZ4c=1.0, CCZ4mu=0.2, CCZ4ds=1.0, CCZ4sk=0.1, CCZ4bs=0.1
      REAL(8)    :: CCZ4GLMc0 = 0.5, CCZ4GLMc = 0.75, CCZ4GLMd = 0.75, CCZ4GLMepsD = 1e-2, CCZ4GLMepsA = 1e-2, CCZ4GLMepsP = 1e-2, cs, alpha, beta, lambda, cv, rho0, p0, tau1, tau2, mu, kappa ,tau
      INTEGER :: CCZ4LapseType=0, EinsteinAutoAux = 0, ReferenceDepth = 1.0
      REAL(8)    :: DivCleaning_a = 1.0
  END TYPE tEquations
  TYPE(tEquations) :: EQN
  ! --------------------------------------------
  ! Argument list declaration
  REAL(8),INTENT(IN)  :: Q(nvar)
  REAL(8),INTENT(OUT) :: S(nvar)
  ! --------------------------------------------
  ! Local variables
  INTEGER :: i,j,k,l,m,n
  REAL(8) :: mu
  REAL(8) :: src(nVar)
  REAL(8) :: k1,k2,k3,fff,ggg,e,c,ds,xi,sk,sknl,bs,dgup(3,3,3),eta,itau
  REAL(8) :: fa,faa
  ! Q and their gradients
  REAL(8) :: g_cov(3,3),g_contr(3,3),det                                ! Q(1-6)
  REAL(8) :: Aex(3,3),Amix(3,3),Aup(3,3),Aupdown,traceA                 ! Q(7-12)
  REAL(8) :: Theta                                                      ! Q(13)
  REAL(8) :: Ghat(3)                                                    ! Q(14-16)
  REAL(8) :: alpha                                                      ! Q(17)
  REAL(8) :: beta(3)                                                    ! Q(18-20)
  REAL(8) :: b(3)                                                       ! Q(21-23)
  REAL(8) :: AA(3)                                                      ! Q(24-26)
  REAL(8) :: BB(3,3),traceB                                             ! Q(27-35)
  REAL(8) :: DD(3,3,3)                                                  ! Q(36-53)
  REAL(8) :: traceK                                                     ! Q(54)
  REAL(8) :: phi                                                        ! Q(55)
  REAL(8) :: PP(3)                                                      ! Q(56-58)
  REAL(8) :: K0                                                         ! Q(59)
  ! time derivatives of Q
  REAL(8) :: dtgamma(3,3)                                               ! Q(1-7)
  REAL(8) :: dtK(3,3)                                                   ! Q(7-12)
  REAL(8) :: dtTheta                                                    ! Q(13)
  REAL(8) :: dtGhat(3)                                                  ! Q(14-16)
  REAL(8) :: dtalpha                                                    ! Q(17)
  REAL(8) :: dtbeta(3)                                                  ! Q(18-20)
  REAL(8) :: dtbb(3)                                                    ! Q(21-23)
  REAL(8) :: dtA(3)                                                     ! Q(24-26)
  REAL(8) :: dtB(3,3)                                                   ! Q(27-35)
  REAL(8) :: dtD(3,3,3)                                                 ! Q(36-53)
  REAL(8) :: dtTraceK                                                   ! Q(54)
  REAL(8) :: dtphi                                                      ! Q(55)
  REAL(8) :: dtP(3)                                                     ! Q(56-58)
  ! intermediate quantities
  REAL(8) :: Gtilde(3)
  REAL(8) :: Kex(3,3),Kmix(3,3),Kup(3,3)
  REAL(8) :: Christoffel(3,3,3),Christoffel_tilde(3,3,3)
  REAL(8) :: dChristoffelSrc(3,3,3,3)
  REAL(8) :: dChristoffel_tildeSrc(3,3,3,3)
  REAL(8) :: RiemannSrc(3,3,3,3)
  REAL(8) :: RicciSrc(3,3)
  REAL(8) :: RSrc
  REAL(8) :: dGtildeSrc(3,3)
  REAL(8) :: Z(3),Zup(3),dZ(3,3),dZSrc(3,3),nablaZSrc(3,3)
  REAL(8) :: RicciPlusNablaZSrc(3,3)
  REAL(8) :: RPlusTwoNablaZSrc
  REAL(8) :: nablaijalphaSrc(3,3)
  REAL(8) :: nablanablaalphaSrc
  REAL(8) :: SecondOrderTermsSrc(3,3),traceSrc
  REAL(8) :: ov(3)

#if defined(CCZ4EINSTEIN) || defined(CCZ4GRHD) || defined(CCZ4GRMHD) || defined(CCZ4GRGPR)
  !
  k1   = EQN%CCZ4k1                             ! kappa_1
  k2   = EQN%CCZ4k2                             ! kappa_2
  k3   = EQN%CCZ4k3                             ! kappa_3
  fff  = EQN%CCZ4f                              ! multiplied to \partial_k(b^i) in the evolution eqn for BB
  ggg  = EQN%CCZ4g                              !
  eta  = EQN%CCZ4eta                            ! eta
  itau = EQN%CCZ4itau                           ! tau^-1
  e    = EQN%CCZ4e                              ! e
  c    = EQN%CCZ4c                              ! c
  mu   = EQN%CCZ4mu                             ! mu
  ds   = EQN%CCZ4ds                             ! only multiplied to Z_i and \nabla_i(Z_j)
  bs   = EQN%CCZ4bs                             ! only used in dtbb and dtB
  xi   = EQN%CCZ4xi                             ! only used in dtbb
  sk   = EQN%CCZ4sk                             ! s multiplied to \partial_i(B_j^k) and other places
  !
  ! these are the tilde quantities, so be careful!
  g_cov(1,1) = Q(1)
  g_cov(1,2) = Q(2)
  g_cov(1,3) = Q(3)
  g_cov(2,1) = Q(2)
  g_cov(2,2) = Q(4)
  g_cov(2,3) = Q(5)
  g_cov(3,1) = Q(3)
  g_cov(3,2) = Q(5)
  g_cov(3,3) = Q(6)
  ! this determinant should be unity, since we use the conformal decomposition
  det = (Q(1)*Q(4)*Q(6)-Q(1)*Q(5)**2-Q(2)**2*Q(6)+2*Q(2)*Q(3)*Q(5)-Q(3)**2*Q(4))
  !
  g_contr(1,1) =  ( g_cov(2,2)*g_cov(3,3)-g_cov(2,3)*g_cov(3,2))/det
  g_contr(1,2) = -( g_cov(1,2)*g_cov(3,3)-g_cov(1,3)*g_cov(3,2))/det
  g_contr(1,3) = -(-g_cov(1,2)*g_cov(2,3)+g_cov(1,3)*g_cov(2,2))/det
  g_contr(2,1) = -( g_cov(2,1)*g_cov(3,3)-g_cov(2,3)*g_cov(3,1))/det
  g_contr(2,2) =  ( g_cov(1,1)*g_cov(3,3)-g_cov(1,3)*g_cov(3,1))/det
  g_contr(2,3) = -( g_cov(1,1)*g_cov(2,3)-g_cov(1,3)*g_cov(2,1))/det
  g_contr(3,1) = -(-g_cov(2,1)*g_cov(3,2)+g_cov(2,2)*g_cov(3,1))/det
  g_contr(3,2) = -( g_cov(1,1)*g_cov(3,2)-g_cov(1,2)*g_cov(3,1))/det
  g_contr(3,3) =  ( g_cov(1,1)*g_cov(2,2)-g_cov(1,2)*g_cov(2,1))/det
  !
  alpha = DEXP(DMAX1(-20.D0,DMIN1(20.D0,Q(17))))
  SELECT CASE(EQN%CCZ4LapseType)
  CASE(0)  ! harmonic
    fa  = 1.0D0
    faa = 0.0D0
  CASE DEFAULT  ! 1 + log
    fa  = 2.0D0/alpha
    faa = -2.0D0/alpha**2
  END SELECT
  !
  K0  = Q(59)
  !
  Aex(1,1) = Q(7 )
  Aex(1,2) = Q(8 )
  Aex(1,3) = Q(9 )
  Aex(2,1) = Q(8 )
  Aex(2,2) = Q(10)
  Aex(2,3) = Q(11)
  Aex(3,1) = Q(9 )
  Aex(3,2) = Q(11)
  Aex(3,3) = Q(12)
  !
  traceA = SUM(g_contr*Aex)
  Aex = Aex-1.0D0/3.0D0*g_cov*traceA
  !
  Amix = MATMUL(g_contr,          Aex  )
  Aup  = MATMUL(g_contr,TRANSPOSE(Amix))
  !
  Theta  = Q(13)
  !
  Ghat = (/Q(14),Q(15),Q(16)/)
  !
  b = Q(21:23)
  !
  AA = (/Q(24),Q(25),Q(26)/)
  !
  traceK = Q(54)
  !
  phi = DEXP(DMAX1(-20.0D0,DMIN1(20.0D0,Q(55))))
  !
  PP  = Q(56:58)
  !
  beta = (/Q(18),Q(19),Q(20)/)
  BB(1,1) = Q(27)
  BB(2,1) = Q(28)
  BB(3,1) = Q(29)
  BB(1,2) = Q(30)
  BB(2,2) = Q(31)
  BB(3,2) = Q(32)
  BB(1,3) = Q(33)
  BB(2,3) = Q(34)
  BB(3,3) = Q(35)
  !
  DD(1,1,1)=Q(36)
  DD(1,1,2)=Q(37)
  DD(1,1,3)=Q(38)
  DD(1,2,1)=Q(37)
  DD(1,2,2)=Q(39)
  DD(1,2,3)=Q(40)
  DD(1,3,1)=Q(38)
  DD(1,3,2)=Q(40)
  DD(1,3,3)=Q(41)
  !
  DD(2,1,1)=Q(42)
  DD(2,1,2)=Q(43)
  DD(2,1,3)=Q(44)
  DD(2,2,1)=Q(43)
  DD(2,2,2)=Q(45)
  DD(2,2,3)=Q(46)
  DD(2,3,1)=Q(44)
  DD(2,3,2)=Q(46)
  DD(2,3,3)=Q(47)
  !
  DD(3,1,1)=Q(48)
  DD(3,1,2)=Q(49)
  DD(3,1,3)=Q(50)
  DD(3,2,1)=Q(49)
  DD(3,2,2)=Q(51)
  DD(3,2,3)=Q(52)
  DD(3,3,1)=Q(50)
  DD(3,3,2)=Q(52)
  DD(3,3,3)=Q(53)
  !
  dgup = 0.0D0
  DO n=1,3
    DO j=1,3
      DO l=1,3
        DO m=1,3
          DO k=1,3
            dgup(k,m,l) = dgup(k,m,l)-2.0D0*g_contr(m,n)*g_contr(j,l)*DD(k,n,j)
          ENDDO
        ENDDO
      ENDDO
    ENDDO
  ENDDO
  !
  Kex  = Aex/phi**2+1.0D0/3.0D0*traceK*g_cov/phi**2
  Kmix = MATMUL(phi**2*g_contr,          Kex  )
  Kup  = MATMUL(phi**2*g_contr,TRANSPOSE(Kmix))
  !
  Christoffel_tilde = 0.0D0
  Christoffel       = 0.0D0
  Gtilde = 0.0D0
  !
  DO k=1,3
    DO j=1,3
      DO i=1,3
        DO l=1,3
          Christoffel_tilde(i,j,k) = Christoffel_tilde(i,j,k)+g_contr(k,l)*(DD(i,j,l)+DD(j,i,l)-DD(l,i,j))
          Christoffel(i,j,k)       = Christoffel(i,j,k)      +g_contr(k,l)*(DD(i,j,l)+DD(j,i,l)-DD(l,i,j)) &
                  &                         -g_contr(k,l)*(g_cov(j,l)*PP(i)+g_cov(i,l)*PP(j)-g_cov(i,j)*PP(l))
        ENDDO
      ENDDO
    ENDDO
  ENDDO
  !
  DO l=1,3
    DO j=1,3
      DO i=1,3
        Gtilde(i) = Gtilde(i)+g_contr(j,l)*Christoffel_tilde(j,l,i)
      ENDDO
    ENDDO
  ENDDO
  !
  Z   = 0.5D0*ds*MATMUL(g_cov,Ghat-Gtilde)
  Zup = MATMUL(phi**2*g_contr,Z)
  !
  dChristoffelSrc = 0.0D0
  dChristoffel_tildeSrc = 0.0D0
  DO l=1,3
    DO m=1,3
      DO j=1,3
        DO i=1,3
          DO k=1,3
            dChristoffelSrc(k,i,j,m) = dChristoffelSrc(k,i,j,m)+dgup(k,m,l)*(DD(i,j,l)+DD(j,i,l)-DD(l,i,j))                      &
                    &                         -dgup(k,m,l)*(g_cov(j,l)*PP(i)+g_cov(i,l)*PP(j)-g_cov(i,j)*PP(l)) &
                    &                         -2.0D0*g_contr(m,l)*(DD(k,j,l)*PP(i)+DD(k,i,l)*PP(j)-DD(k,i,j)*PP(l))
            !
            dChristoffel_tildeSrc(k,i,j,m) = dChristoffel_tildeSrc(k,i,j,m)+dgup(k,m,l)*(DD(i,j,l)+DD(j,i,l)-DD(l,i,j))
          ENDDO
        ENDDO
      ENDDO
    ENDDO
  ENDDO
  !
  RiemannSrc = 0.0D0
  DO m=1,3
    DO j=1,3
      DO k=1,3
        DO i=1,3
          RiemannSrc(i,k,j,m) = dChristoffelSrc(k,i,j,m)-dChristoffelSrc(j,i,k,m)
          DO l=1,3
            RiemannSrc(i,k,j,m) = RiemannSrc(i,k,j,m)+Christoffel(i,j,l)*Christoffel(l,k,m)-Christoffel(i,k,l)*Christoffel(l,j,m)
          ENDDO
        ENDDO
      ENDDO
    ENDDO
  ENDDO
  !
  RicciSrc = 0.0D0
  DO l=1,3
    DO n=1,3
      DO m=1,3
        RicciSrc(m,n) = RicciSrc(m,n)+RiemannSrc(m,l,n,l)
      ENDDO
    ENDDO
  ENDDO
  !
  RSrc = phi**2*SUM(g_contr*RicciSrc)
  !
  ! Here we directly compute the derivative of Gtilde from its original definition as contracted Christoffel symbol,
  ! without assuming unit determinant of the conformal metric. Back to the roots, and as few assumptions as possible...
  !
  dGtildeSrc = 0.0D0
  DO l=1,3
    DO j=1,3
      DO i=1,3
        DO k=1,3
          dGtildeSrc(k,i) = dGtildeSrc(k,i)+dgup(k,j,l)*Christoffel_tilde(j,l,i)+g_contr(j,l)*dChristoffel_tildeSrc(k,j,l,i)
        ENDDO
      ENDDO
    ENDDO
  ENDDO
  !
  dZSrc = 0.0D0
  DO j=1,3
    DO i=1,3
      DO k=1,3
        dZSrc(k,i) = dZSrc(k,i)+ds*(DD(k,i,j)*(Ghat(j)-Gtilde(j))+0.5D0*g_cov(i,j)*(-dGtildeSrc(k,j)))
      ENDDO
    ENDDO
  ENDDO
  !
  nablaZSrc = 0.0D0
  DO j=1,3
    DO i=1,3
      nablaZSrc(i,j) = dZSrc(i,j)
      DO k=1,3
        nablaZSrc(i,j) = nablaZSrc(i,j)-Christoffel(i,j,k)*Z(k)
      ENDDO
    ENDDO
  ENDDO
  !
  RicciPlusNablaZSrc = RicciSrc+(nablaZSrc+TRANSPOSE(nablaZSrc))
  !
  RPlusTwoNablaZSrc = phi**2*SUM(g_contr*RicciPlusNablaZSrc)
  !
  nablaijalphaSrc = 0.0D0
  DO j=1,3
    DO i=1,3
      nablaijalphaSrc(i,j) =      alpha*AA(j)*AA(i)
      DO k=1,3
        nablaijalphaSrc(i,j) = nablaijalphaSrc(i,j)-alpha*Christoffel(i,j,k)*AA(k)
      ENDDO
    ENDDO
  ENDDO
  nablanablaalphaSrc = phi**2*SUM(g_contr*nablaijalphaSrc)
  !
  SecondOrderTermsSrc = -nablaijalphaSrc+alpha*RicciPlusNablaZSrc
  traceSrc = SUM(g_contr*SecondOrderTermsSrc)
  SecondOrderTermsSrc = SecondOrderTermsSrc-1.0D0/3.0D0*g_cov*traceSrc
  !
  ! now assemble all this terrible stuff...
  !
  dtgamma = -2.0D0*alpha*Aex-itau*(det-1.0D0)*g_cov
  DO k=1,3
    DO j=1,3
      DO i=1,3
        dtgamma(i,j) = dtgamma(i,j)+g_cov(k,i)*BB(j,k)+g_cov(k,j)*BB(i,k)-2.0D0/3.0D0*g_cov(i,j)*BB(k,k)+2.0D0*beta(k)*DD(k,i,j)
      ENDDO
    ENDDO
  ENDDO
  !
  ! Main variables of the CCZ4 system
  ! extrinsic curvature
  dtK = phi**2*SecondOrderTermsSrc + alpha*Aex*(traceK-2.0D0*Theta) - 2.0D0*alpha*MATMUL(Aex,Amix)-itau*g_cov*traceA
  DO j=1,3
    DO i=1,3
      DO k=1,3
        dtK(i,j) = dtK(i,j)+Aex(k,i)*BB(j,k)+Aex(k,j)*BB(i,k)-2.0D0/3.0D0*Aex(i,j)*BB(k,k)
      ENDDO
    ENDDO
  ENDDO
  !
  ! dtTraceK = -nablanablaalphaNCP-nablanablaalphaSrc+alpha*(RPlusTwoNablaZNCP+RPlusTwoNablaZSrc+traceK**2-2.0D0*Theta*traceK)-3.0D0*alpha*k1*(1.0D0+k2)*Theta+SUM(beta(:)*dtraceK(:))   ! Baojiu
  dtTraceK = -nablanablaalphaSrc+alpha*(RPlusTwoNablaZSrc+traceK**2-2.0D0*c*Theta*traceK)-3.0D0*alpha*k1*(1.0D0+k2)*Theta ! Baojiu
  !
  traceB  = BB(1,1)+BB(2,2)+BB(3,3)
  dtphi   = beta(1)*PP(1)+beta(2)*PP(2)+beta(3)*PP(3)+1.0D0/3.0D0*alpha*traceK-1.0D0/3.0D0*traceB
  dtalpha = -alpha*fa*(traceK-K0-2.0D0*c*Theta)+beta(1)*AA(1)+beta(2)*AA(2)+beta(3)*AA(3)
  !
  Aupdown = SUM(Aex*Aup)
  ! *** original
  dtTheta = 0.5D0*alpha*e**2*RplusTwoNablaZSrc+    &            ! temporal Z
          !         & 0.5D0*alpha*e**2*(-Aupdown+2.0D0/3.0D0*traceK**2)-alpha*Theta*traceK-SUM(Zup*alpha*AA)-alpha*k1*(2.0D0+k2)*Theta    ! Baojiu
          & 0.5D0*alpha*e**2*(-Aupdown+2.0D0/3.0D0*traceK**2)-c*alpha*Theta*traceK-alpha*SUM(Zup*AA)-alpha*k1*(2.0D0+k2)*Theta  ! Baojiu
  !
  dtGhat = 0.0D0
  DO i=1,3
    dtGhat(i) = dtGhat(i)  &
            & +2.0D0*alpha*(SUM(Christoffel_tilde(:,:,i)*Aup(:,:))-3.0D0*SUM(Aup(i,:)*PP(:)))    &
            & +2.0D0*alpha*SUM(g_contr(:,i)*(-Theta*AA(:)-2.0D0/3.0D0*traceK*Z(:)))  &
            & -2.0D0*alpha*SUM(Aup(i,:)*AA(:))-2.0D0*alpha*k1*SUM(g_contr(i,:)*Z(:))-SUM(Gtilde(:)*BB(:,i))   &
            & +2.0D0/3.0D0*Gtilde(i)*traceB
    DO l=1,3
      DO k=1,3
        dtGhat(i) = dtGhat(i)+ &
                &  2.0D0*k3*(2.0D0/3.0D0*g_contr(i,l)*Z(l)*BB(k,k)-g_contr(l,k)*Z(l)*BB(k,i))
      ENDDO
    ENDDO
  ENDDO
  !
  DO k=1,3
    ov(k) = 2.0D0*alpha*SUM(dgup(k,:,:)*Aex(:,:))    ! here we can use the constraint that trace A tilde = 0.
  ENDDO
  !
  dtGhat = dtGhat+sk*MATMUL(g_contr,ov)                                               ! the above ordering constraint is "down", so we must raise the index via g_contr.
  !
  dtbb = xi*dtGhat-eta*b                                                            !  <= be careful, this damping term -eta*b may be dangerous for the gamma driver, since it may kill the waves that you want !
  dtbb = sk*dtbb
  !
  dtbeta  = fff*b
  ! Add the following term if you want to have shift convection in the PDE for beta^i
  ! Do not add it if you want a real Lie derivative for beta. In this case, the advection term cancels out.
  dtbeta = dtbeta+bs*(beta(1)*BB(1,:)+beta(2)*BB(2,:)+beta(3)*BB(3,:))
  dtbeta = sk*dtbeta
  !
  ! Auxiliary variables
  dtA = -alpha*AA*(fa+alpha*faa)*(traceK-K0-2.0D0*c*Theta)+MATMUL(BB,AA)
  DO k=1,3
    dtA(k) = dtA(k)-sk*alpha*fa*SUM(dgup(k,:,:)*Aex(:,:))  ! here we can use the constraint that trace A tilde = 0.
  ENDDO
  !
  dtB = sk*MATMUL(BB,BB)     ! Baojiu
  !
  dtD = 0.0D0
  DO m=1,3
    DO j=1,3
      DO i=1,3
        DO k=1,3
          DO n=1,3
            dtD(k,i,j) = dtD(k,i,j)+1.0D0/3.0D0*alpha*g_cov(i,j)*dgup(k,n,m)*Aex(n,m)   ! explicitly remove the trace of tilde A again
          ENDDO
        ENDDO
      ENDDO
    ENDDO
  ENDDO
  !
  DO j=1,3
    DO i=1,3
      DO k=1,3
        dtD(k,i,j) = dtD(k,i,j)-alpha*AA(k)*Aex(i,j) !trace removing missing here
        DO l=1,3
          dtD(k,i,j) = dtD(k,i,j)+BB(k,l)*DD(l,i,j)+DD(k,l,i)*BB(j,l)+DD(k,l,j)*BB(i,l)-2.0D0/3.0D0*DD(k,i,j)*BB(l,l)
        ENDDO
      ENDDO
    ENDDO
  ENDDO
  !
  dtP = MATMUL(BB,PP)

  DO k=1,3
    dtP(k) = dtP(k)+1.0D0/3.0D0*alpha*AA(k)*traceK+sk*1.0D0/3.0D0*alpha*SUM(dgup(k,:,:)*Aex(:,:))
  ENDDO

  src(1:6)   = (/dtgamma(1,1),dtgamma(1,2),dtgamma(1,3),dtgamma(2,2),dtgamma(2,3),dtgamma(3,3)/)       ! \tilde \gamma_ij
  src(7:12)  = (/dtK(1,1),dtK(1,2),dtK(1,3),dtK(2,2),dtK(2,3),dtK(3,3)/)                               ! \tilde A_ij
  src(13)    = dtTheta                                                                                ! Theta
  src(14:16) = dtGhat(1:3)                                                                             ! \hat \Gamma^i
  src(17)    = dtalpha                                                                                ! log alpha
  src(18:20) = dtbeta                                                                                ! beta^i
  src(21:23) = dtbb                                                                                ! b^i
  src(24:26) = dtA(1:3)                                                                                ! A_k
  src(27:35) = (/dtB(1,1),dtB(2,1),dtB(3,1),dtB(1,2),dtB(2,2),dtB(3,2),dtB(1,3),dtB(2,3),dtB(3,3)/)    ! B_k^i
  src(36:41) = (/dtD(1,1,1),dtD(1,1,2),dtD(1,1,3),dtD(1,2,2),dtD(1,2,3),dtD(1,3,3)/)                   ! D_kij
  src(42:47) = (/dtD(2,1,1),dtD(2,1,2),dtD(2,1,3),dtD(2,2,2),dtD(2,2,3),dtD(2,3,3)/)                   ! D_kij
  src(48:53) = (/dtD(3,1,1),dtD(3,1,2),dtD(3,1,3),dtD(3,2,2),dtD(3,2,3),dtD(3,3,3)/)                   ! D_kij
  src(54)    = dtTraceK                                                                                ! traceK
  src(55)    = dtphi                                                                                ! log phi
  src(56:58) = dtP                                                                                ! P_k
  src(59)    = 0.0D0
  !
  S = src    ! here, we do not have to change sign, since we work on the right hand side in the fused subroutine
  !
  RETURN
#endif
end SUBROUTINE PDESource

program main
  implicit none
  REAL(8) ::  Q(59), S(59), Qtest(59)
  integer :: i,j,k,l,m

  Qtest = (/1.03876392436862219348e+00,1.13327632951146378931e-17,1.13328125850752231240e-17,9.81163922513405450943e-01,7.28991960382758263436e-20,9.81163922513405450943e-01,1.60702820377219834924e-01,-2.51854521837995827255e-14,-2.51859943549822510890e-14,-7.58958825491163335819e-02,-1.66695209611466999131e-16,-7.58958825491163335819e-02,5.73443499779581738335e-04,3.01713236980058585601e-01,-5.73062863551328161271e-12,-5.73061639353499262517e-12,2.85203957292370774423e-02,0.00000000000000000000e+00,0.00000000000000000000e+00,0.00000000000000000000e+00,0.00000000000000000000e+00,0.00000000000000000000e+00,0.00000000000000000000e+00,2.33452764998758000026e-01,-4.17807322717328905611e-12,-4.17806121758503744557e-12,0.00000000000000000000e+00,0.00000000000000000000e+00,0.00000000000000000000e+00,0.00000000000000000000e+00,0.00000000000000000000e+00,0.00000000000000000000e+00,0.00000000000000000000e+00,0.00000000000000000000e+00,0.00000000000000000000e+00,1.66029261165760388952e-01,3.52110122269561003271e-16,3.52110623323521089469e-16,-7.84114259822868420180e-02,-1.00892874234056400197e-18,-7.84114259822868420180e-02,-2.87874071850877923045e-12,-3.11299149429065573305e-16,4.67768108082361629111e-18,1.35940313205684060638e-12,-2.07569443609550208564e-18,1.35970991086859628736e-12,-2.87874063909529684826e-12,1.43318865709343599115e-18,-3.14548568405474184678e-16,1.35970993559255365097e-12,-2.04322863271445272127e-18,1.35940303232291987362e-12,2.34302828568053289615e-01,-9.50679857641236088217e-03,-7.99171325660463643947e-02,1.44427998332769005893e-12,1.44427998345849223420e-12,0.00000000000000000000e+00/)

  ! The initial data for Q is chosen such that we do not divide by 0 in the inverse determinant
  Q=1
  Q(1)=2
  Q(2)=3

  S=0
  !do i=1,1000000
  !call PDESource(S,Q)
  call PDESource(S,Qtest)
  !enddo

  !do i=1,1000000
    !call PDENCP(BgradQ, Q, gradQin)
  !enddo
  do i=1,59
    print*,i,S(i)
  enddo
  !call PDENCP(BgradQ, Q, gradQin)
  !print*, BgradQ
end program main