      SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA,
     &                     MV, V, LDV, WORK, LWORK, INFO )
*
*  -- LAPACK routine (version 3.2)                                    --
*
*  -- Contributed by Zlatko Drmac of the University of Zagreb and     --
*  -- Kresimir Veselic of the Fernuniversitaet Hagen                  --
*  -- November 2008                                                   --
*
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* This routine is also part of SIGMA (version 1.23, October 23. 2008.)
* SIGMA is a library of algorithms for highly accurate algorithms for
* computation of SVD, PSVD, QSVD, (H,K)-SVD, and for solution of the
* eigenvalue problems Hx = lambda M x, H M x = lambda x with H, M > 0.
*
*     -#- Scalar Arguments -#-
*
      IMPLICIT    NONE
      INTEGER     INFO, LDA, LDV, LWORK, M, MV, N
      CHARACTER*1 JOBA, JOBU, JOBV
*
*     -#- Array Arguments -#-
*
      DOUBLE PRECISION A( LDA, * ), SVA( N ), V( LDV, * ), WORK( LWORK )
*     ..
*
*  Purpose
*  ~~~~~~~
*  DGESVJ computes the singular value decomposition (SVD) of a real
*  M-by-N matrix A, where M >= N. The SVD of A is written as
*                                     [++]   [xx]   [x0]   [xx]
*               A = U * SIGMA * V^t,  [++] = [xx] * [ox] * [xx]
*                                     [++]   [xx]
*  where SIGMA is an N-by-N diagonal matrix, U is an M-by-N 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.
*
*  Further Details
*  ~~~~~~~~~~~~~~~
*  The orthogonal N-by-N matrix V is obtained as a product of Jacobi plane
*  rotations. The rotations are implemented as fast scaled rotations of
*  Anda and Park [1]. In the case of underflow of the Jacobi angle, a
*  modified Jacobi transformation of Drmac [4] is used. Pivot strategy uses
*  column interchanges of de Rijk [2]. The relative accuracy of the computed
*  singular values and the accuracy of the computed singular vectors (in
*  angle metric) is as guaranteed by the theory of Demmel and Veselic [3].
*  The condition number that determines the accuracy in the full rank case
*  is essentially min_{D=diag} kappa(A*D), where kappa(.) is the
*  spectral condition number. The best performance of this Jacobi SVD
*  procedure is achieved if used in an  accelerated version of Drmac and
*  Veselic [5,6], and it is the kernel routine in the SIGMA library [7].
*  Some tunning parameters (marked with [TP]) are available for the
*  implementer.
*  The computational range for the nonzero singular values is the  machine
*  number interval ( UNDERFLOW , OVERFLOW ). In extreme cases, even
*  denormalized singular values can be computed with the corresponding
*  gradual loss of accurate digits.
*
*  Contributors
*  ~~~~~~~~~~~~
*  Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)
*
*  References
*  ~~~~~~~~~~
* [1] A. A. Anda and H. Park: Fast plane rotations with dynamic scaling.
*     SIAM J. matrix Anal. Appl., Vol. 15 (1994), pp. 162-174.
* [2] P. P. M. De Rijk: A one-sided Jacobi algorithm for computing the
*     singular value decomposition on a vector computer.
*     SIAM J. Sci. Stat. Comp., Vol. 10 (1998), pp. 359-371.
* [3] J. Demmel and K. Veselic: Jacobi method is more accurate than QR.
* [4] Z. Drmac: Implementation of Jacobi rotations for accurate singular
*     value computation in floating point arithmetic.
*     SIAM J. Sci. Comp., Vol. 18 (1997), pp. 1200-1222.
* [5] 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.
* [6] 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.
* [7] Z. Drmac: SIGMA - mathematical software library for accurate SVD, PSV,
*     QSVD, (H,K)-SVD computations.
*     Department of Mathematics, University of Zagreb, 2008.
*
*  Bugs, Examples and Comments
*  ~~~~~~~~~~~~~~~~~~~~~~~~~~~
*  Please report all bugs and send interesting test examples and comments to
*  drmac@math.hr. Thank you.
*
*  Arguments
*  ~~~~~~~~~
*
*  JOBA    (input) CHARACTER* 1
*          Specifies the structure of A.
*          = 'L': The input matrix A is lower triangular;
*          = 'U': The input matrix A is upper triangular;
*          = 'G': The input matrix A is general M-by-N matrix, M >= N.
*
*  JOBU    (input) CHARACTER*1
*          Specifies whether to compute the left singular vectors
*          (columns of U):
*
*          = 'U': The left singular vectors corresponding to the nonzero
*                 singular values are computed and returned in the leading
*                 columns of A. See more details in the description of A.
*                 The default numerical orthogonality threshold is set to
*                 approximately TOL=CTOL*EPS, CTOL=DSQRT(M), EPS=DLAMCH('E').
*          = 'C': Analogous to JOBU='U', except that user can control the
*                 level of numerical orthogonality of the computed left
*                 singular vectors. TOL can be set to TOL = CTOL*EPS, where
*                 CTOL is given on input in the array WORK.
*                 No CTOL smaller than ONE is allowed. CTOL greater
*                 than 1 / EPS is meaningless. The option 'C'
*                 can be used if M*EPS is satisfactory orthogonality
*                 of the computed left singular vectors, so CTOL=M could
*                 save few sweeps of Jacobi rotations.
*                 See the descriptions of A and WORK(1).
*          = 'N': The matrix U is not computed. However, see the
*                 description of A.
*
*  JOBV    (input) CHARACTER*1
*          Specifies whether to compute the right singular vectors, that
*          is, the matrix V:
*          = 'V' : the matrix V is computed and returned in the array V
*          = 'A' : the Jacobi rotations are applied to the MV-by-N
*                  array V. In other words, the right singular vector
*                  matrix V is not computed explicitly, instead it is
*                  applied to an MV-by-N matrix initially stored in the
*                  first MV rows of V.
*          = 'N' : the matrix V is not computed and the array V is not
*                  referenced
*
*  M       (input) INTEGER
*          The number of rows of the input matrix A.  M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the input matrix A.
*          M >= N >= 0.
*
*  A       (input/output) REAL array, dimension (LDA,N)
*          On entry, the M-by-N matrix A.
*          On exit,
*          If JOBU .EQ. 'U' .OR. JOBU .EQ. 'C':
*          ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
*                 If INFO .EQ. 0,
*                 ~~~~~~~~~~~~~~~
*                 RANKA orthonormal columns of U are returned in the
*                 leading RANKA columns of the array A. Here RANKA <= N
*                 is the number of computed singular values of A that are
*                 above the underflow threshold DLAMCH('S'). The singular
*                 vectors corresponding to underflowed or zero singular
*                 values are not computed. The value of RANKA is returned
*                 in the array WORK as RANKA=NINT(WORK(2)). Also see the
*                 descriptions of SVA and WORK. The computed columns of U
*                 are mutually numerically orthogonal up to approximately
*                 TOL=DSQRT(M)*EPS (default); or TOL=CTOL*EPS (JOBU.EQ.'C'),
*                 see the description of JOBU.
*                 If INFO .GT. 0,
*                 ~~~~~~~~~~~~~~~
*                 the procedure DGESVJ did not converge in the given number
*                 of iterations (sweeps). In that case, the computed
*                 columns of U may not be orthogonal up to TOL. The output
*                 U (stored in A), SIGMA (given by the computed singular
*                 values in SVA(1:N)) and V is still a decomposition of the
*                 input matrix A in the sense that the residual
*                 ||A-SCALE*U*SIGMA*V^T||_2 / ||A||_2 is small.
*
*          If JOBU .EQ. 'N':
*          ~~~~~~~~~~~~~~~~~
*                 If INFO .EQ. 0
*                 ~~~~~~~~~~~~~~
*                 Note that the left singular vectors are 'for free' in the
*                 one-sided Jacobi SVD algorithm. However, if only the
*                 singular values are needed, the level of numerical
*                 orthogonality of U is not an issue and iterations are
*                 stopped when the columns of the iterated matrix are
*                 numerically orthogonal up to approximately M*EPS. Thus,
*                 on exit, A contains the columns of U scaled with the
*                 corresponding singular values.
*                 If INFO .GT. 0,
*                 ~~~~~~~~~~~~~~~
*                 the procedure DGESVJ did not converge in the given number
*                 of iterations (sweeps).
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,M).
*
*  SVA     (workspace/output) REAL array, dimension (N)
*          On exit,
*          If INFO .EQ. 0,
*          ~~~~~~~~~~~~~~~
*          depending on the value SCALE = WORK(1), we have:
*                 If SCALE .EQ. ONE:
*                 ~~~~~~~~~~~~~~~~~~
*                 SVA(1:N) contains the computed singular values of A.
*                 During the computation SVA contains the Euclidean column
*                 norms of the iterated matrices in the array A.
*                 If SCALE .NE. ONE:
*                 ~~~~~~~~~~~~~~~~~~
*                 The singular values of A are SCALE*SVA(1:N), and this
*                 factored representation is due to the fact that some of the
*                 singular values of A might underflow or overflow.
*
*          If INFO .GT. 0,
*          ~~~~~~~~~~~~~~~
*          the procedure DGESVJ did not converge in the given number of
*          iterations (sweeps) and SCALE*SVA(1:N) may not be accurate.
*
*  MV      (input) INTEGER
*          If JOBV .EQ. 'A', then the product of Jacobi rotations in DGESVJ
*          is applied to the first MV rows of V. See the description of JOBV.
*
*  V       (input/output) REAL array, dimension (LDV,N)
*          If JOBV = 'V', then V contains on exit the N-by-N matrix of
*                         the right singular vectors;
*          If JOBV = 'A', then V contains the product of the computed right
*                         singular vector matrix and the initial matrix in
*                         the array V.
*          If JOBV = 'N', then V is not referenced.
*
*  LDV     (input) INTEGER
*          The leading dimension of the array V, LDV .GE. 1.
*          If JOBV .EQ. 'V', then LDV .GE. max(1,N).
*          If JOBV .EQ. 'A', then LDV .GE. max(1,MV) .
*
*  WORK    (input/workspace/output) REAL array, dimension max(4,M+N).
*          On entry,
*          If JOBU .EQ. 'C',
*          ~~~~~~~~~~~~~~~~~
*          WORK(1) = CTOL, where CTOL defines the threshold for convergence.
*                    The process stops if all columns of A are mutually
*                    orthogonal up to CTOL*EPS, EPS=DLAMCH('E').
*                    It is required that CTOL >= ONE, i.e. it is not
*                    allowed to force the routine to obtain orthogonality
*                    below EPSILON.
*          On exit,
*          WORK(1) = SCALE is the scaling factor such that SCALE*SVA(1:N)
*                    are the computed singular vcalues of A.
*                    (See description of SVA().)
*          WORK(2) = NINT(WORK(2)) is the number of the computed nonzero
*                    singular values.
*          WORK(3) = NINT(WORK(3)) is the number of the computed singular
*                    values that are larger than the underflow threshold.
*          WORK(4) = NINT(WORK(4)) is the number of sweeps of Jacobi
*                    rotations needed for numerical convergence.
*          WORK(5) = max_{i.NE.j} |COS(A(:,i),A(:,j))| in the last sweep.
*                    This is useful information in cases when DGESVJ did
*                    not converge, as it can be used to estimate whether
*                    the output is stil useful and for post festum analysis.
*          WORK(6) = the largest absolute value over all sines of the
*                    Jacobi rotation angles in the last sweep. It can be
*                    useful for a post festum analysis.
*
*  LWORK   length of WORK, WORK >= MAX(6,M+N)
*
*  INFO    (output) INTEGER
*          = 0 : successful exit.
*          < 0 : if INFO = -i, then the i-th argument had an illegal value
*          > 0 : DGESVJ did not converge in the maximal allowed number (30)
*                of sweeps. The output may still be useful. See the
*                description of WORK.
*
*     Local Parameters
*
      DOUBLE PRECISION   ZERO,  HALF,         ONE,         TWO
      PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, TWO = 2.0D0 )
      INTEGER     NSWEEP
      PARAMETER ( NSWEEP = 30 )
*
*     Local Scalars
*
      DOUBLE PRECISION AAPP, AAPP0, AAPQ,  AAQQ,    APOAQ,     AQOAP,
     &        BIG,     BIGTHETA, CS,       CTOL,    EPSILON,   LARGE,
     &        MXAAPQ,  MXSINJ,   ROOTBIG,  ROOTEPS, ROOTSFMIN, ROOTTOL,
     &        SCALE,   SFMIN,    SMALL,    SN,      T,         TEMP1,
     &        THETA,   THSIGN,   TOL
      INTEGER BLSKIP,  EMPTSW,   i,        ibr,     IERR,      igl,
     &        IJBLSK,  ir1,      ISWROT,   jbc,     jgl,       KBL,
     &        LKAHEAD, MVL,      N2,       N34,     N4,        NBL,
     &        NOTROT,  p,        PSKIPPED, q,       ROWSKIP,   SWBAND
      LOGICAL APPLV,   GOSCALE,  LOWER,    LSVEC,   NOSCALE,   ROTOK,
     &        RSVEC,   UCTOL,    UPPER
*
*     Local Arrays
*
      DOUBLE PRECISION FASTR(5)
*
*     Intrinsic Functions
*
      INTRINSIC DABS, DMAX1, DMIN1, DBLE, MIN0, DSIGN, DSQRT
*
*     External Functions
*     .. from BLAS
      DOUBLE PRECISION DDOT, DNRM2
      EXTERNAL         DDOT, DNRM2
      INTEGER          IDAMAX
      EXTERNAL         IDAMAX
*     .. from LAPACK
      DOUBLE PRECISION DLAMCH
      EXTERNAL         DLAMCH
      LOGICAL          LSAME
      EXTERNAL         LSAME
*
*     External Subroutines
*     .. from BLAS
      EXTERNAL  DAXPY,  DCOPY, DROTM, DSCAL, DSWAP
*     .. from LAPACK
      EXTERNAL  DLASCL, DLASET, DLASSQ, XERBLA
*
      EXTERNAL  DGSVJ0, DGSVJ1
*
*     Test the input arguments
*
      LSVEC = LSAME( JOBU, 'U' )
      UCTOL = LSAME( JOBU, 'C' )
      RSVEC = LSAME( JOBV, 'V' )
      APPLV = LSAME( JOBV, 'A' )
      UPPER = LSAME( JOBA, 'U' )
      LOWER = LSAME( JOBA, 'L' )
*
      IF ( .NOT.( UPPER .OR. LOWER .OR. LSAME(JOBA,'G') ) ) THEN
         INFO = - 1
      ELSE IF ( .NOT.( LSVEC .OR. UCTOL .OR. LSAME(JOBU,'N') ) ) THEN
         INFO = - 2
      ELSE IF ( .NOT.( RSVEC .OR. APPLV .OR. LSAME(JOBV,'N') ) ) THEN
         INFO = - 3
      ELSE IF ( M .LT. 0 ) THEN
         INFO = - 4
      ELSE IF ( ( N .LT. 0 ) .OR. ( N .GT. M ) ) THEN
         INFO = - 5
      ELSE IF ( LDA .LT. M ) THEN
         INFO = - 7
      ELSE IF ( MV .LT. 0 ) THEN
         INFO = - 9
      ELSE IF ( ( RSVEC .AND. (LDV .LT. N ) ) .OR.
     &          ( APPLV .AND. (LDV .LT. MV) ) ) THEN
         INFO = -11
      ELSE IF ( UCTOL .AND. (WORK(1) .LE. ONE) ) THEN
         INFO = - 12
      ELSE IF ( LWORK .LT. MAX0( M + N , 6 ) ) THEN
         INFO = - 13
      ELSE
         INFO =   0
      END IF
