*> \brief  DGESV computes the solution to system of linear equations A * X = B for GE matrices
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DGESV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
*       .. Scalar Arguments ..
*       INTEGER            INFO, LDA, LDB, N, NRHS
*       ..
*       .. Array Arguments ..
*       INTEGER            IPIV( * )
*       DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DGESV computes the solution to a real system of linear equations
*>    A * X = B,
*> where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
*>
*> The LU decomposition with partial pivoting and row interchanges is
*> used to factor A as
*>    A = P * L * U,
*> where P is a permutation matrix, L is unit lower triangular, and U is
*> upper triangular.  The factored form of A is then used to solve the
*> system of equations A * X = B.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of linear equations, i.e., the order of the
*>          matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*>          NRHS is INTEGER
*>          The number of right hand sides, i.e., the number of columns
*>          of the matrix B.  NRHS >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is DOUBLE PRECISION array, dimension (LDA,N)
*>          On entry, the N-by-N coefficient matrix A.
*>          On exit, the factors L and U from the factorization
*>          A = P*L*U; the unit diagonal elements of L are not stored.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] IPIV
*> \verbatim
*>          IPIV is INTEGER array, dimension (N)
*>          The pivot indices that define the permutation matrix P;
*>          row i of the matrix was interchanged with row IPIV(i).
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*>          B is DOUBLE PRECISION array, dimension (LDB,NRHS)
*>          On entry, the N-by-NRHS matrix of right hand side matrix B.
*>          On exit, if INFO = 0, the N-by-NRHS solution matrix X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of the array B.  LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value
*>          > 0:  if INFO = i, U(i,i) is exactly zero.  The factorization
*>                has been completed, but the factor U is exactly
*>                singular, so the solution could not be computed.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup doubleGEsolve
*
*  =====================================================================
      SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
*  -- LAPACK driver routine (version 3.7.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     December 2016
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, N, NRHS
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
*     ..
*
*  =====================================================================
*
*     .. External Subroutines ..
      EXTERNAL           DGETRF, DGETRS, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGESV ', -INFO )
         RETURN
      END IF
*
*     Compute the LU factorization of A.
*
      CALL DGETRF( N, N, A, LDA, IPIV, INFO )
      IF( INFO.EQ.0 ) THEN
*
*        Solve the system A*X = B, overwriting B with X.
*
         CALL DGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB,
     $                INFO )
      END IF
      RETURN
*
*     End of DGESV
*
      END
*> \brief \b DGETRF
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DGETRF + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO )
*
*       .. Scalar Arguments ..
*       INTEGER            INFO, LDA, M, N
*       ..
*       .. Array Arguments ..
*       INTEGER            IPIV( * )
*       DOUBLE PRECISION   A( LDA, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DGETRF computes an LU factorization of a general M-by-N matrix A
*> using partial pivoting with row interchanges.
*>
*> The factorization has the form
*>    A = P * L * U
*> where P is a permutation matrix, L is lower triangular with unit
*> diagonal elements (lower trapezoidal if m > n), and U is upper
*> triangular (upper trapezoidal if m < n).
*>
*> This is the right-looking Level 3 BLAS version of the algorithm.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the matrix A.  M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is DOUBLE PRECISION array, dimension (LDA,N)
*>          On entry, the M-by-N matrix to be factored.
*>          On exit, the factors L and U from the factorization
*>          A = P*L*U; the unit diagonal elements of L are not stored.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] IPIV
*> \verbatim
*>          IPIV is INTEGER array, dimension (min(M,N))
*>          The pivot indices; for 1 <= i <= min(M,N), row i of the
*>          matrix was interchanged with row IPIV(i).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value
*>          > 0:  if INFO = i, U(i,i) is exactly zero. The factorization
*>                has been completed, but the factor U is exactly
*>                singular, and division by zero will occur if it is used
*>                to solve a system of equations.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup doubleGEcomputational
*
*  =====================================================================
      SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO )
*
*  -- LAPACK computational routine (version 3.7.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     December 2016
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, IINFO, J, JB, NB
*     ..
*     .. External Subroutines ..
      EXTERNAL           DGEMM, DGETRF2, DLASWP, DTRSM, XERBLA
*     ..
*     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGETRF', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( M.EQ.0 .OR. N.EQ.0 )
     $   RETURN
*
*     Determine the block size for this environment.
*
      NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 )
      IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN
*
*        Use unblocked code.
*
         CALL DGETRF2( M, N, A, LDA, IPIV, INFO )
      ELSE
*
*        Use blocked code.
*
         DO 20 J = 1, MIN( M, N ), NB
            JB = MIN( MIN( M, N )-J+1, NB )
*
*           Factor diagonal and subdiagonal blocks and test for exact
*           singularity.
*
            CALL DGETRF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO )
*
*           Adjust INFO and the pivot indices.
*
            IF( INFO.EQ.0 .AND. IINFO.GT.0 )
     $         INFO = IINFO + J - 1
            DO 10 I = J, MIN( M, J+JB-1 )
               IPIV( I ) = J - 1 + IPIV( I )
   10       CONTINUE
*
*           Apply interchanges to columns 1:J-1.
*
            CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 )
*
            IF( J+JB.LE.N ) THEN
*
*              Apply interchanges to columns J+JB:N.
*
               CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1,
     $                      IPIV, 1 )
*
*              Compute block row of U.
*
               CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB,
     $                     N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ),
     $                     LDA )
               IF( J+JB.LE.M ) THEN
*
*                 Update trailing submatrix.
*
                  CALL DGEMM( 'No transpose', 'No transpose', M-J-JB+1,
     $                        N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA,
     $                        A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ),
     $                        LDA )
               END IF
            END IF
   20    CONTINUE
      END IF
      RETURN
*
*     End of DGETRF
*
      END
*> \brief \b DGETRF2
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       RECURSIVE SUBROUTINE DGETRF2( M, N, A, LDA, IPIV, INFO )
*
*       .. Scalar Arguments ..
*       INTEGER            INFO, LDA, M, N
*       ..
*       .. Array Arguments ..
*       INTEGER            IPIV( * )
*       DOUBLE PRECISION   A( LDA, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DGETRF2 computes an LU factorization of a general M-by-N matrix A
*> using partial pivoting with row interchanges.
*>
*> The factorization has the form
*>    A = P * L * U
*> where P is a permutation matrix, L is lower triangular with unit
*> diagonal elements (lower trapezoidal if m > n), and U is upper
*> triangular (upper trapezoidal if m < n).
*>
*> This is the recursive version of the algorithm. It divides
*> the matrix into four submatrices:
*>
*>        [  A11 | A12  ]  where A11 is n1 by n1 and A22 is n2 by n2
*>    A = [ -----|----- ]  with n1 = min(m,n)/2
*>        [  A21 | A22  ]       n2 = n-n1
*>
*>                                       [ A11 ]
*> The subroutine calls itself to factor [ --- ],
*>                                       [ A12 ]
*>                 [ A12 ]
*> do the swaps on [ --- ], solve A12, update A22,
*>                 [ A22 ]
*>
*> then calls itself to factor A22 and do the swaps on A21.
*>
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the matrix A.  M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is DOUBLE PRECISION array, dimension (LDA,N)
*>          On entry, the M-by-N matrix to be factored.
*>          On exit, the factors L and U from the factorization
*>          A = P*L*U; the unit diagonal elements of L are not stored.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] IPIV
*> \verbatim
*>          IPIV is INTEGER array, dimension (min(M,N))
*>          The pivot indices; for 1 <= i <= min(M,N), row i of the
*>          matrix was interchanged with row IPIV(i).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value
*>          > 0:  if INFO = i, U(i,i) is exactly zero. The factorization
*>                has been completed, but the factor U is exactly
*>                singular, and division by zero will occur if it is used
*>                to solve a system of equations.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2016
*
*> \ingroup doubleGEcomputational
*
*  =====================================================================
      RECURSIVE SUBROUTINE DGETRF2( M, N, A, LDA, IPIV, INFO )
*
*  -- LAPACK computational routine (version 3.7.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     June 2016
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      DOUBLE PRECISION   SFMIN, TEMP
      INTEGER            I, IINFO, N1, N2
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      INTEGER            IDAMAX
      EXTERNAL           DLAMCH, IDAMAX
*     ..
*     .. External Subroutines ..
      EXTERNAL           DGEMM, DSCAL, DLASWP, DTRSM, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters
*
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGETRF2', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( M.EQ.0 .OR. N.EQ.0 )
     $   RETURN

      IF ( M.EQ.1 ) THEN
*
*        Use unblocked code for one row case
*        Just need to handle IPIV and INFO
*
         IPIV( 1 ) = 1
         IF ( A(1,1).EQ.ZERO )
     $      INFO = 1
*
      ELSE IF( N.EQ.1 ) THEN
*
*        Use unblocked code for one column case
*
*
*        Compute machine safe minimum
*
         SFMIN = DLAMCH('S')
*
*        Find pivot and test for singularity
*
         I = IDAMAX( M, A( 1, 1 ), 1 )
         IPIV( 1 ) = I
         IF( A( I, 1 ).NE.ZERO ) THEN
*
*           Apply the interchange
*
            IF( I.NE.1 ) THEN
               TEMP = A( 1, 1 )
               A( 1, 1 ) = A( I, 1 )
               A( I, 1 ) = TEMP
            END IF
*
*           Compute elements 2:M of the column
*
            IF( ABS(A( 1, 1 )) .GE. SFMIN ) THEN
               CALL DSCAL( M-1, ONE / A( 1, 1 ), A( 2, 1 ), 1 )
            ELSE
               DO 10 I = 1, M-1
                  A( 1+I, 1 ) = A( 1+I, 1 ) / A( 1, 1 )
   10          CONTINUE
            END IF
*
         ELSE
            INFO = 1
         END IF
*
      ELSE
*
*        Use recursive code
*
         N1 = MIN( M, N ) / 2
         N2 = N-N1
*
*               [ A11 ]
*        Factor [ --- ]
*               [ A21 ]
*
         CALL DGETRF2( M, N1, A, LDA, IPIV, IINFO )

         IF ( INFO.EQ.0 .AND. IINFO.GT.0 )
     $      INFO = IINFO
*
*                              [ A12 ]
*        Apply interchanges to [ --- ]
*                              [ A22 ]
*
         CALL DLASWP( N2, A( 1, N1+1 ), LDA, 1, N1, IPIV, 1 )
*
*        Solve A12
*
         CALL DTRSM( 'L', 'L', 'N', 'U', N1, N2, ONE, A, LDA,
     $               A( 1, N1+1 ), LDA )
*
*        Update A22
*
         CALL DGEMM( 'N', 'N', M-N1, N2, N1, -ONE, A( N1+1, 1 ), LDA,
     $               A( 1, N1+1 ), LDA, ONE, A( N1+1, N1+1 ), LDA )
*
*        Factor A22
*
         CALL DGETRF2( M-N1, N2, A( N1+1, N1+1 ), LDA, IPIV( N1+1 ),
     $                 IINFO )
*
*        Adjust INFO and the pivot indices
*
         IF ( INFO.EQ.0 .AND. IINFO.GT.0 )
     $      INFO = IINFO + N1
         DO 20 I = N1+1, MIN( M, N )
            IPIV( I ) = IPIV( I ) + N1
   20    CONTINUE
*
*        Apply interchanges to A21
*
         CALL DLASWP( N1, A( 1, 1 ), LDA, N1+1, MIN( M, N), IPIV, 1 )
*
      END IF
      RETURN
*
*     End of DGETRF2
*
      END
*> \brief \b DGETRS
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DGETRS + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          TRANS
*       INTEGER            INFO, LDA, LDB, N, NRHS
*       ..
*       .. Array Arguments ..
*       INTEGER            IPIV( * )
*       DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DGETRS solves a system of linear equations
*>    A * X = B  or  A**T * X = B
*> with a general N-by-N matrix A using the LU factorization computed
*> by DGETRF.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] TRANS
*> \verbatim
*>          TRANS is CHARACTER*1
*>          Specifies the form of the system of equations:
*>          = 'N':  A * X = B  (No transpose)
*>          = 'T':  A**T* X = B  (Transpose)
*>          = 'C':  A**T* X = B  (Conjugate transpose = Transpose)
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*>          NRHS is INTEGER
*>          The number of right hand sides, i.e., the number of columns
*>          of the matrix B.  NRHS >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*>          A is DOUBLE PRECISION array, dimension (LDA,N)
*>          The factors L and U from the factorization A = P*L*U
*>          as computed by DGETRF.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*>          IPIV is INTEGER array, dimension (N)
*>          The pivot indices from DGETRF; for 1<=i<=N, row i of the
*>          matrix was interchanged with row IPIV(i).
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*>          B is DOUBLE PRECISION array, dimension (LDB,NRHS)
*>          On entry, the right hand side matrix B.
*>          On exit, the solution matrix X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of the array B.  LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup doubleGEcomputational
*
*  =====================================================================
      SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
