!*==cgesvj.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief  CGESVJ
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download CGESVJ + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V,
!                          LDV, CWORK, LWORK, RWORK, LRWORK, INFO )
!
!       .. Scalar Arguments ..
!       INTEGER            INFO, LDA, LDV, LWORK, LRWORK, M, MV, N
!       CHARACTER*1        JOBA, JOBU, JOBV
!       ..
!       .. Array Arguments ..
!       COMPLEX            A( LDA, * ),  V( LDV, * ), CWORK( LWORK )
!       REAL               RWORK( LRWORK ),  SVA( N )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> CGESVJ computes the singular value decomposition (SVD) of a complex
!> M-by-N matrix A, where M >= N. The SVD of A is written as
!>                                    [++]   [xx]   [x0]   [xx]
!>              A = U * SIGMA * V^*,  [++] = [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 unitary 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.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] JOBA
!> \verbatim
!>          JOBA is 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.
!> \endverbatim
!>
!> \param[in] JOBU
!> \verbatim
!>          JOBU is CHARACTER*1
!>          Specifies whether to compute the left singular vectors
!>          (columns of U):
!>          = 'U' or 'F': 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=SQRT(M), EPS=SLAMCH('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.
!> \endverbatim
!>
!> \param[in] JOBV
!> \verbatim
!>          JOBV is CHARACTER*1
!>          Specifies whether to compute the right singular vectors, that
!>          is, the matrix V:
!>          = 'V' or 'J': 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
!> \endverbatim
!>
!> \param[in] M
!> \verbatim
!>          M is INTEGER
!>          The number of rows of the input matrix A. 1/SLAMCH('E') > M >= 0.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The number of columns of the input matrix A.
!>          M >= N >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is COMPLEX array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit,
!>          If JOBU = 'U' .OR. JOBU = 'C':
!>                 If INFO = 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 SLAMCH('S'). The singular
!>                 vectors corresponding to underflowed or zero singular
!>                 values are not computed. The value of RANKA is returned
!>                 in the array RWORK as RANKA=NINT(RWORK(2)). Also see the
!>                 descriptions of SVA and RWORK. The computed columns of U
!>                 are mutually numerically orthogonal up to approximately
!>                 TOL=SQRT(M)*EPS (default); or TOL=CTOL*EPS (JOBU = 'C'),
!>                 see the description of JOBU.
!>                 If INFO > 0,
!>                 the procedure CGESVJ 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^* ||_2 / ||A||_2 is small.
!>          If JOBU = 'N':
!>                 If INFO = 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 > 0 :
!>                 the procedure CGESVJ did not converge in the given number
!>                 of iterations (sweeps).
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!> \endverbatim
!>
!> \param[out] SVA
!> \verbatim
!>          SVA is REAL array, dimension (N)
!>          On exit,
!>          If INFO = 0 :
!>          depending on the value SCALE = RWORK(1), we have:
!>                 If SCALE = 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 > 0 :
!>          the procedure CGESVJ did not converge in the given number of
!>          iterations (sweeps) and SCALE*SVA(1:N) may not be accurate.
!> \endverbatim
!>
!> \param[in] MV
!> \verbatim
!>          MV is INTEGER
!>          If JOBV = 'A', then the product of Jacobi rotations in CGESVJ
!>          is applied to the first MV rows of V. See the description of JOBV.
!> \endverbatim
!>
!> \param[in,out] V
!> \verbatim
!>          V is COMPLEX 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.
!> \endverbatim
!>
!> \param[in] LDV
!> \verbatim
!>          LDV is INTEGER
!>          The leading dimension of the array V, LDV >= 1.
!>          If JOBV = 'V', then LDV >= max(1,N).
!>          If JOBV = 'A', then LDV >= max(1,MV) .
!> \endverbatim
!>
!> \param[in,out] CWORK
!> \verbatim
!>          CWORK is COMPLEX array, dimension (max(1,LWORK))
!>          Used as workspace.
!>          If on entry LWORK = -1, then a workspace query is assumed and
!>          no computation is done; CWORK(1) is set to the minial (and optimal)
!>          length of CWORK.
!> \endverbatim
!>
!> \param[in] LWORK
!> \verbatim
!>          LWORK is INTEGER.
!>          Length of CWORK, LWORK >= M+N.
!> \endverbatim
!>
!> \param[in,out] RWORK
!> \verbatim
!>          RWORK is REAL array, dimension (max(6,LRWORK))
!>          On entry,
!>          If JOBU = 'C' :
!>          RWORK(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=SLAMCH('E').
!>                    It is required that CTOL >= ONE, i.e. it is not
!>                    allowed to force the routine to obtain orthogonality
!>                    below EPSILON.
!>          On exit,
!>          RWORK(1) = SCALE is the scaling factor such that SCALE*SVA(1:N)
!>                    are the computed singular values of A.
!>                    (See description of SVA().)
!>          RWORK(2) = NINT(RWORK(2)) is the number of the computed nonzero
!>                    singular values.
!>          RWORK(3) = NINT(RWORK(3)) is the number of the computed singular
!>                    values that are larger than the underflow threshold.
!>          RWORK(4) = NINT(RWORK(4)) is the number of sweeps of Jacobi
!>                    rotations needed for numerical convergence.
!>          RWORK(5) = max_{i.NE.j} |COS(A(:,i),A(:,j))| in the last sweep.
!>                    This is useful information in cases when CGESVJ did
!>                    not converge, as it can be used to estimate whether
!>                    the output is still useful and for post festum analysis.
!>          RWORK(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.
!>         If on entry LRWORK = -1, then a workspace query is assumed and
!>         no computation is done; RWORK(1) is set to the minial (and optimal)
!>         length of RWORK.
!> \endverbatim
!>
!> \param[in] LRWORK
!> \verbatim
!>         LRWORK is INTEGER
!>         Length of RWORK, LRWORK >= MAX(6,N).
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit.
!>          < 0:  if INFO = -i, then the i-th argument had an illegal value
!>          > 0:  CGESVJ did not converge in the maximal allowed number
!>                (NSWEEP=30) of sweeps. The output may still be useful.
!>                See the description of RWORK.
!> \endverbatim
!>
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date June 2016
!
!> \ingroup complexGEcomputational
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!> The orthogonal N-by-N matrix V is obtained as a product of Jacobi plane
!> rotations. In the case of underflow of the tangent of the Jacobi angle, a
!> modified Jacobi transformation of Drmac [3] is used. Pivot strategy uses
!> column interchanges of de Rijk [1]. 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 [2].
!> 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 [4,5], and it is the kernel routine in the SIGMA library [6].
!> Some tuning 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.
!> \endverbatim
!
!> \par Contributor:
!  ==================
!>
!> \verbatim
!>
!>  ============
!>
!>  Zlatko Drmac (Zagreb, Croatia)
!>
!> \endverbatim
!
!> \par References:
!  ================
!>
!> \verbatim
!>
!> [1] 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.
!> [2] J. Demmel and K. Veselic: Jacobi method is more accurate than QR.
!> [3] 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.
!> [4] 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.
!> [5] 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.
!> [6] Z. Drmac: SIGMA - mathematical software library for accurate SVD, PSV,
!>    QSVD, (H,K)-SVD computations.
!>    Department of Mathematics, University of Zagreb, 2008, 2015.
!> \endverbatim
!
!> \par Bugs, examples and comments:
!  =================================
!>
!> \verbatim
!>  ===========================
!>  Please report all bugs and send interesting test examples and comments to
!>  drmac@math.hr. Thank you.
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE CGESVJ(Joba,Jobu,Jobv,M,N,A,Lda,Sva,Mv,V,Ldv,Cwork,    &
     &                  Lwork,Rwork,Lrwork,Info)
!
!  -- LAPACK computational routine (version 3.8.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     June 2016
!
      IMPLICIT NONE
!*--CGESVJ361
!     .. Scalar Arguments ..
      INTEGER Info , Lda , Ldv , Lwork , Lrwork , M , Mv , N
      CHARACTER*1 Joba , Jobu , Jobv
!     ..
!     .. Array Arguments ..
      COMPLEX A(Lda,*) , V(Ldv,*) , Cwork(Lwork)
      REAL Rwork(Lrwork) , Sva(N)
!     ..
!
!  =====================================================================
!
!     .. Local Parameters ..
      REAL ZERO , HALF , ONE
      PARAMETER (ZERO=0.0E0,HALF=0.5E0,ONE=1.0E0)
      COMPLEX CZERO , CONE
      PARAMETER (CZERO=(0.0E0,0.0E0),CONE=(1.0E0,0.0E0))
      INTEGER NSWEEP
      PARAMETER (NSWEEP=30)
!     ..
!     .. Local Scalars ..
      COMPLEX aapq , ompq
      REAL aapp , aapp0 , aapq1 , aaqq , apoaq , aqoap , big ,          &
     &     bigtheta , cs , ctol , epsln , mxaapq , mxsinj , rootbig ,   &
     &     rooteps , rootsfmin , roottol , skl , 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 , lquery , lsvec , noscale ,      &
     &        rotok , rsvec , uctol , upper
!     ..
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , MAX , MIN , CONJG , REAL , SIGN , SQRT
!     ..
!     .. External Functions ..
!     ..
!     from BLAS
      REAL SCNRM2
      COMPLEX CDOTC
      EXTERNAL CDOTC , SCNRM2
      INTEGER ISAMAX
      EXTERNAL ISAMAX
!     from LAPACK
      REAL SLAMCH
      EXTERNAL SLAMCH
      LOGICAL LSAME
      EXTERNAL LSAME
!     ..
!     .. External Subroutines ..
!     ..
!     from BLAS
      EXTERNAL CCOPY , CROT , CSSCAL , CSWAP , CAXPY
!     from LAPACK
      EXTERNAL CLASCL , CLASET , CLASSQ , SLASCL , XERBLA
      EXTERNAL CGSVJ0 , CGSVJ1
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      lsvec = LSAME(Jobu,'U') .OR. LSAME(Jobu,'F')
      uctol = LSAME(Jobu,'C')
      rsvec = LSAME(Jobv,'V') .OR. LSAME(Jobv,'J')
      applv = LSAME(Jobv,'A')
      upper = LSAME(Joba,'U')
      lower = LSAME(Joba,'L')
!
      lquery = (Lwork==-1) .OR. (Lrwork==-1)
      IF ( .NOT.(upper .OR. lower .OR. LSAME(Joba,'G')) ) THEN
         Info = -1
      ELSEIF ( .NOT.(lsvec .OR. uctol .OR. LSAME(Jobu,'N')) ) THEN
         Info = -2
      ELSEIF ( .NOT.(rsvec .OR. applv .OR. LSAME(Jobv,'N')) ) THEN
         Info = -3
      ELSEIF ( M<0 ) THEN
         Info = -4
      ELSEIF ( (N<0) .OR. (N>M) ) THEN
         Info = -5
      ELSEIF ( Lda<M ) THEN
         Info = -7
      ELSEIF ( Mv<0 ) THEN
         Info = -9
      ELSEIF ( (rsvec .AND. (Ldv<N)) .OR. (applv .AND. (Ldv<Mv)) ) THEN
         Info = -11
      ELSEIF ( uctol .AND. (Rwork(1)<=ONE) ) THEN
         Info = -12
      ELSEIF ( Lwork<(M+N) .AND. (.NOT.lquery) ) THEN
         Info = -13
      ELSEIF ( Lrwork<MAX(N,6) .AND. (.NOT.lquery) ) THEN
         Info = -15
      ELSE
         Info = 0
      ENDIF
!
!     #:(
      IF ( Info/=0 ) THEN
         CALL XERBLA('CGESVJ',-Info)
         RETURN
      ELSEIF ( lquery ) THEN
         Cwork(1) = M + N
         Rwork(1) = MAX(N,6)
         RETURN
      ENDIF
!
! #:) Quick return for void matrix
!
      IF ( (M==0) .OR. (N==0) ) RETURN
!
!     Set numerical parameters
!     The stopping criterion for Jacobi rotations is
!
!     max_{i<>j}|A(:,i)^* * 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 = Rwork(1)
!        ... default
      ELSEIF ( lsvec .OR. rsvec .OR. applv ) THEN
         ctol = SQRT(REAL(M))
      ELSE
         ctol = REAL(M)
      ENDIF
!     ... and the machine dependent parameters are
![!]  (Make sure that SLAMCH() works properly on the target machine.)
!
      epsln = SLAMCH('Epsilon')
      rooteps = SQRT(epsln)
      sfmin = SLAMCH('SafeMinimum')
      rootsfmin = SQRT(sfmin)
      small = sfmin/epsln
!      BIG = SLAMCH( 'Overflow' )
      big = ONE/sfmin
      rootbig = ONE/rootsfmin
!     LARGE = BIG / SQRT( REAL( M*N ) )
      bigtheta = ONE/rooteps
!
      tol = ctol*epsln
      roottol = SQRT(tol)
!
      IF ( REAL(M)*epsln>=ONE ) THEN
         Info = -4
         CALL XERBLA('CGESVJ',-Info)
         RETURN
      ENDIF
!
!     Initialize the right singular vector matrix.
!
      IF ( rsvec ) THEN
         mvl = N
         CALL CLASET('A',mvl,N,CZERO,CONE,V,Ldv)
      ELSEIF ( applv ) THEN
         mvl = Mv
      ENDIF
      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
!     SQRT(N)*max_i SVA(i) does not overflow. If INFinite entries
!     in A are detected, the procedure returns with INFO=-6.
!
      skl = ONE/SQRT(REAL(M)*REAL(N))
      noscale = .TRUE.
      goscale = .TRUE.
!
      IF ( lower ) THEN
!        the input matrix is M-by-N lower triangular (trapezoidal)
         DO p = 1 , N
            aapp = ZERO
            aaqq = ONE
            CALL CLASSQ(M-p+1,A(p,p),1,aapp,aaqq)
            IF ( aapp>big ) THEN
               Info = -6
               CALL XERBLA('CGESVJ',-Info)
               RETURN
            ENDIF
            aaqq = SQRT(aaqq)
            IF ( (aapp<(big/aaqq)) .AND. noscale ) THEN
               Sva(p) = aapp*aaqq
            ELSE
               noscale = .FALSE.
               Sva(p) = aapp*(aaqq*skl)
               IF ( goscale ) THEN
                  goscale = .FALSE.
                  DO q = 1 , p - 1
                     Sva(q) = Sva(q)*skl
                  ENDDO
               ENDIF
            ENDIF
         ENDDO
      ELSEIF ( upper ) THEN
!        the input matrix is M-by-N upper triangular (trapezoidal)
         DO p = 1 , N
            aapp = ZERO
            aaqq = ONE
            CALL CLASSQ(p,A(1,p),1,aapp,aaqq)
            IF ( aapp>big ) THEN
               Info = -6
               CALL XERBLA('CGESVJ',-Info)
               RETURN
            ENDIF
            aaqq = SQRT(aaqq)
            IF ( (aapp<(big/aaqq)) .AND. noscale ) THEN
               Sva(p) = aapp*aaqq
            ELSE
               noscale = .FALSE.
               Sva(p) = aapp*(aaqq*skl)
               IF ( goscale ) THEN
                  goscale = .FALSE.
                  DO q = 1 , p - 1
                     Sva(q) = Sva(q)*skl
                  ENDDO
               ENDIF
            ENDIF
         ENDDO
      ELSE
!        the input matrix is M-by-N general dense
         DO p = 1 , N
            aapp = ZERO
            aaqq = ONE
            CALL CLASSQ(M,A(1,p),1,aapp,aaqq)
            IF ( aapp>big ) THEN
               Info = -6
               CALL XERBLA('CGESVJ',-Info)
               RETURN
            ENDIF
            aaqq = SQRT(aaqq)
            IF ( (aapp<(big/aaqq)) .AND. noscale ) THEN
               Sva(p) = aapp*aaqq
            ELSE
               noscale = .FALSE.
               Sva(p) = aapp*(aaqq*skl)
               IF ( goscale ) THEN
                  goscale = .FALSE.
                  DO q = 1 , p - 1
                     Sva(q) = Sva(q)*skl
                  ENDDO
               ENDIF
            ENDIF
         ENDDO
      ENDIF
!
      IF ( noscale ) skl = 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 p = 1 , N
         IF ( Sva(p)/=ZERO ) aaqq = MIN(aaqq,Sva(p))
         aapp = MAX(aapp,Sva(p))
      ENDDO
!
! #:) Quick return for zero matrix
!
      IF ( aapp==ZERO ) THEN
         IF ( lsvec ) CALL CLASET('G',M,N,CZERO,CONE,A,Lda)
         Rwork(1) = ONE
         Rwork(2) = ZERO
         Rwork(3) = ZERO
         Rwork(4) = ZERO
         Rwork(5) = ZERO
         Rwork(6) = ZERO
         RETURN
      ENDIF
!
! #:) Quick return for one-column matrix
!
      IF ( N==1 ) THEN
         IF ( lsvec ) CALL CLASCL('G',0,0,Sva(1),skl,M,1,A(1,1),Lda,    &
     &                            ierr)
         Rwork(1) = ONE/skl
         IF ( Sva(1)>=sfmin ) THEN
            Rwork(2) = ONE
         ELSE
            Rwork(2) = ZERO
         ENDIF
         Rwork(3) = ZERO
         Rwork(4) = ZERO
         Rwork(5) = ZERO
         Rwork(6) = ZERO
         RETURN
      ENDIF
!
!     Protect small singular values from underflow, and try to
!     avoid underflows/overflows in computing Jacobi rotations.
!
      sn = SQRT(sfmin/epsln)
      temp1 = SQRT(big/REAL(N))
      IF ( (aapp<=sn) .OR. (aaqq>=temp1) .OR.                           &
     &     ((sn<=aaqq) .AND. (aapp<=temp1)) ) THEN
         temp1 = MIN(big,temp1/aapp)
!         AAQQ  = AAQQ*TEMP1
!         AAPP  = AAPP*TEMP1
      ELSEIF ( (aaqq<=sn) .AND. (aapp<=temp1) ) THEN
         temp1 = MIN(sn/aaqq,big/(aapp*SQRT(REAL(N))))
!         AAQQ  = AAQQ*TEMP1
!         AAPP  = AAPP*TEMP1
      ELSEIF ( (aaqq>=sn) .AND. (aapp>=temp1) ) THEN
         temp1 = MAX(sn/aaqq,temp1/aapp)
!         AAQQ  = AAQQ*TEMP1
!         AAPP  = AAPP*TEMP1
      ELSEIF ( (aaqq<=sn) .AND. (aapp>=temp1) ) THEN
         temp1 = MIN(sn/aaqq,big/(SQRT(REAL(N))*aapp))
!         AAQQ  = AAQQ*TEMP1
!         AAPP  = AAPP*TEMP1
      ELSE
         temp1 = ONE
      ENDIF
!
!     Scale, if necessary
!
      IF ( temp1/=ONE ) CALL SLASCL('G',0,0,ONE,temp1,N,1,Sva,N,ierr)
      skl = temp1*skl
      IF ( skl/=ONE ) THEN
         CALL CLASCL(Joba,0,0,ONE,skl,M,N,A,Lda,ierr)
         skl = ONE/skl
      ENDIF
!
!     Row-cyclic Jacobi SVD algorithm with column pivoting
!
      emptsw = (N*(N-1))/2
      notrot = 0

      DO q = 1 , N
         Cwork(q) = CONE
      ENDDO
!
!
!
      swband = 3
![TP] SWBAND is a tuning parameter [TP]. It is meaningful and effective
!     if CGESVJ is used as a computational routine in the preconditioned
!     Jacobi SVD algorithm CGEJSV. 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 = MIN(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)/=N ) nbl = nbl + 1
!
      blskip = kbl**2
![TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL.
!
      rowskip = MIN(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>MAX(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
         ENDIF
!
         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 CGSVJ0(Jobv,M-n34,N-n34,A(n34+1,n34+1),Lda,Cwork(n34+1)&
     &                  ,Sva(n34+1),mvl,V(n34*q+1,n34+1),Ldv,epsln,     &
     &                  sfmin,tol,2,Cwork(N+1),Lwork-N,ierr)

            CALL CGSVJ0(Jobv,M-n2,n34-n2,A(n2+1,n2+1),Lda,Cwork(n2+1),  &
     &                  Sva(n2+1),mvl,V(n2*q+1,n2+1),Ldv,epsln,sfmin,   &
     &                  tol,2,Cwork(N+1),Lwork-N,ierr)

            CALL CGSVJ1(Jobv,M-n2,N-n2,n4,A(n2+1,n2+1),Lda,Cwork(n2+1), &
     &                  Sva(n2+1),mvl,V(n2*q+1,n2+1),Ldv,epsln,sfmin,   &
     &                  tol,1,Cwork(N+1),Lwork-N,ierr)
!
            CALL CGSVJ0(Jobv,M-n4,n2-n4,A(n4+1,n4+1),Lda,Cwork(n4+1),   &
     &                  Sva(n4+1),mvl,V(n4*q+1,n4+1),Ldv,epsln,sfmin,   &
     &                  tol,1,Cwork(N+1),Lwork-N,ierr)
!
            CALL CGSVJ0(Jobv,M,n4,A,Lda,Cwork,Sva,mvl,V,Ldv,epsln,sfmin,&
     &                  tol,1,Cwork(N+1),Lwork-N,ierr)
!
            CALL CGSVJ1(Jobv,M,n2,n4,A,Lda,Cwork,Sva,mvl,V,Ldv,epsln,   &
     &                  sfmin,tol,1,Cwork(N+1),Lwork-N,ierr)
!
!
         ELSEIF ( upper ) THEN
!
!
            CALL CGSVJ0(Jobv,n4,n4,A,Lda,Cwork,Sva,mvl,V,Ldv,epsln,     &
     &                  sfmin,tol,2,Cwork(N+1),Lwork-N,ierr)
!
            CALL CGSVJ0(Jobv,n2,n4,A(1,n4+1),Lda,Cwork(n4+1),Sva(n4+1), &
     &                  mvl,V(n4*q+1,n4+1),Ldv,epsln,sfmin,tol,1,       &
     &                  Cwork(N+1),Lwork-N,ierr)
!
            CALL CGSVJ1(Jobv,n2,n2,n4,A,Lda,Cwork,Sva,mvl,V,Ldv,epsln,  &
     &                  sfmin,tol,1,Cwork(N+1),Lwork-N,ierr)
!
            CALL CGSVJ0(Jobv,n2+n4,n4,A(1,n2+1),Lda,Cwork(n2+1),        &
     &                  Sva(n2+1),mvl,V(n2*q+1,n2+1),Ldv,epsln,sfmin,   &
     &                  tol,1,Cwork(N+1),Lwork-N,ierr)

         ENDIF
!
      ENDIF
!
!     .. Row-cyclic pivot strategy with de Rijk's pivoting ..
!
      DO 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 ibr = 1 , nbl
!
            igl = (ibr-1)*kbl + 1
!
            DO ir1 = 0 , MIN(lkahead,nbl-ibr)
!
               igl = igl + ir1*kbl
!
               DO p = igl , MIN(igl+kbl-1,N-1)
!
!     .. de Rijk's pivoting
!
                  q = ISAMAX(N-p+1,Sva(p),1) + p - 1
                  IF ( p/=q ) THEN
                     CALL CSWAP(M,A(1,p),1,A(1,q),1)
                     IF ( rsvec ) CALL CSWAP(mvl,V(1,p),1,V(1,q),1)
                     temp1 = Sva(p)
                     Sva(p) = Sva(q)
                     Sva(q) = temp1
                     aapq = Cwork(p)
                     Cwork(p) = Cwork(q)
                     Cwork(q) = aapq
                  ENDIF
!
                  IF ( ir1==0 ) THEN
!
!        Column norms are periodically updated by explicit
!        norm computation.
![!]     Caveat:
!        Unfortunately, some BLAS implementations compute SCNRM2(M,A(1,p),1)
!        as SQRT(S=CDOTC(M,A(1,p),1,A(1,p),1)), which may cause the result to
!        overflow for ||A(:,p)||_2 > SQRT(overflow_threshold), and to
!        underflow for ||A(:,p)||_2 < SQRT(underflow_threshold).
!        Hence, SCNRM2 cannot be trusted, not even in the case when
!        the true norm is far from the under(over)flow boundaries.
!        If properly implemented SCNRM2 is available, the IF-THEN-ELSE-END IF
!        below should be replaced with "AAPP = SCNRM2( M, A(1,p), 1 )".
!
                     IF ( (Sva(p)<rootbig) .AND. (Sva(p)>rootsfmin) )   &
     &                    THEN
                        Sva(p) = SCNRM2(M,A(1,p),1)
                     ELSE
                        temp1 = ZERO
                        aapp = ONE
                        CALL CLASSQ(M,A(1,p),1,temp1,aapp)
                        Sva(p) = temp1*SQRT(aapp)
                     ENDIF
                     aapp = Sva(p)
                  ELSE
                     aapp = Sva(p)
                  ENDIF
!
                  IF ( aapp>ZERO ) THEN
!
                     pskipped = 0
!
                     DO q = p + 1 , MIN(igl+kbl-1,N)
!
                        aaqq = Sva(q)
!
                        IF ( aaqq>ZERO ) THEN
!
                           aapp0 = aapp
                           IF ( aaqq>=ONE ) THEN
                              rotok = (small*aapp)<=aaqq
                              IF ( aapp<(big/aaqq) ) THEN
                                 aapq = (CDOTC(M,A(1,p),1,A(1,q),1)     &
     &                                  /aaqq)/aapp
                              ELSE
                                 CALL CCOPY(M,A(1,p),1,Cwork(N+1),1)
                                 CALL CLASCL('G',0,0,aapp,ONE,M,1,      &
     &                              Cwork(N+1),Lda,ierr)
                                 aapq = CDOTC(M,Cwork(N+1),1,A(1,q),1)  &
     &                                  /aaqq
                              ENDIF
                           ELSE
                              rotok = aapp<=(aaqq/small)
                              IF ( aapp>(small/aaqq) ) THEN
                                 aapq = (CDOTC(M,A(1,p),1,A(1,q),1)     &
     &                                  /aapp)/aaqq
                              ELSE
                                 CALL CCOPY(M,A(1,q),1,Cwork(N+1),1)
                                 CALL CLASCL('G',0,0,aaqq,ONE,M,1,      &
     &                              Cwork(N+1),Lda,ierr)
                                 aapq = CDOTC(M,A(1,p),1,Cwork(N+1),1)  &
     &                                  /aapp
                              ENDIF
                           ENDIF
!
!                           AAPQ = AAPQ * CONJG( CWORK(p) ) * CWORK(q)
                           aapq1 = -ABS(aapq)
                           mxaapq = MAX(mxaapq,-aapq1)
!
!        TO rotate or NOT to rotate, THAT is the question ...
!
                           IF ( ABS(aapq1)>tol ) THEN
                              ompq = aapq/ABS(aapq)
!
!           .. rotate
![RTD]      ROTATED = ROTATED + ONE
!
                              IF ( ir1==0 ) THEN
                                 notrot = 0
                                 pskipped = 0
                                 iswrot = iswrot + 1
                              ENDIF
!
                              IF ( rotok ) THEN
!
                                 aqoap = aaqq/aapp
                                 apoaq = aapp/aaqq
                                 theta = -HALF*ABS(aqoap-apoaq)/aapq1
!
                                 IF ( ABS(theta)>bigtheta ) THEN
!
                                    t = HALF/theta
                                    cs = ONE

                                    CALL CROT(M,A(1,p),1,A(1,q),1,cs,   &
     &                                 CONJG(ompq)*t)
                                    IF ( rsvec )                        &
     &                                 CALL CROT(mvl,V(1,p),1,V(1,q),1, &
     &                                 cs,CONJG(ompq)*t)

                                    Sva(q)                              &
     &                                 = aaqq*SQRT(MAX(ZERO,ONE+t*apoaq*&
     &                                 aapq1))
                                    aapp = aapp*SQRT                    &
     &                                 (MAX(ZERO,ONE-t*aqoap*aapq1))
                                    mxsinj = MAX(mxsinj,ABS(t))
!
                                 ELSE
!
!                 .. choose correct signum for THETA and rotate
!
                                    thsign = -SIGN(ONE,aapq1)
                                    t = ONE/                            &
     &                                  (theta+thsign*SQRT(ONE+theta*   &
     &                                  theta))
                                    cs = SQRT(ONE/(ONE+t*t))
                                    sn = t*cs
!
                                    mxsinj = MAX(mxsinj,ABS(sn))
                                    Sva(q)                              &
     &                                 = aaqq*SQRT(MAX(ZERO,ONE+t*apoaq*&
     &                                 aapq1))
                                    aapp = aapp*SQRT                    &
     &                                 (MAX(ZERO,ONE-t*aqoap*aapq1))
!
                                    CALL CROT(M,A(1,p),1,A(1,q),1,cs,   &
     &                                 CONJG(ompq)*sn)
                                    IF ( rsvec )                        &
     &                                 CALL CROT(mvl,V(1,p),1,V(1,q),1, &
     &                                 cs,CONJG(ompq)*sn)
                                 ENDIF
                                 Cwork(p) = -Cwork(q)*ompq
!
                              ELSE
!              .. have to use modified Gram-Schmidt like transformation
                                 CALL CCOPY(M,A(1,p),1,Cwork(N+1),1)
                                 CALL CLASCL('G',0,0,aapp,ONE,M,1,      &
     &                              Cwork(N+1),Lda,ierr)
                                 CALL CLASCL('G',0,0,aaqq,ONE,M,1,A(1,q)&
     &                              ,Lda,ierr)
                                 CALL CAXPY(M,-aapq,Cwork(N+1),1,A(1,q),&
     &                              1)
                                 CALL CLASCL('G',0,0,ONE,aaqq,M,1,A(1,q)&
     &                              ,Lda,ierr)
                                 Sva(q) = aaqq*SQRT(MAX(ZERO,ONE-aapq1* &
     &                              aapq1))
                                 mxsinj = MAX(mxsinj,sfmin)
                              ENDIF
!           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<=rooteps ) THEN
                                 IF ( (aaqq<rootbig) .AND.              &
     &                                (aaqq>rootsfmin) ) THEN
                                    Sva(q) = SCNRM2(M,A(1,q),1)
                                 ELSE
                                    t = ZERO
                                    aaqq = ONE
                                    CALL CLASSQ(M,A(1,q),1,t,aaqq)
                                    Sva(q) = t*SQRT(aaqq)
                                 ENDIF
                              ENDIF
                              IF ( (aapp/aapp0)<=rooteps ) THEN
                                 IF ( (aapp<rootbig) .AND.              &
     &                                (aapp>rootsfmin) ) THEN
                                    aapp = SCNRM2(M,A(1,p),1)
                                 ELSE
                                    t = ZERO
                                    aapp = ONE
                                    CALL CLASSQ(M,A(1,p),1,t,aapp)
                                    aapp = t*SQRT(aapp)
                                 ENDIF
                                 Sva(p) = aapp
                              ENDIF
!
                           ELSE
!                             A(:,p) and A(:,q) already numerically orthogonal
                              IF ( ir1==0 ) notrot = notrot + 1
![RTD]      SKIPPED  = SKIPPED + 1
                              pskipped = pskipped + 1
                           ENDIF
                        ELSE
!                          A(:,q) is zero column
                           IF ( ir1==0 ) notrot = notrot + 1
                           pskipped = pskipped + 1
                        ENDIF
!
                        IF ( (i<=swband) .AND. (pskipped>rowskip) ) THEN
                           IF ( ir1==0 ) aapp = -aapp
                           notrot = 0
                           EXIT
                        ENDIF
!
                     ENDDO
!     END q-LOOP
!
!     bailed out of q-loop
!
                     Sva(p) = aapp
!
                  ELSE
                     Sva(p) = aapp
                     IF ( (ir1==0) .AND. (aapp==ZERO) )                 &
     &                    notrot = notrot + MIN(igl+kbl-1,N) - p
                  ENDIF
!
               ENDDO
!     end of the p-loop
!     end of doing the block ( ibr, ibr )
            ENDDO
!     end of ir1-loop
!
! ... go to the off diagonal blocks
!
            igl = (ibr-1)*kbl + 1
!
            DO jbc = ibr + 1 , nbl
!
               jgl = (jbc-1)*kbl + 1
!
!        doing the block at ( ibr, jbc )
!
               ijblsk = 0
               DO p = igl , MIN(igl+kbl-1,N)
!
                  aapp = Sva(p)
                  IF ( aapp>ZERO ) THEN
!
                     pskipped = 0
!
                     DO q = jgl , MIN(jgl+kbl-1,N)
!
                        aaqq = Sva(q)
                        IF ( aaqq>ZERO ) THEN
                           aapp0 = aapp
!
!     .. M x 2 Jacobi SVD ..
!
!        Safe Gram matrix computation
!
                           IF ( aaqq>=ONE ) THEN
                              IF ( aapp>=aaqq ) THEN
                                 rotok = (small*aapp)<=aaqq
                              ELSE
                                 rotok = (small*aaqq)<=aapp
                              ENDIF
                              IF ( aapp<(big/aaqq) ) THEN
                                 aapq = (CDOTC(M,A(1,p),1,A(1,q),1)     &
     &                                  /aaqq)/aapp
                              ELSE
                                 CALL CCOPY(M,A(1,p),1,Cwork(N+1),1)
                                 CALL CLASCL('G',0,0,aapp,ONE,M,1,      &
     &                              Cwork(N+1),Lda,ierr)
                                 aapq = CDOTC(M,Cwork(N+1),1,A(1,q),1)  &
     &                                  /aaqq
                              ENDIF
                           ELSE
                              IF ( aapp>=aaqq ) THEN
                                 rotok = aapp<=(aaqq/small)
                              ELSE
                                 rotok = aaqq<=(aapp/small)
                              ENDIF
                              IF ( aapp>(small/aaqq) ) THEN
                                 aapq = (CDOTC(M,A(1,p),1,A(1,q),1)     &
     &                                  /MAX(aaqq,aapp))/MIN(aaqq,aapp)
                              ELSE
                                 CALL CCOPY(M,A(1,q),1,Cwork(N+1),1)
                                 CALL CLASCL('G',0,0,aaqq,ONE,M,1,      &
     &                              Cwork(N+1),Lda,ierr)
                                 aapq = CDOTC(M,A(1,p),1,Cwork(N+1),1)  &
     &                                  /aapp
                              ENDIF
                           ENDIF
!
!                           AAPQ = AAPQ * CONJG(CWORK(p))*CWORK(q)
                           aapq1 = -ABS(aapq)
                           mxaapq = MAX(mxaapq,-aapq1)
!
!        TO rotate or NOT to rotate, THAT is the question ...
!
                           IF ( ABS(aapq1)>tol ) THEN
                              ompq = aapq/ABS(aapq)
                              notrot = 0
![RTD]      ROTATED  = ROTATED + 1
                              pskipped = 0
                              iswrot = iswrot + 1
!
                              IF ( rotok ) THEN
!
                                 aqoap = aaqq/aapp
                                 apoaq = aapp/aaqq
                                 theta = -HALF*ABS(aqoap-apoaq)/aapq1
                                 IF ( aaqq>aapp0 ) theta = -theta
!
                                 IF ( ABS(theta)>bigtheta ) THEN
                                    t = HALF/theta
                                    cs = ONE
                                    CALL CROT(M,A(1,p),1,A(1,q),1,cs,   &
     &                                 CONJG(ompq)*t)
                                    IF ( rsvec )                        &
     &                                 CALL CROT(mvl,V(1,p),1,V(1,q),1, &
     &                                 cs,CONJG(ompq)*t)
                                    Sva(q)                              &
     &                                 = aaqq*SQRT(MAX(ZERO,ONE+t*apoaq*&
     &                                 aapq1))
                                    aapp = aapp*SQRT                    &
     &                                 (MAX(ZERO,ONE-t*aqoap*aapq1))
                                    mxsinj = MAX(mxsinj,ABS(t))
                                 ELSE
!
!                 .. choose correct signum for THETA and rotate
!
                                    thsign = -SIGN(ONE,aapq1)
                                    IF ( aaqq>aapp0 ) thsign = -thsign
                                    t = ONE/                            &
     &                                  (theta+thsign*SQRT(ONE+theta*   &
     &                                  theta))
                                    cs = SQRT(ONE/(ONE+t*t))
                                    sn = t*cs
                                    mxsinj = MAX(mxsinj,ABS(sn))
                                    Sva(q)                              &
     &                                 = aaqq*SQRT(MAX(ZERO,ONE+t*apoaq*&
     &                                 aapq1))
                                    aapp = aapp*SQRT                    &
     &                                 (MAX(ZERO,ONE-t*aqoap*aapq1))
!
                                    CALL CROT(M,A(1,p),1,A(1,q),1,cs,   &
     &                                 CONJG(ompq)*sn)
                                    IF ( rsvec )                        &
     &                                 CALL CROT(mvl,V(1,p),1,V(1,q),1, &
     &                                 cs,CONJG(ompq)*sn)
                                 ENDIF
                                 Cwork(p) = -Cwork(q)*ompq
!
!              .. have to use modified Gram-Schmidt like transformation
                              ELSEIF ( aapp>aaqq ) THEN
                                 CALL CCOPY(M,A(1,p),1,Cwork(N+1),1)
                                 CALL CLASCL('G',0,0,aapp,ONE,M,1,      &
     &                              Cwork(N+1),Lda,ierr)
                                 CALL CLASCL('G',0,0,aaqq,ONE,M,1,A(1,q)&
     &                              ,Lda,ierr)
                                 CALL CAXPY(M,-aapq,Cwork(N+1),1,A(1,q),&
     &                              1)
                                 CALL CLASCL('G',0,0,ONE,aaqq,M,1,A(1,q)&
     &                              ,Lda,ierr)
                                 Sva(q) = aaqq*SQRT(MAX(ZERO,ONE-aapq1* &
     &                              aapq1))
                                 mxsinj = MAX(mxsinj,sfmin)
                              ELSE
                                 CALL CCOPY(M,A(1,q),1,Cwork(N+1),1)
                                 CALL CLASCL('G',0,0,aaqq,ONE,M,1,      &
     &                              Cwork(N+1),Lda,ierr)
                                 CALL CLASCL('G',0,0,aapp,ONE,M,1,A(1,p)&
     &                              ,Lda,ierr)
                                 CALL CAXPY(M,-CONJG(aapq),Cwork(N+1),1,&
     &                              A(1,p),1)
                                 CALL CLASCL('G',0,0,ONE,aapp,M,1,A(1,p)&
     &                              ,Lda,ierr)
                                 Sva(p) = aapp*SQRT(MAX(ZERO,ONE-aapq1* &
     &                              aapq1))
                                 mxsinj = MAX(mxsinj,sfmin)
                              ENDIF
!           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<=rooteps ) THEN
                                 IF ( (aaqq<rootbig) .AND.              &
     &                                (aaqq>rootsfmin) ) THEN
                                    Sva(q) = SCNRM2(M,A(1,q),1)
                                 ELSE
                                    t = ZERO
                                    aaqq = ONE
                                    CALL CLASSQ(M,A(1,q),1,t,aaqq)
                                    Sva(q) = t*SQRT(aaqq)
                                 ENDIF
                              ENDIF
                              IF ( (aapp/aapp0)**2<=rooteps ) THEN
                                 IF ( (aapp<rootbig) .AND.              &
     &                                (aapp>rootsfmin) ) THEN
                                    aapp = SCNRM2(M,A(1,p),1)
                                 ELSE
                                    t = ZERO
                                    aapp = ONE
                                    CALL CLASSQ(M,A(1,p),1,t,aapp)
                                    aapp = t*SQRT(aapp)
                                 ENDIF
                                 Sva(p) = aapp
                              ENDIF
!              end of OK rotation
                           ELSE
                              notrot = notrot + 1
![RTD]      SKIPPED  = SKIPPED  + 1
                              pskipped = pskipped + 1
                              ijblsk = ijblsk + 1
                           ENDIF
                        ELSE
                           notrot = notrot + 1
                           pskipped = pskipped + 1
                           ijblsk = ijblsk + 1
                        ENDIF
!
                        IF ( (i<=swband) .AND. (ijblsk>=blskip) ) THEN
                           Sva(p) = aapp
                           notrot = 0
                           GOTO 20
                        ENDIF
                        IF ( (i<=swband) .AND. (pskipped>rowskip) ) THEN
                           aapp = -aapp
                           notrot = 0
                           EXIT
                        ENDIF
!
                     ENDDO
!        end of the q-loop
!
                     Sva(p) = aapp
!
                  ELSE
!
                     IF ( aapp==ZERO ) notrot = notrot +                &
     &                    MIN(jgl+kbl-1,N) - jgl + 1
                     IF ( aapp<ZERO ) notrot = 0
!
                  ENDIF
!
               ENDDO
!     end of the p-loop
            ENDDO
!     end of the jbc-loop
!2011 bailed out of the jbc-loop
 20         DO p = igl , MIN(igl+kbl-1,N)
               Sva(p) = ABS(Sva(p))
            ENDDO
!**
         ENDDO
!2000 :: end of the ibr-loop
!
!     .. update SVA(N)
         IF ( (Sva(N)<rootbig) .AND. (Sva(N)>rootsfmin) ) THEN
            Sva(N) = SCNRM2(M,A(1,N),1)
         ELSE
            t = ZERO
            aapp = ONE
            CALL CLASSQ(M,A(1,N),1,t,aapp)
            Sva(N) = t*SQRT(aapp)
         ENDIF
!
!     Additional steering devices
!
         IF ( (i<swband) .AND. ((mxaapq<=roottol) .OR. (iswrot<=N)) )   &
     &        swband = i
!
         IF ( (i>swband+1) .AND. (mxaapq<SQRT(REAL(N))*tol) .AND.       &
     &        (REAL(N)*mxaapq*mxsinj<tol) ) GOTO 100
!
         IF ( notrot>=emptsw ) GOTO 100
!
      ENDDO
!     end i=1:NSWEEP loop
!
! #:( Reaching this point means that the procedure has not converged.
      Info = NSWEEP - 1
      GOTO 200
!
! #:) Reaching this point means numerical convergence after the i-th
!     sweep.
!
 100  Info = 0
! #:) INFO = 0 confirms successful iterations.
!
!     Sort the singular values and find how many are above
!     the underflow threshold.
!
 200  n2 = 0
      n4 = 0
      DO p = 1 , N - 1
         q = ISAMAX(N-p+1,Sva(p),1) + p - 1
         IF ( p/=q ) THEN
            temp1 = Sva(p)
            Sva(p) = Sva(q)
            Sva(q) = temp1
            CALL CSWAP(M,A(1,p),1,A(1,q),1)
            IF ( rsvec ) CALL CSWAP(mvl,V(1,p),1,V(1,q),1)
         ENDIF
         IF ( Sva(p)/=ZERO ) THEN
            n4 = n4 + 1
            IF ( Sva(p)*skl>sfmin ) n2 = n2 + 1
         ENDIF
      ENDDO
      IF ( Sva(N)/=ZERO ) THEN
         n4 = n4 + 1
         IF ( Sva(N)*skl>sfmin ) n2 = n2 + 1
      ENDIF
!
!     Normalize the left singular vectors.
!
      IF ( lsvec .OR. uctol ) THEN
         DO p = 1 , n4
!           CALL CSSCAL( M, ONE / SVA( p ), A( 1, p ), 1 )
            CALL CLASCL('G',0,0,Sva(p),ONE,M,1,A(1,p),M,ierr)
         ENDDO
      ENDIF
!
!     Scale the product of Jacobi rotations.
!
      IF ( rsvec ) THEN
         DO p = 1 , N
            temp1 = ONE/SCNRM2(mvl,V(1,p),1)
            CALL CSSCAL(mvl,temp1,V(1,p),1)
         ENDDO
      ENDIF
!
!     Undo scaling, if necessary (and possible).
      IF ( ((skl>ONE) .AND. (Sva(1)<(big/skl))) .OR.                    &
     &     ((skl<ONE) .AND. (Sva(MAX(n2,1))>(sfmin/skl))) ) THEN
         DO p = 1 , N
            Sva(p) = skl*Sva(p)
         ENDDO
         skl = ONE
      ENDIF
!
      Rwork(1) = skl
!     The singular values of A are SKL*SVA(1:N). If SKL.NE.ONE
!     then some of the singular values may overflow or underflow and
!     the spectrum is given in this factored representation.
!
      Rwork(2) = REAL(n4)
!     N4 is the number of computed nonzero singular values of A.
!
      Rwork(3) = REAL(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.
!
      Rwork(4) = REAL(i)
!     i is the index of the last sweep before declaring convergence.
!
      Rwork(5) = mxaapq
!     MXAAPQ is the largest absolute value of scaled pivots in the
!     last sweep
!
      Rwork(6) = mxsinj
!     MXSINJ is the largest absolute value of the sines of Jacobi angles
!     in the last sweep
!
!     ..
!     .. END OF CGESVJ
!     ..
      END SUBROUTINE CGESVJ


module multifab_filter_module

  use multifab_module

  implicit none

  private

  public :: multifab_filter

contains

  subroutine multifab_filter(mfab, width)

    ! Note: This routine assumes ghost values are valid on entry but does NOT
    !       sync ghost values at the end.
    !       If ghost values need to remain consistent do a multifab_fill_boundary
    !       after calling multifab_filter!

    type(multifab), intent(inout) :: mfab
    integer       , intent(in   ) :: width

    ! local
    integer :: i,j,k,box,dm
    real(kind=dp_t), pointer :: fp(:,:,:,:), fpvar(:,:,:,:)

    integer :: lo(3), hi(3), lo_g(3), hi_g(3)

    type(bl_prof_timer),save :: bpt

    call build(bpt,"multifab_filter")

    lo=1
    hi=1
    lo_g=1
    hi_g=1

    dm = multifab_get_dim(mfab)

    !--------------------------------------
    FilterX: do box = 1, nfabs(mfab)

       fp => dataptr(mfab,box) ! Including ghosts

       ! Without ghosts:
       lo(1:dm) = lwb(get_ibox(mfab,box))
       hi(1:dm) = upb(get_ibox(mfab,box))
       !write(*,*) "lo=", lo, " hi=", hi

       ! With ghosts:
       lo_g(1:dm) = lwb(get_pbox(mfab,box))
       hi_g(1:dm) = upb(get_pbox(mfab,box))
       !write(*,*) "lo_g=", lo_g, " hi_g=", hi_g

       if(.not.(all(lo_g(1:dm)<=lo(1:dm)-width) .and. all(hi_g(1:dm)>=hi(1:dm)+width) ) ) then
         call bl_error("Filtering requires at least width cells!")
       end if

       allocate(fpvar(lo(1):hi(1),lo(2):hi(2),lo(3):hi(3), &
                      lbound(fp,4):ubound(fp,4))) ! Temporary array

       ! Filter along x:
       do k = lo(3),hi(3)
          do j = lo(2),hi(2)
             do i = lo(1),hi(1)
                select case(width)
                case(1)
                   fpvar(i,j,k,:) = ( fp(i,j,k,:)/2 &
                     +fp(i-1,j,k,:)/4+fp(i+1,j,k,:)/4 )
                case(2)
                   fpvar(i,j,k,:) = ( 5*fp(i,j,k,:)/8 &
                     -fp(i-2,j,k,:)/16+fp(i-1,j,k,:)/4 &
                     -fp(i+2,j,k,:)/16+fp(i+1,j,k,:)/4 )
                case(4)
                   fpvar(i,j,k,:) = ( 93*fp(i,j,k,:)/128 &
                     + 7*fp(i-1,j,k,:)/32 - 7*fp(i-2,j,k,:)/64 + fp(i-3,j,k,:)/32 - fp(i-4,j,k,:)/256 &
                     + 7*fp(i+1,j,k,:)/32 - 7*fp(i+2,j,k,:)/64 + fp(i+3,j,k,:)/32 - fp(i+4,j,k,:)/256 )
                case default
                  call bl_error("Input width must be 0,1,2 or 4")
                end select
             end do
          end do
       end do
       fp(lo(1):hi(1),lo(2):hi(2),lo(3):hi(3),:) = fpvar(lo(1):hi(1),lo(2):hi(2),lo(3):hi(3),:)

       deallocate(fpvar)

    end do FilterX

    !--------------------------------------
    ! Update ghost values to reflect filtering
    call multifab_fill_boundary(mfab)

    FilterY: do box = 1, nfabs(mfab)

       fp => dataptr(mfab,box) ! Including ghosts

       ! Without ghosts:
       lo(1:dm) = lwb(get_ibox(mfab,box))
       hi(1:dm) = upb(get_ibox(mfab,box))
       ! With ghosts:
       lo_g(1:dm) = lwb(get_pbox(mfab,box))
       hi_g(1:dm) = upb(get_pbox(mfab,box))

       allocate(fpvar(lo(1):hi(1),lo(2):hi(2),lo(3):hi(3), &
                      lbound(fp,4):ubound(fp,4))) ! Temporary array

       ! Filter along y:
       do k = lo(3),hi(3)
          do j = lo(2),hi(2)
             do i = lo(1),hi(1)
                select case(width)
                case(1)
                   fpvar(i,j,k,:) = ( fp(i,j,k,:)/2 &
                     +fp(i,j-1,k,:)/4+fp(i,j+1,k,:)/4 )
                case(2)
                   fpvar(i,j,k,:) = ( 5*fp(i,j,k,:)/8 &
                    -fp(i,j-2,k,:)/16+fp(i,j-1,k,:)/4 &
                    -fp(i,j+2,k,:)/16+fp(i,j+1,k,:)/4 )
                case(4)
                   fpvar(i,j,k,:) = ( 93*fp(i,j,k,:)/128 &
                     + 7*fp(i,j-1,k,:)/32 - 7*fp(i,j-2,k,:)/64 + fp(i,j-3,k,:)/32 - fp(i,j-4,k,:)/256 &
                     + 7*fp(i,j+1,k,:)/32 - 7*fp(i,j+2,k,:)/64 + fp(i,j+3,k,:)/32 - fp(i,j+4,k,:)/256 )
                case default
                  call bl_error("Input width must be 0,1,2 or 4")
                end select
             end do
          end do
       end do
       fp(lo(1):hi(1),lo(2):hi(2),lo(3):hi(3),:) = fpvar(lo(1):hi(1),lo(2):hi(2),lo(3):hi(3),:)

       deallocate(fpvar)

    end do FilterY
    !--------------------------------------

    if(dm<=2) return ! We are done

    !--------------------------------------
    call multifab_fill_boundary(mfab) ! Update ghost values to reflect filtering

    FilterZ: do box = 1, nfabs(mfab)

       fp => dataptr(mfab,box) ! Including ghosts

       ! Without ghosts:
       lo(1:dm) = lwb(get_ibox(mfab,box))
       hi(1:dm) = upb(get_ibox(mfab,box))
       ! With ghosts:
       lo_g(1:dm) = lwb(get_pbox(mfab,box))
       hi_g(1:dm) = upb(get_pbox(mfab,box))

       allocate(fpvar(lo(1):hi(1),lo(2):hi(2),lo(3):hi(3), &
                      lbound(fp,4):ubound(fp,4))) ! Temporary array

       ! Filter along z:
       do k = lo(3),hi(3)
          do j = lo(2),hi(2)
             do i = lo(1),hi(1)
                select case(width)
                case(1)
                   fpvar(i,j,k,:) = ( fp(i,j,k,:)/2 &
                     +fp(i,j,k-1,:)/4+fp(i,j,k+1,:)/4 )
                case(2)
                   fpvar(i,j,k,:) = ( 5*fp(i,j,k,:)/8 &
                    -fp(i,j,k-2,:)/16+fp(i,j,k-1,:)/4 &
                    -fp(i,j,k+2,:)/16+fp(i,j,k+1,:)/4 )
                case(4)
                   fpvar(i,j,k,:) = ( 93*fp(i,j,k,:)/128 &
                     + 7*fp(i,j,k-1,:)/32 - 7*fp(i,j,k-2,:)/64 + fp(i,j,k-3,:)/32 - fp(i,j,k-4,:)/256 &
                     + 7*fp(i,j,k+1,:)/32 - 7*fp(i,j,k+2,:)/64 + fp(i,j,k+3,:)/32 - fp(i,j,k+4,:)/256 )
                case default
                  call bl_error("Input width must be 0,1,2 or 4")
                end select
             end do
          end do
       end do
       fp(lo(1):hi(1),lo(2):hi(2),lo(3):hi(3),:) = fpvar(lo(1):hi(1),lo(2):hi(2),lo(3):hi(3),:)

       deallocate(fpvar)

    end do FilterZ
    !--------------------------------------

    call destroy(bpt)

  end subroutine multifab_filter

end module multifab_filter_module


program test_potential3D

use mpi
use mumps_interface, only : mumps_struc, mumps_exec

implicit none (type, external)

type(mumps_struc) :: mumps_par

integer :: ierr

integer, parameter :: npts1=34,npts2=144,npts3=96
integer, parameter :: lk=npts1*npts2*npts3
integer :: lent
integer :: ix1,ix2,ix3,lx1,lx2,lx3
integer :: iPhi,ient
integer, dimension(:), allocatable :: ir,ic
real(8), dimension(:), allocatable :: M
real(8), dimension(:), allocatable :: b
real(8) :: dx1
real(8), dimension(npts2,npts3) :: Vminx1,Vmaxx1
real(8), dimension(npts1,npts3) :: Vminx2,Vmaxx2
real(8), dimension(npts1,npts2) :: Vminx3,Vmaxx3
real(8), dimension(:,:), allocatable ::  Mfull
real(8) :: tstart,tfin

!------------------------------------------------------------
!-------DEFINE A MATRIX USING SPARSE STORAGE (CENTRALIZED
!-------ASSEMBLED MATRIX INPUT, SEE SECTION 4.5 OF MUMPS USER
!-------GUIDE).
!------------------------------------------------------------
lent=7*(npts1-2)*(npts2-2)*(npts3-2)                                           !interior entries
lent=lent+2*(npts1-2)*(npts2-2)+2*(npts2-2)*(npts3-2)+2*(npts1-2)*(npts3-2)    !6 faces of cube
lent=lent+4*(npts1-2)+4*(npts2-2)+4*(npts3-2)                                  !12 edges
lent=lent+8                                                                    !8 corners
allocate(ir(lent),ic(lent),M(lent),b(lk))
lx1=npts1
lx2=npts2
lx3=npts3

dx1=1.0/npts1           !scale dx so the domain of problem is [0,1]

Vminx1(:,:)=0
Vmaxx1(:,:)=0
Vminx2(:,:)=0
Vmaxx2(:,:)=0
Vminx3(:,:)=0
Vmaxx3(:,:)=10

M(:)=0.0
b(:)=0.0
ient=1

!LOAD UP MATRIX ELEMENTS
do ix3=1,lx3
  do ix2=1,lx2
    do ix1=1,lx1
      iPhi=lx1*lx2*(ix3-1)+lx1*(ix2-1)+ix1     !linear index referencing Phi(ix1,ix2,ix3) as a column vector.  Also row # of big matrix

      if (ix1==1) then
        ir(ient)=iPhi
        ic(ient)=iPhi
        M(ient)=1.0
        b(iPhi)=Vminx1(ix2,ix3)
        ient=ient+1
      elseif (ix1==lx1) then
        ir(ient)=iPhi
        ic(ient)=iPhi
        M(ient)=1.0
        b(iPhi)=Vmaxx1(ix2,ix3)
        ient=ient+1
      elseif (ix2==1) then
        ir(ient)=iPhi
        ic(ient)=iPhi
        M(ient)=1.0
        b(iPhi)=Vminx2(ix1,ix3)
        ient=ient+1
      elseif (ix2==lx2) then
        ir(ient)=iPhi
        ic(ient)=iPhi
        M(ient)=1.0
        b(iPhi)=Vmaxx2(ix1,ix3)
        ient=ient+1
      elseif (ix3==1) then
        ir(ient)=iPhi
        ic(ient)=iPhi
        M(ient)=1.0
        b(iPhi)=Vminx3(ix1,ix2)
        ient=ient+1
      elseif (ix3==lx3) then
        ir(ient)=iPhi
        ic(ient)=iPhi
        M(ient)=1.0
        b(iPhi)=Vmaxx3(ix1,ix2)
        ient=ient+1
      else                       !INTERIOR
        !ix1,ix2,ix3-1 grid point in ix1,ix2,ix3 equation
        ir(ient)=iPhi
        ic(ient)=iPhi-lx1*lx2
        M(ient)=1.0
        ient=ient+1

        !ix1,ix2-1,ix3
        ir(ient)=iPhi
        ic(ient)=iPhi-lx1
        M(ient)=1.0
        ient=ient+1

        !ix1-1,ix2,ix3
        ir(ient)=iPhi
        ic(ient)=iPhi-1
        M(ient)=1.0
        ient=ient+1

        !ix1,ix2,ix3
        ir(ient)=iPhi
        ic(ient)=iPhi
        M(ient)=-6.0
        ient=ient+1

        !ix1+1,ix2,ix3
        ir(ient)=iPhi
        ic(ient)=iPhi+1
        M(ient)=1.0
        ient=ient+1

        !ix1,ix2+1,ix3
        ir(ient)=iPhi
        ic(ient)=iPhi+lx1
        M(ient)=1.0
        ient=ient+1

        !ix1,ix2,ix3+1
        ir(ient)=iPhi
        ic(ient)=iPhi+lx1*lx2
        M(ient)=1.0
        ient=ient+1
      end if
    end do
  end do
end do

!CORRECT FOR DX /= 1
b=b*dx1**2

!OUTPUT FULL MATRIX FOR DEBUGGING IF ITS NOT TOO BIG (ZZZ --> CAN BE COMMENTED OUT)
block
  integer :: u
  open(newunit=u,file='test_potential3D.dat',status='replace')
  write(u,*) lx1,lx2,lx3
  if (lk<150) then
    allocate(Mfull(lk,lk))
    Mfull(:,:)=0.0
    do ient=1,size(ir)
      Mfull(ir(ient),ic(ient))=M(ient)
    end do
    call write2Darray(u,Mfull)
    call writearray(u,b)
    deallocate(Mfull)
  end if

  !------------------------------------------------------------
  !-------DO SOME STUFF TO CALL MUMPS
  !------------------------------------------------------------
  call MPI_INIT(IERR)
  if (ierr/=0) error stop 'mpi init'

  ! Define a communicator for the package.
  mumps_par%COMM = MPI_COMM_WORLD

  !Initialize an instance of the package
  !for L U factorization (sym = 0, with working host)
  mumps_par%JOB = -1
  mumps_par%SYM = 0
  mumps_par%PAR = 1
  call mumps_exec(mumps_par)

  !Define problem on the host (processor 0)
  if ( mumps_par%MYID .eq. 0 ) then
    mumps_par%N=lk
    mumps_par%NZ=lent
    allocate( mumps_par%IRN ( mumps_par%NZ ) )
    allocate( mumps_par%JCN ( mumps_par%NZ ) )
    allocate( mumps_par%A( mumps_par%NZ ) )
    allocate( mumps_par%RHS ( mumps_par%N  ) )
    mumps_par%IRN=ir
    mumps_par%JCN=ic
    mumps_par%A=M
    mumps_par%RHS=b

  !  mumps_par%ICNTL(7)=6    !force a particular reordering - see mumps docs
  !  mumps_par%ICNTL(28)=2
  !  mumps_par%ICNTL(29)=2
  end if

  !Call package for solution
  mumps_par%JOB = 6
  call cpu_time(tstart)
  call mumps_exec(mumps_par)
  call cpu_time(tfin)
  write(*,*) 'Solve took ',tfin-tstart,' seconds...'

  !Solution has been assembled on the host
  if ( mumps_par%MYID == 0 ) then
    call writearray(u,mumps_par%RHS/dx1**2)
  end if
  close(u)
end block

!Deallocate user data
if ( mumps_par%MYID == 0 ) then
  deallocate( mumps_par%IRN )
  deallocate( mumps_par%JCN )
  deallocate( mumps_par%A   )
  deallocate( mumps_par%RHS )
end if
deallocate(ir,ic,M,b)

!Destroy the instance (deallocate internal data structures)
mumps_par%JOB = -2
call mumps_exec(mumps_par)

call MPI_FINALIZE(IERR)
if (ierr /= 0) error stop 'mpi finalize'

contains

  subroutine writearray(fileunit,array)
    integer, intent(in) :: fileunit
    real(8), dimension(:), intent(in) :: array

    integer :: k

    do k=1,size(array)
      write(fileunit,*) array(k)
    end do
  end subroutine writearray

  subroutine write2Darray(fileunit,array)
    integer, intent(in) :: fileunit
    real(8), dimension(:,:), intent(in) :: array

    integer :: k1,k2

    do k1=1,size(array,1)
      write(fileunit,'(f4.0)') (array(k1,k2), k2=1,size(array,2))
    end do
  end subroutine write2Darray

end program test_potential3D


C NCLFORTSTART
      SUBROUTINE DLSPOLY(N,M,X,Y,WGT,COEF,IER)
      INTEGER N,M,IER
      DOUBLE PRECISION X(M),Y(M),WGT(M),COEF(N)
C NCLEND

C NCL:   coef = lspoly(x,y,wgt,n)

C AUTOMATIC ARRAYS AND LOCAL VARIABLES
      INTEGER IC(N)
      DOUBLE PRECISION WRK(N,N),WRK2(M)
      INTEGER I
C
C TEST INPUT PARAMETERS
C .   IER=1:  M LESS THAN N IN LSPOLY
C .   IER=2:  DEGREE OF POLYNOMIAL GREATER THAN 4 IN LSPOLY **WARNING**
C .   IER=3:  MATRIX SINGULAR IN LSPOLY
C
      IER = 0
      IF (M.LE.N) IER = 1
      IF (N.GT.5) IER = 2
      IF (IER.NE.0) THEN
          DO I = 1,N
              COEF(I) = 1D20
          END DO
          RETURN
      END IF
C
      CALL DLSPLY2(M,N,X,Y,COEF,WGT,WRK,WRK2,IC,IER)
C
      RETURN
      END
C----------------------------------------------------------------------
C ++++ ORIGINAL LSPOLY DOCUMENTATION ++++
C     SUBROUTINE DLSPOLY (N,M,X,Y,W,C,WRK,IER)
C DIMENSION OF           X(M),Y(M),W(M),C(N),WRK(N**2+N+M)
C ARGUMENTS
C
C LATEST REVISION        FEBRUARY 1985
C
C PURPOSE                GIVEN A SET OF DATA (X(I),Y(I)), I = 1,...,M,
C                        LSPOLY CALCULATES A SET OF COEFFICIENTS FOR A
C                        WEIGHTED LEAST SQUARES POLYNOMIAL FIT TO THE
C                        GIVEN DATA.  IT IS NECESSARY THAT M (THE NUMBER
C                        OF DATA POINTS) BE GREATER THAN OR EQUAL TO N
C                        (THE NUMBER OF COEFFICIENTS).
C
C USAGE                  CALL DLSPOLY (N,M,X,Y,W,C,WRK,IER)
C
C ARGUMENTS
C
C ON INPUT               N
C                          AN INTEGER VARIABLE SET EQUAL TO THE NUMBER
C                          OF COEFFICIENTS DESIRED (I.E., N-1 WILL BE
C                          THE DEGREE OF THE POLYNOMIAL).
C
C                        M
C                          AN INTEGER VARIABLE SET EQUAL TO THE NUMBER
C                          OF DATA POINTS.  M MUST BE GREATER THAN OR
C                          EQUAL TO N.
C
C                        X
C                          A REAL ARRAY WITH DIMENSION AT LEAST M.  ON
C                          INPUT, X CONTAINS THE ABSCISSA VALUES OF THE
C                          DATA POINTS.
C
C                        Y
C                          A REAL ARRAY WITH DIMENSION AT LEAST M.  ON
C                          INPUT, Y CONTAINS THE ORDINATE VALUES OF THE
C                          DATA POINTS.
C
C                        W
C                          A REAL ARRAY WITH DIMENSION AT LEAST M.  ON
C                          INPUT, W IS A VECTOR OF WEIGHTS FOR A
C                          WEIGHTED LEAST SQUARES MODEL.  IF NO
C                          WEIGHTING IS DESIRED, THE ELEMENTS OF W
C                          SHOULD BE SET TO 1 .
C
C                        WRK
C                          A REAL ARRAY WITH DIMENSION AT LEAST N*N+N+M.
C                          WRK IS USED INTERNALLY FOR WORKING STORAGE.
C
C ON OUTPUT              C
C                          A REAL ARRAY WITH DIMENSION AT LEAST N.  ON
C                          OUTPUT, C CONTAINS THE COEFFICIENTS FOR THE
C                          POLYNOMIAL.  C(1) WILL CONTAIN THE CONSTANT
C                          TERM.
C
C                        IER
C                          AN INTEGER ERROR FLAG
C                          = 1  IF M .LT. N.
C                          = 2  IF N .GT. 5 (NON-FATAL).
C                          = 3  IF THE LINEAR SYSTEM IS SINGULAR.
C                          = 0  OTHERWISE.
C
C I/O                    ALL MESSAGES ARE PRINTED USING ROUTINE ULIBER.
C
C                        FOR IER = 1, THE FOLLOWING MESSAGE IS PRINTED.
C                            M LESS THAN N IN LSPOLY
C
C                        FOR IER = 2, THE FOLLOWING MESSAGE IS PRINTED.
C                            **WARNING** DEGREE OF POLYNOMIAL GREATER
C                                        THAN 4 IN LSPOLY
C
C                        FOR IER = 3, THE FOLLOWING MESSAGE IS PRINTED.
C                            *MATRIX SINGULAR IN LSPOLY*
C
C HISTORY                LSPOLY WAS WRITTEN IN THE EARLY 1970'S
C                        BY MEMBERS OF NCAR'S SCIENTIFIC COMPUTING
C                        DIVISION.  LSPOLY REPLACES FORMER ULIB
C                        ROUTINE LSTSQR.
C
C PORTABILITY            FORTRAN 66.
C
C ALGORITHM              LSPOLY FORMS THE NORMAL EQUATIONS AND SOLVES
C                        THE RESULTING SQUARE LINEAR SYSTEM USING
C                        GAUSSIAN ELIMINATION WITH FULL PIVOTING.
C
C ACCURACY               FOR LOWER ORDER POLYNOMIALS (N .LE. 5), LSPOLY
C                        CAN BE EXPECTED TO GIVE SATISFACTORY RESULTS.
C                        AS THE DEGREE OF THE FITTING POLYNOMIAL IS
C                        INCREASED, THE PROBLEM BECOMES NUMERICALLY
C                        UNSTABLE.  IF A HIGHER DEGREE POLYNOMIAL FIT
C                        IS DESIRED, THEN ROUTINE RGRSN1 SHOULD
C                        BE USED.
C
C **********************************************************************
c c c SUBROUTINE DLSPOLY (N,M,X,Y,W,C,WRK,IER)
c c c DIMENSION       X(M)       ,Y(M)       ,W(M)       ,C(N)       ,
c c c1                WRK(1)
c c c SAVE
c c c I1 = N*N+1
c c c I2 = N*N+M+1
c c c CALL DLSPLY2 (M,N,X,Y,C,W,WRK,WRK(I1),WRK(I2),IER)
c c c RETURN
c c   END
C **************************************************************
C the following was modified to provide explicit array sizes
C **************************************************************
      SUBROUTINE DLSPLY2(M,N,X,Y,C,W,WRK,WRK2,IC,IER)
C
      IMPLICIT NONE
      INTEGER M,N,IC(N),IER
      DOUBLE PRECISION X(M),Y(M),W(M),WRK(N,N),WRK2(M)
      DOUBLE PRECISION C(N)
C
      DOUBLE PRECISION C1,HOLD,A,AMXA,AMXFS
      INTEGER I,J,NM1,NP1,NMI,K,KP1,ICT,ICNMI,IRT

C
C FORM NORMAL EQUATIONS
C
      DO I = 1,M
          WRK2(I) = W(I)
      END DO

      DO J = 1,N
          WRK(1,J) = 0.D0
          C(J) = 0.D0
          DO I = 1,M
              WRK(1,J) = WRK(1,J) + WRK2(I)
              C(J) = C(J) + WRK2(I)*Y(I)
              WRK2(I) = WRK2(I)*X(I)
          END DO
      END DO

      IF (N.NE.1) THEN
          DO J = 2,N
              WRK(J,N) = 0.D0
              DO I = 1,M
                  WRK(J,N) = WRK(J,N) + WRK2(I)
                  WRK2(I) = WRK2(I)*X(I)
              END DO
          END DO
          DO I = 2,N
              DO J = 2,N
                  WRK(I,J-1) = WRK(I-1,J)
              END DO
          END DO
      END IF
      NM1 = N - 1

      IF (N.EQ.1) GO TO 240
C
C DECOMPOSE MATRIX USING GAUSSIAN ELIMINATION WITH FULL PIVOTING
C
      NP1 = N + 1
      DO K = 1,NM1
          KP1 = K + 1
          AMXA = 0.D0
          DO J = K,N
              DO I = K,N
                  A = ABS(WRK(I,J))
                  IF ((AMXA-A).LT.0.D0) THEN
                      AMXA = A
                      IRT = I
                      ICT = J
                  END IF
              END DO
          END DO
          IC(K) = ICT
          IF ((IRT-K).NE.0) THEN
              DO J = 1,N
                  HOLD = WRK(IRT,J)
                  WRK(IRT,J) = WRK(K,J)
                  WRK(K,J) = HOLD
              END DO
              HOLD = C(IRT)
              C(IRT) = C(K)
              C(K) = HOLD
          END IF
          IF ((ICT-K).NE.0) THEN
              DO I = 1,N
                  HOLD = WRK(I,ICT)
                  WRK(I,ICT) = WRK(I,K)
                  WRK(I,K) = HOLD
              END DO
          END IF
          IF (K.EQ.1) AMXFS = ABS(AMXA)
          IF ((ABS(AMXA/DBLE(K))+AMXFS).EQ.AMXFS) GO TO 290
          C1 = 1.D0/AMXA
          DO J = KP1,N
              WRK(K,J) = WRK(K,J)*C1
          END DO
          C(K) = C(K)*C1
          DO I = KP1,N
              DO J = KP1,N
                  WRK(I,J) = WRK(I,J) - WRK(I,K)*WRK(K,J)
              END DO
              C(I) = C(I) - WRK(I,K)*C(K)
          END DO
      END DO
C
C SOLVE FOR COEFFICIENTS USING BACK SUBSTITUTION
C
      IF ((ABS(WRK(N,N)/DBLE(N))+AMXFS).EQ.AMXFS) GO TO 290
  240 C(N) = C(N)/WRK(N,N)
      IF (N.EQ.1) RETURN
      DO I = 1,NM1
          NMI = N - I
          DO K = NMI,NM1
              C(NMI) = C(NMI) - WRK(NMI,K+1)*C(K+1)
          END DO
      END DO
C
C PERMUTE SOLUTION VECTOR
C
      DO I = 1,NM1
          NMI = N - I
          ICNMI = IC(NMI)
          IF (ICNMI-NMI.NE.0) THEN
              HOLD = C(ICNMI)
              C(ICNMI) = C(NMI)
              C(NMI) = HOLD
          END IF
      END DO
      RETURN

  290 IER = 3
c c c CALL ULIBER (33,28H *MATRIX SINGULAR IN LSPOLY*,28)
      RETURN
      END


! Subroutine SNOEMINT gets NO estimate from the NOEM emperical model and
! INTerpolates it onto an altitude grid.  Extrapolation is done above 150
! km assuming a scale height approximation, and below 100 km
! assuming a constant number density profile.

! Stan Solomon, 12/2014
! Refactored to f90, scs, 6/2016
! Fixed bug in Kp (estimated from Ap) so that xkp >= 0, scs, 1/2017

! Input:
!   IDATE  Date in yyddd or yyyyddd format
!   GLAT   Geographic latitude in degrees
!   GLONG  Geographic longitude in degrees
!   F107   10.7 cm radio flux index
!   AP     Ap index
!   JMAX   Number of points in altitude grid
!   Z      Altitude grid in km
!   ZTN    Temperature at Z in K
! Output:
!   ZNO    Nitric oxide density at Z in cm-3

    subroutine snoemint(idate,glat,glong,f107,ap,jmax,z,ztn,zno)

      implicit none

      integer,intent(in) :: idate, jmax
      real,intent(in) :: glat, glong, f107, ap, z(jmax), ztn(jmax)
      real,intent(out) :: zno(jmax)

      real,parameter :: pi=3.1415926536

      integer :: iday, klat1, klat2, kz1, kz2, j
      real :: zg(16), xmlatno(33), zmno(33,16), zmnoi(16)
      real :: xmlong, xmlat, xkp, rat, h

! Find magnetic latitude:

      call geomag(0,glong,glat,xmlong,xmlat)

! Get zonal mean no profiles:

      iday=idate-idate/1000*1000
      xkp=1.75*alog(0.4*ap)
      if (xkp < 0.0) xkp=0.0
      call snoem(iday,xkp,f107,zg,xmlatno,zmno)

! Interpolate altitude profile at magnetic latitude:

      klat1=ifix(xmlat+80.)/5+1
      klat2=klat1+1
      if (klat1 < 1) klat1=1
      if (klat1 > 33) klat1=33
      if (klat2 < 1) klat1=1
      if (klat2 > 33) klat2=33
      rat=xmlat/5.-ifix(xmlat)/5

      do j=1,16
        zmnoi(j) = alog(zmno(klat1,j)*(1.-rat)+zmno(klat2,j)*rat)
      end do

! Interpolate onto altitude grid:
! Use constant value below 100 km and scale height assumption above 150 km:

      h=0.03*ztn(jmax)
      do j=1,jmax
        if (z(j) <= 100.) zno(j)=exp(zmnoi(16))
        if (z(j) > 100. .and. z(j) <= 150.) then
          kz2=ifix((150.-z(j))*.3)+1
          kz1=kz2+1
          zno(j)=exp(zmnoi(kz1) + (zmnoi(kz2)-zmnoi(kz1)) * (z(j)-zg(kz1)) / (zg(kz2)-zg(kz1)))
        endif
        if (z(j) > 150.) zno(j)=exp(zmnoi(1)+(150.-z(j))/h)
      end do

      return

    end


!==========================================================================
elemental function gsw_sp_from_sa (sa, p, long, lat)
!==========================================================================
!
! Calculates Practical salinity, sp, from Absolute salinity, sa
!
! sa     : Absolute Salinity                               [g/kg]
! p      : sea pressure                                    [dbar]
! long   : longitude                                       [DEG E]
! lat    : latitude                                        [DEG N]
!
! gsw_sp_from_sa      : Practical Salinity                 [unitless]
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_saar, gsw_sp_from_sa_baltic

use gsw_mod_error_functions, only : gsw_error_code, gsw_error_limit

use gsw_mod_teos10_constants, only : gsw_ups

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, p, long, lat

real (r8) :: gsw_sp_from_sa

real (r8) :: saar, sp_baltic

character (*), parameter :: func_name = "gsw_sp_from_sa"

sp_baltic = gsw_sp_from_sa_baltic(sa,long,lat)

if (sp_baltic .lt. 1e10_r8) then

   gsw_sp_from_sa = sp_baltic

else

   saar = gsw_saar(p,long,lat)
   if (saar .gt. gsw_error_limit) then
      gsw_sp_from_sa = gsw_error_code(1,func_name,saar)
   else
      gsw_sp_from_sa = (sa/gsw_ups)/(1.0_r8 + saar)
   end if

end if

return
end function

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