*
*     #:(
      IF ( INFO .NE. 0 ) THEN
         CALL XERBLA( 'DGESVJ', -INFO )
         RETURN
      END IF
*
* #:) Quick return for void matrix
*
      IF ( ( M .EQ. 0 ) .OR. ( N .EQ. 0 ) ) RETURN
*
*     Set numerical parameters
*     The stopping criterion for Jacobi rotations is
*
*     max_{i<>j}|A(:,i)^T * A(:,j)|/(||A(:,i)||*||A(:,j)||) < CTOL*EPS
*
*     where EPS is the round-off and CTOL is defined as follows:
*
      IF ( UCTOL ) THEN
*        ... user controlled
         CTOL = WORK(1)
      ELSE
*        ... default
         IF ( LSVEC .OR. RSVEC .OR. APPLV ) THEN
            CTOL = DSQRT(DBLE(M))
         ELSE
            CTOL = DBLE(M)
         END IF
      END IF
*     ... and the machine dependent parameters are
*[!]  (Make sure that DLAMCH() works properly on the target machine.)
*
      EPSILON     = DLAMCH('Epsilon')
      ROOTEPS     = DSQRT(EPSILON)
      SFMIN       = DLAMCH('SafeMinimum')
      ROOTSFMIN   = DSQRT(SFMIN)
      SMALL       = SFMIN   / EPSILON
      BIG         = DLAMCH('Overflow')
*     BIG         = ONE    / SFMIN
      ROOTBIG     = ONE   / ROOTSFMIN
      LARGE       = BIG  / DSQRT(DBLE(M*N))
      BIGTHETA    = ONE / ROOTEPS
*
      TOL         = CTOL * EPSILON
      ROOTTOL     = DSQRT(TOL)
*
      IF ( DBLE(M)*EPSILON .GE. ONE ) THEN
         INFO = - 5
         CALL XERBLA( 'DGESVJ', -INFO )
         RETURN
      END IF
*
*     Initialize the right singular vector matrix.
*
      IF ( RSVEC )  THEN
         MVL = N
         CALL DLASET( 'A', MVL, N, ZERO, ONE, V, LDV )
      ELSE IF ( APPLV ) THEN
         MVL = MV
      END IF
      RSVEC = RSVEC .OR. APPLV
*
*     Initialize SVA( 1:N ) = ( ||A e_i||_2, i = 1:N )
*(!)  If necessary, scale A to protect the largest singular value
*     from overflow. It is possible that saving the largest singular
*     value destroys the information about the small ones.
*     This initial scaling is almost minimal in the sense that the
*     goal is to make sure that no column norm overflows, and that
*     DSQRT(N)*max_i SVA(i) does not overflow. If INFinite entries
*     in A are detected, the procedure returns with INFO=-6.
*
      SCALE    = ONE / DSQRT(DBLE(M)*DBLE(N))
      NOSCALE  = .TRUE.
      GOSCALE  = .TRUE.
*
      IF ( LOWER ) THEN
*        the input matrix is M-by-N lower triangular (trapezoidal)
         DO 1874 p = 1, N
            AAPP = ZERO
            AAQQ = ZERO
            CALL DLASSQ( M-p+1, A(p,p), 1, AAPP, AAQQ )
            IF ( AAPP .GT. BIG ) THEN
               INFO = - 6
               CALL XERBLA( 'DGESVJ', -INFO )
               RETURN
            END IF
            AAQQ = DSQRT(AAQQ)
            IF ( ( AAPP .LT. (BIG / AAQQ) ) .AND. NOSCALE ) THEN
               SVA(p)   = AAPP * AAQQ
            ELSE
               NOSCALE = .FALSE.
               SVA(p)   = AAPP * ( AAQQ * SCALE )
               IF ( GOSCALE ) THEN
                  GOSCALE = .FALSE.
                  DO 1873 q = 1, p - 1
                     SVA(q) = SVA(q)*SCALE
 1873             CONTINUE
               END IF
            END IF
 1874    CONTINUE
      ELSE IF ( UPPER ) THEN
*        the input matrix is M-by-N upper triangular (trapezoidal)
         DO 2874 p = 1, N
            AAPP = ZERO
            AAQQ = ZERO
            CALL DLASSQ( p, A(1,p), 1, AAPP, AAQQ )
            IF ( AAPP .GT. BIG ) THEN
               INFO = - 6
               CALL XERBLA( 'DGESVJ', -INFO )
               RETURN
            END IF
            AAQQ = DSQRT(AAQQ)
            IF ( ( AAPP .LT. (BIG / AAQQ) ) .AND. NOSCALE ) THEN
               SVA(p)   = AAPP * AAQQ
            ELSE
               NOSCALE = .FALSE.
               SVA(p)   = AAPP * ( AAQQ * SCALE )
               IF ( GOSCALE ) THEN
                  GOSCALE = .FALSE.
                  DO 2873 q = 1, p - 1
                     SVA(q) = SVA(q)*SCALE
 2873             CONTINUE
               END IF
            END IF
 2874    CONTINUE
      ELSE
*        the input matrix is M-by-N general dense
         DO 3874 p = 1, N
            AAPP = ZERO
            AAQQ = ZERO
            CALL DLASSQ( M, A(1,p), 1, AAPP, AAQQ )
            IF ( AAPP .GT. BIG ) THEN
               INFO = - 6
               CALL XERBLA( 'DGESVJ', -INFO )
               RETURN
            END IF
            AAQQ = DSQRT(AAQQ)
            IF ( ( AAPP .LT. (BIG / AAQQ) ) .AND. NOSCALE ) THEN
               SVA(p)  = AAPP * AAQQ
            ELSE
               NOSCALE = .FALSE.
               SVA(p)  = AAPP * ( AAQQ * SCALE )
               IF ( GOSCALE ) THEN
                  GOSCALE = .FALSE.
                  DO 3873 q = 1, p - 1
                     SVA(q) = SVA(q)*SCALE
 3873             CONTINUE
               END IF
            END IF
 3874    CONTINUE
      END IF
*
      IF ( NOSCALE ) SCALE = ONE
*
*     Move the smaller part of the spectrum from the underflow threshold
*(!)  Start by determining the position of the nonzero entries of the
*     array SVA() relative to ( SFMIN, BIG ).
*
      AAPP = ZERO
      AAQQ = BIG
      DO 4781 p = 1, N
         IF ( SVA(p) .NE. ZERO ) AAQQ = DMIN1( AAQQ, SVA(p) )
         AAPP = DMAX1( AAPP, SVA(p) )
 4781 CONTINUE
*
* #:) Quick return for zero matrix
*
      IF ( AAPP .EQ. ZERO ) THEN
         IF ( LSVEC ) CALL DLASET( 'G', M, N, ZERO, ONE, A, LDA )
         WORK(1) = ONE
         WORK(2) = ZERO
         WORK(3) = ZERO
         WORK(4) = ZERO
         WORK(5) = ZERO
         WORK(6) = ZERO
         RETURN
      END IF
*
* #:) Quick return for one-column matrix
*
      IF ( N .EQ. 1 ) THEN
         IF ( LSVEC )
     &      CALL DLASCL( 'G',0,0,SVA(1),SCALE,M,1,A(1,1),LDA,IERR )
         WORK(1) = ONE / SCALE
         IF ( SVA(1) .GE. SFMIN ) THEN
            WORK(2) = ONE
         ELSE
            WORK(2) = ZERO
         END IF
         WORK(3) = ZERO
         WORK(4) = ZERO
         WORK(5) = ZERO
         WORK(6) = ZERO
         RETURN
      END IF
*
*     Protect small singular values from underflow, and try to
*     avoid underflows/overflows in computing Jacobi rotations.
*
      SN    = DSQRT( SFMIN / EPSILON  )
      TEMP1 = DSQRT(  BIG /  DBLE(N) )
      IF ( (AAPP.LE.SN).OR.(AAQQ.GE.TEMP1)
     &   .OR.((SN.LE.AAQQ).AND.(AAPP.LE.TEMP1)) ) THEN
         TEMP1 = DMIN1(BIG,TEMP1/AAPP)
*         AAQQ  = AAQQ*TEMP1
*         AAPP  = AAPP*TEMP1
      ELSE IF ( (AAQQ.LE.SN).AND.(AAPP.LE.TEMP1) ) THEN
         TEMP1 = DMIN1( SN / AAQQ, BIG/(AAPP*DSQRT(DBLE(N))) )
*         AAQQ  = AAQQ*TEMP1
*         AAPP  = AAPP*TEMP1
      ELSE IF ( (AAQQ.GE.SN).AND.(AAPP.GE.TEMP1) ) THEN
         TEMP1 = DMAX1( SN / AAQQ, TEMP1 / AAPP )
*         AAQQ  = AAQQ*TEMP1
*         AAPP  = AAPP*TEMP1
      ELSE IF ( (AAQQ.LE.SN).AND.(AAPP.GE.TEMP1) ) THEN
         TEMP1 = DMIN1( SN / AAQQ, BIG / (DSQRT(DBLE(N))*AAPP))
*         AAQQ  = AAQQ*TEMP1
*         AAPP  = AAPP*TEMP1
      ELSE
         TEMP1 = ONE
      END IF
*
*     Scale, if necessary
*
      IF ( TEMP1 .NE. ONE ) THEN
         CALL DLASCL( 'G', 0, 0, ONE, TEMP1, N, 1, SVA, N, IERR )
      END IF
      SCALE = TEMP1 * SCALE
      IF ( SCALE .NE. ONE ) THEN
         CALL DLASCL( JOBA, 0, 0, ONE, SCALE, M, N, A, LDA, IERR )
         SCALE = ONE / SCALE
      END IF
*
*     Row-cyclic Jacobi SVD algorithm with column pivoting
*
      EMPTSW   = ( N * ( N - 1 ) ) / 2
      NOTROT   = 0
      FASTR(1) = ZERO
*
*     A is represented in factored form A = A * diag(WORK), where diag(WORK)
*     is initialized to identity. WORK is updated during fast scaled
*     rotations.
*
      DO 1868 q = 1, N
         WORK(q) = ONE
 1868 CONTINUE
*
*
      SWBAND = 3
*[TP] SWBAND is a tuning parameter [TP]. It is meaningful and effective
*     if DGESVJ is used as a computational routine in the preconditioned
*     Jacobi SVD algorithm DGESVJ. For sweeps i=1:SWBAND the procedure
*     works on pivots inside a band-like region around the diagonal.
*     The boundaries are determined dynamically, based on the number of
*     pivots above a threshold.
*
      KBL = MIN0( 8, N )
*[TP] KBL is a tuning parameter that defines the tile size in the
*     tiling of the p-q loops of pivot pairs. In general, an optimal
*     value of KBL depends on the matrix dimensions and on the
*     parameters of the computer's memory.
*
      NBL = N / KBL
      IF ( ( NBL * KBL ) .NE. N ) NBL = NBL + 1
*
      BLSKIP = KBL**2