*  -- LAPACK computational routine (version 3.7.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     December 2016
*
*     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            INFO, LDA, LDB, N, NRHS
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            NOTRAN
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLASWP, DTRSM, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      NOTRAN = LSAME( TRANS, 'N' )
      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
     $    LSAME( TRANS, 'C' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGETRS', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 .OR. NRHS.EQ.0 )
     $   RETURN
*
      IF( NOTRAN ) THEN
*
*        Solve A * X = B.
*
*        Apply row interchanges to the right hand sides.
*
         CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 )
*
*        Solve L*X = B, overwriting B with X.
*
         CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS,
     $               ONE, A, LDA, B, LDB )
*
*        Solve U*X = B, overwriting B with X.
*
         CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N,
     $               NRHS, ONE, A, LDA, B, LDB )
      ELSE
*
*        Solve A**T * X = B.
*
*        Solve U**T *X = B, overwriting B with X.
*
         CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS,
     $               ONE, A, LDA, B, LDB )
*
*        Solve L**T *X = B, overwriting B with X.
*
         CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE,
     $               A, LDA, B, LDB )
*
*        Apply row interchanges to the solution vectors.
*
         CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 )
      END IF
*
      RETURN
*
*     End of DGETRS
*
      END
*> \brief \b DLASWP performs a series of row interchanges on a general rectangular matrix.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLASWP + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX )
*
*       .. Scalar Arguments ..
*       INTEGER            INCX, K1, K2, LDA, N
*       ..
*       .. Array Arguments ..
*       INTEGER            IPIV( * )
*       DOUBLE PRECISION   A( LDA, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DLASWP performs a series of row interchanges on the matrix A.
*> One row interchange is initiated for each of rows K1 through K2 of A.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the matrix A.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is DOUBLE PRECISION array, dimension (LDA,N)
*>          On entry, the matrix of column dimension N to which the row
*>          interchanges will be applied.
*>          On exit, the permuted matrix.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.
*> \endverbatim
*>
*> \param[in] K1
*> \verbatim
*>          K1 is INTEGER
*>          The first element of IPIV for which a row interchange will
*>          be done.
*> \endverbatim
*>
*> \param[in] K2
*> \verbatim
*>          K2 is INTEGER
*>          (K2-K1+1) is the number of elements of IPIV for which a row
*>          interchange will be done.
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*>          IPIV is INTEGER array, dimension (K1+(K2-K1)*abs(INCX))
*>          The vector of pivot indices. Only the elements in positions
*>          K1 through K1+(K2-K1)*abs(INCX) of IPIV are accessed.
*>          IPIV(K1+(K-K1)*abs(INCX)) = L implies rows K and L are to be
*>          interchanged.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*>          INCX is INTEGER
*>          The increment between successive values of IPIV. If INCX
*>          is negative, the pivots are applied in reverse order.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2017
*
*> \ingroup doubleOTHERauxiliary
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  Modified by
*>   R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA
*> \endverbatim
*>
*  =====================================================================
      SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX )
*
*  -- LAPACK auxiliary routine (version 3.7.1) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     June 2017
*
*     .. Scalar Arguments ..
      INTEGER            INCX, K1, K2, LDA, N
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * )
*     ..
*
* =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I, I1, I2, INC, IP, IX, IX0, J, K, N32
      DOUBLE PRECISION   TEMP
*     ..
*     .. Executable Statements ..
*
*     Interchange row I with row IPIV(K1+(I-K1)*abs(INCX)) for each of rows
*     K1 through K2.
*
      IF( INCX.GT.0 ) THEN
         IX0 = K1
         I1 = K1
         I2 = K2
         INC = 1
      ELSE IF( INCX.LT.0 ) THEN
         IX0 = K1 + ( K1-K2 )*INCX
         I1 = K2
         I2 = K1
         INC = -1
      ELSE
         RETURN
      END IF
*
      N32 = ( N / 32 )*32
      IF( N32.NE.0 ) THEN
         DO 30 J = 1, N32, 32
            IX = IX0
            DO 20 I = I1, I2, INC
               IP = IPIV( IX )
               IF( IP.NE.I ) THEN
                  DO 10 K = J, J + 31
                     TEMP = A( I, K )
                     A( I, K ) = A( IP, K )
                     A( IP, K ) = TEMP
   10             CONTINUE
               END IF
               IX = IX + INCX
   20       CONTINUE
   30    CONTINUE
      END IF
      IF( N32.NE.N ) THEN
         N32 = N32 + 1
         IX = IX0
         DO 50 I = I1, I2, INC
            IP = IPIV( IX )
            IF( IP.NE.I ) THEN
               DO 40 K = N32, N
                  TEMP = A( I, K )
                  A( I, K ) = A( IP, K )
                  A( IP, K ) = TEMP
   40          CONTINUE
            END IF
            IX = IX + INCX
   50    CONTINUE
      END IF
*
      RETURN
*
*     End of DLASWP
*
      END
*> \brief \b DTRSM
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
*
*       .. Scalar Arguments ..
*       DOUBLE PRECISION ALPHA
*       INTEGER LDA,LDB,M,N
*       CHARACTER DIAG,SIDE,TRANSA,UPLO
*       ..
*       .. Array Arguments ..
*       DOUBLE PRECISION A(LDA,*),B(LDB,*)
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DTRSM  solves one of the matrix equations
*>
*>    op( A )*X = alpha*B,   or   X*op( A ) = alpha*B,
*>
*> where alpha is a scalar, X and B are m by n matrices, A is a unit, or
*> non-unit,  upper or lower triangular matrix  and  op( A )  is one  of
*>
*>    op( A ) = A   or   op( A ) = A**T.
*>
*> The matrix X is overwritten on B.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] SIDE
*> \verbatim
*>          SIDE is CHARACTER*1
*>           On entry, SIDE specifies whether op( A ) appears on the left
*>           or right of X as follows:
*>
*>              SIDE = 'L' or 'l'   op( A )*X = alpha*B.
*>
*>              SIDE = 'R' or 'r'   X*op( A ) = alpha*B.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*>          UPLO is CHARACTER*1
*>           On entry, UPLO specifies whether the matrix A is an upper or
*>           lower triangular matrix as follows:
*>
*>              UPLO = 'U' or 'u'   A is an upper triangular matrix.
*>
*>              UPLO = 'L' or 'l'   A is a lower triangular matrix.
*> \endverbatim
*>
*> \param[in] TRANSA
*> \verbatim
*>          TRANSA is CHARACTER*1
*>           On entry, TRANSA specifies the form of op( A ) to be used in
*>           the matrix multiplication as follows:
*>
*>              TRANSA = 'N' or 'n'   op( A ) = A.
*>
*>              TRANSA = 'T' or 't'   op( A ) = A**T.
*>
*>              TRANSA = 'C' or 'c'   op( A ) = A**T.
*> \endverbatim
*>
*> \param[in] DIAG
*> \verbatim
*>          DIAG is CHARACTER*1
*>           On entry, DIAG specifies whether or not A is unit triangular
*>           as follows:
*>
*>              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
*>
*>              DIAG = 'N' or 'n'   A is not assumed to be unit
*>                                  triangular.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>           On entry, M specifies the number of rows of B. M must be at
*>           least zero.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>           On entry, N specifies the number of columns of B.  N must be
*>           at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*>          ALPHA is DOUBLE PRECISION.
*>           On entry,  ALPHA specifies the scalar  alpha. When  alpha is
*>           zero then  A is not referenced and  B need not be set before
*>           entry.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*>          A is DOUBLE PRECISION array, dimension ( LDA, k ),
*>           where k is m when SIDE = 'L' or 'l'
*>             and k is n when SIDE = 'R' or 'r'.
*>           Before entry  with  UPLO = 'U' or 'u',  the  leading  k by k
*>           upper triangular part of the array  A must contain the upper
*>           triangular matrix  and the strictly lower triangular part of
*>           A is not referenced.
*>           Before entry  with  UPLO = 'L' or 'l',  the  leading  k by k
*>           lower triangular part of the array  A must contain the lower
*>           triangular matrix  and the strictly upper triangular part of
*>           A is not referenced.
*>           Note that when  DIAG = 'U' or 'u',  the diagonal elements of
*>           A  are not referenced either,  but are assumed to be  unity.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>           On entry, LDA specifies the first dimension of A as declared
*>           in the calling (sub) program.  When  SIDE = 'L' or 'l'  then
*>           LDA  must be at least  max( 1, m ),  when  SIDE = 'R' or 'r'
*>           then LDA must be at least max( 1, n ).
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*>          B is DOUBLE PRECISION array, dimension ( LDB, N )
*>           Before entry,  the leading  m by n part of the array  B must
*>           contain  the  right-hand  side  matrix  B,  and  on exit  is
*>           overwritten by the solution matrix  X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>           On entry, LDB specifies the first dimension of B as declared
*>           in  the  calling  (sub)  program.   LDB  must  be  at  least
*>           max( 1, m ).
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup double_blas_level3
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  Level 3 Blas routine.
*>
*>
*>  -- Written on 8-February-1989.
*>     Jack Dongarra, Argonne National Laboratory.
*>     Iain Duff, AERE Harwell.
*>     Jeremy Du Croz, Numerical Algorithms Group Ltd.
*>     Sven Hammarling, Numerical Algorithms Group Ltd.
*> \endverbatim
*>
*  =====================================================================
      SUBROUTINE DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
*
*  -- Reference BLAS level3 routine (version 3.7.0) --
*  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     December 2016
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION ALPHA
      INTEGER LDA,LDB,M,N
      CHARACTER DIAG,SIDE,TRANSA,UPLO
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION A(LDA,*),B(LDB,*)
*     ..
*
*  =====================================================================
*
*     .. External Functions ..
      LOGICAL LSAME
      EXTERNAL LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC MAX
*     ..
*     .. Local Scalars ..
      DOUBLE PRECISION TEMP
      INTEGER I,INFO,J,K,NROWA
      LOGICAL LSIDE,NOUNIT,UPPER
*     ..
*     .. Parameters ..
      DOUBLE PRECISION ONE,ZERO
      PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
*     ..
*
*     Test the input parameters.
*
      LSIDE = LSAME(SIDE,'L')
      IF (LSIDE) THEN
          NROWA = M
      ELSE
          NROWA = N
      END IF
      NOUNIT = LSAME(DIAG,'N')
      UPPER = LSAME(UPLO,'U')
*
      INFO = 0
      IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN
          INFO = 1
      ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
          INFO = 2
      ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND.
     +         (.NOT.LSAME(TRANSA,'T')) .AND.
     +         (.NOT.LSAME(TRANSA,'C'))) THEN
          INFO = 3
      ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN
          INFO = 4
      ELSE IF (M.LT.0) THEN
          INFO = 5
      ELSE IF (N.LT.0) THEN
          INFO = 6
      ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
          INFO = 9
      ELSE IF (LDB.LT.MAX(1,M)) THEN
          INFO = 11
      END IF
      IF (INFO.NE.0) THEN
          CALL XERBLA('DTRSM ',INFO)
          RETURN
      END IF
*
*     Quick return if possible.
*
      IF (M.EQ.0 .OR. N.EQ.0) RETURN
*
*     And when  alpha.eq.zero.
*
      IF (ALPHA.EQ.ZERO) THEN
          DO 20 J = 1,N
              DO 10 I = 1,M
                  B(I,J) = ZERO
   10         CONTINUE
   20     CONTINUE
          RETURN
      END IF
*
*     Start the operations.
*
      IF (LSIDE) THEN
          IF (LSAME(TRANSA,'N')) THEN
*
*           Form  B := alpha*inv( A )*B.
*
              IF (UPPER) THEN
                  DO 60 J = 1,N
                      IF (ALPHA.NE.ONE) THEN
                          DO 30 I = 1,M
                              B(I,J) = ALPHA*B(I,J)
   30                     CONTINUE
                      END IF
                      DO 50 K = M,1,-1
                          IF (B(K,J).NE.ZERO) THEN
                              IF (NOUNIT) B(K,J) = B(K,J)/A(K,K)
                              DO 40 I = 1,K - 1
                                  B(I,J) = B(I,J) - B(K,J)*A(I,K)
   40                         CONTINUE
                          END IF
   50                 CONTINUE
   60             CONTINUE
              ELSE
                  DO 100 J = 1,N
                      IF (ALPHA.NE.ONE) THEN
                          DO 70 I = 1,M
                              B(I,J) = ALPHA*B(I,J)
   70                     CONTINUE
                      END IF
                      DO 90 K = 1,M
                          IF (B(K,J).NE.ZERO) THEN
                              IF (NOUNIT) B(K,J) = B(K,J)/A(K,K)
                              DO 80 I = K + 1,M
                                  B(I,J) = B(I,J) - B(K,J)*A(I,K)
   80                         CONTINUE
                          END IF
   90                 CONTINUE
  100             CONTINUE
              END IF
          ELSE
*
*           Form  B := alpha*inv( A**T )*B.
*
              IF (UPPER) THEN
                  DO 130 J = 1,N
                      DO 120 I = 1,M
                          TEMP = ALPHA*B(I,J)
                          DO 110 K = 1,I - 1
                              TEMP = TEMP - A(K,I)*B(K,J)
  110                     CONTINUE
                          IF (NOUNIT) TEMP = TEMP/A(I,I)
                          B(I,J) = TEMP
  120                 CONTINUE
  130             CONTINUE
              ELSE
                  DO 160 J = 1,N
                      DO 150 I = M,1,-1
                          TEMP = ALPHA*B(I,J)
                          DO 140 K = I + 1,M
                              TEMP = TEMP - A(K,I)*B(K,J)
  140                     CONTINUE
                          IF (NOUNIT) TEMP = TEMP/A(I,I)
                          B(I,J) = TEMP
  150                 CONTINUE
  160             CONTINUE
              END IF
          END IF
      ELSE
          IF (LSAME(TRANSA,'N')) THEN
*
*           Form  B := alpha*B*inv( A ).
*
              IF (UPPER) THEN
                  DO 210 J = 1,N
                      IF (ALPHA.NE.ONE) THEN
                          DO 170 I = 1,M
                              B(I,J) = ALPHA*B(I,J)
  170                     CONTINUE
                      END IF
                      DO 190 K = 1,J - 1
                          IF (A(K,J).NE.ZERO) THEN
                              DO 180 I = 1,M
                                  B(I,J) = B(I,J) - A(K,J)*B(I,K)
  180                         CONTINUE
                          END IF
  190                 CONTINUE
                      IF (NOUNIT) THEN
                          TEMP = ONE/A(J,J)
                          DO 200 I = 1,M
                              B(I,J) = TEMP*B(I,J)
  200                     CONTINUE
                      END IF
  210             CONTINUE
              ELSE
                  DO 260 J = N,1,-1
                      IF (ALPHA.NE.ONE) THEN
                          DO 220 I = 1,M
                              B(I,J) = ALPHA*B(I,J)
  220                     CONTINUE
                      END IF
                      DO 240 K = J + 1,N
                          IF (A(K,J).NE.ZERO) THEN
                              DO 230 I = 1,M
                                  B(I,J) = B(I,J) - A(K,J)*B(I,K)
  230                         CONTINUE
                          END IF
  240                 CONTINUE
                      IF (NOUNIT) THEN
                          TEMP = ONE/A(J,J)
                          DO 250 I = 1,M
                              B(I,J) = TEMP*B(I,J)
  250                     CONTINUE
                      END IF
  260             CONTINUE
              END IF
          ELSE
*
*           Form  B := alpha*B*inv( A**T ).
*
              IF (UPPER) THEN
                  DO 310 K = N,1,-1
                      IF (NOUNIT) THEN
                          TEMP = ONE/A(K,K)
                          DO 270 I = 1,M
                              B(I,K) = TEMP*B(I,K)
  270                     CONTINUE
                      END IF
                      DO 290 J = 1,K - 1
                          IF (A(J,K).NE.ZERO) THEN
                              TEMP = A(J,K)
                              DO 280 I = 1,M
                                  B(I,J) = B(I,J) - TEMP*B(I,K)
  280                         CONTINUE
                          END IF
  290                 CONTINUE
                      IF (ALPHA.NE.ONE) THEN
                          DO 300 I = 1,M
                              B(I,K) = ALPHA*B(I,K)
  300                     CONTINUE
                      END IF
  310             CONTINUE
              ELSE
                  DO 360 K = 1,N
                      IF (NOUNIT) THEN
                          TEMP = ONE/A(K,K)
                          DO 320 I = 1,M
                              B(I,K) = TEMP*B(I,K)
  320                     CONTINUE
                      END IF
                      DO 340 J = K + 1,N
                          IF (A(J,K).NE.ZERO) THEN
                              TEMP = A(J,K)
                              DO 330 I = 1,M
                                  B(I,J) = B(I,J) - TEMP*B(I,K)
  330                         CONTINUE
                          END IF
  340                 CONTINUE
                      IF (ALPHA.NE.ONE) THEN
                          DO 350 I = 1,M
                              B(I,K) = ALPHA*B(I,K)
  350                     CONTINUE
                      END IF
  360             CONTINUE
              END IF
          END IF
      END IF
*
      RETURN
*
*     End of DTRSM .
*
      END
*> \brief \b IDAMAX
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       INTEGER FUNCTION IDAMAX(N,DX,INCX)
*
*       .. Scalar Arguments ..
*       INTEGER INCX,N
*       ..
*       .. Array Arguments ..
*       DOUBLE PRECISION DX(*)
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*>    IDAMAX finds the index of the first element having maximum absolute value.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>         number of elements in input vector(s)
*> \endverbatim
*>
*> \param[in] DX
*> \verbatim
*>          DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*>          INCX is INTEGER
*>         storage spacing between elements of DX
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2017
*
*> \ingroup aux_blas
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>     jack dongarra, linpack, 3/11/78.
*>     modified 3/93 to return if incx .le. 0.
*>     modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
*  =====================================================================
      INTEGER FUNCTION IDAMAX(N,DX,INCX)
*
*  -- Reference BLAS level1 routine (version 3.8.0) --
*  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2017
*
*     .. Scalar Arguments ..
      INTEGER INCX,N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION DX(*)
*     ..
*
*  =====================================================================
*
*     .. Local Scalars ..
      DOUBLE PRECISION DMAX
      INTEGER I,IX
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC DABS
*     ..
      IDAMAX = 0
      IF (N.LT.1 .OR. INCX.LE.0) RETURN
      IDAMAX = 1
      IF (N.EQ.1) RETURN
      IF (INCX.EQ.1) THEN
*
*        code for increment equal to 1
*
         DMAX = DABS(DX(1))
         DO I = 2,N
            IF (DABS(DX(I)).GT.DMAX) THEN
               IDAMAX = I
               DMAX = DABS(DX(I))
            END IF
         END DO
      ELSE
*
*        code for increment not equal to 1
*
         IX = 1
         DMAX = DABS(DX(1))
         IX = IX + INCX
         DO I = 2,N
            IF (DABS(DX(IX)).GT.DMAX) THEN
               IDAMAX = I
               DMAX = DABS(DX(IX))
            END IF
            IX = IX + INCX
         END DO
      END IF
      RETURN
      END


      INTEGER FUNCTION ignbin(n,pp)
C**********************************************************************
C
C     INTEGER FUNCTION IGNBIN( N, PP )
C
C                    GENerate BINomial random deviate
C
C
C                              Function
C
C
C     Generates a single random deviate from a binomial
C     distribution whose number of trials is N and whose
C     probability of an event in each trial is P.
C
C
C                              Arguments
C
C
C     N  --> The number of trials in the binomial distribution
C            from which a random deviate is to be generated.
C                              INTEGER N
C     JJV                      (N >= 0)
C
C     PP --> The probability of an event in each trial of the
C            binomial distribution from which a random deviate
C            is to be generated.
C                              DOUBLE PRECISION PP
C     JJV                      (0.0 <= pp <= 1.0)
C
C     IGNBIN <-- A random deviate yielding the number of events
C                from N independent trials, each of which has
C                a probability of event P.
C                              INTEGER IGNBIN
C
C
C                              Note
C
C
C     Uses RANF so the value of the seeds, ISEED1 and ISEED2 must be set
C     by a call similar to the following
C          DUM = RANSET( ISEED1, ISEED2 )
C
C
C                              Method
C
C
C     This is algorithm BTPE from:
C
C         Kachitvichyanukul, V. and Schmeiser, B. W.
C
C         Binomial Random Variate Generation.
C         Communications of the ACM, 31, 2
C         (February, 1988) 216.
C
C**********************************************************************
C     SUBROUTINE BTPEC(N,PP,ISEED,JX)
C
C     BINOMIAL RANDOM VARIATE GENERATOR
C     MEAN .LT. 30 -- INVERSE CDF
C       MEAN .GE. 30 -- ALGORITHM BTPE:  ACCEPTANCE-REJECTION VIA
C       FOUR REGION COMPOSITION.  THE FOUR REGIONS ARE A TRIANGLE
C       (SYMMETRIC IN THE CENTER), A PAIR OF PARALLELOGRAMS (ABOVE
C       THE TRIANGLE), AND EXPONENTIAL LEFT AND RIGHT TAILS.
C
C     BTPE REFERS TO BINOMIAL-TRIANGLE-PARALLELOGRAM-EXPONENTIAL.
C     BTPEC REFERS TO BTPE AND "COMBINED."  THUS BTPE IS THE
C       RESEARCH AND BTPEC IS THE IMPLEMENTATION OF A COMPLETE
C       USABLE ALGORITHM.
C     REFERENCE:  VORATAS KACHITVICHYANUKUL AND BRUCE SCHMEISER,
C       "BINOMIAL RANDOM VARIATE GENERATION,"
C       COMMUNICATIONS OF THE ACM, FORTHCOMING
C     WRITTEN:  SEPTEMBER 1980.
C       LAST REVISED:  MAY 1985, JULY 1987
C     REQUIRED SUBPROGRAM:  RAND() -- A UNIFORM (0,1) RANDOM NUMBER
C                           GENERATOR
C     ARGUMENTS
C
C       N : NUMBER OF BERNOULLI TRIALS            (INPUT)
C       PP : PROBABILITY OF SUCCESS IN EACH TRIAL (INPUT)
C       ISEED:  RANDOM NUMBER SEED                (INPUT AND OUTPUT)
C       JX:  RANDOMLY GENERATED OBSERVATION       (OUTPUT)
C
C     VARIABLES
C       PSAVE: VALUE OF PP FROM THE LAST CALL TO BTPEC
C       NSAVE: VALUE OF N FROM THE LAST CALL TO BTPEC
C       XNP:  VALUE OF THE MEAN FROM THE LAST CALL TO BTPEC
C
C       P: PROBABILITY USED IN THE GENERATION PHASE OF BTPEC
C       FFM: TEMPORARY VARIABLE EQUAL TO XNP + P
C       M:  INTEGER VALUE OF THE CURRENT MODE
C       FM:  FLOATING POINT VALUE OF THE CURRENT MODE
C       XNPQ: TEMPORARY VARIABLE USED IN SETUP AND SQUEEZING STEPS
C       P1:  AREA OF THE TRIANGLE
C       C:  HEIGHT OF THE PARALLELOGRAMS
C       XM:  CENTER OF THE TRIANGLE
C       XL:  LEFT END OF THE TRIANGLE
C       XR:  RIGHT END OF THE TRIANGLE
C       AL:  TEMPORARY VARIABLE
C       XLL:  RATE FOR THE LEFT EXPONENTIAL TAIL
C       XLR:  RATE FOR THE RIGHT EXPONENTIAL TAIL
C       P2:  AREA OF THE PARALLELOGRAMS
C       P3:  AREA OF THE LEFT EXPONENTIAL TAIL
C       P4:  AREA OF THE RIGHT EXPONENTIAL TAIL
C       U:  A U(0,P4) RANDOM VARIATE USED FIRST TO SELECT ONE OF THE
C           FOUR REGIONS AND THEN CONDITIONALLY TO GENERATE A VALUE
C           FROM THE REGION
C       V:  A U(0,1) RANDOM NUMBER USED TO GENERATE THE RANDOM VALUE
C           (REGION 1) OR TRANSFORMED INTO THE VARIATE TO ACCEPT OR
C           REJECT THE CANDIDATE VALUE
C       IX:  INTEGER CANDIDATE VALUE
C       X:  PRELIMINARY CONTINUOUS CANDIDATE VALUE IN REGION 2 LOGIC
C           AND A FLOATING POINT IX IN THE ACCEPT/REJECT LOGIC
C       K:  ABSOLUTE VALUE OF (IX-M)
C       F:  THE HEIGHT OF THE SCALED DENSITY FUNCTION USED IN THE
C           ACCEPT/REJECT DECISION WHEN BOTH M AND IX ARE SMALL
C           ALSO USED IN THE INVERSE TRANSFORMATION
C       R: THE RATIO P/Q
C       G: CONSTANT USED IN CALCULATION OF PROBABILITY
C       MP:  MODE PLUS ONE, THE LOWER INDEX FOR EXPLICIT CALCULATION
C            OF F WHEN IX IS GREATER THAN M
C       IX1:  CANDIDATE VALUE PLUS ONE, THE LOWER INDEX FOR EXPLICIT
C             CALCULATION OF F WHEN IX IS LESS THAN M
C       I:  INDEX FOR EXPLICIT CALCULATION OF F FOR BTPE
C       AMAXP: MAXIMUM ERROR OF THE LOGARITHM OF NORMAL BOUND
C       YNORM: LOGARITHM OF NORMAL BOUND
C       ALV:  NATURAL LOGARITHM OF THE ACCEPT/REJECT VARIATE V
C
C       X1,F1,Z,W,Z2,X2,F2, AND W2 ARE TEMPORARY VARIABLES TO BE
C       USED IN THE FINAL ACCEPT/REJECT TEST
C
C       QN: PROBABILITY OF NO SUCCESS IN N TRIALS
C
C     REMARK
C       IX AND JX COULD LOGICALLY BE THE SAME VARIABLE, WHICH WOULD
C       SAVE A MEMORY POSITION AND A LINE OF CODE.  HOWEVER, SOME
C       COMPILERS (E.G.,CDC MNF) OPTIMIZE BETTER WHEN THE ARGUMENTS
C       ARE NOT INVOLVED.
C
C     ISEED NEEDS TO BE DOUBLE PRECISION IF THE IMSL ROUTINE
C     GGUBFS IS USED TO GENERATE UNIFORM RANDOM NUMBER, OTHERWISE
C     TYPE OF ISEED SHOULD BE DICTATED BY THE UNIFORM GENERATOR
C
C**********************************************************************