*[TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL.
*
      ROWSKIP = MIN0( 5, KBL )
*[TP] ROWSKIP is a tuning parameter.
*
      LKAHEAD = 1
*[TP] LKAHEAD is a tuning parameter.
*
*     Quasi block transformations, using the lower (upper) triangular
*     structure of the input matrix. The quasi-block-cycling usually
*     invokes cubic convergence. Big part of this cycle is done inside
*     canonical subspaces of dimensions less than M.
*
      IF ( (LOWER .OR. UPPER) .AND. (N .GT. MAX0(64, 4*KBL)) ) THEN
*[TP] The number of partition levels and the actual partition are
*     tuning parameters.
      N4     = N / 4
      N2     = N / 2
      N34    = 3 * N4
      IF ( APPLV ) THEN
         q = 0
      ELSE
         q = 1
      END IF
*
      IF ( LOWER ) THEN
*
*     This works very well on lower triangular matrices, in particular
*     in the framework of the preconditioned Jacobi SVD (xGEJSV).
*     The idea is simple:
*     [+ 0 0 0]   Note that Jacobi transformations of [0 0]
*     [+ + 0 0]                                       [0 0]
*     [+ + x 0]   actually work on [x 0]              [x 0]
*     [+ + x x]                    [x x].             [x x]
*
      CALL DGSVJ0(JOBV,M-N34,N-N34,A(N34+1,N34+1),LDA,WORK(N34+1),
     &     SVA(N34+1),MVL,V(N34*q+1,N34+1),LDV,EPSILON,SFMIN,TOL,2,
     &     WORK(N+1),LWORK-N,IERR )
*
      CALL DGSVJ0( JOBV,M-N2,N34-N2,A(N2+1,N2+1),LDA,WORK(N2+1),
     &     SVA(N2+1),MVL,V(N2*q+1,N2+1),LDV,EPSILON,SFMIN,TOL,2,
     &     WORK(N+1),LWORK-N,IERR )
*
      CALL DGSVJ1( JOBV,M-N2,N-N2,N4,A(N2+1,N2+1),LDA,WORK(N2+1),
     &     SVA(N2+1),MVL,V(N2*q+1,N2+1),LDV,EPSILON,SFMIN,TOL,1,
     &     WORK(N+1),LWORK-N,IERR )
*
      CALL DGSVJ0( JOBV,M-N4,N2-N4,A(N4+1,N4+1),LDA,WORK(N4+1),
     &     SVA(N4+1),MVL,V(N4*q+1,N4+1),LDV,EPSILON,SFMIN,TOL,1,
     &     WORK(N+1),LWORK-N,IERR )
*
      CALL DGSVJ0( JOBV,M,N4,A,LDA,WORK,SVA,MVL,V,LDV,EPSILON,
     &     SFMIN,TOL,1,WORK(N+1),LWORK-N,IERR )
*
      CALL DGSVJ1( JOBV,M,N2,N4,A,LDA,WORK,SVA,MVL,V,LDV,EPSILON,
     &     SFMIN,TOL,1,WORK(N+1),LWORK-N,IERR )
*
*
      ELSE IF ( UPPER ) THEN
*
*
      CALL DGSVJ0( JOBV,N4,N4,A,LDA,WORK,SVA,MVL,V,LDV,EPSILON,
     &     SFMIN,TOL,2,WORK(N+1),LWORK-N,IERR )
*
      CALL DGSVJ0(JOBV,N2,N4,A(1,N4+1),LDA,WORK(N4+1),SVA(N4+1),MVL,
     &     V(N4*q+1,N4+1),LDV,EPSILON,SFMIN,TOL,1,WORK(N+1),LWORK-N,
     &     IERR )
*
      CALL DGSVJ1( JOBV,N2,N2,N4,A,LDA,WORK,SVA,MVL,V,LDV,EPSILON,
     &     SFMIN,TOL,1,WORK(N+1),LWORK-N,IERR )
*
      CALL DGSVJ0( JOBV,N2+N4,N4,A(1,N2+1),LDA,WORK(N2+1),SVA(N2+1),MVL,
     &     V(N2*q+1,N2+1),LDV,EPSILON,SFMIN,TOL,1,
     &     WORK(N+1),LWORK-N,IERR )

      END IF
*
      END IF
*
*     -#- Row-cyclic pivot strategy with de Rijk's pivoting -#-
*
      DO 1993 i = 1, NSWEEP
*
*     .. go go go ...
*
      MXAAPQ = ZERO
      MXSINJ = ZERO
      ISWROT = 0
*
      NOTROT   = 0
      PSKIPPED = 0
*
*     Each sweep is unrolled using KBL-by-KBL tiles over the pivot pairs
*     1 <= p < q <= N. This is the first step toward a blocked implementation
*     of the rotations. New implementation, based on block transformations,
*     is under development.
*
      DO 2000 ibr = 1, NBL
*
      igl = ( ibr - 1 ) * KBL + 1
*
      DO 1002 ir1 = 0, MIN0( LKAHEAD, NBL - ibr )
*
      igl = igl + ir1 * KBL
*
      DO 2001 p = igl, MIN0( igl + KBL - 1, N - 1)
*
*     .. de Rijk's pivoting
*
      q   = IDAMAX( N-p+1, SVA(p), 1 ) + p - 1
      IF ( p .NE. q ) THEN
         CALL DSWAP( M, A(1,p), 1, A(1,q), 1 )
         IF ( RSVEC ) CALL DSWAP( MVL, V(1,p), 1, V(1,q), 1 )
         TEMP1   = SVA(p)
         SVA(p)  = SVA(q)
         SVA(q)  = TEMP1
         TEMP1   = WORK(p)
         WORK(p) = WORK(q)
         WORK(q) = TEMP1
      END IF
*
      IF ( ir1 .EQ. 0 ) THEN
*
*        Column norms are periodically updated by explicit
*        norm computation.
*        Caveat:
*        Unfortunately, some BLAS implementations compute DNRM2(M,A(1,p),1)
*        as DSQRT(DDOT(M,A(1,p),1,A(1,p),1)), which may cause the result to
*        overflow for ||A(:,p)||_2 > DSQRT(overflow_threshold), and to
*        underflow for ||A(:,p)||_2 < DSQRT(underflow_threshold).
*        Hence, DNRM2 cannot be trusted, not even in the case when
*        the true norm is far from the under(over)flow boundaries.
*        If properly implemented DNRM2 is available, the IF-THEN-ELSE
*        below should read "AAPP = DNRM2( M, A(1,p), 1 ) * WORK(p)".
*
         IF ((SVA(p) .LT. ROOTBIG) .AND. (SVA(p) .GT. ROOTSFMIN)) THEN
            SVA(p) = DNRM2( M, A(1,p), 1 ) * WORK(p)
         ELSE
            TEMP1 = ZERO
            AAPP  = ZERO
            CALL DLASSQ( M, A(1,p), 1, TEMP1, AAPP )
            SVA(p) = TEMP1 * DSQRT(AAPP) * WORK(p)
         END IF
         AAPP = SVA(p)
      ELSE
         AAPP = SVA(p)
      END IF
*
      IF ( AAPP .GT. ZERO ) THEN
*
      PSKIPPED = 0
*
      DO 2002 q = p + 1, MIN0( igl + KBL - 1, N )
*
      AAQQ = SVA(q)
*
      IF ( AAQQ .GT. ZERO ) THEN
*
         AAPP0 = AAPP
         IF ( AAQQ .GE. ONE ) THEN
            ROTOK  = ( SMALL*AAPP ) .LE. AAQQ
            IF ( AAPP .LT. ( BIG / AAQQ ) ) THEN
               AAPQ = ( DDOT(M, A(1,p), 1, A(1,q), 1 ) *
     &                  WORK(p) * WORK(q) / AAQQ ) / AAPP
            ELSE
               CALL DCOPY( M, A(1,p), 1, WORK(N+1), 1 )
               CALL DLASCL( 'G', 0, 0, AAPP, WORK(p), M,
     &              1, WORK(N+1), LDA, IERR )
               AAPQ = DDOT( M, WORK(N+1),1, A(1,q),1 )*WORK(q) / AAQQ
            END IF
         ELSE
            ROTOK  = AAPP .LE. ( AAQQ / SMALL )
            IF ( AAPP .GT.  ( SMALL / AAQQ ) ) THEN
               AAPQ = ( DDOT( M, A(1,p), 1, A(1,q), 1 ) *
     &               WORK(p) * WORK(q) / AAQQ ) / AAPP
            ELSE
               CALL DCOPY( M, A(1,q), 1, WORK(N+1), 1 )
               CALL DLASCL( 'G', 0, 0, AAQQ, WORK(q), M,
     &              1, WORK(N+1), LDA, IERR )
               AAPQ = DDOT( M, WORK(N+1),1, A(1,p),1 )*WORK(p) / AAPP
            END IF
         END IF
*
         MXAAPQ = DMAX1( MXAAPQ, DABS(AAPQ) )
*
*        TO rotate or NOT to rotate, THAT is the question ...
*
         IF ( DABS( AAPQ ) .GT. TOL ) THEN
*
*           .. rotate
*[RTD]      ROTATED = ROTATED + ONE
*
            IF ( ir1 .EQ. 0 ) THEN
               NOTROT   = 0
               PSKIPPED = 0
               ISWROT   = ISWROT  + 1
            END IF
*
            IF ( ROTOK ) THEN
*
               AQOAP = AAQQ / AAPP
               APOAQ = AAPP / AAQQ
               THETA = - HALF * DABS( AQOAP - APOAQ ) / AAPQ
*
               IF ( DABS( THETA ) .GT. BIGTHETA ) THEN
*
                  T        = HALF / THETA
                  FASTR(3) =   T * WORK(p) / WORK(q)
                  FASTR(4) = - T * WORK(q) / WORK(p)
                  CALL DROTM( M,   A(1,p), 1, A(1,q), 1, FASTR )
                  IF ( RSVEC )
     &            CALL DROTM( MVL, V(1,p), 1, V(1,q), 1, FASTR )
                  SVA(q) = AAQQ*DSQRT( DMAX1(ZERO,ONE + T*APOAQ*AAPQ) )
                  AAPP   = AAPP*DSQRT( ONE - T*AQOAP*AAPQ )
                  MXSINJ = DMAX1( MXSINJ, DABS(T) )
*
               ELSE
*
*                 .. choose correct signum for THETA and rotate
*
                  THSIGN =  - DSIGN(ONE,AAPQ)
                  T  = ONE / ( THETA + THSIGN*DSQRT(ONE+THETA*THETA) )
                  CS = DSQRT( ONE / ( ONE + T*T ) )
                  SN = T * CS
*
                  MXSINJ = DMAX1( MXSINJ, DABS(SN) )
                  SVA(q) = AAQQ*DSQRT( DMAX1(ZERO, ONE+T*APOAQ*AAPQ) )
                  AAPP   = AAPP*DSQRT( DMAX1(ZERO, ONE-T*AQOAP*AAPQ) )
*
                  APOAQ = WORK(p) / WORK(q)
                  AQOAP = WORK(q) / WORK(p)
                  IF ( WORK(p) .GE. ONE ) THEN
                     IF ( WORK(q) .GE.  ONE ) THEN
                        FASTR(3) =   T * APOAQ
                        FASTR(4) = - T * AQOAP
                        WORK(p)  = WORK(p) * CS
                        WORK(q)  = WORK(q) * CS
                        CALL DROTM( M,   A(1,p),1, A(1,q),1, FASTR )
                        IF ( RSVEC )
     &                  CALL DROTM( MVL, V(1,p),1, V(1,q),1, FASTR )
                     ELSE
                        CALL DAXPY( M,    -T*AQOAP, A(1,q),1, A(1,p),1 )
                        CALL DAXPY( M, CS*SN*APOAQ, A(1,p),1, A(1,q),1 )
                        WORK(p) = WORK(p) * CS
                        WORK(q) = WORK(q) / CS
                        IF ( RSVEC ) THEN
                        CALL DAXPY(MVL,   -T*AQOAP, V(1,q),1,V(1,p),1)
                        CALL DAXPY(MVL,CS*SN*APOAQ, V(1,p),1,V(1,q),1)
                        END IF
                     END IF
                  ELSE
                     IF ( WORK(q) .GE. ONE ) THEN
                        CALL DAXPY( M,     T*APOAQ, A(1,p),1, A(1,q),1 )
                        CALL DAXPY( M,-CS*SN*AQOAP, A(1,q),1, A(1,p),1 )
                        WORK(p) = WORK(p) / CS
                        WORK(q) = WORK(q) * CS
                        IF ( RSVEC ) THEN
                        CALL DAXPY(MVL, T*APOAQ,    V(1,p),1,V(1,q),1)
                        CALL DAXPY(MVL,-CS*SN*AQOAP,V(1,q),1,V(1,p),1)
                        END IF
                     ELSE
                        IF ( WORK(p) .GE. WORK(q) ) THEN
                           CALL DAXPY( M,-T*AQOAP,   A(1,q),1,A(1,p),1 )
                           CALL DAXPY( M,CS*SN*APOAQ,A(1,p),1,A(1,q),1 )
                           WORK(p) = WORK(p) * CS
                           WORK(q) = WORK(q) / CS
                           IF ( RSVEC ) THEN
                           CALL DAXPY(MVL, -T*AQOAP,  V(1,q),1,V(1,p),1)
                           CALL DAXPY(MVL,CS*SN*APOAQ,V(1,p),1,V(1,q),1)
                           END IF
                        ELSE
                           CALL DAXPY( M, T*APOAQ,    A(1,p),1,A(1,q),1)
                           CALL DAXPY( M,-CS*SN*AQOAP,A(1,q),1,A(1,p),1)
                           WORK(p) = WORK(p) / CS
                           WORK(q) = WORK(q) * CS
                          IF ( RSVEC ) THEN
                          CALL DAXPY(MVL, T*APOAQ,    V(1,p),1,V(1,q),1)
                          CALL DAXPY(MVL,-CS*SN*AQOAP,V(1,q),1,V(1,p),1)
                          END IF
                        END IF
                     END IF
                  ENDIF
               END IF
*
            ELSE
*              .. have to use modified Gram-Schmidt like transformation
               CALL DCOPY( M, A(1,p), 1, WORK(N+1), 1 )
               CALL DLASCL( 'G',0,0,AAPP,ONE,M,1,WORK(N+1),LDA,IERR )
               CALL DLASCL( 'G',0,0,AAQQ,ONE,M,1,   A(1,q),LDA,IERR )
               TEMP1 = -AAPQ * WORK(p) / WORK(q)
               CALL DAXPY ( M, TEMP1, WORK(N+1), 1, A(1,q), 1 )
               CALL DLASCL( 'G',0,0,ONE,AAQQ,M,1,   A(1,q),LDA,IERR )
               SVA(q) = AAQQ*DSQRT( DMAX1( ZERO, ONE - AAPQ*AAPQ ) )
               MXSINJ = DMAX1( MXSINJ, SFMIN )
            END IF
*           END IF ROTOK THEN ... ELSE
*
*           In the case of cancellation in updating SVA(q), SVA(p)
*           recompute SVA(q), SVA(p).
*
            IF ( (SVA(q) / AAQQ )**2 .LE. ROOTEPS  ) THEN
               IF ((AAQQ .LT. ROOTBIG).AND.(AAQQ .GT. ROOTSFMIN)) THEN
                  SVA(q) = DNRM2( M, A(1,q), 1 ) * WORK(q)
               ELSE
                  T    = ZERO
                  AAQQ = ZERO
                  CALL DLASSQ( M, A(1,q), 1, T, AAQQ )
                  SVA(q) = T * DSQRT(AAQQ) * WORK(q)
               END IF
            END IF
            IF ( ( AAPP / AAPP0) .LE. ROOTEPS  ) THEN
               IF ((AAPP .LT. ROOTBIG).AND.(AAPP .GT. ROOTSFMIN)) THEN
                  AAPP = DNRM2( M, A(1,p), 1 ) * WORK(p)
               ELSE
                  T    = ZERO
                  AAPP = ZERO
                  CALL DLASSQ( M, A(1,p), 1, T, AAPP )
                  AAPP = T * DSQRT(AAPP) * WORK(p)
               END IF
               SVA(p) = AAPP
            END IF
*
         ELSE
*        A(:,p) and A(:,q) already numerically orthogonal
            IF ( ir1 .EQ. 0 ) NOTROT   = NOTROT + 1
*[RTD]      SKIPPED  = SKIPPED  + 1
            PSKIPPED = PSKIPPED + 1
         END IF
      ELSE
*        A(:,q) is zero column
         IF ( ir1. EQ. 0 ) NOTROT = NOTROT + 1
         PSKIPPED = PSKIPPED + 1
      END IF
*
      IF ( ( i .LE. SWBAND ) .AND. ( PSKIPPED .GT. ROWSKIP ) ) THEN
         IF ( ir1 .EQ. 0 ) AAPP = - AAPP
         NOTROT = 0
         GO TO 2103
      END IF
*
 2002 CONTINUE
*     END q-LOOP
*
 2103 CONTINUE
*     bailed out of q-loop
*
      SVA(p) = AAPP
*
      ELSE
         SVA(p) = AAPP
         IF ( ( ir1 .EQ. 0 ) .AND. (AAPP .EQ. ZERO) )
     &        NOTROT=NOTROT+MIN0(igl+KBL-1,N)-p
      END IF
*
 2001 CONTINUE
*     end of the p-loop
*     end of doing the block ( ibr, ibr )
 1002 CONTINUE
*     end of ir1-loop
*
* ... go to the off diagonal blocks
*
      igl = ( ibr - 1 ) * KBL + 1
*
      DO 2010 jbc = ibr + 1, NBL
*
         jgl = ( jbc - 1 ) * KBL + 1
*
*        doing the block at ( ibr, jbc )
*
         IJBLSK = 0
         DO 2100 p = igl, MIN0( igl + KBL - 1, N )
*
         AAPP = SVA(p)
         IF ( AAPP .GT. ZERO ) THEN
*
         PSKIPPED = 0
*
         DO 2200 q = jgl, MIN0( jgl + KBL - 1, N )
*
         AAQQ = SVA(q)
         IF ( AAQQ .GT. ZERO ) THEN
            AAPP0 = AAPP
*
*     -#- M x 2 Jacobi SVD -#-
*
*        Safe Gram matrix computation
*
         IF ( AAQQ .GE. ONE ) THEN
            IF ( AAPP .GE. AAQQ ) THEN
               ROTOK = ( SMALL*AAPP ) .LE. AAQQ
            ELSE
               ROTOK = ( SMALL*AAQQ ) .LE. AAPP
            END IF
            IF ( AAPP .LT. ( BIG / AAQQ ) ) THEN
               AAPQ = ( DDOT(M, A(1,p), 1, A(1,q), 1 ) *
     &                  WORK(p) * WORK(q) / AAQQ ) / AAPP
            ELSE
               CALL DCOPY( M, A(1,p), 1, WORK(N+1), 1 )
               CALL DLASCL( 'G', 0, 0, AAPP, WORK(p), M,
     &              1, WORK(N+1), LDA, IERR )
               AAPQ = DDOT( M, WORK(N+1), 1, A(1,q), 1 ) *
     &                WORK(q) / AAQQ
            END IF
         ELSE
            IF ( AAPP .GE. AAQQ ) THEN
               ROTOK = AAPP .LE. ( AAQQ / SMALL )
            ELSE
               ROTOK = AAQQ .LE. ( AAPP / SMALL )
            END IF
            IF ( AAPP .GT.  ( SMALL / AAQQ ) ) THEN
               AAPQ = ( DDOT( M, A(1,p), 1, A(1,q), 1 ) *
     &               WORK(p) * WORK(q) / AAQQ ) / AAPP
            ELSE
               CALL DCOPY( M, A(1,q), 1, WORK(N+1), 1 )
               CALL DLASCL( 'G', 0, 0, AAQQ, WORK(q), M, 1,
     &              WORK(N+1), LDA, IERR )
               AAPQ = DDOT(M,WORK(N+1),1,A(1,p),1) * WORK(p) / AAPP
            END IF
         END IF
*
         MXAAPQ = DMAX1( MXAAPQ, DABS(AAPQ) )
*
*        TO rotate or NOT to rotate, THAT is the question ...
*
         IF ( DABS( AAPQ ) .GT. TOL ) THEN
            NOTROT   = 0
*[RTD]      ROTATED  = ROTATED + 1
            PSKIPPED = 0
            ISWROT   = ISWROT  + 1
*
            IF ( ROTOK ) THEN
*
               AQOAP = AAQQ / AAPP
               APOAQ = AAPP / AAQQ
               THETA = - HALF * DABS( AQOAP - APOAQ ) / AAPQ
               IF ( AAQQ .GT. AAPP0 ) THETA = - THETA
*
               IF ( DABS( THETA ) .GT. BIGTHETA ) THEN
                  T = HALF / THETA
                  FASTR(3) =  T * WORK(p) / WORK(q)
                  FASTR(4) = -T * WORK(q) / WORK(p)
                  CALL DROTM( M,   A(1,p), 1, A(1,q), 1, FASTR )
                  IF ( RSVEC )
     &            CALL DROTM( MVL, V(1,p), 1, V(1,q), 1, FASTR )
                  SVA(q) = AAQQ*DSQRT( DMAX1(ZERO,ONE + T*APOAQ*AAPQ) )
                  AAPP   = AAPP*DSQRT( DMAX1(ZERO,ONE - T*AQOAP*AAPQ) )
                  MXSINJ = DMAX1( MXSINJ, DABS(T) )
               ELSE
*
*                 .. choose correct signum for THETA and rotate
*
                  THSIGN = - DSIGN(ONE,AAPQ)
                  IF ( AAQQ .GT. AAPP0 ) THSIGN = - THSIGN
                  T  = ONE / ( THETA + THSIGN*DSQRT(ONE+THETA*THETA) )
                  CS = DSQRT( ONE / ( ONE + T*T ) )
                  SN = T * CS
                  MXSINJ = DMAX1( MXSINJ, DABS(SN) )
                  SVA(q) = AAQQ*DSQRT( DMAX1(ZERO, ONE+T*APOAQ*AAPQ) )
                  AAPP   = AAPP*DSQRT( ONE - T*AQOAP*AAPQ)
*
                  APOAQ = WORK(p) / WORK(q)
                  AQOAP = WORK(q) / WORK(p)
                  IF ( WORK(p) .GE. ONE ) THEN
*
                     IF ( WORK(q) .GE.  ONE ) THEN
                        FASTR(3) =   T * APOAQ
                        FASTR(4) = - T * AQOAP
                        WORK(p)  = WORK(p) * CS
                        WORK(q)  = WORK(q) * CS
                        CALL DROTM( M,   A(1,p),1, A(1,q),1, FASTR )
                        IF ( RSVEC )
     &                  CALL DROTM( MVL, V(1,p),1, V(1,q),1, FASTR )
                     ELSE
                        CALL DAXPY( M,    -T*AQOAP, A(1,q),1, A(1,p),1 )
                        CALL DAXPY( M, CS*SN*APOAQ, A(1,p),1, A(1,q),1 )
                        IF ( RSVEC ) THEN
                        CALL DAXPY( MVL, -T*AQOAP,  V(1,q),1, V(1,p),1 )
                        CALL DAXPY( MVL,CS*SN*APOAQ,V(1,p),1, V(1,q),1 )
                        END IF
                        WORK(p) = WORK(p) * CS
                        WORK(q) = WORK(q) / CS
                     END IF
                  ELSE
                     IF ( WORK(q) .GE. ONE ) THEN
                        CALL DAXPY( M,     T*APOAQ, A(1,p),1, A(1,q),1 )
                        CALL DAXPY( M,-CS*SN*AQOAP, A(1,q),1, A(1,p),1 )
                        IF ( RSVEC ) THEN
                        CALL DAXPY(MVL,T*APOAQ,     V(1,p),1, V(1,q),1 )
                        CALL DAXPY(MVL,-CS*SN*AQOAP,V(1,q),1, V(1,p),1 )
                        END IF
                        WORK(p) = WORK(p) / CS
                        WORK(q) = WORK(q) * CS
                     ELSE
                        IF ( WORK(p) .GE. WORK(q) ) THEN
                           CALL DAXPY( M,-T*AQOAP,   A(1,q),1,A(1,p),1 )
                           CALL DAXPY( M,CS*SN*APOAQ,A(1,p),1,A(1,q),1 )
                           WORK(p) = WORK(p) * CS
                           WORK(q) = WORK(q) / CS
                           IF ( RSVEC ) THEN
                           CALL DAXPY( MVL, -T*AQOAP, V(1,q),1,V(1,p),1)
                           CALL DAXPY(MVL,CS*SN*APOAQ,V(1,p),1,V(1,q),1)
                           END IF
                        ELSE
                           CALL DAXPY(M, T*APOAQ,    A(1,p),1,A(1,q),1)
                           CALL DAXPY(M,-CS*SN*AQOAP,A(1,q),1,A(1,p),1)
                           WORK(p) = WORK(p) / CS
                           WORK(q) = WORK(q) * CS
                          IF ( RSVEC ) THEN
                          CALL DAXPY(MVL, T*APOAQ,    V(1,p),1,V(1,q),1)
                          CALL DAXPY(MVL,-CS*SN*AQOAP,V(1,q),1,V(1,p),1)
                          END IF
                        END IF
                     END IF
                  ENDIF
               END IF
*
            ELSE
               IF ( AAPP .GT. AAQQ ) THEN
                  CALL DCOPY( M, A(1,p), 1, WORK(N+1), 1 )
                  CALL DLASCL('G',0,0,AAPP,ONE,M,1,WORK(N+1),LDA,IERR)
                  CALL DLASCL('G',0,0,AAQQ,ONE,M,1,   A(1,q),LDA,IERR)
                  TEMP1 = -AAPQ * WORK(p) / WORK(q)
                  CALL DAXPY(M,TEMP1,WORK(N+1),1,A(1,q),1)
                  CALL DLASCL('G',0,0,ONE,AAQQ,M,1,A(1,q),LDA,IERR)
                  SVA(q) = AAQQ*DSQRT(DMAX1(ZERO, ONE - AAPQ*AAPQ))
                  MXSINJ = DMAX1( MXSINJ, SFMIN )
               ELSE
                  CALL DCOPY( M, A(1,q), 1, WORK(N+1), 1 )
                  CALL DLASCL('G',0,0,AAQQ,ONE,M,1,WORK(N+1),LDA,IERR)
                  CALL DLASCL('G',0,0,AAPP,ONE,M,1,   A(1,p),LDA,IERR)
                  TEMP1 = -AAPQ * WORK(q) / WORK(p)
                  CALL DAXPY(M,TEMP1,WORK(N+1),1,A(1,p),1)
                  CALL DLASCL('G',0,0,ONE,AAPP,M,1,A(1,p),LDA,IERR)
                  SVA(p) = AAPP*DSQRT(DMAX1(ZERO, ONE - AAPQ*AAPQ))
                  MXSINJ = DMAX1( MXSINJ, SFMIN )
               END IF
            END IF
*           END IF ROTOK THEN ... ELSE
*
*           In the case of cancellation in updating SVA(q)
*           .. recompute SVA(q)
            IF ( (SVA(q) / AAQQ )**2 .LE. ROOTEPS  ) THEN
               IF ((AAQQ .LT. ROOTBIG).AND.(AAQQ .GT. ROOTSFMIN)) THEN
                  SVA(q) = DNRM2( M, A(1,q), 1 ) * WORK(q)
               ELSE
                  T    = ZERO
                  AAQQ = ZERO
                  CALL DLASSQ( M, A(1,q), 1, T, AAQQ )
                  SVA(q) = T * DSQRT(AAQQ) * WORK(q)
               END IF
            END IF
            IF ( (AAPP / AAPP0 )**2 .LE. ROOTEPS  ) THEN
               IF ((AAPP .LT. ROOTBIG).AND.(AAPP .GT. ROOTSFMIN)) THEN
                  AAPP = DNRM2( M, A(1,p), 1 ) * WORK(p)
               ELSE
                  T    = ZERO
                  AAPP = ZERO
                  CALL DLASSQ( M, A(1,p), 1, T, AAPP )
                  AAPP = T * DSQRT(AAPP) * WORK(p)
               END IF
               SVA(p) = AAPP
            END IF
*              end of OK rotation
         ELSE
            NOTROT   = NOTROT   + 1
*[RTD]      SKIPPED  = SKIPPED  + 1
            PSKIPPED = PSKIPPED + 1
            IJBLSK   = IJBLSK   + 1
         END IF
      ELSE
         NOTROT   = NOTROT   + 1
         PSKIPPED = PSKIPPED + 1
         IJBLSK   = IJBLSK   + 1
      END IF
*
      IF ( ( i .LE. SWBAND ) .AND. ( IJBLSK .GE. BLSKIP ) ) THEN
         SVA(p) = AAPP
         NOTROT = 0
         GO TO 2011
      END IF
      IF ( ( i .LE. SWBAND ) .AND. ( PSKIPPED .GT. ROWSKIP ) ) THEN
         AAPP = -AAPP
         NOTROT = 0
         GO TO 2203
      END IF
*
 2200    CONTINUE
*        end of the q-loop
 2203    CONTINUE
*
         SVA(p) = AAPP
*
      ELSE
*
         IF ( AAPP .EQ. ZERO ) NOTROT=NOTROT+MIN0(jgl+KBL-1,N)-jgl+1
         IF ( AAPP .LT. ZERO ) NOTROT = 0
*
      END IF
*
 2100 CONTINUE
*     end of the p-loop
 2010 CONTINUE
*     end of the jbc-loop
 2011 CONTINUE
*2011 bailed out of the jbc-loop
      DO 2012 p = igl, MIN0( igl + KBL - 1, N )
         SVA(p) = DABS(SVA(p))
 2012 CONTINUE
***
 2000 CONTINUE
*2000 :: end of the ibr-loop
*
*     .. update SVA(N)
      IF ((SVA(N) .LT. ROOTBIG).AND.(SVA(N) .GT. ROOTSFMIN)) THEN
         SVA(N) = DNRM2( M, A(1,N), 1 ) * WORK(N)
      ELSE
         T    = ZERO
         AAPP = ZERO
         CALL DLASSQ( M, A(1,N), 1, T, AAPP )
         SVA(N) = T * DSQRT(AAPP) * WORK(N)
      END IF
*
*     Additional steering devices
*
      IF ( ( i.LT.SWBAND ) .AND. ( ( MXAAPQ.LE.ROOTTOL ) .OR.
     &     ( ISWROT .LE. N ) ) )
     &   SWBAND = i
*
      IF ( (i .GT. SWBAND+1) .AND. (MXAAPQ .LT. DSQRT(DBLE(N))*TOL)
     &   .AND. (DBLE(N)*MXAAPQ*MXSINJ .LT. TOL) ) THEN
        GO TO 1994
      END IF
*
      IF ( NOTROT .GE. EMPTSW ) GO TO 1994
*
 1993 CONTINUE
*     end i=1:NSWEEP loop
*
* #:( Reaching this point means that the procedure has not converged.
      INFO = NSWEEP - 1
      GO TO 1995
*
 1994 CONTINUE
* #:) Reaching this point means numerical convergence after the i-th
*     sweep.
*
      INFO = 0
* #:) INFO = 0 confirms successful iterations.
 1995 CONTINUE
*
*     Sort the singular values and find how many are above
*     the underflow threshold.
*
      N2 = 0
      N4 = 0
      DO 5991 p = 1, N - 1
         q = IDAMAX( N-p+1, SVA(p), 1 ) + p - 1
         IF ( p .NE. q ) THEN
            TEMP1  = SVA(p)
            SVA(p) = SVA(q)
            SVA(q) = TEMP1
            TEMP1   = WORK(p)
            WORK(p) = WORK(q)
            WORK(q) = TEMP1
            CALL DSWAP( M, A(1,p), 1, A(1,q), 1 )
            IF ( RSVEC ) CALL DSWAP( MVL, V(1,p), 1, V(1,q), 1 )
         END IF
         IF ( SVA(p) .NE. ZERO ) THEN
            N4 = N4 + 1
            IF ( SVA(p)*SCALE .GT. SFMIN ) N2 = N2 + 1
         END IF
 5991 CONTINUE
      IF ( SVA(N) .NE. ZERO ) THEN
         N4 = N4 + 1
         IF ( SVA(N)*SCALE .GT. SFMIN ) N2 = N2 + 1
      END IF
*
*     Normalize the left singular vectors.
*
      IF ( LSVEC .OR. UCTOL ) THEN
         DO 1998 p = 1, N2
            CALL DSCAL( M, WORK(p) / SVA(p), A(1,p), 1 )
 1998    CONTINUE
      END IF
*
*     Scale the product of Jacobi rotations (assemble the fast rotations).
*
      IF ( RSVEC ) THEN
         IF ( APPLV ) THEN
            DO 2398 p = 1, N
               CALL DSCAL( MVL, WORK(p), V(1,p), 1 )
 2398       CONTINUE
         ELSE
            DO 2399 p = 1, N
               TEMP1 = ONE / DNRM2(MVL, V(1,p), 1 )
               CALL DSCAL( MVL, TEMP1, V(1,p), 1 )
 2399       CONTINUE
         END IF
      END IF
*
*     Undo scaling, if necessary (and possible).
      IF ( ((SCALE.GT.ONE).AND.(SVA(1).LT.(BIG/SCALE)))
     & .OR.((SCALE.LT.ONE).AND.(SVA(N2).GT.(SFMIN/SCALE))) ) THEN
         DO 2400 p = 1, N
            SVA(p) = SCALE*SVA(p)
 2400    CONTINUE
         SCALE = ONE
      END IF
*
      WORK(1) = SCALE
*     The singular values of A are SCALE*SVA(1:N). If SCALE.NE.ONE
*     then some of the singular values may overflow or underflow and
*     the spectrum is given in this factored representation.
*
      WORK(2) = DBLE(N4)
*     N4 is the number of computed nonzero singular values of A.
*
      WORK(3) = DBLE(N2)
*     N2 is the number of singular values of A greater than SFMIN.
*     If N2<N, SVA(N2:N) contains ZEROS and/or denormalized numbers
*     that may carry some information.
*
      WORK(4) = DBLE(i)
*     i is the index of the last sweep before declaring convergence.
*
      WORK(5) = MXAAPQ
*     MXAAPQ is the largest absolute value of scaled pivots in the
*     last sweep
*
      WORK(6) = MXSINJ
*     MXSINJ is the largest absolute value of the sines of Jacobi angles
*     in the last sweep
*
      RETURN
*     ..
*     .. END OF DGESVJ
*     ..
      END
*


C File: arrays-constr-06.f
C This program has a simple 1-D array with the default lower bound of 1.
C It shows the use of an array constructor to initialize the array.

      program main
      implicit none

C     A is a 1-D array of integers with an implicit lower-bound = 1
C     and an upper bound of 12.
      integer, dimension(12) :: A
      integer, dimension(12) :: B = (/12,11,10,9,8,7,6,5,4,3,2,1/)
      integer, dimension(12) :: C = (/1,3,5,7,9,11,13,15,17,19,21,23/)
      integer :: i

C     array constructor III -- implied do loop, nested array expressions
C     In this example, the array expression consists of nested array
C     references.  The inner expression B(1:12) gives the sequence of
C     values of B's elements in the order B(1), B(2), ..., B(12), i.e.:
C
C         12, 11, 10, ..., 3, 2, 1
C
C     The outer expression uses this sequence of values to index into
C     the array C, giving the sequence of values of C's elements in the
C     order C(12), C(11), C(10), ..., C(3), C(2), C(1).  The sequence of
C     values assigned to the elements of A is therefore:
C
C         23, 21, 19, 17, 15, 13, 11, 9, 7, 5, 3, 1

      A = (/ (C(B(1:12))) /)

      do i = 1, 12
          write (*,10) A(i)
      end do

 10   format(I5)

      stop
      end program main


!       VERSION 1.0     2/5/99
!*********************************************************************

!                         SUBROUTINE IPAR
!                         ===============

!        This integer function subroutine returns the value -1
!        if its argument is odd, and +1 if it is even.

!*********************************************************************

    integer function ipar(num)

    integer :: num

!#####################################################################

    if (mod(num,2) == 0) then
        ipar=1
    else
        ipar=-1
    end if
    return
    end function ipar


      SUBROUTINE DSVDC(X,LDX,N,P,S,E,U,LDU,V,LDV,WORK,JOB,INFO)
      INTEGER LDX,N,P,LDU,LDV,JOB,INFO
      DOUBLE PRECISION X(LDX,1),S(1),E(1),U(LDU,1),V(LDV,1),WORK(1)
C
C
C     DSVDC IS A SUBROUTINE TO REDUCE A DOUBLE PRECISION NXP MATRIX X
C     BY ORTHOGONAL TRANSFORMATIONS U AND V TO DIAGONAL FORM.  THE
C     DIAGONAL ELEMENTS S(I) ARE THE SINGULAR VALUES OF X.  THE
C     COLUMNS OF U ARE THE CORRESPONDING LEFT SINGULAR VECTORS,
C     AND THE COLUMNS OF V THE RIGHT SINGULAR VECTORS.
C
C     ON ENTRY
C
C         X         DOUBLE PRECISION(LDX,P), WHERE LDX.GE.N.
C                   X CONTAINS THE MATRIX WHOSE SINGULAR VALUE
C                   DECOMPOSITION IS TO BE COMPUTED.  X IS
C                   DESTROYED BY DSVDC.
C
C         LDX       INTEGER.
C                   LDX IS THE LEADING DIMENSION OF THE ARRAY X.
C
C         N         INTEGER.
C                   N IS THE NUMBER OF COLUMNS OF THE MATRIX X.
C
C         P         INTEGER.
C                   P IS THE NUMBER OF ROWS OF THE MATRIX X.
C
C         LDU       INTEGER.
C                   LDU IS THE LEADING DIMENSION OF THE ARRAY U.
C                   (SEE BELOW).
C
C         LDV       INTEGER.
C                   LDV IS THE LEADING DIMENSION OF THE ARRAY V.
C                   (SEE BELOW).
C
C         WORK      DOUBLE PRECISION(N).
C                   WORK IS A SCRATCH ARRAY.
C
C         JOB       INTEGER.
C                   JOB CONTROLS THE COMPUTATION OF THE SINGULAR
C                   VECTORS.  IT HAS THE DECIMAL EXPANSION AB
C                   WITH THE FOLLOWING MEANING
C
C                        A.EQ.0    DO NOT COMPUTE THE LEFT SINGULAR
C                                  VECTORS.
C                        A.EQ.1    RETURN THE N LEFT SINGULAR VECTORS
C                                  IN U.
C                        A.GE.2    RETURN THE FIRST MIN(N,P) SINGULAR
C                                  VECTORS IN U.
C                        B.EQ.0    DO NOT COMPUTE THE RIGHT SINGULAR
C                                  VECTORS.
C                        B.EQ.1    RETURN THE RIGHT SINGULAR VECTORS
C                                  IN V.
C
C     ON RETURN
C
C         S         DOUBLE PRECISION(MM), WHERE MM=MIN(N+1,P).
C                   THE FIRST MIN(N,P) ENTRIES OF S CONTAIN THE
C                   SINGULAR VALUES OF X ARRANGED IN DESCENDING
C                   ORDER OF MAGNITUDE.
C
C         E         DOUBLE PRECISION(P).
C                   E ORDINARILY CONTAINS ZEROS.  HOWEVER SEE THE
C                   DISCUSSION OF INFO FOR EXCEPTIONS.
C
C         U         DOUBLE PRECISION(LDU,K), WHERE LDU.GE.N.  IF
C                                   JOBA.EQ.1 THEN K.EQ.N, IF JOBA.GE.2
C                                   THEN K.EQ.MIN(N,P).
C                   U CONTAINS THE MATRIX OF RIGHT SINGULAR VECTORS.
C                   U IS NOT REFERENCED IF JOBA.EQ.0.  IF N.LE.P
C                   OR IF JOBA.EQ.2, THEN U MAY BE IDENTIFIED WITH X
C                   IN THE SUBROUTINE CALL.
C
C         V         DOUBLE PRECISION(LDV,P), WHERE LDV.GE.P.
C                   V CONTAINS THE MATRIX OF RIGHT SINGULAR VECTORS.
C                   V IS NOT REFERENCED IF JOB.EQ.0.  IF P.LE.N,
C                   THEN V MAY BE IDENTIFIED WITH X IN THE
C                   SUBROUTINE CALL.
C
C         INFO      INTEGER.
C                   THE SINGULAR VALUES (AND THEIR CORRESPONDING
C                   SINGULAR VECTORS) S(INFO+1),S(INFO+2),...,S(M)
C                   ARE CORRECT (HERE M=MIN(N,P)).  THUS IF
C                   INFO.EQ.0, ALL THE SINGULAR VALUES AND THEIR
C                   VECTORS ARE CORRECT.  IN ANY EVENT, THE MATRIX
C                   B = TRANS(U)*X*V IS THE BIDIAGONAL MATRIX
C                   WITH THE ELEMENTS OF S ON ITS DIAGONAL AND THE
C                   ELEMENTS OF E ON ITS SUPER-DIAGONAL (TRANS(U)
C                   IS THE TRANSPOSE OF U).  THUS THE SINGULAR
C                   VALUES OF X AND B ARE THE SAME.
C
C     LINPACK. THIS VERSION DATED 03/19/79 .
C     G.W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB.
C
C     DSVDC USES THE FOLLOWING FUNCTIONS AND SUBPROGRAMS.
C
C     EXTERNAL DROT
C     BLAS DAXPY,DDOT,DSCAL,DSWAP,DNRM2,DROTG
C     FORTRAN DABS,DMAX1,MAX0,MIN0,MOD,DSQRT
C
C     INTERNAL VARIABLES
C
      INTEGER I,ITER,J,JOBU,K,KASE,KK,L,LL,LLS,LM1,LP1,LS,LU,M,MAXIT,
     *        MM,MM1,MP1,NCT,NCTP1,NCU,NRT,NRTP1
      DOUBLE PRECISION DDOT,T,R
      DOUBLE PRECISION B,C,CS,EL,EMM1,F,G,DNRM2,SCALE,SHIFT,SL,SM,SN,
     *                 SMM1,T1,TEST,ZTEST
      LOGICAL WANTU,WANTV
C
C
C     SET THE MAXIMUM NUMBER OF ITERATIONS.
C
      MAXIT = 30
C
C     DETERMINE WHAT IS TO BE COMPUTED.
C
      WANTU = .FALSE.
      WANTV = .FALSE.
      JOBU = MOD(JOB,100)/10
      NCU = N
      IF (JOBU .GT. 1) NCU = MIN0(N,P)
      IF (JOBU .NE. 0) WANTU = .TRUE.
      IF (MOD(JOB,10) .NE. 0) WANTV = .TRUE.
C
C     REDUCE X TO BIDIAGONAL FORM, STORING THE DIAGONAL ELEMENTS
C     IN S AND THE SUPER-DIAGONAL ELEMENTS IN E.
C
      INFO = 0
      NCT = MIN0(N-1,P)
      NRT = MAX0(0,MIN0(P-2,N))
      LU = MAX0(NCT,NRT)
      IF (LU .LT. 1) GO TO 170
      DO 160 L = 1, LU
         LP1 = L + 1
         IF (L .GT. NCT) GO TO 20
C
C           COMPUTE THE TRANSFORMATION FOR THE L-TH COLUMN AND
C           PLACE THE L-TH DIAGONAL IN S(L).
C
            S(L) = DNRM2(N-L+1,X(L,L),1)
            IF (S(L) .EQ. 0.0D0) GO TO 10
               IF (X(L,L) .NE. 0.0D0) S(L) = DSIGN(S(L),X(L,L))
               CALL DSCAL(N-L+1,1.0D0/S(L),X(L,L),1)
               X(L,L) = 1.0D0 + X(L,L)
   10       CONTINUE
            S(L) = -S(L)
   20    CONTINUE
         IF (P .LT. LP1) GO TO 50
         DO 40 J = LP1, P
            IF (L .GT. NCT) GO TO 30
            IF (S(L) .EQ. 0.0D0) GO TO 30
C
C              APPLY THE TRANSFORMATION.
C
               T = -DDOT(N-L+1,X(L,L),1,X(L,J),1)/X(L,L)
               CALL DAXPY(N-L+1,T,X(L,L),1,X(L,J),1)
   30       CONTINUE
C
C           PLACE THE L-TH ROW OF X INTO  E FOR THE
C           SUBSEQUENT CALCULATION OF THE ROW TRANSFORMATION.
C
            E(J) = X(L,J)
   40    CONTINUE
   50    CONTINUE
         IF (.NOT.WANTU .OR. L .GT. NCT) GO TO 70
C
C           PLACE THE TRANSFORMATION IN U FOR SUBSEQUENT BACK
C           MULTIPLICATION.
C
            DO 60 I = L, N
               U(I,L) = X(I,L)
   60       CONTINUE
   70    CONTINUE
         IF (L .GT. NRT) GO TO 150
C
C           COMPUTE THE L-TH ROW TRANSFORMATION AND PLACE THE
C           L-TH SUPER-DIAGONAL IN E(L).
C
            E(L) = DNRM2(P-L,E(LP1),1)
            IF (E(L) .EQ. 0.0D0) GO TO 80
               IF (E(LP1) .NE. 0.0D0) E(L) = DSIGN(E(L),E(LP1))
               CALL DSCAL(P-L,1.0D0/E(L),E(LP1),1)
               E(LP1) = 1.0D0 + E(LP1)
   80       CONTINUE
            E(L) = -E(L)
            IF (LP1 .GT. N .OR. E(L) .EQ. 0.0D0) GO TO 120
C
C              APPLY THE TRANSFORMATION.
C
               DO 90 I = LP1, N
                  WORK(I) = 0.0D0
   90          CONTINUE
               DO 100 J = LP1, P
                  CALL DAXPY(N-L,E(J),X(LP1,J),1,WORK(LP1),1)
  100          CONTINUE
               DO 110 J = LP1, P
                  CALL DAXPY(N-L,-E(J)/E(LP1),WORK(LP1),1,X(LP1,J),1)
  110          CONTINUE
  120       CONTINUE
            IF (.NOT.WANTV) GO TO 140
C
C              PLACE THE TRANSFORMATION IN V FOR SUBSEQUENT
C              BACK MULTIPLICATION.
C
               DO 130 I = LP1, P
                  V(I,L) = E(I)
  130          CONTINUE
  140       CONTINUE
  150    CONTINUE
  160 CONTINUE
  170 CONTINUE
C
C     SET UP THE FINAL BIDIAGONAL MATRIX OR ORDER M.
C
      M = MIN0(P,N+1)
      NCTP1 = NCT + 1
      NRTP1 = NRT + 1
      IF (NCT .LT. P) S(NCTP1) = X(NCTP1,NCTP1)
      IF (N .LT. M) S(M) = 0.0D0
      IF (NRTP1 .LT. M) E(NRTP1) = X(NRTP1,M)
      E(M) = 0.0D0
C
C     IF REQUIRED, GENERATE U.
C
      IF (.NOT.WANTU) GO TO 300
         IF (NCU .LT. NCTP1) GO TO 200
         DO 190 J = NCTP1, NCU
            DO 180 I = 1, N
               U(I,J) = 0.0D0
  180       CONTINUE
            U(J,J) = 1.0D0
  190    CONTINUE
  200    CONTINUE
         IF (NCT .LT. 1) GO TO 290
         DO 280 LL = 1, NCT
            L = NCT - LL + 1
            IF (S(L) .EQ. 0.0D0) GO TO 250
               LP1 = L + 1
               IF (NCU .LT. LP1) GO TO 220
               DO 210 J = LP1, NCU
                  T = -DDOT(N-L+1,U(L,L),1,U(L,J),1)/U(L,L)
                  CALL DAXPY(N-L+1,T,U(L,L),1,U(L,J),1)
  210          CONTINUE
  220          CONTINUE
               CALL DSCAL(N-L+1,-1.0D0,U(L,L),1)
               U(L,L) = 1.0D0 + U(L,L)
               LM1 = L - 1
               IF (LM1 .LT. 1) GO TO 240
               DO 230 I = 1, LM1
                  U(I,L) = 0.0D0
  230          CONTINUE
  240          CONTINUE
            GO TO 270
  250       CONTINUE
               DO 260 I = 1, N
                  U(I,L) = 0.0D0
  260          CONTINUE
               U(L,L) = 1.0D0
  270       CONTINUE
  280    CONTINUE
  290    CONTINUE
  300 CONTINUE
C
C     IF IT IS REQUIRED, GENERATE V.
C
      IF (.NOT.WANTV) GO TO 350
         DO 340 LL = 1, P
            L = P - LL + 1
            LP1 = L + 1
            IF (L .GT. NRT) GO TO 320
            IF (E(L) .EQ. 0.0D0) GO TO 320
               DO 310 J = LP1, P
                  T = -DDOT(P-L,V(LP1,L),1,V(LP1,J),1)/V(LP1,L)
                  CALL DAXPY(P-L,T,V(LP1,L),1,V(LP1,J),1)
  310          CONTINUE
  320       CONTINUE
            DO 330 I = 1, P
               V(I,L) = 0.0D0
  330       CONTINUE
            V(L,L) = 1.0D0
  340    CONTINUE
  350 CONTINUE
C
C     MAIN ITERATION LOOP FOR THE SINGULAR VALUES.
C
      MM = M
      ITER = 0
  360 CONTINUE
C
C        QUIT IF ALL THE SINGULAR VALUES HAVE BEEN FOUND.
C
C     ...EXIT
         IF (M .EQ. 0) GO TO 620
C
C        IF TOO MANY ITERATIONS HAVE BEEN PERFORMED, SET
C        FLAG AND RETURN.
C
         IF (ITER .LT. MAXIT) GO TO 370
            INFO = M
C     ......EXIT
            GO TO 620
  370    CONTINUE
C
C        THIS SECTION OF THE PROGRAM INSPECTS FOR
C        NEGLIGIBLE ELEMENTS IN THE S AND E ARRAYS.  ON
C        COMPLETION THE VARIABLES KASE AND L ARE SET AS FOLLOWS.
C
C           KASE = 1     IF S(M) AND E(L-1) ARE NEGLIGIBLE AND L.LT.M
C           KASE = 2     IF S(L) IS NEGLIGIBLE AND L.LT.M
C           KASE = 3     IF E(L-1) IS NEGLIGIBLE, L.LT.M, AND
C                        S(L), ..., S(M) ARE NOT NEGLIGIBLE (QR STEP).
C           KASE = 4     IF E(M-1) IS NEGLIGIBLE (CONVERGENCE).
C
         DO 390 LL = 1, M
            L = M - LL
C        ...EXIT
            IF (L .EQ. 0) GO TO 400
            TEST = DABS(S(L)) + DABS(S(L+1))
            ZTEST = TEST + DABS(E(L))
            IF (ZTEST .NE. TEST) GO TO 380
               E(L) = 0.0D0
C        ......EXIT
               GO TO 400
  380       CONTINUE
  390    CONTINUE
  400    CONTINUE
         IF (L .NE. M - 1) GO TO 410
            KASE = 4
         GO TO 480
  410    CONTINUE
            LP1 = L + 1
            MP1 = M + 1
            DO 430 LLS = LP1, MP1
               LS = M - LLS + LP1
C           ...EXIT
               IF (LS .EQ. L) GO TO 440
               TEST = 0.0D0
               IF (LS .NE. M) TEST = TEST + DABS(E(LS))
               IF (LS .NE. L + 1) TEST = TEST + DABS(E(LS-1))
               ZTEST = TEST + DABS(S(LS))
               IF (ZTEST .NE. TEST) GO TO 420
                  S(LS) = 0.0D0
C           ......EXIT
                  GO TO 440
  420          CONTINUE
  430       CONTINUE
  440       CONTINUE
            IF (LS .NE. L) GO TO 450
               KASE = 3
            GO TO 470
  450       CONTINUE
            IF (LS .NE. M) GO TO 460
               KASE = 1
            GO TO 470
  460       CONTINUE
               KASE = 2
               L = LS
  470       CONTINUE
  480    CONTINUE
         L = L + 1
C
C        PERFORM THE TASK INDICATED BY KASE.
C
         GO TO (490,520,540,570), KASE
C
C        DEFLATE NEGLIGIBLE S(M).
C
  490    CONTINUE
            MM1 = M - 1
            F = E(M-1)
            E(M-1) = 0.0D0
            DO 510 KK = L, MM1
               K = MM1 - KK + L
               T1 = S(K)
               CALL DROTG(T1,F,CS,SN)
               S(K) = T1
               IF (K .EQ. L) GO TO 500
                  F = -SN*E(K-1)
                  E(K-1) = CS*E(K-1)
  500          CONTINUE
               IF (WANTV) CALL DROT(P,V(1,K),1,V(1,M),1,CS,SN)
  510       CONTINUE
         GO TO 610
C
C        SPLIT AT NEGLIGIBLE S(L).
C
  520    CONTINUE
            F = E(L-1)
            E(L-1) = 0.0D0
            DO 530 K = L, M
               T1 = S(K)
               CALL DROTG(T1,F,CS,SN)
               S(K) = T1
               F = -SN*E(K)
               E(K) = CS*E(K)
               IF (WANTU) CALL DROT(N,U(1,K),1,U(1,L-1),1,CS,SN)
  530       CONTINUE
         GO TO 610
C
C        PERFORM ONE QR STEP.
C
  540    CONTINUE
C
C           CALCULATE THE SHIFT.
C
            SCALE = DMAX1(DABS(S(M)),DABS(S(M-1)),DABS(E(M-1)),
     *                    DABS(S(L)),DABS(E(L)))
            SM = S(M)/SCALE
            SMM1 = S(M-1)/SCALE
            EMM1 = E(M-1)/SCALE
            SL = S(L)/SCALE
            EL = E(L)/SCALE
            B = ((SMM1 + SM)*(SMM1 - SM) + EMM1**2)/2.0D0
            C = (SM*EMM1)**2
            SHIFT = 0.0D0
            IF (B .EQ. 0.0D0 .AND. C .EQ. 0.0D0) GO TO 550
               SHIFT = DSQRT(B**2+C)
               IF (B .LT. 0.0D0) SHIFT = -SHIFT
               SHIFT = C/(B + SHIFT)
  550       CONTINUE
            F = (SL + SM)*(SL - SM) - SHIFT
            G = SL*EL
C
C           CHASE ZEROS.
C
            MM1 = M - 1
            DO 560 K = L, MM1
               CALL DROTG(F,G,CS,SN)
               IF (K .NE. L) E(K-1) = F
               F = CS*S(K) + SN*E(K)
               E(K) = CS*E(K) - SN*S(K)
               G = SN*S(K+1)
               S(K+1) = CS*S(K+1)
               IF (WANTV) CALL DROT(P,V(1,K),1,V(1,K+1),1,CS,SN)
               CALL DROTG(F,G,CS,SN)
               S(K) = F
               F = CS*E(K) + SN*S(K+1)
               S(K+1) = -SN*E(K) + CS*S(K+1)
               G = SN*E(K+1)
               E(K+1) = CS*E(K+1)
               IF (WANTU .AND. K .LT. N)
     *            CALL DROT(N,U(1,K),1,U(1,K+1),1,CS,SN)
  560       CONTINUE
            E(M-1) = F
            ITER = ITER + 1
         GO TO 610
C
C        CONVERGENCE.
C
  570    CONTINUE
C
C           MAKE THE SINGULAR VALUE  POSITIVE.
C
            IF (S(L) .GE. 0.0D0) GO TO 580
               S(L) = -S(L)
               IF (WANTV) CALL DSCAL(P,-1.0D0,V(1,L),1)
  580       CONTINUE
C
C           ORDER THE SINGULAR VALUE.
C
  590       IF (L .EQ. MM) GO TO 600
C           ...EXIT
               IF (S(L) .GE. S(L+1)) GO TO 600
               T = S(L)
               S(L) = S(L+1)
               S(L+1) = T
               IF (WANTV .AND. L .LT. P)
     *            CALL DSWAP(P,V(1,L),1,V(1,L+1),1)
               IF (WANTU .AND. L .LT. N)
     *            CALL DSWAP(N,U(1,L),1,U(1,L+1),1)
               L = L + 1
            GO TO 590
  600       CONTINUE
            ITER = 0
            M = M - 1
  610    CONTINUE
      GO TO 360
  620 CONTINUE
      RETURN
      END


      SUBROUTINE strain2stress(stress,strain,vp,vs,dens)
C----
C CALCULATE STRESS FROM STRAIN ASSUMING ELASTIC, ISOTROPIC MATERIAL.
C----
      IMPLICIT NONE
      REAL*8 stress(3,3),strain(3,3),vp,vs,dens,lam,mu,diag

      mu  = dens*vs*vs
      lam = dens*vp*vp - 2.0d0*mu
      if (mu.lt.10.0e9) mu = 10.0e9
      if (lam.lt.10.0e9) lam = 10.0e9

      diag = strain(1,1) + strain(2,2) + strain(3,3)

      stress(1,1) = lam*diag + 2.0d0*mu*strain(1,1)
      stress(2,2) = lam*diag + 2.0d0*mu*strain(2,2)
      stress(3,3) = lam*diag + 2.0d0*mu*strain(3,3)
      stress(1,2) = 2.0d0*mu*strain(1,2)
      stress(1,3) = 2.0d0*mu*strain(1,3)
      stress(2,3) = 2.0d0*mu*strain(2,3)
      stress(2,1) = stress(1,2)
      stress(3,1) = stress(1,3)
      stress(3,2) = stress(2,3)

      RETURN
      END

C----------------------------------------------------------------------C

      SUBROUTINE coulomb(coul,norml,shear,stress,strin,dipin,rakin,
     1                   coeffr)
C----
C GIVEN A STRESS FIELD AND THE ORIENTATION OF A TARGET PLANE, CALCULATE
C THE NORMAL, SHEAR, AND COULOMB STRESS ON THE PLANE.
C----
      IMPLICIT none
      REAL*8 pi,d2r
      PARAMETER (pi=4.0d0*datan(1.0d0),d2r=pi/180.0d0)
      REAL*8 coul,norml,shear,stress(3,3),coeffr,mag
      REAL*8 strin,dipin,rakin,str,dip,rak,n(3),trac(3),r(3),s(3)
      INTEGER i
C----
C NORMAL VECTOR OF TARGET PLANE
C----
      str = strin*d2r
      dip = dipin*d2r
      rak = rakin*d2r
      n(1) = dsin(dip)*dsin(str+pi/2.0d0)
      n(2) = dsin(dip)*dcos(str+pi/2.0d0)
      n(3) = dcos(dip)
C----
C TRACTION ON TARGET PLANE
C----
      do 11 i = 1,3
          trac(i) = stress(i,1)*n(1)+stress(i,2)*n(2)+stress(i,3)*n(3)
   11 continue
C----
C NORMAL STRESS ON TARGET PLANE
C (POSITIVE => DILATION => COULOMB STRESS INCREASES)
C----
      norml = 0.0d0
      do 12 i = 1,3
          norml = norml + trac(i)*n(i)
   12 continue
C----
C RAKE VECTOR OF TARGET PLANE
C----
      r(1) =  dcos(str-pi/2.0d0)*dcos(rak)
     1                          + dsin(str-pi/2.0d0)*dsin(rak)*dcos(dip)
      r(2) = -dsin(str-pi/2.0d0)*dcos(rak)
     1                          + dcos(str-pi/2.0d0)*dsin(rak)*dcos(dip)
      r(3) =                                         dsin(rak)*dsin(dip)
C----
C SHEAR STRESS (VECTOR) ON TARGET PLANE
C----
      s(1) = trac(1) - norml*n(1)
      s(2) = trac(2) - norml*n(2)
      s(3) = trac(3) - norml*n(3)
C----
C COMPONENT OF SHEAR STRESS IN DIRECTION OF RAKE ON TARGET PLANE
C----
      shear = s(1)*r(1) + s(2)*r(2) + s(3)*r(3)
C----
C COULOMB STRESS CHANGE
C----
      coul = shear + coeffr*norml

      RETURN
      END


      subroutine brooks_corey_cap(s, p1, p2, lambda, cmax, cut1, cut2,
     &     prop1, dprop11)
!***********************************************************************
! Copyright 2009 Los Alamos National Security, LLC  All rights reserved
! Unless otherwise indicated,  this information has been authored by an
! employee or employees of the Los Alamos National Security, LLC (LANS),
! operator of the  Los  Alamos National  Laboratory  under Contract  No.
! DE-AC52-06NA25396  with  the U. S. Department  of  Energy.  The  U. S.
! Government   has   rights  to  use,  reproduce,  and  distribute  this
! information.  The  public may copy  and  use this  information without
! charge, provided that this  Notice and any statement of authorship are
! reproduced on all copies.  Neither  the  Government nor LANS makes any
! warranty,   express   or   implied,   or   assumes  any  liability  or
! responsibility for the use of this information.
!***********************************************************************
!D1
!D1 PURPOSE
!D1
!D1 calculate Brooks-Corey capillary pressure
! 2-phase
! input:  s is wetting phase saturation
!         p1 is residual wetting phase saturation
!         p2 is max wetting phase saturation
!         cut1,cut2 are cutoff parameters
!  cut2 is saturation value; if s > cut2; brooks-corey, otherwise, linear
!  cut1 is only used for s < cut2 calculations
!  cp at s=0 will be cut1*cp(at s=cut2)
!
!         cmax = entry pressure
!         lambda (Li and Horne, 2006)
! output: prop1 is cap pressure
!		dprop11 is dcp/ds
!***********************************************************************

c      use comdi
      use comrlp

      implicit none
      real*8 s, p1, p2, lambda, prop1, dprop11
      real*8 rp31, sw_star, ds, fac_use, fac_min
      real*8 smcut, smcutm, cut1, cut2, slcut, hcut, cmax
      real*8 slope, dhp, hmax, hmin
      integer iflag, fac
      parameter (fac_min=2.d0)
      parameter (hmin=0.d0)

      rp31 = (2.d0+3.d0*lambda)/lambda
      sw_star = (s-p1)/(1.d0-p1)
      ds = 1.d0/(1.d0-p1)
c     calculate cap pressures
c     rp12 is entry pressure
c     sucut = 1.d0
c     rp15, rp16 are cutoff fitting parameters
      smcut=(cut2-p1)/(p2-p1)
      smcutm=max(smcut,1.d-3)
      slcut=smcutm*(p2-p1)+p1
      if(s.gt.0.d0) then
         if(s.le.cut2) then
            hcut=cmax*(smcutm**(-1.d0/lambda))
            if(cut1.gt.0.0) then
c     a multiple of value of
               fac_use=max(cut1,fac_min)
               hmax=hcut*cut1
               slope=-(hmax-hcut)/slcut
            else
c     linear fit from saturation curve
               ds=1.d0/(p2-p1)
               dhp=cmax*(-1.d0/lambda)*
     $              smcutm**((-lambda-1.d0)/lambda)*ds
               hmax=hcut-dhp*smcutm
               slope=-(hmax-hcut)/smcutm
            endif
            prop1=slope*s+hmax
            dprop11=slope
         else
            prop1 = cmax*((s-p1)/(p2-p1))**(-1.d0/lambda)
            dprop11 = cmax*(-1.d0/lambda)*
     $           ((s-p1)**((-lambda-1.d0)/lambda))/
     $           ((p2-p1)**(-1.d0/lambda))
         endif
      elseif(s.le.0.d0) then
         hcut=cmax*(smcutm**(-1.d0/lambda))
         if(cut1.gt.0.0) then
c     a multiple of value of
            fac_use=max(cut1,fac_min)
            hmax=hcut*cut1
c           write(45,*) 'fac_use',hcut,cut1
         else
c     linear fit from saturation curve
            ds=1.d0/(lambda-p1)
            dhp=cmax*(-1.d0/lambda)*
     $           smcutm**((-lambda-1.d0)/lambda)*ds
            hmax=hcut-dhp*smcutm
c           write(45,*) 'linear fit',ds,dhp,hmax

         endif
         prop1=hmax
         dprop11=0.d0
      endif

      end subroutine brooks_corey_cap


!***********************************************************************
!
      function relci_qed_F_Klarsfeld(n,kappa,Z)                   result(F)
!--------------------------------------------------------------------
! Estimates the function  F (Z*\alpha) by using a series expansion
! from S Klarsfeld and A Maquet, Physics Letters  43B (1973) 201,
! Eqs (1) and (2) and the table of Bethe logarithms. The
! vacuum-polarization contribution in Eq (2) is omitted.
! This procedure is adapted from RCI92 of GRASP92, written
! by Farid A Parpia, to the Fortran 95 standard.
!-----------------------------------------------
!...Translated by Pacific-Sierra Research 77to90  4.3E  14:04:58   1/ 3/07
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      IMPLICIT NONE
      !
      integer, intent(in)               :: n, kappa
      real(double), intent(in)         :: Z
      real(double)                     :: F
      !
      real(double), dimension(36), parameter :: bethe = &
         (/ 2.9841285_dp,   2.8117699_dp,  -0.0300167_dp,   2.7676636_dp, &
           -0.0381902_dp,  -0.0052321_dp,   2.7498118_dp,  -0.0419549_dp, &
           -0.0067409_dp,  -0.0017337_dp,   2.7408237_dp,  -0.0440347_dp, &
           -0.0076008_dp,  -0.0022022_dp,  -0.0007721_dp,   2.7356642_dp, &
           -0.0453122_dp,  -0.0081472_dp,  -0.0025022_dp,  -0.0009628_dp, &
           -0.0004079_dp,   2.7324291_dp,  -0.0461552_dp,  -0.0085192_dp, &
           -0.0027091_dp,  -0.0010945_dp,  -0.0004997_dp,  -0.0002409_dp, &
            2.7302673_dp,  -0.0467413_dp,  -0.0087850_dp,  -0.0028591_dp, &
           -0.0011904_dp,  -0.0005665_dp,  -0.0002904_dp,  -0.0001539_dp /)
      !
      real(double), parameter :: C401 = 11.0_dp/24.0_dp,                 &
                               C402 = 3.0_dp/8.0_dp, ovlfac = 4.0_dp/3.0_dp
      !
      integer       :: l, loc
      real(double) :: bethel, factor, term
      !
      ! Ensure that the principal quantum number is in range
      if (n < 1   .or.   n > 8) then
         print *, "Principal quantum number,",n,", should be in the range 1-8."
         stop     "relci_qed_F_Klarsfeld(): program stop A."
      end if
      !
      l = angular_momentum_l(kappa)
      if (l > n-1) then
         print *, "Kappa = ",kappa," is out of range for n = ",n,"."
         stop     "relci_qed_F_Klarsfeld(): program stop B."
      end if
      !
      ! Find the appropriate entry in the table
      loc    = (n*n-n)/2+l+1
      bethel = bethe(loc)
      !
      ! Determine the quantity in square brackets in eq.(1) of
      ! Klarsfeld and Maquet
      term = -bethel
      !
      if (kappa > 0) then
         term = term - c402 / (l*(l+l+one))
      else
         term = term + c402 / ((l+one)*(l+l+one))
         if (kappa == -1) then
            factor = log (Z/c)
            factor = - (factor + factor)
            term   = term + factor + c401
         end if
      end if
      !
      F = ovlfac * term
      !
   end function relci_qed_F_Klarsfeld


!	This function computes the modified Cholesky decomposition
!	of the n by n nonnegative definite symmecholc macholx sym.
!	tolsing is the singularity tolerance.
function chol(sym,tolsing)
implicit none
real(kind=8),intent(in)::sym(:,:),tolsing
real(kind=8)::chol(size(sym,1),size(sym,1))
real(kind=8)::minsize
integer::row,col
do row=1,size(sym,1)
	minsize = tolsing*sym(row,row)
	chol(1,row) = sym(row,1)
	if(row>1) then
		if(chol(1,1)>0.0_8) chol(row,1) = chol(1,row)/chol(1,1)
	 	do col=2,row
	 		if(col<row.and.chol(col,col)<=0.0)cycle
	 		chol(col,row) = sym(row,col)-dot_product(chol(row,1:col-1),chol(1:col-1,col))
	 		if(col<row) chol(row,col) = chol(col,row)/chol(col,col)
	 	end do
	end if
	if(chol(row,row)>minsize)cycle

	do col=1,size(sym,1)
		if(row/=col) then
			chol(row,col) = 0.0_8
			chol(col,row) = 0.0_8
		end if
	end do
end do
return
end function chol


! This file is modified from diag.F90 in
!     www.geosci-model-dev.net/5/887/2012/gmd-5-887-2012-supplment.zip
! supplementary material for the paper [LSPT2012]
!     Lauritzen, Skamarock, Prather, Taylor, A standard test case suite for
!     two-dimensional linear transport on the sphere, GMD 2012.

MODULE diag
  use iso_c_binding

  IMPLICIT NONE
  !
  ! Numerical mixing diagnostics are computed in Subroutine correlation_diag below.
  !
  ! Filament preservation diagnostic is computed in Subroutine filament_diag below.
  !
  ! It is assumed that the data is in one-dimensional arrays of length K, however,
  ! the code can easily be changed to accommodate other data structures.
  !
  ! dA(j) is the spherical area of grid cell j
  ! f1 is the mixing ratio of tracer 1
  ! f2 is the mixing ratio of tracer 2
  !

  integer, parameter :: dbl = c_double

CONTAINS
  !
  ! compute correlation diagnostics
  !

  SUBROUTINE correlation_diag(f1,f2,K,dA,real_mixing,overshooting,range_pres_unmixing) bind(c)
    IMPLICIT NONE
    INTEGER(c_int), value, INTENT(IN) :: K
    REAL(c_double), DIMENSION(K)      , INTENT(IN) :: f1,f2,dA
    real(c_double), intent(out) :: real_mixing,overshooting,range_pres_unmixing
    !
    ! local workspace
    !
    REAL(dbl)     :: root, tol,q1,q2,c
    INTEGER  :: j
    REAL(dbl)     :: q1_min,q1_max,q2_min,q2_max
    REAL(dbl)     :: total_area, sqrt_arg

    REAL(dbl), parameter :: eps = 1.0d-7

    q1_min = 0.1d0
    q1_max = 1.0d0

!! Changed so that end points of line segment are (q1_min,q2_min) and (q1_max,q2_max)
!! Note that "q2_min > q2_max".
    q2_min = corr_fct(q1_min)
    q2_max = corr_fct(q1_max)

    real_mixing          = 0.0d0
    overshooting         = 0.0d0
    range_pres_unmixing  = 0.0d0

    total_area = 0.0d0

    DO j = 1,K
       total_area = total_area+dA(j)

       q1 = f1(j)
       q2 = f2(j)

       !! Check to make sure we are not in the (very unlikely) situation where the argument
       !! to the sqrt (below) is negative.  This will happen if we are in a region which
       !! the cubic has three real roots, and so we'd have to be careful about which one we pick.
       sqrt_arg = (-DBLE(1687296) + DBLE(12168000)*q2 &
            -DBLE(29250000)*q2**2+DBLE(23437500)*q2**3+DBLE(29648025)*q1**2)
       IF (sqrt_arg < 0) THEN
          WRITE(6,*) 'Warning : (xk,yk) data is in region where there are three possible ', &
               ' real roots to the closest point problem'
          STOP
       ENDIF

       c = (DBLE(65340)*q1+12.d0*SQRT(-DBLE(1687296)+DBLE(12168000)*q2 &
            -DBLE(29250000)*q2**2+DBLE(23437500)*q2**3+DBLE(29648025)*q1**2))**(1.d0/3.d0)
       c=c/(DBLE(60))

       root = c-(-(DBLE(13)/DBLE(75))+(DBLE(5)/DBLE(12))*q2)/c
       root = MAX(0.1d0,root)
       root = MIN(1.0d0,root)

       !! Also fixed bug here : call to line_fct passed in q2 instead of q1 as argument.
       IF (q2 < corr_fct(q1)+eps.AND.q2 > line_fct(q1,q1_min,q1_max,q2_min,q2_max)-eps) THEN
          !
          ! `real' mixing
          !
          real_mixing = real_mixing + dist_fct(root,q1,q2)*dA(j)
       ELSE IF (q1 < q1_max+eps.AND.q1 > q1_min-eps.AND.q2 < q2_min+eps.AND.q2 > q2_max-eps) THEN
          !! Note that "q2_min > q2_max", so this 'if' branch had to be modifed

          !
          ! range-preserving unmixing
          !
          range_pres_unmixing = range_pres_unmixing+dist_fct(root,q1,q2)*dA(j)
       ELSE
          !
          ! overshooting
          !
          overshooting = overshooting + dist_fct(root,q1,q2)*dA(j)
       END IF
    END DO
    real_mixing = real_mixing/total_area
    range_pres_unmixing = range_pres_unmixing/total_area
    overshooting = overshooting/total_area
    return
    WRITE(*,*) "========================================================================"
    WRITE(*,*) " "
    WRITE(*,*) "mixing diagnostics"
    WRITE(*,*) " "
    WRITE(*,*) "------------------------------------------------------------------------"
    WRITE(*,*) " "
    WRITE(*,*) "real_mixing ",real_mixing
    WRITE(*,*) "range_pres_unmixing ",range_pres_unmixing
    WRITE(*,*) "overshooting     ",overshooting
    WRITE(*,*) " "
    WRITE(*,*) "========================================================================"
  END SUBROUTINE correlation_diag

  !
  ! correlation function
  !
  REAL(dbl) FUNCTION corr_fct(x)
    IMPLICIT NONE
    REAL(dbl) , INTENT(IN)  :: x
    corr_fct = -0.8d0*x**2+0.9d0
  END FUNCTION corr_fct
  !
  ! Eucledian distance function
  !
  REAL(dbl) FUNCTION dist_fct(x,x0,y0)
    IMPLICIT NONE
    REAL(dbl) , INTENT(IN)  :: x,x0,y0
    dist_fct = SQRT((x-x0)*(x-x0)/(0.9d0**2)+(corr_fct(x)-y0)*(corr_fct(x)-y0)/(0.792d0**2))
  END FUNCTION dist_fct
  !
  ! straight line line function
  !
  REAL(dbl) FUNCTION line_fct(x,xmin,xmax,ymin,ymax)
    IMPLICIT NONE
    REAL(dbl) , INTENT(IN)  :: x,xmin,xmax,ymin,ymax
    REAL(dbl)  :: a,b
    !
    ! line: y=a*x+b
    !
    a = (ymax-ymin)/(xmax-xmin)
    b = ymin-xmin*a
    line_fct = a*x+b
  END FUNCTION line_fct

  !
  ! linit = .TRUE. if t=0 else .FALSE.
  !
  ! Note that this subroutine must be called with the initial
  ! condition data to get "fila_t0".
  !
  SUBROUTINE filament_diag(K,f1,dA,fila_t0,linit,thresholds,fila_tf) bind(c)
    IMPLICIT NONE
    INTEGER(c_int), value, INTENT(IN)                    :: K
    REAL(c_double)   , DIMENSION(K)  , INTENT(IN)    :: f1, dA
    REAL(c_double)   , DIMENSION(100), INTENT(INOUT) :: fila_t0
    REAL(c_double)   , DIMENSION(100), INTENT(OUT)   :: thresholds, fila_tf
    INTEGER(c_int), value, INTENT(IN)    :: linit
    !
    ! local workspace
    !
    REAL(dbl)    :: threshold,tiny
    REAL(dbl)    :: out
    INTEGER :: j,jk,jlevels

    tiny=1.0d-12
    OPEN (unit = 31, file='filament.dat',status='replace')
    jlevels = 18
    IF (linit == 0) thresholds(jlevels+2) = -1
    DO jk=0,jlevels
       threshold = 0.1d0+(DBLE(jk)/DBLE(jlevels))*0.9d0
       IF (linit == 0) thresholds(jk+1) = threshold
       out       = 0.0d0
       DO j=1,K
          IF (f1(j).GE.threshold-tiny) THEN
             out = out+dA(j)
          END IF
       END DO
       IF (linit /= 0) THEN
          fila_t0(jk+1)=out
       ELSE
          IF (fila_t0(jk+1)<tiny) THEN
             fila_tf(jk+1) = 0.0d0
             !WRITE(31,*) threshold,0.0d0
          ELSE
             fila_tf(jk+1) = 100.0d0*out/fila_t0(jk+1)
             !WRITE(31,*) threshold,100.0d0*out/fila_t0(jk+1)
          END IF
       END IF
    END DO
    CLOSE(31)
  END SUBROUTINE filament_diag
END MODULE diag


module time_step_mod
  implicit none

  private

  public invoke_time_step

contains

  subroutine invoke_time_step(istp, ssha, ssha_u, ssha_v, &
                              sshn_t, sshn_u, sshn_v, &
                              hu, hv, ht, ua, va, un, vn)
    use kind_params_mod
    use dl_timer
    use field_mod
    use grid_mod
    use model_mod,       only: rdt, cbfr, visc
    use physical_params_mod, only: g, omega, d2r
    use boundary_conditions_mod
    implicit none
    real(go_wp),        intent(in)    :: istp
    type(r2d_field), intent(inout) :: un, vn, sshn_t, sshn_u, sshn_v
    type(r2d_field), intent(inout) :: ua, va, ssha, ssha_u, ssha_v
    type(r2d_field), intent(in)    :: hu, hv, ht
    ! Locals
    integer :: ji, jj, jiu, jiv
    integer :: M, N
    integer :: cont_timer, mom_timer, bc_timer, next_timer
    ! Locals for momentum
    REAL(go_wp) :: u_e, u_w, v_n, v_s
    real(go_wp) :: v_nc, v_sc
    real(go_wp) :: depe, depw, deps, depn
    real(go_wp) :: hpg, adv, cor, vis
    real(go_wp) :: dudx_e, dudx_w, dudy_s, dudy_n
    real(go_wp) :: uu_e, uu_n, uu_s, uu_w
    real(go_wp) :: u_ec, u_wc, vv_e, vv_n, vv_s, vv_w
    real(go_wp) :: dvdx_e, dvdx_w, dvdy_n, dvdy_s
    real(go_wp) :: rtmp1, rtmp2, rtmp3, rtmp4
    ! end locals for momentum
    ! Locals for BCs
    real(go_wp) :: amp_tide, omega_tide, rtime

    M  = ssha%grid%subdomain%global%nx
    N  = ssha%grid%subdomain%global%ny

    ! In the general case we have to reason about whether or not the
    ! domain has PBCs and what sort of offset convention the kernels
    ! use. However, this is a middle layer specific to NEMOLite2D and
    ! therefore we know that we have no periodic BCs and are using a
    ! NE stagger
    !txstart = 2 ! grid%simulation_domain%xstart
    !tystart = 2 ! grid%simulation_domain%ystart

    !uxstart = 2 ! grid%simulation_domain%xstart
    !uxstop  = M - 1
    !uystart = 2 ! grid%simulation_domain%ystart
    !uystop  = N

    !vxstart = 2 ! grid%simulation_domain%xstart
    !vxstop  = M
    !vystart = 2 ! grid%simulation_domain%ystart
    !vystop  = N - 1

    !uwhole_xstart = 1 ! uxstart - NBOUNDARY
    !uwhole_xstop  = M ! uxstop  + NBOUNDARY
    !uwhole_ystart = 1 ! uystart - NBOUNDARY
    !uwhole_ystop  = N+1 ! uystop  + NBOUNDARY

    !vwhole_xstart = 1 ! vxstart - NBOUNDARY
    !vwhole_xstop  = M+1 ! vxstop  + NBOUNDARY
    !vwhole_ystart = 1 ! vystart - NBOUNDARY
    !vwhole_ystop  = N ! vystop  + NBOUNDARY

    call timer_start(cont_timer, label='Continuity')

!    do jj = ssha%internal%ystart, ssha%internal%ystop, 1
!      do ji = ssha%internal%xstart, ssha%internal%xstop, 1
    do jj = 2, N, 1
      do ji = 2, M, 1

!        call continuity_code(ji, jj,                             &
!                             ssha%data, sshn_t%data,             &
!                             sshn_u%data, sshn_v%data,           &
!                             hu%data, hv%data, un%data, vn%data, &
!                             sshn_t%grid%area_t)
         rtmp1 = (sshn_u%data(ji  ,jj ) + hu%data(ji  ,jj  ))*un%data(ji  ,jj)
         rtmp2 = (sshn_u%data(ji-1,jj ) + hu%data(ji-1,jj  ))*un%data(ji-1,jj)
         rtmp3 = (sshn_v%data(ji ,jj ) + hv%data(ji  ,jj  ))*vn%data(ji ,jj)
         rtmp4 = (sshn_v%data(ji ,jj-1) + hv%data(ji  ,jj-1))*vn%data(ji,jj-1)

         ssha%data(ji,jj) = sshn_t%data(ji,jj) + (rtmp2 - rtmp1 + rtmp4 - rtmp3) * &
                       rdt / sshn_t%grid%area_t(ji,jj)
      end do
    end do

    call timer_stop(cont_timer)

  end subroutine invoke_time_step

end module time_step_mod


!
!     ------------------------------------------------------------------
!         R M E
!     ------------------------------------------------------------------
!
!
      REAL(KIND(0.0D0)) FUNCTION RME (L, LP, K)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE FACT_C
!
!...Translated by Pacific-Sierra Research 77to90  4.3E  21:52:17  11/14/01
!...Switches:
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER , INTENT(IN) :: L
      INTEGER , INTENT(IN) :: LP
      INTEGER , INTENT(IN) :: K
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: I2G, IG, I1, I2, I3
      REAL(DOUBLE) :: QUSQRT
!-----------------------------------------------
!
!
!--- EVALUATES THE REDUCED MATRIX ELEMENT (L//C(K)//LP)  -  SEE FANO
!    AND RACAH, IRREDUCIBLE TENSORIAL SETS, CHAP. 14, P. 81
!
!
      IF (MIN0(L,LP) == 0) THEN
         RME = 1.D0
      ELSE IF (K == 0) THEN
         RME = 2*L + 1
         RME = DSQRT(RME)
      ELSE IF (K == 1) THEN
         RME = MAX0(L,LP)
         RME = DSQRT(RME)
      ELSE
         I2G = L + LP + K
         IG = I2G/2
         IF (I2G - 2*IG /= 0) THEN
            RME = 0.D0
         ELSE
            I1 = IG - L
            I2 = IG - LP
            I3 = IG - K
            QUSQRT = (2*L + 1)*(2*LP + 1)
            RME = DSQRT(QUSQRT)*DEXP((GAM(2*I1+1)+GAM(2*I2+1)+GAM(2*I3+1)-GAM(&
               I2G+2))/2.D0+GAM(IG+1)-GAM(I1+1)-GAM(I2+1)-GAM(I3+1))
         ENDIF
      ENDIF
      RETURN
      END FUNCTION RME


      subroutine xyz_to_polar_r(x,y,z,dec,ra,r)

      IMPLICIT REAL*8(A-Z)

      ATAN3(X,Y)=DMOD((DATAN2(X,Y)+6.2831853071796D0),6.2831853071796D0)

      r=DSQRT(x**2+y**2+z**2)
      dec=ASIN(z/r)
      ra=ATAN3(y,x)

      return
      end


!==========================================================================
elemental function gsw_beta (sa, ct, p)
!==========================================================================
!
!  Calculates the saline (i.e. haline) contraction coefficient of seawater
!  at constant Conservative Temperature using the computationally-efficient
!  expression for specific volume in terms of SA, CT and p
!  (Roquet et al., 2014).
!
!  SA  =  Absolute Salinity                                        [ g/kg ]
!  CT  =  Conservative Temperature (ITS-90)                       [ deg C ]
!  p   =  sea pressure                                             [ dbar ]
!         ( i.e. absolute pressure - 10.1325 dbar )
!
!  beta  =  saline contraction coefficient                         [ kg/g ]
!           at constant Conservative Temperature
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_specvol

use gsw_mod_teos10_constants, only : gsw_sfac, offset

use gsw_mod_specvol_coefficients

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, ct, p

real (r8) :: gsw_beta

real (r8) :: xs, ys, z, v_sa_part

xs = sqrt(gsw_sfac*sa + offset)
ys = ct*0.025_r8
z = p*1e-4_r8

v_sa_part = b000 + xs*(b100 + xs*(b200 + xs*(b300 + xs*(b400 + b500*xs)))) &
       + ys*(b010 + xs*(b110 + xs*(b210 + xs*(b310 + b410*xs))) &
       + ys*(b020 + xs*(b120 + xs*(b220 + b320*xs)) + ys*(b030 &
       + xs*(b130 + b230*xs) + ys*(b040 + b140*xs + b050*ys)))) &
       + z*(b001 + xs*(b101 + xs*(b201 + xs*(b301 + b401*xs))) &
       + ys*(b011 + xs*(b111 + xs*(b211 + b311*xs)) + ys*(b021 &
       + xs*(b121 + b221*xs) + ys*(b031 + b131*xs + b041*ys))) &
       + z*(b002 + xs*(b102 + xs*(b202 + b302*xs))+ ys*(b012 &
       + xs*(b112 + b212*xs) + ys*(b022 + b122*xs + b032*ys)) &
       + z*(b003 +  b103*xs + b013*ys + b004*z)))

gsw_beta = -v_sa_part*0.5_r8*gsw_sfac/(gsw_specvol(sa,ct,p)*xs)

return
end function

!--------------------------------------------------------------------------


c
c     =================================================
      function fdisc(x,y,time)
c     =================================================
c
c     # for computing cell averages for initial data that has a
c     # discontinuity along some curve.  fdisc should be negative to the
c     # left of the curve and positive to the right
c     # idisc specifies the nature of the discontinuity for two
c     # particular cases (a straight line and circle) but this routine
c     # can be modified for any other curve.

c     thanks for Randy LeVeque for his cellave routine.
c
c
      use amr_module, only:  ylower
      implicit double precision (a-h,o-z)
      include "cdisc.i"
      common /moredata/ sloc

      idisc = 10  ! for straight line shock problem
      go to (10,20) idisc
c
   10 continue
c     # straight line through (x0,y0) with normal (alf,beta) pointing
c     # into right state
c
      ! mach 10 30 degree ramp
      pi = 4.d0*atan(1.0d0)
      alf = cos(pi/10.d0)
      beta = -sin(pi/10.d0)
      y0 = ylower
      x0 = sloc + 20.d0*time/sqrt(3.d0)

      fdisc = (x-x0)*alf + (y-y0)*beta
      return
c
   20 continue
c     # circle of radius r0:
      fdisc = (x-x0)**2 + (y-y0)**2 - r0**2
c
      return
      end


subroutine convert(rmnc, zmns, lmns, xm, xn, js, &
                   rmncc,rmnss, zmncs,zmnsc, lmncs,lmnsc)

      use stel_kinds, only: dp
      use name0, only: czero, cp5
      use name1, only: mnmax, nmax, mpol1
      use scalars, only: ns
      use mnarray, only: mscale, nscale
      use inputdat, only: nfp

      implicit none

      real(kind=dp), intent(out) :: rmnc(mnmax)
      real(kind=dp), intent(out) :: zmns(mnmax)
      real(kind=dp), intent(out) :: lmns(mnmax)
      real(kind=dp), intent(out) :: xm(mnmax)
      real(kind=dp), intent(out) :: xn(mnmax)
      real(kind=dp), intent(in)  :: rmncc(ns,0:nmax,0:mpol1)
      real(kind=dp), intent(in)  :: rmnss(ns,0:nmax,0:mpol1)
      real(kind=dp), intent(in)  :: zmncs(ns,0:nmax,0:mpol1)
      real(kind=dp), intent(in)  :: zmnsc(ns,0:nmax,0:mpol1)
      real(kind=dp), intent(in)  :: lmncs(ns,0:nmax,0:mpol1)
      real(kind=dp), intent(in)  :: lmnsc(ns,0:nmax,0:mpol1)
      integer      , intent(in)  :: js

      integer       :: m, n, mn
      integer       :: nmin0, n1
      real(kind=dp) :: t1, sgn

      ! CONVERTS INTERNAL MODE REPRESENTATION TO STANDARD
      ! FORM FOR OUTPUT (COEFFICIENTS OF cos(mu-nv), sin(mu-nv

      mn = 0
      do m = 0, mpol1

        nmin0 = -nmax
        if (m.eq.0) &
          nmin0 = 0

        do n = nmin0, nmax
          n1 = abs(n)

          t1 = mscale(m)*nscale(n1)

          mn = mn + 1

          xm(mn) = real(m)
          xn(mn) = real(n*nfp)

          if (m.eq.0)then
            rmnc(mn) = t1*rmncc(js,n,m)
            zmns(mn) =-t1*zmncs(js,n,m)
            lmns(mn) =-t1*lmncs(js,n,m)
          else if (n.eq.0) then
            rmnc(mn) = t1*rmncc(js,n,m)
            zmns(mn) = t1*zmnsc(js,n,m)
            lmns(mn) = t1*lmnsc(js,n,m)
          else if (js.gt.1) then
            sgn = real(n/n1)
            rmnc(mn) = cp5*t1*(rmncc(js,n1,m) + sgn*rmnss(js,n1,m))
            zmns(mn) = cp5*t1*(zmnsc(js,n1,m) - sgn*zmncs(js,n1,m))
            lmns(mn) = cp5*t1*(lmnsc(js,n1,m) - sgn*lmncs(js,n1,m))
          else if (js.eq.1) then
            rmnc(mn) = czero
            zmns(mn) = czero
            lmns(mn) = czero
          endif

        enddo
      enddo

      return

end


! Downstream boundary condition
!subroutine dsbc(n)
subroutine dsbc()

    use constants_module
    use arrays_module
    use var_module
    use sgate_module

    implicit none

    ! Input
    !integer, intent(in) :: n

    ! Locals
    real(kind=4) :: ads, frds, qn, yconj

    ! compute conjugate depth at dwon stream end
    !ads=(y(n,ncomp)-z(ncomp))*bo(ncomp)
	ads=(oldY(ncomp)-z(ncomp))*bo(ncomp)
    !frds=q(n,ncomp)/sqrt(grav*ads**3.0/bo(ncomp))
	frds=oldQ(ncomp)/sqrt(grav*ads**3.0/bo(ncomp))
    !yconj=0.5*(y(n,ncomp)-z(ncomp))*(sqrt(1.0+8.0*frds*frds)-1.0)
    yconj=0.5*(oldY(ncomp)-z(ncomp))*(sqrt(1.0+8.0*frds*frds)-1.0)
    yconj=yconj+z(ncomp)
    !print *, yn,y(n,ncomp),yconj,z(ncomp)
    print *, yn,oldY(ncomp),yconj,z(ncomp)
    if(yconj < yn) then
        ! print *, 'no'
        if(option == 1) then
            ! downstream water level imposed (option 1)
            !dac(ncomp)=(yn-y(n,ncomp))*bo(ncomp)
            dac(ncomp)=(yn-oldY(ncomp))*bo(ncomp)
            !dap(ncomp)=(yn-y(n,ncomp))*bo(ncomp)
            dap(ncomp)=(yn-oldY(ncomp))*bo(ncomp)
            dqc(ncomp)=dqp(ncomp)
            ! print *, 'yes',dac(ncomp),yn,oldY(ncomp),dqc(ncomp)
        else if (option == 2) then
            ! downstream discharge imposed  (option 2)
            dqc(ncomp)=0.0
            dqp(ncomp)=0.0
            dac(ncomp)=dap(ncomp)
        elseif(option == 3) then
            ! downstream rating curve imposed (option 3)
            dac(ncomp)=dap(ncomp)
            yn=(area(ncomp)+dap(ncomp))/bo(ncomp)
            qn=0.65*10*1.0*sqrt(2.0*grav*(yn-0.5))
            !dqp(ncomp)=qn-q(n,ncomp)
			dqp(ncomp)=qn-oldQ(ncomp)
            dqc(ncomp)=dqp(ncomp)
        end if
    else
        ! super critical flow exist at downstream exit
        dac(ncomp)=dap(ncomp)
        dqc(ncomp)=dqp(ncomp)
    end if

end subroutine dsbc


c function gamma.f
c
c source
c   Bevington, page 126.
c
c purpose
c   calculate the gamma function for integers and half-integers
c
c usage
c   result = gamma (x)
c
c description of parameters
c   x      - integer or half-integer
c
c subroutines or function subprograms required
c   factor (n)
c      calculates n factorial for integers
c
	function gamma (x)
	double precision prod,sum,fi
c
c integerize argument
c
11	n=x-0.25
	xn=n
13	if (x-xn-0.75) 31,31,21
c
c argument is integer
c
21	gamma=factor(n)
	goto 60
c
c argument is half-integer
c
31	prod=1.77245385
	if (n) 44,44,33
33	if (n-10) 41,41,51
41	do 43 i=1,n
	fi=i
43	prod=prod*(fi-0.5)
44	gamma=prod
	goto 60
51	sum=0.
	do 54 i=11,n
	fi=i
54	sum=sum+dlog(fi-0.5)
55	gamma=prod*639383.8623*dexp(sum)
60	return
	end