C
C
C
C*****DETERMINE APPROPRIATE ALGORITHM AND WHETHER SETUP IS NECESSARY
C
C     ..
C     .. Scalar Arguments ..
      DOUBLE PRECISION pp
      INTEGER n
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION al,alv,amaxp,c,f,f1,f2,ffm,fm,g,p,p1,p2,p3,p4,
     +     psave,q,qn,r,u,
     +     v,w,w2,x,x1,x2,xl,xll,xlr,xm,xnp,xnpq,xr,ynorm,z,z2
      INTEGER i,ix,ix1,k,m,mp,nsave
C     ..
C     .. External Functions ..
      DOUBLE PRECISION ranf
      EXTERNAL ranf
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC abs,log,dmin1,iabs,int,sqrt
C     JJV ..
C     JJV .. Save statement ..
      SAVE p,q,m,fm,xnp,xnpq,p1,xm,xl,xr,c,xll,xlr,p2,p3,p4,qn,r,g,
     +     psave,nsave
C     JJV I am including the variables in data statements
C     ..
C     .. Data statements ..
C     JJV made these ridiculous starting values - the hope is that
C     JJV no one will call this the first time with them as args
      DATA psave,nsave/-1.0E37,-214748365/
C     ..
C     .. Executable Statements ..
      IF (pp.NE.psave) GO TO 10
      IF (n.NE.nsave) GO TO 20
      IF (xnp-30.) 150,30,30
C
C*****SETUP, PERFORM ONLY WHEN PARAMETERS CHANGE
C

C     JJV added the argument checker - involved only renaming 10
C     JJV and 20 to the checkers and adding checkers
C     JJV Only remaining problem - if called initially with the
C     JJV initial values of psave and nsave, it will hang
 10   continue
      psave = pp
      p = dmin1(psave,1.-psave)
      q = 1. - p
 20   continue
      xnp = n*p
      nsave = n
      IF (xnp.LT.30.) GO TO 140
      ffm = xnp + p
      m = ffm
      fm = m
      xnpq = xnp*q
      p1 = int(2.195*sqrt(xnpq)-4.6*q) + 0.5
      xm = fm + 0.5
      xl = xm - p1
      xr = xm + p1
      c = 0.134 + 20.5/ (15.3+fm)
      al = (ffm-xl)/ (ffm-xl*p)
      xll = al* (1.+.5*al)
      al = (xr-ffm)/ (xr*q)
      xlr = al* (1.+.5*al)
      p2 = p1* (1.+c+c)
      p3 = p2 + c/xll
      p4 = p3 + c/xlr
C      WRITE(6,100) N,P,P1,P2,P3,P4,XL,XR,XM,FM
C  100 FORMAT(I15,4F18.7/5F18.7)
C
C*****GENERATE VARIATE
C
   30 u = ranf()*p4
      v = ranf()
C
C     TRIANGULAR REGION
C
      IF (u.GT.p1) GO TO 40
      ix = xm - p1*v + u
      GO TO 170
C
C     PARALLELOGRAM REGION
C
   40 IF (u.GT.p2) GO TO 50
      x = xl + (u-p1)/c
      v = v*c + 1. - abs(xm-x)/p1
      IF (v.GT.1. .OR. v.LE.0.) GO TO 30
      ix = x
      GO TO 70
C
C     LEFT TAIL
C
   50 IF (u.GT.p3) GO TO 60
      ix = xl + log(v)/xll
      IF (ix.LT.0) GO TO 30
      v = v* (u-p2)*xll
      GO TO 70
C
C     RIGHT TAIL
C
   60 ix = xr - log(v)/xlr
      IF (ix.GT.n) GO TO 30
      v = v* (u-p3)*xlr
C
C*****DETERMINE APPROPRIATE WAY TO PERFORM ACCEPT/REJECT TEST
C
   70 k = iabs(ix-m)
      IF (k.GT.20 .AND. k.LT.xnpq/2-1) GO TO 130
C
C     EXPLICIT EVALUATION
C
      f = 1.0
      r = p/q
      g = (n+1)*r
      IF (m-ix) 80,120,100
   80 mp = m + 1
      DO 90 i = mp,ix
          f = f* (g/i-r)
   90 CONTINUE
      GO TO 120

  100 ix1 = ix + 1
      DO 110 i = ix1,m
          f = f/ (g/i-r)
  110 CONTINUE
  120 IF (v-f) 170,170,30
C
C     SQUEEZING USING UPPER AND LOWER BOUNDS ON LOG(F(X))
C
  130 amaxp = (k/xnpq)* ((k* (k/3.+.625)+.1666666666666)/xnpq+.5)
      ynorm = -k*k/ (2.*xnpq)
      alv = log(v)
      IF (alv.LT.ynorm-amaxp) GO TO 170
      IF (alv.GT.ynorm+amaxp) GO TO 30
C
C     STIRLING'S FORMULA TO MACHINE ACCURACY FOR
C     THE FINAL ACCEPTANCE/REJECTION TEST
C
      x1 = ix + 1
      f1 = fm + 1.
      z = n + 1 - fm
      w = n - ix + 1.
      z2 = z*z
      x2 = x1*x1
      f2 = f1*f1
      w2 = w*w
      IF (alv- (xm*log(f1/x1)+ (n-m+.5)*log(z/w)+ (ix-
     +    m)*log(w*p/ (x1*q))+ (13860.- (462.- (132.- (99.-
     +    140./f2)/f2)/f2)/f2)/f1/166320.+ (13860.- (462.- (132.- (99.-
     +    140./z2)/z2)/z2)/z2)/z/166320.+ (13860.- (462.- (132.- (99.-
     +    140./x2)/x2)/x2)/x2)/x1/166320.+ (13860.- (462.- (132.- (99.-
     +    140./w2)/w2)/w2)/w2)/w/166320.)) 170,170,30
C
C     INVERSE CDF LOGIC FOR MEAN LESS THAN 30
C
  140 qn = q**n
      r = p/q
      g = r* (n+1)
  150 ix = 0
      f = qn
      u = ranf()
  160 IF (u.LT.f) GO TO 170
      IF (ix.GT.110) GO TO 150
      u = u - f
      ix = ix + 1
      f = f* (g/ix-r)
      GO TO 160

  170 IF (psave.GT.0.5) ix = n - ix
      ignbin = ix
      RETURN

      END


program main
    implicit none
    integer, parameter :: dp = selected_real_kind(8)
    real(dp), parameter :: pi = acos(-1.d0)
    real(dp) :: epsilonA = 1.d0, epsilonB = 4.d0, tAA = .5d0, tBB = .25d0, k, EA, EB

    open(unit = 1, file = '4-E-k.txt', status = 'unknown')
    k = -pi
    do while (k <= pi)
        EA = epsilonA - 2.d0 * tAA * cos(k)
        EB = epsilonB - 2.d0 * tBB * cos(k)
        write(1,'(3f20.8)') k, EA, EB
        k = k + 1.d-2
    end do
    close(1)
end program main


!
!
!     ------------------------------------------------------------------
!     L U L U
!     ------------------------------------------------------------------
!
      SUBROUTINE LULU(A, L, U, NDIM)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
!
! LU DECOMPOSITION OF MATRIX A
!
!     A = L * U
!
! WHERE L IS A LOWER TRIANGULAR MATRIX WITH A
! UNIT DIAGONAL AND U IS AN UPPER DIAGONAL
!
! L AND U ARE STORED AS ONE DIMENSIONAL ARRAYS
!
!   L(I,J) = L(I*(I-1)/2 + J ) ( I .GE. J )
!
!   U(I,J) = U(J*(J-1)/2 + I ) ( J .GE. I )
!
! THIS ADRESSING SCHEMES SUPPORTS VECTORIZATION OVER COLUMNS
! FOR L AND  OVER ROWS FOR U .
!
!
! NO PIVOTING IS DONE HERE , SO THE SCHEME GOES :
!
!     LOOP OVER R=1, NDIM
!        LOOP OVER J = R, NDIM
!          U(R,J) = A(R,J) - SUM(K=1,R-1) L(R,K) * U(K,J)
!        END OF LOOP OVER J
!
!        LOOP OVER I = R+1, NDIM
!          L(I,R) = (A(I,R) - SUM(K=1,R-1)L(I,K) * U(K,R) ) /U(R,R)
!        END OF LOOP OVER I
!     END OF LOOP OVER R
!
! JEPPE OLSEN , OCTOBER 1988
!
!...Translated by Pacific-Sierra Research 77to90  4.3E  14:49:11  11/20/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE inprod_I
      USE prsym_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: NDIM
      REAL(DOUBLE) , INTENT(IN) :: A(NDIM,NDIM)
      REAL(DOUBLE)  :: L(*)
      REAL(DOUBLE)  :: U(*)
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: R, J, I, NTEST
      REAL(DOUBLE) :: XFACI
!-----------------------------------------------
!
!
      DO R = 1, NDIM
!
         DO J = R, NDIM
            U(J*(J-1)/2+R) = A(R,J) - INPROD(L(R*(R-1)/2+1),U(J*(J-1)/2+1),R-1)
         END DO
!
         XFACI = 1.0D0/U(R*(R+1)/2)
         L(R*(R+1)/2) = 1.0D0
         DO I = R + 1, NDIM
            L(I*(I-1)/2+R) = (A(I,R)-INPROD(L(I*(I-1)/2+1),U(R*(R-1)/2+1),R-1))&
               *XFACI
         END DO
!
      END DO
!
      NTEST = 0
      IF (NTEST /= 0) THEN
         WRITE (6, *) ' L MATRIX '
         CALL PRSYM (L, NDIM)
         WRITE (6, *) ' U MATRIX ( TRANSPOSED ) '
         CALL PRSYM (U, NDIM)
      ENDIF
!
      RETURN
      END SUBROUTINE LULU


c------------------------------------------------------------------------------
c
c
      SUBROUTINE         voigt(x,y,u,v)
c
c
c
c  this routine computes the complex probability function w(z)
c
c         w(z)   = exp(-z**2) * erfc(-iz) = u(x,y) + iv(x,y)
c  where
c         z      = x + iy
c         u(x,y) = Voigt "function" = H(x,y)
c         v(x,y) = complex component to w(z)
c         x      = wave number scale in Doppler width units
c         y      = ratio of Lorentz to Doppler width
c
c  computation is valid for the upper half plane (y>0); computational
c  accuracy is claimed to be maximum relative error < 2.0e-6 for u
c  and < 5.0e-6 for v;  code is from method of J. Humlicek (1979) J.
c  Quant. Spectrosc. Radiat. Transfer _21_ 309.  typed in and trivially
c  modified by Christopher W. Churchill, March 1994.
c
c  the 2-REGION n=12 approximation
c
c==============================================================================
c
c  local declarations
      implicit none
      integer            i,m
      parameter          (m=6)
      double precision   b1,b2,t(m),c(m),s(m)
      double precision   u,v,x,y,d,d1,d2,d3,d4,r,r2,y1,y2,y3
c
c  load the data ...
c  harmonic roots and weights of the n-point Gauss-Hermite formula,
c  chosen to keep absolute error of u and v < 1.0e-7
c
      data b1/ 0.850d0/
      data  t/ 0.314240376  ,  0.947788391  ,  1.59768264   ,
     @         2.27950708   ,  3.02063703   ,  3.8897249    /
      data  c/ 1.01172805   , -0.75197147   ,  1.2557727e-2 ,
     @         1.00220082e-2, -2.42068135e-4,  5.00848061e-7/
      data  s/ 1.393237     ,  0.231152406  , -0.155351466  ,
     @         6.21836624e-3,  9.19082986e-5, -6.27525958e-7/
c
c  initialize this pass; define the x<18.1 REGION boundary
c
      u  = 0.0d0
      v  = 0.0d0
      y1 = y + 1.50d0
      y2 = y1*y1
      b2 = 18.10d0*y + 1.650d0
c
c
      if ((y.gt.b1).or.(abs(x).lt.b2)) then
c
c
c
c  eq.(6);  REGION 1  y > (x-1.65)/18.1  for x<=18.1
c                     y > 0.85           for x> 18.1
c
       do 3 i=1,m
        r  = x - t(i)
        d  = 1.0d0/(r*r+y2)
        d1 = y1*d
        d2 = r*d
        r  = x + t(i)
        d  = 1.0d0/(r*r+y2)
        d3 = y1*d
        d4 = r*d
        u  = u + c(i)*(d1+d3) - s(i)*(d2-d4)
        v  = v + c(i)*(d2+d4) + s(i)*(d1-d3)
 03    continue
       return
c
c
c
      else
c
c
c
c  eq.(11); REGION 2  y <= (x-1.65)/18.1  for x<=18.1
c                     y <= 0.85           for x> 18.1
c
       if (abs(x).lt.12.0d0) u = exp(-x*x)
       y3 = y + 3
       do 5 i=1,m
        r  = x - t(i)
        r2 = r*r
        d  = 1.0d0/(r2+y2)
        d1 = y1*d
        d2 = r*d
        u  = u + y*(c(i)*(r*d2-1.50d0*d1)+s(i)*y3*d2)/(r2+2.250d0)
        r  = x + t(i)
        r2 = r*r
        d  = 1.0d0/(r2+y2)
        d3 = y1*d
        d4 = r*d
        u  = u + y*(c(i)*(r*d4-1.50d0*d3)-s(i)*y3*d4)/(r2+2.250d0)
        v  = v + c(i)*(d2+d4) + s(i)*(d1-d3)
 05    continue
       return
c
      end if
c
      end
c
c..............................................................................


 subroutine make_freq_array()
   use dyn_lc
   implicit none
   integer :: j

! !Frequency array
   df = 0.5d0 / (dt * int_len_dim)
   if (.not. allocated(freq)) allocate(freq(int_len_dim / 2))
   ! print *, dt, int_len_dim

   do j = 1, int_len_dim / 2
      freq(j) = real(j) / (dt * int_len_dim)
      ! write(*,*) freq(j)
   enddo

 end subroutine make_freq_array

!-------------------------------------------------------------------
 subroutine make_freq_array_obs()
   use dyn_lc
   implicit none
   integer :: j, o

   ! !Frequency array

   if(.not. allocated(df_obs)) allocate(df_obs(obs_num))
   if (.not. allocated(freq_obs)) allocate(freq_obs(int_len_dim_max / 2, obs_num))
   do o = 1, obs_num
      df_obs(o) = 0.5d0 / (dt * int_len_dim_obs(o))

      do j = 1, int_len_dim_obs(o) / 2
         freq_obs(j, o) = real(j) / (dt * int_len_dim_obs(o))
      enddo
   enddo

 end subroutine make_freq_array_obs


!< WenOOF test: reconstruction of sin function.
program sin_reconstruction
!< WenOOF test: reconstruction of sin function.

use penf, only : I_P, R_P, str
use wenoof, only : interpolator, wenoof_create
use pyplot_module, only :  pyplot

implicit none
class(interpolator), allocatable :: weno_interpolator          !< WENO interpolator.
integer(I_P), parameter          :: S = 6_I_P                  !< Stencils used.
integer(I_P), parameter          :: Nv = 30_I_P                !< Number of discretized values to be interpolated.
real(R_P),    parameter          :: pi = 4._R_P * atan(1._R_P) !< Extent of domain.
real(R_P)                        :: x(1-S:Nv+S)                !< Whole domain.
real(R_P)                        :: fx(1-S:Nv+S)               !< Discretized values to be interpolated.
real(R_P)                        :: xi(1:Nv)                   !< Domain of the interpolation.
real(R_P)                        :: fx_ref(1:Nv)               !< Reference values.
real(R_P)                        :: interpolation(1:1, 1:Nv)   !< Interpolated values.
type(pyplot)                     :: plt                        !< Plotter handler.
integer                          :: i, j, f                    !< Counters.

! build the values used for the reconstruction of sin function: nodal values
x = 0.
do i = 1 - S, Nv + S
  x(i) = i * 2 * pi / Nv
  fx(i) = sin(x(i))
enddo
! face values to which the reconstruction should tend
do i = 1, Nv
  xi(i) = x(i) + pi / Nv
  fx_ref(i) = sin(xi(i))
enddo

! create weno interpolator
call wenoof_create(interpolator_type='JS', S=S, wenoof_interpolator=weno_interpolator)

! interpolate values
interpolation = 0.
do i = 1, Nv ! interpolated values loop
  call weno_interpolator%interpolate(S=S,                                                      &
                                     stencil=reshape(source=fx(i+1-S:i-1+S), shape=[1,2*S-1]), &
                                     location='right',                                         &
                                     interpolation=interpolation(1:1, i))
enddo

! print results
print "(A)", '# x, sin(x), weno_interpolation(x)'
do i = 1, Nv
  print "(A)", str(n=xi(i))//' '//str(n=fx_ref(i))//' '//str(n=interpolation(1, i))
enddo

! plotting graph to image file
call plt%initialize(grid=.true., xlabel='angle (rad)', title='WENO interpolation of $\sin(x)$', legend=.true.)
call plt%add_plot(x=xi(1:Nv),        &
                  y=fx_ref(1:Nv),    &
                  label='$\sin(x)$', &
                  linestyle='k-',    &
                  linewidth=2)
call plt%add_plot(x=xi(1:Nv),                 &
                  y=interpolation(1, 1:Nv),   &
                  label='WENO interpolation', &
                  linestyle='ro',             &
                  markersize=6)
call plt%savefig('sin_reconstruction.png')
endprogram sin_reconstruction


MODULE procgrid

IMPLICIT NONE

CONTAINS

   SUBROUTINE calgrid
     USE glodata

     distance_wind_to_core = 3.0*(win_length - wind_width)/2.0
     win_width = distance_wind_to_core + wind_thickness &
                 + distance_wind_to_wind/2.0

     Nx = INT(core_length/(1.0*grid_size))
     N_core_x = INT((core_length - win_length)/grid_size)/2
     N_core_y = N_core_x
     N_win_width = INT(win_width/grid_size)
     Ny = N_win_width + N_core_y

     !calculate displacment grids for core-to-winding distance
     N_core_wind_x = INT((win_length - wind_width)/grid_size)/2
     N_core_wind = INT(distance_wind_to_core/grid_size)
     !calculate grids for windings
     N_wind_x = INT(wind_width/(1.0*grid_size))
     N_wind_y = INT(wind_thickness/grid_size)
     !calculate grids for winding distance
     N_dis_wind = INT(distance_wind_to_wind/(2.0*grid_size))
     !calculate grids for bumps
     N_bump_x = INT(bump_length/grid_size)
     N_bump_y = INT(bump_width/(2.0*grid_size))

   END SUBROUTINE calgrid

END MODULE procgrid


      SUBROUTINE MB04QU( TRANC, TRAND, TRANQ, STOREV, STOREW, M, N, K,
     $                   V, LDV, W, LDW, C, LDC, D, LDD, CS, TAU, DWORK,
     $                   LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To overwrite general real m-by-n matrices C and D, or their
C     transposes, with
C
C               [ op(C) ]
C         Q  *  [       ]   if TRANQ = 'N', or
C               [ op(D) ]
C
C          T    [ op(C) ]
C         Q  *  [       ]   if TRANQ = 'T',
C               [ op(D) ]
C
C     where Q is defined as the product of symplectic reflectors and
C     Givens rotations,
C
C         Q = diag( H(1),H(1) ) G(1) diag( F(1),F(1) )
C             diag( H(2),H(2) ) G(2) diag( F(2),F(2) )
C                               ....
C             diag( H(k),H(k) ) G(k) diag( F(k),F(k) ).
C
C     Unblocked version.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     TRANC   CHARACTER*1
C             Specifies the form of op( C ) as follows:
C             = 'N':  op( C ) = C;
C             = 'T':  op( C ) = C';
C             = 'C':  op( C ) = C'.
C
C     STOREV  CHARACTER*1
C             Specifies how the vectors which define the concatenated
C             Householder reflectors contained in V are stored:
C             = 'C':  columnwise;
C             = 'R':  rowwise.
C
C     STOREW  CHARACTER*1
C             Specifies how the vectors which define the concatenated
C             Householder reflectors contained in W are stored:
C             = 'C':  columnwise;
C             = 'R':  rowwise.
C
C     TRAND   CHARACTER*1
C             Specifies the form of op( D ) as follows:
C             = 'N':  op( D ) = D;
C             = 'T':  op( D ) = D';
C             = 'C':  op( D ) = D'.
C
C     TRANQ   CHARACTER*1
C             = 'N':  apply Q;
C             = 'T':  apply Q'.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows of the matrices op(C) and op(D).
C             M >= 0.
C
C     N       (input) INTEGER
C             The number of columns of the matrices op(C) and op(D).
C             N >= 0.
C
C     K       (input) INTEGER
C             The number of elementary reflectors whose product defines
C             the matrix Q.  M >= K >= 0.
C
C     V       (input) DOUBLE PRECISION array, dimension
C                     (LDV,K) if STOREV = 'C',
C                     (LDV,M) if STOREV = 'R'
C             On entry with STOREV = 'C', the leading M-by-K part of
C             this array must contain in its columns the vectors which
C             define the elementary reflectors F(i).
C             On entry with STOREV = 'R', the leading K-by-M part of
C             this array must contain in its rows the vectors which
C             define the elementary reflectors F(i).
C
C     LDV     INTEGER
C             The leading dimension of the array V.
C             LDV >= MAX(1,M),  if STOREV = 'C';
C             LDV >= MAX(1,K),  if STOREV = 'R'.
C
C     W       (input) DOUBLE PRECISION array, dimension
C                     (LDW,K) if STOREW = 'C',
C                     (LDW,M) if STOREW = 'R'
C             On entry with STOREW = 'C', the leading M-by-K part of
C             this array must contain in its columns the vectors which
C             define the elementary reflectors H(i).
C             On entry with STOREW = 'R', the leading K-by-M part of
C             this array must contain in its rows the vectors which
C             define the elementary reflectors H(i).
C
C     LDW     INTEGER
C             The leading dimension of the array W.
C             LDW >= MAX(1,M),  if STOREW = 'C';
C             LDW >= MAX(1,K),  if STOREW = 'R'.
C
C     C       (input/output) DOUBLE PRECISION array, dimension
C                     (LDC,N) if TRANC = 'N',
C                     (LDC,M) if TRANC = 'T' or TRANC = 'C'
C             On entry with TRANC = 'N', the leading M-by-N part of
C             this array must contain the matrix C.
C             On entry with TRANC = 'C' or TRANC = 'T', the leading
C             N-by-M part of this array must contain the transpose of
C             the matrix C.
C             On exit with TRANC = 'N', the leading M-by-N part of
C             this array contains the updated matrix C.
C             On exit with TRANC = 'C' or TRANC = 'T', the leading
C             N-by-M part of this array contains the transpose of the
C             updated matrix C.
C
C     LDC     INTEGER
C             The leading dimension of the array C.
C             LDC >= MAX(1,M),  if TRANC = 'N';
C             LDC >= MAX(1,N),  if TRANC = 'T' or TRANC = 'C'.
C
C     D       (input/output) DOUBLE PRECISION array, dimension
C                     (LDD,N) if TRAND = 'N',
C                     (LDD,M) if TRAND = 'T' or TRAND = 'C'
C             On entry with TRAND = 'N', the leading M-by-N part of
C             this array must contain the matrix D.
C             On entry with TRAND = 'C' or TRAND = 'T', the leading
C             N-by-M part of this array must contain the transpose of
C             the matrix D.
C             On exit with TRAND = 'N', the leading M-by-N part of
C             this array contains the updated matrix D.
C             On exit with TRAND = 'C' or TRAND = 'T', the leading
C             N-by-M part of this array contains the transpose of the
C             updated matrix D.
C
C     LDD     INTEGER
C             The leading dimension of the array D.
C             LDD >= MAX(1,M),  if TRAND = 'N';
C             LDD >= MAX(1,N),  if TRAND = 'T' or TRAND = 'C'.
C
C     CS      (input) DOUBLE PRECISION array, dimension (2*K)
C             On entry, the first 2*K elements of this array must
C             contain the cosines and sines of the symplectic Givens
C             rotations G(i).
C
C     TAU     (input) DOUBLE PRECISION array, dimension (K)
C             On entry, the first K elements of this array must
C             contain the scalar factors of the elementary reflectors
C             F(i).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0,  DWORK(1)  returns the optimal
C             value of LDWORK.
C             On exit, if  INFO = -20,  DWORK(1)  returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.  LDWORK >= MAX(1,N).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     CONTRIBUTORS
C
C     D. Kressner, Technical Univ. Berlin, Germany, and
C     P. Benner, Technical Univ. Chemnitz, Germany, December 2003.
C
C     REVISIONS
C
C     V. Sima, June 2008 (SLICOT version of the HAPACK routine DOSMSQ).
C
C     KEYWORDS
C
C     Elementary matrix operations, orthogonal symplectic matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE
      PARAMETER         ( ONE = 1.0D+0 )
C     .. Scalar Arguments ..
      CHARACTER         STOREV, STOREW, TRANC, TRAND, TRANQ
      INTEGER           INFO, K, LDC, LDD, LDV, LDW, LDWORK, M, N
C     .. Array Arguments ..
      DOUBLE PRECISION  CS(*), DWORK(*), C(LDC,*), D(LDD,*), V(LDV,*),
     $                  W(LDW,*), TAU(*)
C     .. Local Scalars ..
      LOGICAL           LCOLV, LCOLW, LTRC, LTRD, LTRQ
      INTEGER           I
      DOUBLE PRECISION  NU
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DLARF, DROT, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, MAX, MIN
C
C     .. Executable Statements ..
C
C     Decode the scalar input parameters.
C
      INFO  = 0
      LCOLV = LSAME( STOREV, 'C' )
      LCOLW = LSAME( STOREW, 'C' )
      LTRC  = LSAME( TRANC,  'T' ) .OR. LSAME( TRANC, 'C' )
      LTRD  = LSAME( TRAND,  'T' ) .OR. LSAME( TRAND, 'C' )
      LTRQ  = LSAME( TRANQ,  'T' )
C
C     Check the scalar input parameters.
C
      IF ( .NOT.( LTRC.OR.LSAME( TRANC, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF ( .NOT.( LTRD .OR. LSAME( TRAND,  'N' ) ) ) THEN
         INFO = -2
      ELSE IF ( .NOT.( LTRQ .OR. LSAME( TRANQ,  'N' ) ) ) THEN
         INFO = -3
      ELSE IF ( .NOT.( LCOLV.OR. LSAME( STOREV, 'R' ) ) ) THEN
         INFO = -4
      ELSE IF ( .NOT.( LCOLW.OR. LSAME( STOREW, 'R' ) ) ) THEN
         INFO = -5
      ELSE IF ( M.LT.0 ) THEN
         INFO = -6
      ELSE IF ( N.LT.0 ) THEN
         INFO = -7
      ELSE IF ( K.LT.0 .OR. K.GT.M ) THEN
         INFO = -8
      ELSE IF ( ( LCOLV.AND.LDV.LT.MAX( 1, M ) ) .OR.
     $     ( .NOT.LCOLV.AND.LDV.LT.MAX( 1, K ) ) ) THEN
         INFO = -10
      ELSE IF ( ( LCOLW.AND.LDW.LT.MAX( 1, M ) ) .OR.
     $     ( .NOT.LCOLW.AND.LDW.LT.MAX( 1, K ) ) ) THEN
         INFO = -12
      ELSE IF ( ( LTRC.AND.LDC.LT.MAX( 1, N ) ) .OR.
     $     ( .NOT.LTRC.AND.LDC.LT.MAX( 1, M ) ) ) THEN
         INFO = -14
      ELSE IF ( ( LTRD.AND.LDD.LT.MAX( 1, N ) ) .OR.
     $     ( .NOT.LTRD.AND.LDD.LT.MAX( 1, M ) ) ) THEN
         INFO = -16
      ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN
         DWORK(1) = DBLE( MAX( 1, N ) )
         INFO = -20
      END IF
C
C     Return if there were illegal values.
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB04QU', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( MIN( K, M, N ).EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
      IF ( LTRQ ) THEN
         DO 10  I = 1, K
C
C           Apply H(I) to C(I:M,:) and D(I:M,:) from the left.
C
            NU = W(I,I)
            W(I,I) = ONE
            IF ( LCOLW ) THEN
               IF ( LTRC ) THEN
                  CALL DLARF( 'Right', N, M-I+1, W(I,I), 1, NU, C(1,I),
     $                        LDC, DWORK )
               ELSE
                  CALL DLARF( 'Left', M-I+1, N, W(I,I), 1, NU, C(I,1),
     $                        LDC, DWORK )
               END IF
               IF ( LTRD ) THEN
                  CALL DLARF( 'Right', N, M-I+1, W(I,I), 1, NU, D(1,I),
     $                        LDD, DWORK )
               ELSE
                  CALL DLARF( 'Left', M-I+1, N, W(I,I), 1, NU, D(I,1),
     $                        LDD, DWORK )
               END IF
            ELSE
               IF ( LTRC ) THEN
                  CALL DLARF( 'Right', N, M-I+1, W(I,I), LDW, NU,
     $                        C(1,I), LDC, DWORK )
               ELSE
                  CALL DLARF( 'Left', M-I+1, N, W(I,I), LDW, NU, C(I,1),
     $                        LDC, DWORK )
               END IF
               IF ( LTRD ) THEN
                  CALL DLARF( 'Right', N, M-I+1, W(I,I), LDW, NU,
     $                        D(1,I), LDD, DWORK )
               ELSE
                  CALL DLARF( 'Left', M-I+1, N, W(I,I), LDW, NU, D(I,1),
     $                        LDD, DWORK )
               END IF
            END IF
            W(I,I) = NU
C
C           Apply G(i) to C(I,:) and D(I,:) from the left.
C
            IF ( LTRC.AND.LTRD ) THEN
               CALL DROT( N, C(1,I), 1, D(1,I), 1, CS(2*I-1), CS(2*I) )
            ELSE IF ( LTRC ) THEN
               CALL DROT( N, C(1,I), 1, D(I,1), LDD, CS(2*I-1),
     $                    CS(2*I) )
            ELSE IF ( LTRD ) THEN
               CALL DROT( N, C(I,1), LDC, D(1,I), 1, CS(2*I-1),
     $                    CS(2*I) )
            ELSE
               CALL DROT( N, C(I,1), LDC, D(I,1), LDD, CS(2*I-1),
     $                    CS(2*I) )
            END IF
C
C           Apply F(I) to C(I:M,:) and D(I:M,:) from the left.
C
            NU = V(I,I)
            V(I,I) = ONE
            IF ( LCOLV ) THEN
               IF ( LTRC ) THEN
                  CALL DLARF( 'Right', N, M-I+1, V(I,I), 1, TAU(I),
     $                        C(1,I), LDC, DWORK )
               ELSE
                  CALL DLARF( 'Left', M-I+1, N, V(I,I), 1, TAU(I),
     $                        C(I,1), LDC, DWORK )
               END IF
               IF ( LTRD ) THEN
                  CALL DLARF( 'Right', N, M-I+1, V(I,I), 1, TAU(I),
     $                        D(1,I), LDD, DWORK )
               ELSE
                  CALL DLARF( 'Left', M-I+1, N, V(I,I), 1, TAU(I),
     $                        D(I,1), LDD, DWORK )
               END IF
            ELSE
               IF ( LTRC ) THEN
                  CALL DLARF( 'Right', N, M-I+1, V(I,I), LDV, TAU(I),
     $                        C(1,I), LDC, DWORK )
               ELSE
                  CALL DLARF( 'Left', M-I+1, N, V(I,I), LDV, TAU(I),
     $                        C(I,1), LDC, DWORK )
               END IF
               IF ( LTRD ) THEN
                  CALL DLARF( 'Right', N, M-I+1, V(I,I), LDV, TAU(I),
     $                        D(1,I), LDD, DWORK )
               ELSE
                  CALL DLARF( 'Left', M-I+1, N, V(I,I), LDV, TAU(I),
     $                        D(I,1), LDD, DWORK )
               END IF
            END IF
            V(I,I) = NU
   10    CONTINUE
      ELSE
         DO 20  I = K, 1, -1
C
C           Apply F(I) to C(I:M,:) and D(I:M,:) from the left.
C
            NU = V(I,I)
            V(I,I) = ONE
            IF ( LCOLV ) THEN
               IF ( LTRC ) THEN
                  CALL DLARF( 'Right', N, M-I+1, V(I,I), 1, TAU(I),
     $                        C(1,I), LDC, DWORK )
               ELSE
                  CALL DLARF( 'Left', M-I+1, N, V(I,I), 1, TAU(I),
     $                        C(I,1), LDC, DWORK )
               END IF
               IF ( LTRD ) THEN
                  CALL DLARF( 'Right', N, M-I+1, V(I,I), 1, TAU(I),
     $                        D(1,I), LDD, DWORK )
               ELSE
                  CALL DLARF( 'Left', M-I+1, N, V(I,I), 1, TAU(I),
     $                        D(I,1), LDD, DWORK )
               END IF
            ELSE
               IF ( LTRC ) THEN
                  CALL DLARF( 'Right', N, M-I+1, V(I,I), LDV, TAU(I),
     $                        C(1,I), LDC, DWORK )
               ELSE
                  CALL DLARF( 'Left', M-I+1, N, V(I,I), LDV, TAU(I),
     $                        C(I,1), LDC, DWORK )
               END IF
               IF ( LTRD ) THEN
                  CALL DLARF( 'Right', N, M-I+1, V(I,I), LDV, TAU(I),
     $                        D(1,I), LDD, DWORK )
               ELSE
                  CALL DLARF( 'Left', M-I+1, N, V(I,I), LDV, TAU(I),
     $                        D(I,1), LDD, DWORK )
               END IF
            END IF
            V(I,I) = NU
C
C           Apply G(i) to C(I,:) and D(I,:) from the left.
C
            IF ( LTRC.AND.LTRD ) THEN
               CALL DROT( N, C(1,I), 1, D(1,I), 1, CS(2*I-1), -CS(2*I) )
            ELSE IF ( LTRC ) THEN
               CALL DROT( N, C(1,I), 1, D(I,1), LDD, CS(2*I-1),
     $                    -CS(2*I) )
            ELSE IF ( LTRD ) THEN
               CALL DROT( N, C(I,1), LDC, D(1,I), 1, CS(2*I-1),
     $                    -CS(2*I) )
            ELSE
               CALL DROT( N, C(I,1), LDC, D(I,1), LDD, CS(2*I-1),
     $                    -CS(2*I) )
            END IF
C
C           Apply H(I) to C(I:M,:) and D(I:M,:) from the left.
C
            NU = W(I,I)
            W(I,I) = ONE
            IF ( LCOLW ) THEN
               IF ( LTRC ) THEN
                  CALL DLARF( 'Right', N, M-I+1, W(I,I), 1, NU, C(1,I),
     $                        LDC, DWORK )
               ELSE
                  CALL DLARF( 'Left', M-I+1, N, W(I,I), 1, NU, C(I,1),
     $                        LDC, DWORK )
               END IF
               IF ( LTRD ) THEN
                  CALL DLARF( 'Right', N, M-I+1, W(I,I), 1, NU, D(1,I),
     $                        LDD, DWORK )
               ELSE
                  CALL DLARF( 'Left', M-I+1, N, W(I,I), 1, NU, D(I,1),
     $                        LDD, DWORK )
               END IF
            ELSE
               IF ( LTRC ) THEN
                  CALL DLARF( 'Right', N, M-I+1, W(I,I), LDW, NU,
     $                        C(1,I), LDC, DWORK )
               ELSE
                  CALL DLARF( 'Left', M-I+1, N, W(I,I), LDW, NU, C(I,1),
     $                        LDC, DWORK )
               END IF
               IF ( LTRD ) THEN
                  CALL DLARF( 'Right', N, M-I+1, W(I,I), LDW, NU,
     $                        D(1,I), LDD, DWORK )
               ELSE
                  CALL DLARF( 'Left', M-I+1, N, W(I,I), LDW, NU, D(I,1),
     $                        LDD, DWORK )
               END IF
            END IF
            W(I,I) = NU
   20    CONTINUE
      END IF
C
      DWORK(1) = DBLE( MAX( 1, N ) )
C *** Last line of MB04QU ***
      END


      double precision function ff_alpha(muj,muk)
c--- This is an implementation of the modifications to the final-final
c--- dipoles ff_qq, according to the formulae in Appendix A of:
c---
c---  G.~Bevilacqua, M.~Czakon, C.~G.~Papadopoulos, R.~Pittau and M.~Worek,
c---  ``Assault on the NLO Wishlist: pp -> tt bb,''
c---  JHEP {\bf 0909}, 109 (2009) [arXiv:0907.4723 [hep-ph]].
c---
c---  Note: according to the MCFM implementation of the final-final dipoles,
c---  alpha in the paper is replaced by (aff*yp) here
      implicit none
      include 'alfacut.f'
      double precision muj,muk,mujsq,muksq,fac,rt
      double precision Deik,Dcoll,yp,ddilog,aa,bb,cc,dd,xx,xp,xm,vjk

c--- some definitions, for speed
      mujsq=muj**2
      muksq=muk**2
      fac=1d0-mujsq-muksq
      rt=dsqrt(1d0+mujsq**2+muksq**2-2d0*(mujsq+muksq+mujsq*muksq))

c--- basic definitions
      yp=1d0-2d0*muk*(1d0-muk)/fac

      aa=2d0*muk/fac
      bb=2d0*(1d0-muk)/fac
      cc=bb*muk
      dd=fac/2d0

      xp=((1d0-muk)**2-mujsq+rt)/fac
      xm=((1d0-muk)**2-mujsq-rt)/fac
      vjk=rt/fac

c--- Equation (A.8) (remember alpha -> alpha*yp)
      xx=yp*(1d0-aff)+dsqrt(yp*(1d0-aff)*
     & (1d0/yp-yp*aff+4d0*mujsq*muksq/(mujsq-(1d0-muk)**2)/fac))

c--- Equation (A.9)
      Deik=(
     & -ddilog((aa+xx)/(aa+xp))+ddilog(aa/(aa+xp))
     & +ddilog((xp-xx)/(xp-bb))-ddilog(xp/(xp-bb))
     & +ddilog((cc+xx)/(cc+xp))-ddilog(cc/(cc+xp))
     & +ddilog((xm-xx)/(xm+aa))-ddilog(xm/(xm+aa))
     & -ddilog((bb-xx)/(bb-xm))+ddilog(bb/(bb-xm))
     & -ddilog((xm-xx)/(xm+cc))+ddilog(xm/(xm+cc))
     & +ddilog((bb-xx)/(bb+aa))-ddilog(bb/(bb+aa))
     & -ddilog((cc+xx)/(cc-aa))+ddilog(cc/(cc-aa))
     & +dlog(cc+xx)*dlog((aa-cc)*(xp-xx)/(aa+xx)/(cc+xp))
     & -dlog(cc)*dlog((aa-cc)*xp/aa/(cc+xp))
     & +dlog(bb-xx)*dlog((aa+xx)*(xm-bb)/(aa+bb)/(xm-xx))
     & -dlog(bb)*dlog(aa*(xm-bb)/(aa+bb)/xm)
     & -dlog((aa+xx)*(bb-xp))*dlog(xp-xx)
     & +dlog(aa*(bb-xp))*dlog(xp)
     & +dlog(dd)*dlog((aa+xx)*xp*xm/aa/(xp-xx)/(xm-xx))
     & +dlog((xm-xx)/xm)*dlog((cc+xm)/(aa+xm))
     & +0.5d0*dlog((aa+xx)/aa)*dlog(aa*(aa+xx)*(aa+xp)**2)
     &  )/vjk

c--- Equation (A.20)  (remember alpha -> alpha*yp)
      Dcoll=1.5d0*(1d0+aff*yp)+1d0/(1d0-muk)-2d0*(2d0-2d0*mujsq-muk)/fac
     & +(1d0-aff*yp)*mujsq/2d0/(mujsq+aff*yp*fac)
     & -2d0*dlog(aff*yp*fac/((1d0-muk)**2-mujsq))
     & +(1d0+mujsq-muksq)/2d0/fac*dlog((mujsq+aff*yp*fac)/(1d0-muk)**2)

c--- the final dipole is equal to this combination (c.f. dipoles_mass.f)
      ff_alpha=2d0*Deik+Dcoll

c      write(6,*) 'ff_alpha: 2d0*Deik   ',2d0*Deik
c      write(6,*) 'ff_alpha:    Dcoll   ',Dcoll
c      write(6,*) 'ff_alpha: ff_alpha   ',ff_alpha
c      pause

      return
      end


      FUNCTION rf(x,y,z)
      REAL rf,x,y,z,ERRTOL,TINY,BIG,THIRD,C1,C2,C3,C4
      PARAMETER (ERRTOL=.08,TINY=1.5e-38,BIG=3.E37,THIRD=1./3.,
     *C1=1./24.,C2=.1,C3=3./44.,C4=1./14.)
      REAL alamb,ave,delx,dely,delz,e2,e3,sqrtx,sqrty,sqrtz,xt,yt,zt
      if(min(x,y,z).lt.0..or.min(x+y,x+z,y+z).lt.TINY.or.max(x,y,
     *z).gt.BIG)pause 'invalid arguments in rf'
      xt=x
      yt=y
      zt=z
1     continue
        sqrtx=sqrt(xt)
        sqrty=sqrt(yt)
        sqrtz=sqrt(zt)
        alamb=sqrtx*(sqrty+sqrtz)+sqrty*sqrtz
        xt=.25*(xt+alamb)
        yt=.25*(yt+alamb)
        zt=.25*(zt+alamb)
        ave=THIRD*(xt+yt+zt)
        delx=(ave-xt)/ave
        dely=(ave-yt)/ave
        delz=(ave-zt)/ave
      if(max(abs(delx),abs(dely),abs(delz)).gt.ERRTOL)goto 1
      e2=delx*dely-delz**2
      e3=delx*dely*delz
      rf=(1.+(C1*e2-C2-C3*e3)*e2+C4*e3)/sqrt(ave)
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/rf.for


! ----------------------------------------- !
!      Set up filtro periodico              !
!             F. Califano, Marzo 2001       !
! ----------------------------------------- !

!**************************************************
!  MPI PARALLEL VERSION: VALENTINI-FAGANELLO 2009
!   3D PARALLEL VERSION: FAGANELLO 2010
!**************************************************

           subroutine init_filtro_per

use box_mod
use parameter_mod
use filtro_per_mod

IMPLICIT NONE

  integer  :: kk
  real(dp) :: tr1, tr2, tr3, tr4, tr5, w0, w11, w22

!   Set up coefficienti filtro periodico in x !!!!!!!!!!!!!!!!refuso!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!   filter parameters

       tr1 = (2.0 + 3.0 * omega_x) / 4.0
       tr2 = (6.0 + 7.0 * omega_x) / 8.0
       tr3 = (6.0 + omega_x)       / 20.0
       tr4 = (2.0 - 3.0 * omega_x) / 40.0
       tr5 = (3.0 - 2.0 * omega_x) / 10.0

 do kk = 1, n2x
  w0 = 2.d0 * pgreco * dfloat(kk) / dfloat(nx)
  w11 = tr1 + tr2*cos(w0) + tr3*cos(2.d0*w0) + tr4*cos(3.d0*w0)
  w22 = 1.0 +2.0 * omega_x*cos(w0) + 2.0 * tr5*cos(2.d0*w0)
  work4x(kk) = w11 / w22
 enddo

!   Set up coefficienti filtro periodico in y

!   filter parameters

       tr1 = (2.0 + 3.0 * omega_y) / 4.0
       tr2 = (6.0 + 7.0 * omega_y) / 8.0
       tr3 = (6.0 + omega_y)       / 20.0
       tr4 = (2.0 - 3.0 * omega_y) / 40.0
       tr5 = (3.0 - 2.0 * omega_y) / 10.0

 do kk = 1, n2y
  w0 = 2.d0 * pgreco * dfloat(kk) / dfloat(ny)
  w11 = tr1 + tr2*cos(w0) + tr3*cos(2.d0*w0) + tr4*cos(3.d0*w0)
  w22 = 1.0 +2.0 * omega_y*cos(w0) + 2.0 * tr5*cos(2.d0*w0)
  work4y(kk) = w11 / w22
 enddo

!   Set up coefficienti filtro periodico in z

!   filter parameters

       tr1 = (2.0 + 3.0 * omega_z) / 4.0
       tr2 = (6.0 + 7.0 * omega_z) / 8.0
       tr3 = (6.0 + omega_z)       / 20.0
       tr4 = (2.0 - 3.0 * omega_z) / 40.0
       tr5 = (3.0 - 2.0 * omega_z) / 10.0

 do kk = 1, n2z
  w0 = 2.d0 * pgreco * dfloat(kk) / dfloat(nz)
  w11 = tr1 + tr2*cos(w0) + tr3*cos(2.d0*w0) + tr4*cos(3.d0*w0)
  w22 = 1.0 +2.0 * omega_z*cos(w0) + 2.0 * tr5*cos(2.d0*w0)
  work4z(kk) = w11 / w22
 enddo

 end subroutine


program main
        use globals
        use initialise
        use fft_routines
        use display
        use solver
        integer :: i,j,fulldump, current_time, num_dumps, time_dump
        integer :: nanspres
        !netcdf variables
        integer :: mdata_id, x_dimid,y_dimid,t_id,cmplx_id
        integer :: uid,vid,wid,rhoid
        integer :: time_rep
        integer, dimension(4) :: dimids,curr_dim, count_dim
        character(len=8) :: ct
        character(len=32) :: kzs,Ns, res, fhs, Lstr
        character(len=80) :: outputname

        !get kz,Fh,Re,N from command line
        i=command_argument_count()
        if(i /= 5) then
                print *, "ERROR: insufficient cl arguments"
                call EXIT(0)
        end if
        call get_command_argument(1,kzs)
        read(kzs,'(g5.2)') ukz
        call get_command_argument(2,fhs)
        read(fhs,'(g5.2)') Fh
        call get_command_argument(3,res)
        read(res,'(g7.2)') Re
        call get_command_argument(4,Ns)
        read(Ns,'(i4)') N
        call get_command_argument(5,Lstr)
        read(Lstr,'(g2.2)') L

        !define some important information
        tpiL=2.0*pi/L
        dx=L/real(N,8)
        dy=dx
        num_steps=floor(t_final/dt)
        !number of times I want to dump the data
        num_dumps=50
        !how often I dump the data, in terms of num_steps
        fulldump=floor((t_final/num_dumps)/dt)

        !allocate
        call alloc_matrices()
        call alloc_fft()
        call init_fft()
        call init_wn()
        call init_grid()
        call init_projection()
        call init_conditions(cont,kzs)
        call init_vorticity()

        if  (hypervis == 1) then
                Rev=Re
                Re=Re*(n_k**2)
        end if
        call afft2(uu,uu_hat)
        call afft2(vv,vv_hat)
        call afft2(ww,ww_hat)
        call afft2(rho,rho_hat)

        print *,'Doing fulldump every', fulldump,' timesteps'
        ifactor=k_sq/Re
        t_ifactor=ifactor*dt
        exp_ifactor_1=exp(-t_ifactor)
        exp_ifactor_2=exp(-2*t_ifactor)

        ! do NETCDF allocation
        outputname='kz.'//trim(kzs)//'.'//trim(Ns)//'.re.'//trim(res)//'.fh.'//trim(fhs)//'.L.'//trim(Lstr)//'.ncf'
        call check(nf90_create(outputname,nf90_64bit_offset,mdata_id))
        call check(nf90_def_dim(mdata_id,"X",N,x_dimid))
        call check(nf90_def_dim(mdata_id,"Y",N,y_dimid))
        !num_dumps + 2 to include first and last
        call check(nf90_def_dim(mdata_id,"t",num_dumps+2,t_id))
        call check(nf90_def_dim(mdata_id,"cmplx",2,cmplx_id))

        dimids=(/ x_dimid,y_dimid,t_id,cmplx_id /)
        call check(nf90_def_var(mdata_id,"u",nf90_double,dimids,uid))
        call check(nf90_def_var(mdata_id,"v",nf90_double,dimids,vid))
        call check(nf90_def_var(mdata_id,"w",nf90_double,dimids,wid))
        call check(nf90_def_var(mdata_id,"rho",nf90_double,dimids,rhoid))

        call check(nf90_enddef(mdata_id))

        uu_hat_temp=uu_hat
        vv_hat_temp=vv_hat
        ww_hat_temp=ww_hat

        ! ensures divergence free
        uu_hat=uu_hat_temp*p11+vv_hat_temp*p12+ww_hat_temp*p13
        vv_hat=uu_hat_temp*p21+vv_hat_temp*p22+ww_hat_temp*p23
        ww_hat=uu_hat_temp*p31+vv_hat_temp*p32+ww_hat_temp*p33

        !convert to integrating factors
        irho_hat=rho_hat
        iuu_hat=uu_hat
        ivv_hat=vv_hat
        iww_hat=ww_hat

        !Euler method for first step
        call rho_right()
        irho_hat_new=exp_ifactor_1*irho_hat+exp_ifactor_1*dt*rr
        call vel_right()

        iuu_hat_new=exp_ifactor_1*iuu_hat+exp_ifactor_1*dt*ur
        ivv_hat_new=exp_ifactor_1*ivv_hat+exp_ifactor_1*dt*vr
        iww_hat_new=exp_ifactor_1*iww_hat+exp_ifactor_1*dt*wr

        ! update scheme
        iuu_hat=iuu_hat_new
        ivv_hat=ivv_hat_new
        iww_hat=iww_hat_new
        irho_hat=irho_hat_new
        rr_old=rr
        ur_old=ur
        vr_old=vr
        wr_old=wr

        !dump initial data
        curr_dim=(/1,1,1,1/)
        count_dim=(/N,N,1,1/)
        call check(nf90_put_var(mdata_id,uid,real(ur),curr_dim,count_dim))
        call check(nf90_put_var(mdata_id,vid,real(vr),curr_dim,count_dim))
        call check(nf90_put_var(mdata_id,wid,real(wr),curr_dim,count_dim))
        call check(nf90_put_var(mdata_id,rhoid,real(rr),curr_dim,count_dim))
!
        curr_dim=(/1,1,1,2/)
        call check(nf90_put_var(mdata_id,uid,imag(ur),curr_dim,count_dim))
        call check(nf90_put_var(mdata_id,vid,imag(vr),curr_dim,count_dim))
        call check(nf90_put_var(mdata_id,wid,imag(wr),curr_dim,count_dim))
        call check(nf90_put_var(mdata_id,rhoid,imag(rr),curr_dim,count_dim))
        time_dump=1
        j=1
        prev_en=0._8
        do i=1,num_steps
                tstep=i
                !apply Adams-Basforth 2nd order time-stepping
                call rho_right()
                call vel_right()
                irho_hat_new=exp_ifactor_1*irho_hat+exp_ifactor_1*1.5_8*dt*rr-exp_ifactor_2*0.5_8*dt*rr_old
                iuu_hat_new=exp_ifactor_1*iuu_hat+exp_ifactor_1*1.5_8*dt*ur-exp_ifactor_2*0.5_8*dt*ur_old
                ivv_hat_new=exp_ifactor_1*ivv_hat+exp_ifactor_1*1.5_8*dt*vr-exp_ifactor_2*0.5_8*dt*vr_old
                iww_hat_new=exp_ifactor_1*iww_hat+exp_ifactor_1*1.5_8*dt*wr-exp_ifactor_2*0.5_8*dt*wr_old
                !update scheme
                iuu_hat=iuu_hat_new
                ivv_hat=ivv_hat_new
                iww_hat=iww_hat_new
                irho_hat=irho_hat_new
                rr_old=rr
                ur_old=ur
                vr_old=vr
                wr_old=wr
                tote(i)=en
                growth_rate(i)=(en-prev_en)/dt
                prev_en=en
                if (isnan(en)) then
                        print *, "ERROR: NaNs detected at timestep"
                        print *, i
                        print *, 'time dump', time_dump, 'at time step', i
                        time_dump=time_dump+1
                        curr_dim=(/1,1,time_dump,1/)
                        count_dim=(/N,N,1,1/)
                        call check(nf90_put_var(mdata_id,uid,real(r1),curr_dim,count_dim))
                        call check(nf90_put_var(mdata_id,vid,real(r2),curr_dim,count_dim))
                        call check(nf90_put_var(mdata_id,wid,real(r3),curr_dim,count_dim))
                        call check(nf90_put_var(mdata_id,rhoid,real(r4),curr_dim,count_dim))
                        curr_dim=(/1,1,time_dump,2/)
                        call check(nf90_put_var(mdata_id,uid,imag(r1),curr_dim,count_dim))
                        call check(nf90_put_var(mdata_id,vid,imag(r2),curr_dim,count_dim))
                        call check(nf90_put_var(mdata_id,wid,imag(r3),curr_dim,count_dim))
                        call check(nf90_put_var(mdata_id,rhoid,imag(r4),curr_dim,count_dim))
                        outputname='kz.'//trim(kzs)//'.totE.'//trim(Ns)//'.re.'//trim(res)//'.fh.'//trim(fhs)//'L.'//trim(Lstr)//'.dat'
                        call arr_w2f(tote,outputname,num_steps)
                        outputname='kz.'//trim(kzs)//'.sigma.'//trim(Ns)//'.re.'//trim(res)//'.fh.'//trim(fhs)//'L.'//trim(Lstr)//'.dat'
                        call arr_w2f(growth_rate,outputname,num_steps)
                        ! close netcdf
                        call check(nf90_close(mdata_id))
                        ! deallocate everything
                        call dealloc_matrices()
                        call dealloc_fft()
                        call EXIT(0)
                end if
                ! every 100 time steps dump some info
                if (mod(i,100)==0) then
                        outputname='kz.'//trim(kzs)//'_data_'//trim(Ns)//'.L.'//trim(Lstr)//'.dat'
                        call data_w2f(growth_rate(i),outputname,i)
                end if

               if(mod(i,fulldump)==0)  then
                        time_dump=time_dump+1
                        curr_dim=(/1,1,time_dump,1/)
                        count_dim=(/N,N,1,1/)
                        call check(nf90_put_var(mdata_id,uid,real(r1),curr_dim,count_dim))
                        call check(nf90_put_var(mdata_id,vid,real(r2),curr_dim,count_dim))
                        call check(nf90_put_var(mdata_id,wid,real(r3),curr_dim,count_dim))
                        call check(nf90_put_var(mdata_id,rhoid,real(r4),curr_dim,count_dim))
                        curr_dim=(/1,1,time_dump,2/)
                        call check(nf90_put_var(mdata_id,uid,imag(r1),curr_dim,count_dim))
                        call check(nf90_put_var(mdata_id,vid,imag(r2),curr_dim,count_dim))
                        call check(nf90_put_var(mdata_id,wid,imag(r3),curr_dim,count_dim))
                        call check(nf90_put_var(mdata_id,rhoid,imag(r4),curr_dim,count_dim))
                        outputname='kz.'//trim(kzs)//'.totE.'//trim(Ns)//'.re.'//trim(res)//'.fh.'//trim(fhs)//'L.'//trim(Lstr)//'.dat'
                        call arr_w2f(tote,outputname,num_steps)
                        outputname='kz.'//trim(kzs)//'.sigma.'//trim(Ns)//'.re.'//trim(res)//'.fh.'//trim(fhs)//'L.'//trim(Lstr)//'.dat'
                        call arr_w2f(growth_rate,outputname,num_steps)
                end if
        end do
        r1_hat=iuu_hat
        r2_hat=ivv_hat
        r3_hat=iww_hat
        r4_hat=irho_hat
        call ifft2(r1_hat,r1)
        call ifft2(r2_hat,r2)
        call ifft2(r3_hat,r3)
        call ifft2(r4_hat,r4)
        curr_dim=(/1,1,num_dumps+2,1/)
        count_dim=(/N,N,1,1/)
        call check(nf90_put_var(mdata_id,uid,real(r1),curr_dim,count_dim))
        call check(nf90_put_var(mdata_id,vid,real(r2),curr_dim,count_dim))
        call check(nf90_put_var(mdata_id,wid,real(r3),curr_dim,count_dim))
        call check(nf90_put_var(mdata_id,rhoid,real(r4),curr_dim,count_dim))
        curr_dim=(/1,1,num_dumps+2,2/)
        call check(nf90_put_var(mdata_id,uid,imag(r1),curr_dim,count_dim))
        call check(nf90_put_var(mdata_id,vid,imag(r2),curr_dim,count_dim))
        call check(nf90_put_var(mdata_id,wid,imag(r3),curr_dim,count_dim))
        call check(nf90_put_var(mdata_id,rhoid,imag(r4),curr_dim,count_dim))
        outputname='kz.'//trim(kzs)//'.totE.'//trim(Ns)//'.re.'//trim(res)//'.fh.'//trim(fhs)//'L.'//trim(Lstr)//'.dat'
        call arr_w2f(tote,outputname,num_steps)
        outputname='kz.'//trim(kzs)//'.sigma.'//trim(Ns)//'.re.'//trim(res)//'.fh.'//trim(fhs)//'L.'//trim(Lstr)//'.dat'
        call arr_w2f(growth_rate,outputname,num_steps)
        ! close netcdf
        call check(nf90_close(mdata_id))
        ! deallocate everything
        call dealloc_matrices()
        call dealloc_fft()
contains
        subroutine check(status)
        integer, intent(in) :: status
        if(status/=nf90_noerr) then
                print *, trim(nf90_strerror(status))
                stop "Stopped. Error in netcdf."
        end if
        end subroutine check
end program main