      SUBROUTINE SB03TD( JOB, FACT, TRANA, UPLO, LYAPUN, N, SCALE, A,
     $                   LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEP,
     $                   RCOND, FERR, WR, WI, IWORK, DWORK, LDWORK,
     $                   INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To solve the real continuous-time Lyapunov matrix equation
C
C            op(A)'*X + X*op(A) = scale*C,
C
C     estimate the conditioning, and compute an error bound on the
C     solution X, where op(A) = A or A' (A**T), the matrix A is N-by-N,
C     the right hand side C and the solution X are N-by-N symmetric
C     matrices (C = C', X = X'), and scale is an output scale factor,
C     set less than or equal to 1 to avoid overflow in X.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Specifies the computation to be performed, as follows:
C             = 'X':  Compute the solution only;
C             = 'S':  Compute the separation only;
C             = 'C':  Compute the reciprocal condition number only;
C             = 'E':  Compute the error bound only;
C             = 'A':  Compute all: the solution, separation, reciprocal
C                     condition number, and the error bound.
C
C     FACT    CHARACTER*1
C             Specifies whether or not the real Schur factorization
C             of the matrix A is supplied on entry, as follows:
C             = 'F':  On entry, T and U (if LYAPUN = 'O') contain the
C                     factors from the real Schur factorization of the
C                     matrix A;
C             = 'N':  The Schur factorization of A will be computed
C                     and the factors will be stored in T and U (if
C                     LYAPUN = 'O').
C
C     TRANA   CHARACTER*1
C             Specifies the form of op(A) to be used, as follows:
C             = 'N':  op(A) = A    (No transpose);
C             = 'T':  op(A) = A**T (Transpose);
C             = 'C':  op(A) = A**T (Conjugate transpose = Transpose).
C
C     UPLO    CHARACTER*1
C             Specifies which part of the symmetric matrix C is to be
C             used, as follows:
C             = 'U':  Upper triangular part;
C             = 'L':  Lower triangular part.
C
C     LYAPUN  CHARACTER*1
C             Specifies whether or not the original or "reduced"
C             Lyapunov equations should be solved, as follows:
C             = 'O':  Solve the original Lyapunov equations, updating
C                     the right-hand sides and solutions with the
C                     matrix U, e.g., X <-- U'*X*U;
C             = 'R':  Solve reduced Lyapunov equations only, without
C                     updating the right-hand sides and solutions.
C                     This means that a real Schur form T of A appears
C                     in the equation, instead of A.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices A, X, and C.  N >= 0.
C
C     SCALE   (input or output) DOUBLE PRECISION
C             If JOB = 'C' or JOB = 'E', SCALE is an input argument:
C             the scale factor, set by a Lyapunov solver.
C             0 <= SCALE <= 1.
C             If JOB = 'X' or JOB = 'A', SCALE is an output argument:
C             the scale factor, scale, set less than or equal to 1 to
C             prevent the solution overflowing.
C             If JOB = 'S', this argument is not used.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             If FACT = 'N' or (LYAPUN = 'O' and JOB <> 'X'), the
C             leading N-by-N part of this array must contain the
C             original matrix A.
C             If FACT = 'F' and (LYAPUN = 'R' or JOB = 'X'), A is
C             not referenced.
C
C     LDA     INTEGER
C             The leading dimension of the array A.
C             LDA >= MAX(1,N), if FACT = 'N' or LYAPUN = 'O' and
C                                               JOB <> 'X';
C             LDA >= 1,        otherwise.
C
C     T       (input/output) DOUBLE PRECISION array, dimension
C             (LDT,N)
C             If FACT = 'F', then on entry the leading N-by-N upper
C             Hessenberg part of this array must contain the upper
C             quasi-triangular matrix T in Schur canonical form from a
C             Schur factorization of A.
C             If FACT = 'N', then this array need not be set on input.
C             On exit, (if INFO = 0 or INFO = N+1, for FACT = 'N') the
C             leading N-by-N upper Hessenberg part of this array
C             contains the upper quasi-triangular matrix T in Schur
C             canonical form from a Schur factorization of A.
C             The contents of array T is not modified if FACT = 'F'.
C
C     LDT     INTEGER
C             The leading dimension of the array T.  LDT >= MAX(1,N).
C
C     U       (input or output) DOUBLE PRECISION array, dimension
C             (LDU,N)
C             If LYAPUN = 'O' and FACT = 'F', then U is an input
C             argument and on entry, the leading N-by-N part of this
C             array must contain the orthogonal matrix U from a real
C             Schur factorization of A.
C             If LYAPUN = 'O' and FACT = 'N', then U is an output
C             argument and on exit, if INFO = 0 or INFO = N+1, it
C             contains the orthogonal N-by-N matrix from a real Schur
C             factorization of A.
C             If LYAPUN = 'R', the array U is not referenced.
C
C     LDU     INTEGER
C             The leading dimension of the array U.
C             LDU >= 1,        if LYAPUN = 'R';
C             LDU >= MAX(1,N), if LYAPUN = 'O'.
C
C     C       (input) DOUBLE PRECISION array, dimension (LDC,N)
C             If JOB <> 'S' and UPLO = 'U', the leading N-by-N upper
C             triangular part of this array must contain the upper
C             triangular part of the matrix C of the original Lyapunov
C             equation (with matrix A), if LYAPUN = 'O', or of the
C             reduced Lyapunov equation (with matrix T), if
C             LYAPUN = 'R'.
C             If JOB <> 'S' and UPLO = 'L', the leading N-by-N lower
C             triangular part of this array must contain the lower
C             triangular part of the matrix C of the original Lyapunov
C             equation (with matrix A), if LYAPUN = 'O', or of the
C             reduced Lyapunov equation (with matrix T), if
C             LYAPUN = 'R'.
C             The remaining strictly triangular part of this array is
C             used as workspace.
C             If JOB = 'X', then this array may be identified with X
C             in the call of this routine.
C             If JOB = 'S', the array C is not referenced.
C
C     LDC     INTEGER
C             The leading dimension of the array C.
C             LDC >= 1,        if JOB = 'S';
C             LDC >= MAX(1,N), otherwise.
C
C     X       (input or output) DOUBLE PRECISION array, dimension
C             (LDX,N)
C             If JOB = 'C' or 'E', then X is an input argument and on
C             entry, the leading N-by-N part of this array must contain
C             the symmetric solution matrix X of the original Lyapunov
C             equation (with matrix A), if LYAPUN = 'O', or of the
C             reduced Lyapunov equation (with matrix T), if
C             LYAPUN = 'R'.
C             If JOB = 'X' or 'A', then X is an output argument and on
C             exit, if INFO = 0 or INFO = N+1, the leading N-by-N part
C             of this array contains the symmetric solution matrix X of
C             of the original Lyapunov equation (with matrix A), if
C             LYAPUN = 'O', or of the reduced Lyapunov equation (with
C             matrix T), if LYAPUN = 'R'.
C             If JOB = 'S', the array X is not referenced.
C
C     LDX     INTEGER
C             The leading dimension of the array X.
C             LDX >= 1,        if JOB = 'S';
C             LDX >= MAX(1,N), otherwise.
C
C     SEP     (output) DOUBLE PRECISION
C             If JOB = 'S' or JOB = 'C' or JOB = 'A', and INFO = 0 or
C             INFO = N+1, SEP contains the estimated separation of the
C             matrices op(A) and -op(A)', sep(op(A),-op(A)').
C             If N = 0, or X = 0, or JOB = 'X' or JOB = 'E', SEP is not
C             referenced.
C
C     RCOND   (output) DOUBLE PRECISION
C             If JOB = 'C' or JOB = 'A', an estimate of the reciprocal
C             condition number of the continuous-time Lyapunov equation.
C             If N = 0 or X = 0, RCOND is set to 1 or 0, respectively.
C             If JOB = 'X' or JOB = 'S' or JOB = 'E', RCOND is not
C             referenced.
C
C     FERR    (output) DOUBLE PRECISION
C             If JOB = 'E' or JOB = 'A', and INFO = 0 or INFO = N+1,
C             FERR contains an estimated forward error bound for the
C             solution X. If XTRUE is the true solution, FERR bounds the
C             relative error in the computed solution, measured in the
C             Frobenius norm:  norm(X - XTRUE)/norm(XTRUE).
C             If N = 0 or X = 0, FERR is set to 0.
C             If JOB = 'X' or JOB = 'S' or JOB = 'C', FERR is not
C             referenced.
C
C     WR      (output) DOUBLE PRECISION array, dimension (N)
C     WI      (output) DOUBLE PRECISION array, dimension (N)
C             If FACT = 'N', and INFO = 0 or INFO = N+1, WR and WI
C             contain the real and imaginary parts, respectively, of the
C             eigenvalues of A.
C             If FACT = 'F', WR and WI are not referenced.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (N*N)
C             This array is not referenced if JOB = 'X'.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the
C             optimal value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             If JOB = 'X', then
C             LDWORK >= MAX(1,N*N),           if FACT = 'F';
C             LDWORK >= MAX(1,MAX(N*N,3*N)),  if FACT = 'N'.
C             If JOB = 'S' or JOB = 'C', then
C             LDWORK >= MAX(1,2*N*N),         if FACT = 'F';
C             LDWORK >= MAX(1,2*N*N,3*N),     if FACT = 'N'.
C             If JOB = 'E', or JOB = 'A', and LYAPUN  = 'O', then
C             LDWORK >= MAX(1,3*N*N);
C             If JOB = 'E', or JOB = 'A', and LYAPUN  = 'R', then
C             LDWORK >= MAX(1,3*N*N+N-1).
C             For optimum performance LDWORK should sometimes be larger.
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             > 0:  if INFO = i, i <= N, the QR algorithm failed to
C                   complete the reduction to Schur canonical form (see
C                   LAPACK Library routine DGEES); on exit, the matrix
C                   T(i+1:N,i+1:N) contains the partially converged
C                   Schur form, and the elements i+1:n of WR and WI
C                   contain the real and imaginary parts, respectively,
C                   of the converged eigenvalues; this error is unlikely
C                   to appear;
C             = N+1:  if the matrices T and -T' have common or very
C                   close eigenvalues; perturbed values were used to
C                   solve Lyapunov equations, but the matrix T, if given
C                   (for FACT = 'F'), is unchanged.
C
C     METHOD
C
C     After reducing matrix A to real Schur canonical form (if needed),
C     the Bartels-Stewart algorithm is used. A set of equivalent linear
C     algebraic systems of equations of order at most four are formed
C     and solved using Gaussian elimination with complete pivoting.
C
C     The condition number of the continuous-time Lyapunov equation is
C     estimated as
C
C     cond = (norm(Theta)*norm(A) + norm(inv(Omega))*norm(C))/norm(X),
C
C     where Omega and Theta are linear operators defined by
C
C     Omega(W) = op(A)'*W + W*op(A),
C     Theta(W) = inv(Omega(op(W)'*X + X*op(W))).
C
C     The routine estimates the quantities
C
C     sep(op(A),-op(A)') = 1 / norm(inv(Omega))
C
C     and norm(Theta) using 1-norm condition estimators.
C
C     The forward error bound is estimated using a practical error bound
C     similar to the one proposed in [2].
C
C     REFERENCES
C
C     [1] Bartels, R.H. and Stewart, G.W.  T
C         Solution of the matrix equation A X + XB = C.
C         Comm. A.C.M., 15, pp. 820-826, 1972.
C
C     [2] Higham, N.J.
C         Perturbation theory and backward error for AX-XB=C.
C         BIT, vol. 33, pp. 124-136, 1993.
C
C     NUMERICAL ASPECTS
C                               3
C     The algorithm requires 0(N ) operations.
C     The accuracy of the estimates obtained depends on the solution
C     accuracy and on the properties of the 1-norm estimator.
C
C     FURTHER COMMENTS
C
C     The separation of op(A) and -op(A)' can also be defined as
C
C            sep( op(A), -op(A)' ) = sigma_min( T ),
C
C     where sigma_min(T) is the smallest singular value of the
C     N*N-by-N*N matrix
C
C        T = kprod( I(N), op(A)' ) + kprod( op(A)', I(N) ).
C
C     I(N) is an N-by-N identity matrix, and kprod denotes the Kronecker
C     product. The routine estimates sigma_min(T) by the reciprocal of
C     an estimate of the 1-norm of inverse(T). The true reciprocal
C     1-norm of inverse(T) cannot differ from sigma_min(T) by more
C     than a factor of N.
C
C     CONTRIBUTOR
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, February 1999.
C     This is an extended and improved version of Release 3.0 routine
C     SB03RD.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Oct. 2004.
C
C     KEYWORDS
C
C     Lyapunov equation, orthogonal transformation, real Schur form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, HALF
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 )
C     ..
C     .. Scalar Arguments ..
      CHARACTER          FACT, JOB, LYAPUN, TRANA, UPLO
      INTEGER            INFO, LDA, LDC, LDT, LDU, LDWORK, LDX, N
      DOUBLE PRECISION   FERR, RCOND, SCALE, SEP
C     ..
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), DWORK( * ),
     $                   T( LDT, * ), U( LDU, * ), WI( * ), WR( * ),
     $                   X( LDX, * )
C     ..
C     .. Local Scalars ..
      LOGICAL            JOBA, JOBC, JOBE, JOBS, JOBX, LOWER, NOFACT,
     $                   NOTRNA, UPDATE
      CHARACTER          CFACT, JOBL, SJOB
      INTEGER            LDW, NN, SDIM
      DOUBLE PRECISION   THNORM
C     ..
C     .. Local Arrays ..
      LOGICAL            BWORK( 1 )
C     ..
C     .. External Functions ..
      LOGICAL            LSAME, SELECT
      EXTERNAL           LSAME, SELECT
C     ..
C     .. External Subroutines ..
      EXTERNAL           DGEES, DLACPY, DSCAL, MA02ED, MB01RU, SB03MY,
     $                   SB03QD, SB03QY, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          DBLE, INT, MAX
C     ..
C     .. Executable Statements ..
C
C     Decode option parameters.
C
      JOBX   = LSAME( JOB,    'X' )
      JOBS   = LSAME( JOB,    'S' )
      JOBC   = LSAME( JOB,    'C' )
      JOBE   = LSAME( JOB,    'E' )
      JOBA   = LSAME( JOB,    'A' )
      NOFACT = LSAME( FACT,   'N' )
      NOTRNA = LSAME( TRANA,  'N' )
      LOWER  = LSAME( UPLO,   'L' )
      UPDATE = LSAME( LYAPUN, 'O' )
C
C     Compute workspace.
C
      NN = N*N
      IF( JOBX ) THEN
         LDW = NN
      ELSE IF( JOBS .OR. JOBC ) THEN
         LDW = 2*NN
      ELSE
         LDW = 3*NN
      END IF
      IF( ( JOBE .OR. JOBA ).AND. .NOT.UPDATE )
     $   LDW = LDW + N - 1
      IF( NOFACT )
     $   LDW = MAX( LDW, 3*N )
C
C     Test the scalar input parameters.
C
      INFO = 0
      IF( .NOT.( JOBX .OR. JOBS .OR. JOBC .OR. JOBE .OR. JOBA ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( NOFACT .OR. LSAME( FACT,   'F' ) ) ) THEN
         INFO = -2
      ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA,  'T' ) .OR.
     $                            LSAME( TRANA,  'C' ) ) ) THEN
         INFO = -3
      ELSE IF( .NOT.( LOWER  .OR. LSAME( UPLO,   'U' ) ) ) THEN
         INFO = -4
      ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN
         INFO = -5
      ELSE IF( N.LT.0 ) THEN
         INFO = -6
      ELSE IF( ( JOBC .OR. JOBE ) .AND.
     $         ( SCALE.LT.ZERO .OR. SCALE.GT.ONE ) )THEN
         INFO = -7
      ELSE IF( LDA.LT.1 .OR.
     $       ( LDA.LT.N .AND. ( ( UPDATE .AND. .NOT.JOBX ) .OR.
     $                            NOFACT ) ) ) THEN
         INFO = -9
      ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
         INFO = -11
      ELSE IF( LDU.LT.1 .OR. ( LDU.LT.N .AND. UPDATE ) ) THEN
         INFO = -13
      ELSE IF( LDC.LT.1 .OR. ( .NOT.JOBS .AND. LDC.LT.N ) ) THEN
         INFO = -15
      ELSE IF( LDX.LT.1 .OR. ( .NOT.JOBS .AND. LDX.LT.N ) ) THEN
         INFO = -17
      ELSE IF( LDWORK.LT.1 .OR. ( LDWORK.LT.LDW ) ) THEN
         INFO = -25
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SB03TD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 ) THEN
         IF( JOBX .OR. JOBA )
     $      SCALE = ONE
         IF( JOBC .OR. JOBA )
     $      RCOND = ONE
         IF( JOBE .OR. JOBA )
     $      FERR  = ZERO
         DWORK( 1 ) = ONE
         RETURN
      END IF
C
      IF( NOFACT ) THEN
C
C        Compute the Schur factorization of A.
C        Workspace:  need   3*N;
C                    prefer larger.
C
         CALL DLACPY( 'Full', N, N, A, LDA, T, LDT )
         IF( UPDATE ) THEN
            SJOB = 'V'
         ELSE
            SJOB = 'N'
         END IF
         CALL DGEES( SJOB, 'Not ordered', SELECT, N, T, LDT, SDIM, WR,
     $               WI, U, LDU, DWORK, LDWORK, BWORK, INFO )
         IF( INFO.GT.0 )
     $      RETURN
         CFACT = 'F'
      ELSE
         CFACT = FACT
      END IF
C
      IF( JOBX .OR. JOBA ) THEN
C
C        Copy the right-hand side in X.
C
         CALL DLACPY( UPLO, N, N, C, LDC, X, LDX )
C
         IF( UPDATE ) THEN
C
C           Transform the right-hand side.
C           Workspace:  need   N*N.
C
            CALL MB01RU( UPLO, 'Transpose', N, N, ZERO, ONE, X, LDX, U,
     $                   LDU, X, LDX, DWORK, LDWORK, INFO )
            CALL DSCAL( N, HALF, X, LDX+1 )
         END IF
C
C        Fill in the remaining triangle of X.
C
         CALL MA02ED( UPLO, N, X, LDX )
C
C        Solve the transformed equation.
C
         CALL SB03MY( TRANA, N, T, LDT, X, LDX, SCALE, INFO )
         IF( INFO.GT.0 )
     $      INFO = N + 1
C
         IF( UPDATE ) THEN
C
C           Transform back the solution.
C
            CALL MB01RU( UPLO, 'No transpose', N, N, ZERO, ONE, X, LDX,
     $                   U, LDU, X, LDX, DWORK, LDWORK, INFO )
            CALL DSCAL( N, HALF, X, LDX+1 )
C
C           Fill in the remaining triangle of X.
C
            CALL MA02ED( UPLO, N, X, LDX )
         END IF
      END IF
C
      IF( JOBS ) THEN
C
C        Estimate sep(op(A),-op(A)').
C        Workspace:  2*N*N.
C
         CALL SB03QY( 'Separation', TRANA, LYAPUN, N, T, LDT, U, LDU, X,
     $                LDX, SEP, THNORM, IWORK, DWORK, LDWORK, INFO )
C
      ELSE IF( .NOT.JOBX ) THEN
C
C        Estimate the reciprocal condition and/or the error bound.
C        Workspace:  2*N*N, if JOB = 'C';
C                    3*N*N + a*(N-1), where:
C                    a = 1, if JOB = 'E' or JOB = 'A', and LYAPUN = 'R';
C                    a = 0, otherwise.
C
         IF( JOBA ) THEN
            JOBL = 'B'
         ELSE
            JOBL = JOB
         END IF
         CALL SB03QD( JOBL, CFACT, TRANA, UPLO, LYAPUN, N, SCALE, A,
     $                LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEP, RCOND,
     $                FERR, IWORK, DWORK, LDWORK, INFO )
         LDW = MAX( LDW, INT( DWORK( 1 ) ) )
      END IF
C
      DWORK( 1 ) = DBLE( LDW )
C
      RETURN
C *** Last line of SB03TD ***
      END


!  DSYGVIC
!
!  Definition:
!  ===========
!
!       SUBROUTINE DSYGVIC( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, &
!                           ETOL, K, W, WORK, LDWORK, WORK2, LWORK, &
!                           IWORK, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER, INTENT(IN)           :: JOBZ, UPLO
!       INTEGER, INTENT(IN)             :: N, ITYPE, LDA, LDB
!       INTEGER, INTENT(IN)             :: LDWORK, LWORK
!       DOUBLE PRECISION, INTENT(IN)    :: ETOL
!       INTEGER, INTENT(OUT)            :: K(2), INFO
!       ..
!       .. Array Arguments ..
!       DOUBLE PRECISION, INTENT(INOUT) :: A(LDA, *), B(LDB, *)
!       DOUBLE PRECISION, INTENT(OUT)   :: W(*)
!       INTEGER                         :: IWORK(N)
!       DOUBLE PRECISION                :: WORK(LDWORK, *), WORK2(*)
!       ..
!
!  Purpose:
!  ========
!
!  DSYGVIC computes the e-finite eigenvalues and the corresponding
!  eigenvectors of the real generalized positive semi-definite
!  eigenproblem, A*x=(lambda)*B*x, where A and B are symmetric and
!  B is positive semi-definite with respect to the threshold ETOL.
!  definite.
!
!  Arguments:
!  ==========
!
!  ITYPE    (input) INTEGER
!           Specifies the problem type to be solved:
!           = 1: A*x = (lambda)*B*x
!
!  JOBZ     (input) CHARACTER*1
!           = 'V': Compute eigenvalues and eigenvectors.
!
!  UPLO     (input) CHARACTER*1
!           = 'U': Upper triangles of A and B are stored;
!           = 'L': Lower triangles of A and B are stored.
!
!  N        (input) INTEGER
!           The order of the matrices A and B. N > 0.
!
!  A        (input/output) DOUBLE PRECISION array, dimension (LDA, N)
!           On entry, the symmetric matrix A. If UPLO = 'U', the
!           leading N-by-N upper triangular part of A contains the
!           upper triangular part of the matrix A. If UPLO = 'L',
!           the leading N-by-N lower triangular part of A contains
!           the lower triangular part of the matrix A.
!           On exit, if JOBZ = 'V', then if INFO = k > 0, the first
!           K(1) columns of A contains the matrix X of eigenvectors.
!
!  LDA      (input) INTEGER
!           The leading dimension of the array A. LDA >= max(1,N).
!
!  B        (input/output) DOUBLE PRECISION array, dimension (LDB, N)
!           On entry, the symmetric semi-positive definite matrix B.
!           If UPLO = 'U', the leading N-by-N upper triangular part of B
!           contains the upper triangular part of the matrix B.
!           If UPLO = 'L', the leading N-by-N lower triangular part of B
!           contains the lower triangular part of the matrix B.
!           On exit, B contains the transformation matrix Q_1*R_1*Q_2*Q_3,
!           depending on the exit stage.
!
!  LDB      (input) INTEGER
!           The leading dimension of the array B.  LDB >= max(1,N).
!
!  ETOL     (input) DOUBLE PRECISION
!           The parameter used to drop small eigenvalues of B.
!
!  K        (output) INTEGER, dimension (2)
!           K(1) indicates the number of finite eigenvalues if INFO = 0.
!           K(2) indicates the case number of different branches of
!           exits. Specifically, if
!           K(1) > 0  : W contains K(1) eigenvalues; K(2) is 1, 2, 3 or 4.
!           K(1) = 0  : regular pencil but no finite eigenvalue; K(2) is
!                       1, 2 or 3.
!           K(1) = -1 : singular pencil; K(2) is 1, 2, ... , 6 or 7
!
!
!  W        (output) DOUBLE PRECISION array, dimension (N)
!           If K(1) > 0, W stores the K(1) eigenvalues.
!
!  WORK     (workspace) DOUBLE PRECISION array, dimension (N, N)
!
!  LDWORK   (input) INTEGER
!           The leading dimension of work.  LDWORK >= max(1,N).
!
!  WORK2    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!           On exit, if LWORK = -1 and INFO = 0, WORK2(1) returns the
!           optimal size of WORK2.
!
!  LWORK    (input) INTEGER
!           The length of the array WORK2.  LWORK >= 3*N+1.
!           For optimal efficiency, LWORK >= 2*N+( N+1 )*NB,
!           where NB is the blocksize.
!           If LWORK = -1, then a workspace query is assumed; the
!           routine only calculates the optimal size of the WORK2 array,
!           returns this value as the first entry of the WORK2 array,
!           and no error message related to LWORK is issued by XERBLA.
!
!  IWORK    (workspace) INTEGER array, dimension (N)
!
!  INFO     (output) INTEGER
!                  INFO  = 0    : successful exit.
!           -17 <= INFO <= -1   : if INFO = -i, the i-th argument had an
!                                 illegal value.
!
!  Date: April 2015
!
!  =====================================================================
      SUBROUTINE DSYGVIC( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, ETOL, &
      K, W, WORK, LDWORK, WORK2, LWORK, IWORK, &
      INFO )
!
!     .. Scalar Arguments ..
CHARACTER, INTENT(IN)           :: JOBZ, UPLO
INTEGER, INTENT(IN)             :: N, ITYPE, LDA, LDB
INTEGER, INTENT(IN)             :: LDWORK, LWORK
DOUBLE PRECISION, INTENT(INOUT)    :: ETOL
INTEGER, INTENT(OUT)            :: K(2), INFO
!       ..
!       .. Array Arguments ..
DOUBLE PRECISION, INTENT(INOUT) :: A(LDA, *), B(LDB, *)
DOUBLE PRECISION, INTENT(OUT)   :: W(*)
INTEGER                         :: IWORK(N)
DOUBLE PRECISION                :: WORK(LDWORK, *), WORK2(*)
!       ..
!
!  =====================================================================
!
!     .. Parameter ..
DOUBLE PRECISION, PARAMETER ::  ONE = 1.0d0, ZERO = 0.0d0
!     ..
!     .. Local Scalar ..
LOGICAL            :: LQUERY, UPPER, WANTZ
INTEGER            :: NB, LWKOPT, I, N1, N2, N3, N4, N5
DOUBLE PRECISION   :: MCHEPS, DLAMCH
!     ..
!     .. External Functions ..
LOGICAL            :: LSAME
INTEGER            :: ILAENV
EXTERNAL           :: LSAME, ILAENV
!     ..
!     .. External Subroutines ..
EXTERNAL           :: ABSSORT, DGEMM, DGEQP3, DLAPMT, DLAMCH
EXTERNAL           :: DORMQR,  DSCAL, DSYEV,  DTRMM,  DTRTRI
!     ..
!     .. Intrinsic Functions ..
INTRINSIC          ABS, MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters
WANTZ = LSAME( JOBZ, 'V' )
UPPER = LSAME( UPLO, 'U' )
LQUERY = ( LWORK.EQ.-1 )
!
INFO = 0
K(1) = 0
K(2) = 0
!
IF( ITYPE.NE.1 ) THEN
INFO = -1
ELSE IF( .NOT.( WANTZ ) ) THEN
INFO = -2
ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
INFO = -3
ELSE IF( N.LE.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( ETOL.LT.0 ) THEN
INFO = -9
ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN
INFO = -13
END IF
!
IF( INFO.EQ.0 ) THEN
!
CALL DGEQP3( N, N, A, LDA, IWORK, W, WORK2, -1, INFO )
!
IF( LWORK.LT.MAX( 1, 3*N+1 ) .AND. .NOT.LQUERY ) THEN
INFO = -16
END IF
END IF
!
IF( INFO.NE.0 ) THEN
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
!
!     Get machine precision
!
MCHEPS = DLAMCH('E')
!
!  =====================================================================
!                            Phase 1.
!  ---------------------------------------------------------------------
!
!     Diagonalize B by eigenvalue decomposition
CALL DSYEV( 'V', UPLO, N, B, LDB, W, WORK2, LWORK, INFO )
IF ( INFO .NE. 0 ) THEN
RETURN
END IF
!
!     Check if B is not semi-positive definite.
!
IF ( W(1) <= -ETOL*W(N) ) THEN
INFO = -7
RETURN
END IF
!
!     Sort eigenvalues and eigenvectors in descending order
!
DO I = 1, N
IWORK(I) = N-I+1
END DO
CALL DLAPMT( .FALSE., 1, N, W, 1, IWORK )
CALL DLAPMT( .FALSE., N, N, B, LDB, IWORK )
!
!     Find n1 and n2
!
IF ( W(1) <= MCHEPS ) THEN
N1 = 0
N2 = n
ELSE
I = 1
DO WHILE ( I < N+1 .AND. W(I) > ETOL*W(1) )
I = I+1
END DO
N1 = I-1
N2 = N-N1
END IF
!
!     Early Exit -- n1 = 0.
!
IF ( N1 == 0 ) THEN
CALL DSYEV( 'N', UPLO, N, A, LDB, W, WORK2, LWORK, INFO )
IF ( INFO .NE. 0 ) THEN
RETURN
END IF
CALL DLAASRT( N, W, IWORK )
IF ( W(N) < MCHEPS ) THEN
!           Singular pencil
K(1) = -1
K(2) = 1
RETURN
ELSE
!           Regular pencil but no finite eigenvalue
K(2) = 1
RETURN
END IF
END IF
!
!     Update A to A0
!
CALL DSYMM( 'L', UPLO, N, N, ONE, A, LDA, B, LDB, ZERO, WORK, &
LDWORK )
CALL DGEMM( 'T', 'N', N, N, N, ONE, B, LDB, WORK, LDWORK, ZERO, &
A, N )
!
!     Reduce B to identity and zero.
!
W(1:N1) = 1/SQRT(W(1:N1))
DO I = 1,N1
CALL DSCAL( N, W(I), B(1:N,I), 1 )
END DO
!
!     Update A to A1
!
DO I = 1,N1
CALL DSCAL( N, W(I), A(1:N,I), 1 )
END DO
DO I = 1,N1
CALL DSCAL( N, W(I), A(I,1:N), 1 )
END DO

!
!     Early Exit: n2 = 0, B is e-well conditioned.
!                 #N e-finite eigenvalues!
!
IF (N2 == 0) THEN
CALL DSYEV( 'V', UPLO, N, A, LDA, W, WORK2, LWORK, INFO )
IF (INFO .NE. 0 ) THEN
RETURN
END IF
CALL DGEMM( 'N', 'N', N, N, N, ONE, B, LDB, A, LDA, ZERO, &
 WORK, LDWORK )
A(1:N,1:N) = WORK(1:N,1:N)
K(1) = N
K(2) = 1
RETURN
END IF
!
!  =====================================================================
!                            Phase 2.
!  ---------------------------------------------------------------------
!
!     Diagonalize A1_22 by eigenvalue decomposition
!
CALL DSYEV( 'V', UPLO, N2, A(N1+1,N1+1), LDA, W, WORK2, LWORK, &
INFO )
IF ( INFO .NE. 0 ) THEN
RETURN
END IF
!
!     Sort eigenvalues and eigenvectors in abs-descending order
!
CALL DLAASRT( N2, W, IWORK )
CALL DLAPMT( .TRUE., N2, N2, A(N1+1,N1+1), LDA, IWORK )
!
!     Find n3 and n4
!
IF ( ABS(W(1)) <= ETOL ) THEN
N3 = 0
N4 = N2
ELSE
I = 1
DO WHILE ( I < N2+1 .AND. ABS(W(I)) > ETOL*ABS(W(1)) )
I = I+1
ENDDO

N3 = I-1
N4 = N2-N3
END IF
!
!     Early Exit: n3 = 0.
!
IF ( N3 == 0 ) THEN
!
!        If n1 < n2, singular pencil, exit.
!
IF ( N1 < N2 ) THEN
K(1) = -1
K(2) = 2
RETURN
END IF

!
!        Reveal the rank of A1_12 by QR decomposition with pivoting
!
IWORK = 0
CALL DGEQP3( N1, N2, A(1,N1+1), LDA, IWORK, W, WORK2, LWORK, &
  INFO )
IF ( INFO .NE. 0 ) THEN
RETURN
END IF
!
!        If n1 = n2:
!           if A1_12 is rank deficient, then singular pencil, exit;
!           else regular pencil but no e-finite eigenvalues, exit.
!
IF ( N1 == N2 ) THEN
IF( ABS(A(N2,N)) <= MCHEPS ) THEN
K(1) = -1
K(2) = 3
RETURN
ELSE
K(2) = 2
RETURN
END IF
END IF
!
!        If n1 > n2:
!           if A2_12 is rank deficient, then singular pencil, exit;
!           else n1-n2 e-finite eigenvalues.
!
IF( ABS(A(N2,N)) <= MCHEPS ) THEN
K(1) = -1
K(2) = 4
RETURN
ELSE
!
!           Update A1_11
!
CALL DORMQR( 'R', 'N', N1, N1, N2, A(1,N1+1), LDA, W, A, &
     LDA, WORK2, LWORK, INFO )
IF ( INFO .NE. 0 ) THEN
RETURN
END IF
CALL DORMQR( 'L', 'T', N1, N1, N2, A(1,N1+1), LDA, W, A, &
     LDA, WORK2, LWORK, INFO )
IF ( INFO .NE. 0 ) THEN
RETURN
END IF
!
!           B <- Q_1 * R_1 * Q_2
!
CALL DLAPMT( .TRUE., N, N2, B(1,N1+1), LDB, IWORK )
CALL DORMQR( 'R', 'N', N, N1, N2, A(1,N1+1), LDA, W, B, &
     LDB, WORK2, LWORK, INFO )
IF ( INFO .NE. 0 ) THEN
RETURN
END IF
!
!           Compute U_2
!
CALL DSYEV( 'V', UPLO, N1-N2, A(N2+1,N2+1), LDA, W, WORK2, &
    LWORK, INFO )
IF ( INFO .NE. 0 ) THEN
RETURN
END IF
WORK(N2+1:N1,N2+1:N1) = A(N2+1:N1,N2+1:N1)
!
!           Compute U_3 = -A2_13^(-1) * A2_12 * U_2
!              (1) Compute A2_12 * U_2
!              (2) Compute A2_13^(-1)
!              (3) Compute -A2_13^(-1) * A2_12 * U_2
!
CALL DGEMM( 'N', 'N', N2, N1-N2, N1-N2, ONE, A(1,N2+1), &
    LDA, WORK(N2+1,N2+1), LDWORK, ZERO, &
    WORK(N1+1,N2+1), LDWORK )
!
CALL DTRTRI( 'U', 'N', N2, A(1,N1+1), N, INFO )
IF ( INFO .NE. 0 ) THEN
RETURN
END IF
!
CALL DTRMM( 'L', 'U', 'N', 'N', N2, N1-N2, -ONE, &
    A(1,N1+1), LDA, WORK(N1+1,N2+1), LDWORK )
!
!           Set U_1 = 0 and compute X = Q_1 * R_1 * Q_2 * U
!
WORK(1:N2, N2+1:N1) = 0
CALL DGEMM( 'N', 'N', N, N1-N2, N, ONE, B, LDB, &
    WORK(1,N2+1), LDWORK, ZERO, A, LDA )
!
!           Output #(N1-N2) eigenvalues
!
K(1) = N1 - N2
K(2) = 2
RETURN
END IF
END IF
!
!     Update A:
!        (1) Update A_12 = A_12*Q_22
!        (2) Update A_21 = Q_22'*A_21
!
CALL DGEMM( 'N', 'N', N1, N2, N2, ONE, A(1,N1+1), LDA, &
A(N1+1,N1+1), LDA, ZERO, WORK(1,N1+1), LDWORK )
A(1:N1,N1+1:N) = WORK(1:N1,N1+1:N)
!
CALL DGEMM( 'T', 'N', N2, N1, N2, ONE, A(N1+1,N1+1), LDA, &
A(N1+1,1), LDA, ZERO, WORK(N1+1,1), LDWORK )
A(N1+1:N,1:N1) = WORK(N1+1:N,1:N1)
!
!     B <- Q_1*R_1*Q_2
!
CALL DGEMM( 'N', 'N', N, N2, N2, ONE, B(1,N1+1), LDB, &
A(N1+1,N1+1), LDA, ZERO, WORK(1,N1+1), LDWORK )
B(:,N1+1:N) = WORK(:,N1+1:N)
!
!     Early Exit: n4 = 0.
!
IF (N4 == 0) THEN
!
!        Compute A2_11-A2_12/D2*A2_12'
!        (1) Compute D^(-1)*A2_12' (row scaling)
!        (2) Compute A2_12*D^(-1)*A2_12'
!        (3) Compute A2_11-A2_12/D*A2_12'
!
W(1:N2) = 1/W(1:N2)
DO I = 1,N2
CALL DSCAL( N1, W(I), A(N1+I,1:N1), 1 )
END DO
!
CALL DGEMM( 'N', 'N', N1, N1, N2, ONE, A(1,N1+1), LDA, &
 A(N1+1,1), LDA, ZERO, WORK, LDWORK )
!
A(1:N1,1:N1) = A(1:N1,1:N1) - WORK(1:N1,1:N1)
!
!        Compute U_1 and U_2 = -D^(-1) * A2_12' * U_1
!
CALL DSYEV( 'V', UPLO, N1, A, N, W, WORK2, LWORK, INFO )
IF ( INFO .NE. 0 ) THEN
RETURN
END IF
CALL DGEMM( 'N', 'N', N2, N1, N1, -ONE, A(N1+1,1), LDA, A, &
 LDA, ZERO, WORK(N1+1,1), LDWORK )
!
!        Compute X = Q_1 * R_1 * Q_2 * U and output #eigenvalues
!
WORK(1:N1,1:N1) = A(1:N1,1:N1)
CALL DGEMM( 'N', 'N', N, N1, N, ONE, B, LDB, WORK, LDWORK, &
 ZERO, A, LDA )
!
!        Output #N1 eigenvalues
!
K(1) = N1
K(2) = 3
RETURN
END IF

!
!  =====================================================================
!                            Phase 3.
!  ---------------------------------------------------------------------
!
!     Since n3 ~= 0 and n4 ~=0, we can view A2 as a 3 by 3 block:
!
!                 n1     n3     n4
!          n1 | A2_11  A2_12  A2_13 |
!     A2 = n3 | A2_12'   D2     0   |
!          n4 | A2_13'   0      0   |
!
!     Early exit: n1 < n4, singular pencil, exit.
!
IF ( N1 < N4 ) THEN
K(1) = -1
K(2) = 5
RETURN
END IF
!
!     If n1 >= n4
!        reveal the rank of A2_13 by QR with column pivoting
!
A(N1+1:N1+N3,N1+1) = W(1:N3)
!
IWORK = 0
CALL DGEQP3( N1, N4, A(1,N1+N3+1), LDA, IWORK, W, WORK2, LWORK, &
INFO )
IF ( INFO .NE. 0 ) THEN
RETURN
END IF
!
!     If n1 = n4:
!        if R3_13 rank deficient, singular pencil,
!        else regular pencil but no e-finite eigenvalues.
!
IF( N1 == N4 ) THEN
IF ( ABS(A(N4,N)) <= MCHEPS ) THEN
K(1) = -1
K(2) = 6
RETURN
ELSE
K(2) = 3
RETURN
END IF
END IF
!
!     n1 > n4:
!        if R3_13 rank deficient, singular pencil,
!        else n1-n4 e-finite eigenvalues.
!
IF( ABS(A(N4,N)) <=  MCHEPS ) THEN
K(1) = -1
K(2) = 7
RETURN
END IF

!     Update A to A3
!     (1) A2_11 = Q3_11'*A2_11*Q3_11
!     (2) A2_12 = Q3_11'*A2_12
!     (3) A2_21 = A2_21*Q3_11
!
!     A3 is a 4 by 4 block matrix:
!
!                 n1     n5     n3     n4
!          n1 | A3_11  A3_12  A3_13  A3_14 |
!     A3 = n5 | A3_12' A3_22  A3_23    0   |
!          n3 | A3_13' A3_23' D2_33    0   |
!          n4 | A3_14'   0      0      0   |
!
CALL DORMQR( 'R', 'N', N1, N1, N4, A(1,N1+N3+1), LDA, W, &
A, LDA, WORK2, LWORK, INFO )
IF ( INFO .NE. 0 ) THEN
RETURN
END IF
CALL DORMQR( 'L', 'T', N1, N1, N4, A(1,N1+N3+1), LDA, W, &
A, LDA, WORK2, LWORK, INFO )
IF ( INFO .NE. 0 ) THEN
RETURN
END IF
!
CALL DORMQR( 'L', 'T', N1, N3, N4, A(1,N1+N3+1), LDA, W, &
A(1,N1+1), LDA, WORK2, LWORK, INFO )
IF ( INFO .NE. 0 ) THEN
RETURN
END IF
!
CALL DORMQR( 'R', 'N', N3, N1, N4, A(1,N1+N3+1), LDA, W, &
A(N1+1,1), LDA, WORK2, LWORK, INFO )
IF ( INFO .NE. 0 ) THEN
RETURN
END IF
!
!     B <- Q_1 * R_1 * Q_2 * P_3 * Q_3
!
CALL DLAPMT( .TRUE., N, N4, B(1,N1+N3+1), LDB, IWORK )
CALL DORMQR( 'R', 'N', N, N1, N4, A(1,N1+N3+1), LDA, W, &
B, LDB, WORK2, LWORK, INFO )
IF ( INFO .NE. 0 ) THEN
RETURN
END IF
!
!     Compute A3_22-A3_23/D2*A3_23'
!     (1) Compute D^(-1)*A3_23' --> A_32 (row scaling)
!     (2) Compute A3_23/D*A3_23'
!     (3) Compute A3_22-A3_23/D*A3_23'
!
W(1:N3) = A(N1+1:N1+N3,N1+1)
DO I = 1, N3
W(I) = 1 / W(I)
END DO
N5 = N1 - N4
DO I = 1, N3
CALL DSCAL( N5, W(I), A(N1+I,N4+1:N1), 1 )
END DO
!
CALL DGEMM( 'N', 'N', N5, N5, N3, ONE, A(N4+1,N1+1), LDA, &
A(N1+1,N4+1), LDA, ZERO, WORK(N4+1,N4+1), LDWORK )
!
A(N4+1:N1,N4+1:N1) = A(N4+1:N1,N4+1:N1) - WORK(N4+1:N1,N4+1:N1)
!
!     Compute U_2
!
CALL DSYEV( 'V', UPLO, N5, A(N4+1,N4+1), LDA, W, WORK2, LWORK, &
INFO )
IF ( INFO .NE. 0 ) THEN
RETURN
END IF
WORK(N4+1:N1,N4+1:N1) = A(N4+1:N1,N4+1:N1)
!
!     Compute U_3 = -D \ A3_23' * U_2
!
CALL DGEMM( 'N', 'N', N3, N5, N5, -ONE, A(N1+1,N4+1), LDA, &
A(N4+1,N4+1), LDA, ZERO, WORK(N1+1,N4+1), LDWORK )
!
!     Compute U_4 = -A3_14^(-1) * ( A3_12 * U_2 + A3_13 * U_3 )
!     (1) Compute A3_12 * U_2
!     (2) Compute A3_13 * U_3
!     (3) Compute A3_12*U_2 + A3_13*U_3
!     (4) Compute A3_14^(-1)
!     (5) Compute -A3_14^(-1) * ( A3_12 * U_2 + A3_13 * U_3 )
!
CALL DGEMM( 'N', 'N', N4, N5, N5, ONE, A(1,N4+1), LDA, &
WORK(N4+1,N4+1), LDWORK, ZERO, WORK(1,N4+1), LDWORK )
!
CALL DGEMM( 'N', 'N', N4, N5, N3, ONE, A(1,N1+1), LDA, &
WORK(N1+1,N4+1), LDWORK, ZERO, WORK(N1+N3+1,N4+1), &
LDWORK )
!
A(N1+N3+1:N,N4+1:N1) = WORK(N1+N3+1:N,N4+1:N1) + &
             WORK(1:N4,N4+1:N1)
WORK(N1+N3+1:N,N4+1:N1) = A(N1+N3+1:N,N4+1:N1)
!
CALL DTRTRI( 'U', 'N', N4, A(1,N1+N3+1), N, INFO )
IF ( INFO .NE. 0 ) THEN
RETURN
END IF
!
CALL DTRMM( 'L', 'U', 'N', 'N', N4, N5, -ONE, A(1,N1+N3+1), &
LDA, WORK(N1+N3+1,N4+1), LDWORK )
!
!     Set U_1 = 0 and compute X = Q_1 * R_1 * Q_2 * P_3 * Q_3 * U
!
WORK(1:N4, N4+1:N1) = 0
CALL DGEMM( 'N', 'N', N, N5, N, ONE, B, LDB, WORK(1,N4+1), &
LDWORK, ZERO, A, LDA )
!
!     Output #n5 eigenvalues
!
K(1) = N5
K(2) = 4
!
!     End of DSYGVIC
!
END


************************************************************************
* This file contains basic routines to support calculating
* distances from a couple of points to a polygon given by straight
* lines.
* The routines are very basic ones without special handling by
* advanced mathematical routines (like Fast Marching,...)
************************************************************************

************************************************************************
* Redistancing via line segments (brute force method)
*
* This routine uses a brute force approach to calculate for all given
* points the distance to a polygon, which is given by line segments.
* NVT describes the number of points, DCORVG the (X/Y)-coordinates
* of the points. The distances of the points are saved into an
* array DU.
*
* In:
*  NVT    - Number of vertices
*  DCORVG - array [1..2,1..NVT] of double.
*           (X/Y)-coordinates of the vertices.
*           DCORVG(1) = X-Coordinate
*           DCORVG(2) = Y-Coordinate
*  NPLNSG - Number of points in the line segment array
*  DCORSG - array [1..2,1..NLINSG] of double
*           (X/Y)-coordinates of all the points defining the lines.
*           DCORSG(1) = X-Coordinate
*           DCORSG(2) = Y-Coordinate
*           This array represents a list of endpoints that define the
*           (NLINSG-1) line segments. The coordinates are stores as
*           pairs of coordinates
*                   [(x1,y1), (x2,y2), ... ,(xn,yn)]
*           with (x1,y1) the first (and thus starting) point of
*           the polygon and (xn,yn) (n=NLINSG) the last point.
*           The polygon itself is given by the lines between the
*           points: (x1,y1)->(x2,y2), (x2,y2)->(x3,y3), ...
*
* Out:
*  DU      - array [1..NVT] of double
*            DU(I) receives the minimum distance from vertex I to
*            all line segments.
*  IPROJ   - array [1..NVT] of integer
*            IPROJ(I) is the number of the line segment that defines
*            the minimum distance to vertex I
*  DPROJ   - array [1..2,1..NVT] of double
*            (DPROJ(1,I),DPROJ(2,I)) contains the projection of node I
*            onto the polygon.
*  DNML    - array [1..2,1..NVT] of double
*            Array with normal vectors pointing from the polygon to
*            the nodes. (DNML(1,I),DNML(2,I)) is a vector pointing from
*            the projected point on line segment IPROJ(I) onto node I.
*            Remark: The normal vectors are not necessarily outer
*             normals!!!
************************************************************************

      SUBROUTINE RDPLSB(NVT,DCORVG,NPLNSG,DCORSG,DU,IPROJ,DPROJ,DNML)

      IMPLICIT NONE

      INTEGER NVT,NPLNSG

      DOUBLE PRECISION DCORVG(2,NVT),DCORSG(2,NPLNSG),DPROJ(2,NVT)
      DOUBLE PRECISION DU(NVT),DNML(2,NVT)
      INTEGER IPROJ(NVT)

C local variables

      INTEGER IVT,ISG
      DOUBLE PRECISION D
C     DOUBLE PRECISION DAREA

C externals

      DOUBLE PRECISION DPO2SG
      EXTERNAL DPO2SG

C Cancel if the number of nodes is incorrect

      IF (NPLNSG.LE.0) RETURN

C Loop through all nodes

      DO IVT=1,NVT

C For each node loop through all line segments

        DO ISG=1,NPLNSG-1

C If the distance is lower than the previously calculated...

          D = DPO2SG(DCORVG(1,IVT),DCORVG(2,IVT),
     *               DCORSG(1,ISG),DCORSG(1,ISG+1))

          IF ((ISG.EQ.1).OR.(D.LT.DU(IVT))) THEN

C save the new best line segment

            DU(IVT) = D
            IPROJ(IVT) = ISG

          END IF

        END DO

C Finally calculate the projection and the normal vector
C from the projected point on the line segment to the original node:
C This is on purpose NOT THE OUTER normal vector!!!

        ISG = IPROJ(IVT)
        CALL PPO2SG(DCORVG(1,IVT),DCORVG(2,IVT),
     *              DCORSG(1,ISG),DCORSG(1,ISG+1),D,DPROJ(1,IVT))
        DNML(1,IVT) = DCORVG(1,IVT)-DPROJ(1,IVT)
        DNML(2,IVT) = DCORVG(2,IVT)-DPROJ(2,IVT)

C Check the sign of the volume of the triangle (point on line 1,
C point on line 2, IVT). If it's positive, we have the outer normal
C vector. If it's negative, we have the "inner" normal vector and must
C change the sign to get the outer one...
C --> This check is disabled because of a different implementation
C     now!!! (see remark above)
C        DAREA=(DCORVG(1,IVT)-DCORSG(1,ISG+1))*
C     *          (DCORVG(2,IVT)+DCORSG(2,ISG+1))
C     *       +(DCORSG(1,ISG+1)-DCORSG(1,ISG))*
C     *          (DCORSG(2,ISG+1)+DCORSG(2,ISG))
C     *       +(DCORSG(1,ISG)-DCORVG(1,IVT))*
C     *          (DCORSG(2,ISG)+DCORVG(2,IVT))
C
C        IF (DAREA.LT.0) THEN
C          DNML(1,IVT) = -DNML(1,IVT)
C          DNML(2,IVT) = -DNML(2,IVT)
C        END IF

      END DO

      END


submodule (BandSpectrum_mod) PhotonFluence_smod

    implicit none

    real(RK)                        :: mv_alpha
    real(RK)                        :: mv_alphaPlusTwoOverEpk

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

contains

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    !> \brief
    !> Integrate the Band differential spectrum over the input energy range.
    !>
    !> \param[in]   lowerLim        :   The lower limit energy (in units of [keV]) of the integration.
    !> \param[in]   upperLim        :   The upper limit energy (in units of [keV]) of the integration.
    !> \param[in]   epk             :   The spectral peak energy in units of [keV].
    !> \param[in]   alpha           :   The lower spectral exponent of the Band model.
    !> \param[in]   beta            :   The upper spectral exponent of the Band model.
    !> \param[in]   tolerance       :   The relative accuracy tolerance of the integration.
    !> \param[out]  photonFluence   :   The fluence in units of photon counts within the input energy range.
    !> \param[out]  Err             :   An object of class [Err_type](@ref err_mod::err_type) containing error-handling information.
    module subroutine getPhotonFluence(lowerLim,upperLim,epk,alpha,beta,tolerance,photonFluence,Err)
#if IFORT_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN) && !defined CFI_ENABLED
        !DEC$ ATTRIBUTES DLLEXPORT :: getPhotonFluence
#endif

       !use Integration_mod, only: doQuadRombClosed
        use Constants_mod, only: IK, RK, HUGE_RK
        use QuadPackSPR_mod, only: qag
        use Err_mod, only: Err_type
        implicit none
        real(RK), intent(in)            :: lowerLim, upperLim, epk, alpha, beta, tolerance
        real(RK), intent(out)           :: photonFluence
        type(Err_type), intent(out)     :: Err
        character(*), parameter         :: PROCEDURE_NAME = "@getPhotonFluence()"
        real(RK)                        :: ebrk, alphaPlusTwo
        real(RK)                        :: thisUpperLim, betaPlusOne
        real(RK)                        :: alphaMinusBeta, coef
        real(RK)                        :: abserr
        integer(IK)                     :: neval
        integer(IK)                     :: ierr
       !real(RK)                        :: alphaPlusOne, logGammaAlphaPlusOne

        Err%occurred = .false.

        if (lowerLim>=upperLim) then
            photonFluence = 0._RK
            return
        end if

        ! check if the photon indices are consistent with the mathematical rules
        if (alpha<beta .or. alpha<-2._RK) then
            photonFluence = -HUGE_RK
            Err%occurred = .true.
            Err%msg = MODULE_NAME // PROCEDURE_NAME // ": Error occurred: alpha<beta .or. alpha<-2._RK"
            return
        end if

        ! integrate the spectrum
        alphaPlusTwo = alpha + 2._RK
        alphaMinusBeta = alpha - beta
        ebrk = epk*alphaMinusBeta/alphaPlusTwo

        if (lowerLim>ebrk) then

            ! there is only the high energy component in the photonFluence
            betaPlusOne = beta + 1._RK
            coef = ebrk**alphaMinusBeta * exp(-alphaMinusBeta);
            photonFluence = coef * ( upperLim**betaPlusOne - lowerLim**betaPlusOne ) / betaPlusOne
            return

        elseif (lowerLim<ebrk) then

            mv_alpha = alpha

            mv_alphaPlusTwoOverEpk = alphaPlusTwo / epk
            thisUpperLim = min(upperLim,ebrk)
            !alphaPlusOne = alpha + 1._RK
            !if (alpha>-1._RK) then
            !    logGammaAlphaPlusOne = log_gamma( alphaPlusOne )
            !    ! use the analytical approach to compute the photonFluence:
            !    ! https://www.wolframalpha.com/input/?i=integrate+x%5Ea+*+exp(-b*x)
            !    photonFluence = getUpperGamma( exponent = alphaPlusOne &
            !                            , logGammaExponent = logGammaAlphaPlusOne &
            !                            , lowerLim = mv_alphaPlusTwoOverEpk * lowerLim &
            !                            , tolerance = tolerance &
            !                            ) &
            !             - getUpperGamma( exponent = alphaPlusOne &
            !                            , logGammaExponent = logGammaAlphaPlusOne &
            !                            , lowerLim = mv_alphaPlusTwoOverEpk * thisUpperLim &
            !                            , tolerance = tolerance &
            !                            )
            !    photonFluence = photonFluence / mv_alphaPlusTwoOverEpk**alphaPlusOne
            !else
                ! use brute-force integration
                call qag( f             = getBandCompLowPhoton  &
                        , a             = lowerLim              &
                        , b             = thisUpperLim          &
                        , epsabs        = 0._RK                 &
                        , epsrel        = tolerance             &
                        , key           = 1_IK                  &
                        , result        = photonFluence         &
                        , abserr        = abserr                &
                        , neval         = neval                 &
                        , ier           = ierr                  &
                        )
                !write(*,*) neval
                !call doQuadRombClosed   ( getFunc       = getBandCompLowPhoton &
                !                        , xmin          = lowerLim             &
                !                        , xmax          = thisUpperLim         &
                !                        , tolerance     = 1.e-7_RK             &
                !                        , nRefinement   = 10_IK                &
                !                        , photonFluence = photonFluence        &
                !                        , ierr          = ierr                 &
                !                        )
                if (ierr/=0_IK) then
                ! LCOV_EXCL_START
                    photonFluence = -HUGE_RK
                    Err%occurred = .true.
                    Err%stat = ierr
                    Err%msg = MODULE_NAME // PROCEDURE_NAME // ": Error occurred at QuadPack routine. Check the error code to identify the root cause."
                    return
                ! LCOV_EXCL_STOP
                end if
            !end if

            if (upperLim>ebrk) then
                ! add the remaining part of the photonFluence from the high-energy component
                betaPlusOne = beta + 1._RK
                alphaMinusBeta = alpha - beta
                coef = ebrk**alphaMinusBeta * exp(-alphaMinusBeta);
                photonFluence = photonFluence + coef * ( upperLim**betaPlusOne - ebrk**betaPlusOne ) / betaPlusOne
                return
            end if

        end if

    end subroutine getPhotonFluence

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    pure function getBandCompLowPhoton(energy) result(bandCompLow)
        implicit none
        real(RK), intent(in)    :: energy
        real(RK)                :: bandCompLow
        bandCompLow = energy**mv_alpha * exp(-mv_alphaPlusTwoOverEpk*energy)
    end function getBandCompLowPhoton

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

end submodule PhotonFluence_smod ! LCOV_EXCL_LINE


FUNCTION rngpi(t, n) RESULT(fn_val)

! N.B. Argument IFAULT has been removed.

! Code converted using TO_F90 by Alan Miller
! Date: 2003-02-09  Time: 14:24:28

!        Algorithm AS 126  Appl. Statist. (1978) Vol. 27, No. 2

!        Computes the probability of the normal range given t, the
!        upper limit of integration, and n, the sample size.

!     Auxiliary function required: ALNORM = algorithm AS66

IMPLICIT NONE
INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(15, 100)

REAL (dp), INTENT(IN)  :: t
INTEGER, INTENT(IN)    :: n
REAL (dp)              :: fn_val

! Local variables
REAL (dp)  :: a, b, c, xl, y
INTEGER    :: i

REAL (dp), PARAMETER  :: g(8) = (/  &
    0.4947004675D0, 0.4722875115D0, 0.4328156012D0, 0.3777022042D0,  &
    0.3089381222D0, 0.2290083888D0, 0.1408017754D0, 0.04750625492D0 /)

REAL (dp), PARAMETER  :: h(8) = (/  &
    0.01357622971D0, 0.03112676197D0, 0.04757925584D0, 0.06231448563D0,  &
    0.07479799441D0, 0.08457825969D0, 0.09130170752D0, 0.09472530523D0 /)

REAL (dp), PARAMETER  :: zero = 0.0_dp, half = 0.5_dp, two = 2.0_dp,  &
                         eight = 8.0_dp

INTERFACE
  FUNCTION alnorm( x, upper ) RESULT( fn_val )
    IMPLICIT NONE
    INTEGER, PARAMETER     :: dp = SELECTED_REAL_KIND(15, 100)
    REAL(DP), INTENT(IN)   ::  x
    LOGICAL,   INTENT(IN)  ::  upper
    REAL(DP)               ::  fn_val
  END FUNCTION alnorm
END INTERFACE

fn_val = zero
IF (t <= zero .OR. n <= 1) RETURN

xl = half * t
a = half * (eight+xl)
b = eight - xl
y = zero
DO  i = 1, 8
  c = b * g(i)
  y = y + h(i) * (risf(a+c) + risf(a-c))
END DO
fn_val = (two*(alnorm(xl,.false.)-half)) ** n + two * b * y * n
RETURN

CONTAINS

FUNCTION risf(x) RESULT(fn_val)

REAL (dp), INTENT(IN)  :: x
REAL (dp)              :: fn_val

fn_val = 0.3989422804D0 * EXP(-half*x*x) * (alnorm(x, .false.) -  &
         alnorm(x-t, .false.)) ** (n-1)
RETURN
END FUNCTION risf

END FUNCTION rngpi


c-----------------------------------------------------------------------------
c     Computes Sum(i=0,degree) x(i)*B_i(t) where the B_i are Bernstein
c     polynomials of degree = n - 1
c-----------------------------------------------------------------------------
      real function kulfan(n, x, t)
      implicit none
      include 'kulfan.h'
      integer n
      real    x(*), t

      integer degree
      real    shapefun
      real    decas

      degree   = n - 1
      shapefun = decas(degree, x, t)

      kulfan   = shapefun * (t)**N1 * (1.0 - t)**N2 + t * yte

      end
c-----------------------------------------------------------------------------


function daylen(dlat,idoy,riseangle)
!
implicit none
!
! Dummy arguments
!
real :: dlat,riseangle
integer :: idoy
real :: daylen
!
! Local variables
!
real :: dec,h
real :: declination,hourangle
!
!     + + + purpose + + +
!     this function calculates the daylength (hours) for any simulation
!     site based on the global position of the site, and day of the
!     year.  the inputs for the function are day of the year, and latitude
!     of the site.

!     + + + keywords + + +
!     day length

!     + + + argument declarations + + +

!     + + + argument definitions + + +
!     idoy - day of year
!     daylen - the length of the day. returns the value of this function.
!     dlat - latitude of the site, degrees (north > 0, south < 0)
!     riseangle - angle of earths rotation where sunrise occurs.
!                 this varies depending on whether you are calculating
!                 direct beam, civil twilight, nautical twilight or
!                 astronomical twilight daylength

!     + + + local variables + + +

!     + + + local variable definitions + + +
!     dec - declination of earth with respect to the sun (degrees)
!     declination -
!     h - hour angle (degrees)
!     hourangle - a function. this variable holds the value returned by
!                 the hourangle function. debe assumed this definition

!     + + + common blocks + + +
!     include 'p1unconv.inc'

!     + + + function declarations + + +

!     + + + end specifications + + +

!     declination angle (dec)
!
dec = declination(idoy)

!     sunrise or sunset hour angle
h = hourangle(dlat,dec,riseangle)

!     calculate the length of the day
daylen = 2.0*h/15.0
!
end function daylen


      FUNCTION RZINTS(IP,IQ,R,Z,NGRIDS)
      DIMENSION R(4),Z(4),PT(3),H(3)
      IF(NGRIDS.EQ.3)GO TO 200
      NPT=3
      PT(1)=-.7745966692
      PT(2)=0.
      PT(3)=-PT(1)
      H(1)=5./9.
      H(2)=8./9.
      H(3)=H(1)
      XINT=0.
      DO 100 III=1,NPT
      DO 100 JJJ=1,NPT
      RR=.25*((1.-PT(III))*(1.-PT(JJJ))*R(1)
     1       +(1.+PT(III))*(1.-PT(JJJ))*R(2)
     1       +(1.+PT(III))*(1.+PT(JJJ))*R(3)
     1       +(1.-PT(III))*(1.+PT(JJJ))*R(4))
      ZZ=.25*((1.-PT(III))*(1.-PT(JJJ))*Z(1)
     1       +(1.+PT(III))*(1.-PT(JJJ))*Z(2)
     1       +(1.+PT(III))*(1.+PT(JJJ))*Z(3)
     1       +(1.-PT(III))*(1.+PT(JJJ))*Z(4))
      RRP=RR**IP
      ZZQ=ZZ**IQ
      DRDXI=.25*((1.-PT(JJJ))*(R(2)-R(1))+(1.+PT(JJJ))*(R(3)-R(4)))
      DZDXI=.25*((1.-PT(JJJ))*(Z(2)-Z(1))+(1.+PT(JJJ))*(Z(3)-Z(4)))
      DRDETA=.25*((1.-PT(III))*(R(4)-R(1))+(1.+PT(III))*(R(3)-R(2)))
      DZDETA=.25*((1.-PT(III))*(Z(4)-Z(1))+(1.+PT(III))*(Z(3)-Z(2)))
      DETJ=DRDXI*DZDETA-DZDXI*DRDETA
      DETJ=ABS(DETJ)
      XINT=XINT+RRP*ZZQ*H(III)*H(JJJ)*DETJ
  100 CONTINUE
      RZINTS=XINT
  200 RETURN
      END


      SUBROUTINE DCALCORC(X,XAVE,XSTD,XMSG,NXY,Y,YMSG,CORC,IER)
      IMPLICIT NONE

c this routine will calculate the cross correlation coef between
c .   series x and series y
c this routine was originally meant to be in the inner portion
c .   of a loop

c     x         - input data 1D array  ( unchanged on output)
c     xave,xstd - ave and st. dev of x (input)
c     xmsg      - missing data code (if none set to some no. not
c                 encountered)
c     nxy       - length of x and y 1D vectors
c     y         - input data 1D array  ( unchanged on output)
c     ymsg      - missing data code (if none set to some no. not
c                 encountered)
c     corc      - correlation coef
c     ier       - error code (if ier=-1 then corc contains missing
c                 entry)
c --------------- input arguments
      INTEGER NXY
      DOUBLE PRECISION X(NXY),Y(NXY),XAVE,XSTD,XMSG,YMSG
c --------------- output arguments
      INTEGER IER
      DOUBLE PRECISION CORC
c --------------- local stuff
      INTEGER N,NPTUSX,NPTUSY
      DOUBLE PRECISION XVAR,YAVE,YVAR,YSTD,RN,XY,COVAR

      CORC = XMSG
      IF (XAVE.EQ.XMSG .OR. XSTD.EQ.XMSG) THEN
          CALL DSTAT2(X,NXY,XMSG,XAVE,XVAR,XSTD,NPTUSX,IER)
          IF (IER.NE.0 .OR. XSTD.EQ.0.0D0) THEN
              IER = 201
              RETURN
          END IF
      END IF

c calculate the mean and var of y

      CALL DSTAT2(Y,NXY,YMSG,YAVE,YVAR,YSTD,NPTUSY,IER)
      IF (IER.NE.0) RETURN
      IF (YSTD.EQ.0.D0) THEN
          IER = 203
          RETURN
      END IF

c calculate the cross correlation coef
c .   calculate the mean and variance of column nc in the data array

      RN = 0.D0
      XY = 0.D0
      DO N = 1,NXY
          IF (X(N).NE.XMSG .AND. Y(N).NE.YMSG) THEN
              RN = RN + 1.D0
              XY = XY + (Y(N)-YAVE)* (X(N)-XAVE)
          END IF
      END DO
      IF (RN.GT.2.D0) THEN
          COVAR = XY/ (RN-1.D0)
          CORC = COVAR/ (XSTD*YSTD)
      END IF

      RETURN
      END

      SUBROUTINE DCALCOVC(X,XAVE,XSTD,XMSG,NXY,Y,YMSG,COVC,IER)
      IMPLICIT NONE

c this routine will calculate the cross covariance between
c .   series x and series y
c this routine was originally meant to be in the inner portion
c .   of a loop

c THIS ROUTINE DOES NOT NEED XSTD BUT IT WAS DUPLICTED
c FROM DCALCORC AND I WANTED TO MINIMIZE ANY WORK MaryH
c WOULD HAVE TO DO. SHE CAN BASICALLY DUPLICATE THE INTERFACE
c FOR DCALCORC.

c     x         - input data 1D array  ( unchanged on output)
c     xave,xstd - ave and st. dev of x (input)
c     xmsg      - missing data code (if none set to some no. not
c                 encountered)
c     nxy       - length of x and y 1D vectors
c     y         - input data 1D array  ( unchanged on output)
c     ymsg      - missing data code (if none set to some no. not
c                 encountered)
c     corc      - correlation coef
c     ier       - error code (if ier=-1 then corc contains missing
c                 entry)
c --------------- input arguments
      INTEGER NXY
      DOUBLE PRECISION X(NXY),Y(NXY),XAVE,XSTD,XMSG,YMSG
c --------------- output arguments
      INTEGER IER
      DOUBLE PRECISION COVC
c --------------- local stuff
      INTEGER N,NPTUSX,NPTUSY
      DOUBLE PRECISION XVAR,YAVE,YVAR,YSTD,RN,XY,COVAR

      COVC = XMSG
C C C IF (XAVE.EQ.XMSG .OR. XSTD.EQ.XMSG) THEN
      IF (XAVE.EQ.XMSG) THEN
          CALL DSTAT2(X,NXY,XMSG,XAVE,XVAR,XSTD,NPTUSX,IER)
          IF (IER.NE.0 .OR. XSTD.EQ.0.0D0) THEN
              IER = 201
              RETURN
          END IF
      END IF

c calculate the mean and var of y

      CALL DSTAT2(Y,NXY,YMSG,YAVE,YVAR,YSTD,NPTUSY,IER)
      IF (IER.NE.0) RETURN
      IF (YSTD.EQ.0.D0) THEN
          IER = 203
          RETURN
      END IF

c calculate the cross covariance
c .   calculate the mean and variance of column nc in the data array

      RN = 0.D0
      XY = 0.D0
      DO N = 1,NXY
          IF (X(N).NE.XMSG .AND. Y(N).NE.YMSG) THEN
              RN = RN + 1.D0
              XY = XY + (Y(N)-YAVE)* (X(N)-XAVE)
          END IF
      END DO
      IF (RN.GT.2.D0) THEN
          COVC = XY/ (RN-1.D0)
      END IF

      RETURN
      END


      SUBROUTINE daub4(a,n,isign)
      INTEGER n,isign,NMAX
      REAL a(n),C3,C2,C1,C0
      PARAMETER (C0=0.4829629131445341,C1=0.8365163037378079,
     *C2=0.2241438680420134,C3=-0.1294095225512604,NMAX=1024)
      REAL wksp(NMAX)
      INTEGER nh,nh1,i,j
      if(n.lt.4)return
      if(n.gt.NMAX) pause 'wksp too small in daub4'
      nh=n/2
      nh1=nh+1
      if (isign.ge.0) then
        i=1
        do 11 j=1,n-3,2
          wksp(i)=C0*a(j)+C1*a(j+1)+C2*a(j+2)+C3*a(j+3)
          wksp(i+nh)=C3*a(j)-C2*a(j+1)+C1*a(j+2)-C0*a(j+3)
          i=i+1
11      continue
        wksp(i)=C0*a(n-1)+C1*a(n)+C2*a(1)+C3*a(2)
        wksp(i+nh)=C3*a(n-1)-C2*a(n)+C1*a(1)-C0*a(2)
      else
        wksp(1)=C2*a(nh)+C1*a(n)+C0*a(1)+C3*a(nh1)
        wksp(2)=C3*a(nh)-C0*a(n)+C1*a(1)-C2*a(nh1)
        j=3
        do 12 i=1,nh-1
          wksp(j)=C2*a(i)+C1*a(i+nh)+C0*a(i+1)+C3*a(i+nh1)
          wksp(j+1)=C3*a(i)-C0*a(i+nh)+C1*a(i+1)-C2*a(i+nh1)
          j=j+2
12      continue
      endif
      do 13 i=1,n
        a(i)=wksp(i)
13    continue
      return
      END

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


C************************************************************************
	SUBROUTINE POLYFIT2(XX,YY,NPOINT,KK,XC,SDEV,ERR)
C
C JLP
C Version 07-09-90
C	Fits a polynomial to real*8 arrays XX and YY
C	Degree : KK (less than 9)
C Same as POLYFIT1.FOR but with E04HEF
C************************************************************************
C      This subroutine calls the NAG Library routine E04HFF which uses
C a modified Gauss-Newton algorithm for finding an unconstrained minima
C of a sum of squares of M non-linear functions in N variables (M >= N).
C	CALL E04HFF(M,N,XC,FSUMSQ,IW,LIW,W,LW,IFAIL)
C The first and second derivatives of the function are required.
C      Variables :
C
C KK: Degree of the polynomial
C M : This integer variable contains the number of residuals.
C N : This integer variable contains the number of variables. With M >= N.
C XX and YY : arrays to be fitted by a polynomial
C
C XC : Array containing the parameters which we are minimizing with respect to.
C XC(I) is the coeff. of X**(I-1) (REAL*8)
C SDEV : standard deviation for the coeff XC(I) (REAL*8).
C ERR : mean deviation of the fit (REAL*4)
C
C FSUMSQ : On exit of E04HFF this contains the sum of the squares of the
C final point.
C IFAIL : The return status of the function E04HFF.
C For a full description of this variable see the description
C in the NAG Library manual of E04HFF (page 4).   Success is signalled by
C IFAIL = 0.
C IW : Integer array of dimension LIW.   This is used by E04HFF as a workspace.
C LIW : The size of the array IW. (usually set to 1)
C W : Real array of dimension LW which is used by the function E04HFF
C as a workspace.
C LW : The size of the array W.  The appropriate values for LW are :
C        LW >= 8*N + 2*N*N + 2*M*N + 3*M  if N > 1
C	 LW >= 11 + 5*M                   if N = 1
C***************************************************************************
	IMPLICIT REAL*8 (A-H,P-Z)
	PARAMETER (IDIM=50)
	PARAMETER (LWW=8000,LV=20)
	REAL*8 XX(*),YY(*),WW(LWW),XC(20),SDEV(20)
	REAL*8 FJACC(IDIM,20),FVECC(IDIM),VV(LV,20)
	REAL*8 XX1(IDIM),YY1(IDIM)
	REAL*8 SUM,ETA,XTOL,STEPMX,SS(20),FSUMSQ
	REAL*4 ERR
	INTEGER*4 IW(100),LIW,MAXCALL
	CHARACTER ANS*1
	EXTERNAL LSQFUN,LSQHES,E04FDZ
	COMMON/MY_NAG/XX1,YY1,ILSFUN2,ILSHES2

10	FORMAT(A)

	IF(NPOINT.LE.KK)THEN
	  PRINT *,' FATAL ERROR IN POLYFIT : TOO FEW POINTS FOR THE FIT'
	  STOP
	ENDIF

C WARNING: 50 points maximum for E04HFF since I put LWW=8000!!!!!!!!!!!
C
	  IMOD=(NPOINT/50)+1
C Sum:
	  SUM=0.D0
	  II=0
	  DO I=1,NPOINT,IMOD
	    II=II+1
	    XX1(II)=XX(I)
	    YY1(II)=YY(I)
	    SUM=SUM+YY1(II)
	  END DO

	IF(NPOINT.GT.50)THEN
	  PRINT *,' Warning, too many points, NPTS=',NPOINT
	  PRINT *,' (Max=50)  After resampling, NPTS=',II
	ENDIF

	NPOINT=II

C    Set up the values for the number of residuals (M) and the number of
C    variables (N).

	M=NPOINT
	N=KK+1

C    Set up some variables

	LIW=100
C First guess
C For XC(1) we take the mean of the input points.
	XC(1)=SUM/FLOAT(NPOINT)
C For the others, we take small values:
	DO I=2,N
	XC(I)=0.1**I
	END DO

C    Call NAG/E04HEF to find the minimum values
39	IFAIL=1
	ILSFUN2=0
	ILSHES2=0
	MAXCALL=50*N
	ETA=0.9
	XTOL=1.E-13
	STEPMX=100000.
	LJC=IDIM
	CALL E04HEF(M,N,LSQFUN,LSDHES,E04FDZ,-1,MAXCALL,
	1	ETA,XTOL,STEPMX,XC,FSUMSQ,FVECC,FJACC,LJC,
	1	SS,VV,LV,NITER,NF,IW,LIW,WW,LWW,IFAIL)

	  IF(IFAIL.NE.0)THEN
	    PRINT 31,ILSFUN2,ILSHES2
31	    FORMAT(' ITERATIONS :   ILSFUN2',I4,
	1	'  ILSHES2',I4)
	    PRINT 101,IFAIL
101	    FORMAT(' IN POLYNOMIAL FITTING, ERROR IN E04HEF,',
	1	'  IFAIL =',I3)
	  IF(IFAIL.EQ.1.OR.IFAIL.EQ.9)STOP
	  ENDIF
C Mean deviation:
	  IF(M.GT.N)THEN
	    ERR=DSQRT(FSUMSQ/(M-N))
	  ELSE
	    ERR=DSQRT(FSUMSQ)
	  ENDIF

	  PRINT 32,ERR
32	  FORMAT(' MEAN DEVIATION FOR THE FIT :',E12.4,/)
C Computes the errors:
	  CALL ERROR_POLYFIT(M,N,XC,SDEV,FSUMSQ)

	DO I=1,N
	  PRINT 33,I,XC(I),SDEV(I)
33	  FORMAT(' XC(',I2,') :',E12.4,5X,'+/-',E12.4)
	END DO

C When IFAIL non equal to 0 :
	IF(IFAIL.EQ.2.OR.IFAIL.EQ.4)THEN
	  PRINT 30
30	  FORMAT(' DO YOU WANT TO TRY AGAIN ? (Y)')
	  READ(5,10) ANS

	IF(ANS.NE.'N'.AND.ANS.NE.'n')THEN
C	  PRINT *,' DO YOU WANT TO USE THE PREVIOUS OUTPUT VALUES ? (Y)'
C	  READ(5,10) ANS
C	  IF(ANS.EQ.'N'.OR.ANS.EQ.'n')THEN
C	    DO I=1,N
C	      PRINT 34,I
C34	      FORMAT(' ENTER XC(',I2,') : ',$)
C	      READ(5,*) XC(I)
C	    END DO
C	  ENDIF
C New iteration :
	GO TO 39
	ENDIF

	ENDIF

	RETURN
	END

C--------------------------------------------------------------------------
C LSQFUN
C       This subroutine calculates the elements of the Jacobian matrix, and
C       the Residuals, storing them in the arrays FJACC and FVECC respectively.
C       LSFUN2 is called from within the NAG routine.
C
C       Local variables :
C	   XC		==      Array of dimension N containing the point at
C				which the values of the function and first
C				derivatives are required.
C XC(1) + XC(2)*XX(I) + XC(3)*XX(I)**2 + ...
C	   FVECC	==	Array of dimension M, which on exit must
C				contain the value of the residual at the point
C				XC.
C	   FJACC	==	Array of dimension (LJC,N), which must contain
C				the elements of the Jacobian upon exit.
C	   LJC		==	The first dimension of the array FJACC, it is
C				set somewhere in E04GEF (=M).
C****************************************************************************

	SUBROUTINE LSQFUN(IFLAG,M,N,XC,FVECC,FJACC,LJC,
	1	IW,LIW,WW,LWW)
	IMPLICIT REAL*8 (A-H,P-Z)
	PARAMETER (IDIM=50)
	INTEGER*4 LIW,LWW
	INTEGER*4 IFLAG,M,N,LJC,IW(LIW)
	REAL*8 FJACC(LJC,N),FVECC(M),XC(N),WW(LWW)
	REAL*8 XX(IDIM),YY(IDIM)

	COMMON/MY_NAG/XX,YY,ILSFUN2,ILSHES2
	ILSFUN2=ILSFUN2+1

C Compulsary:::
	IFLAG=2

	DO 20 I=1,M

C Calculates the residuals.
C YY - ( XC(1)+XC(2)*XX+XC(3)*XX**2+...)
	WORK1=1.
	WORK2=XC(1)
	DO J=2,N
	  WORK1=WORK1*XX(I)
	  WORK2=WORK2+XC(J)*WORK1
	END DO

	FVECC(I)=YY(I)-WORK2

C Calculates the Jacobian elements.
C for J=1  -1.
C for J=2  -X
C for J=3  -X**2
C...

	FJACC(I,1)=-1.
	DO J=2,N
	  FJACC(I,J)=FJACC(I,J-1)*XX(I)
	END DO

20	CONTINUE

	RETURN
	END

C*******************************************************
C LSQHES
C Subroutine called by E04HEF to calculate the elements of
C the Hessian matrix multiplied by the residuals
C Here it is very simple, since there are no cross terms
C neither diagonal terms : they are all null !!
C*******************************************************
	SUBROUTINE LSQHES(IFLAG,M,N,FVECC,XC,BB,LBB,
	1	IW,LIW,WW,LWW)
	IMPLICIT REAL*8 (A-H,P-Z)
	PARAMETER (IDIM=50)
	REAL*8 BB(LBB),FVECC(M),XC(N)
	REAL*8 XX(IDIM),YY(IDIM),WW(LWW)
	INTEGER*4 LIW,LWW
	INTEGER*4 IFLAG,M,N,LJC,IW(LIW)
	COMMON/MY_NAG/XX,YY,ILSFUN2,ILSHES2

	ILSHES2=ILSHES2+1
	DO I=1,LBB
	  BB(I)=0.0
	END DO

	RETURN
	END

C*******************************************************
      SUBROUTINE ERROR_POLYFIT(M,N,XC,SDEV,FSUMSQ)
C
C  This routine works out the formal errors on the fit by
C  inverting the Hessian matrix.
C  The matrix of second partial derivative (Hessian) is
C  in many least square problems adequately approximated
C  by A = 2 JT J where J is the jacobian
C  Let H be the inverse of A and S the sum of squares
C  then var xi = 2*S*Hii/(m-n)
C
	IMPLICIT REAL*8(A-H,P-Z)
	PARAMETER (IDIM=50,LIW=100,LWW=8000)
	REAL*8 XX(IDIM),YY(IDIM),FJACC(IDIM,20),FVECC(IDIM)
	REAL*8 A(21,20),B(20,20),Z(20),SDEV(20),XC(20)
	INTEGER*4 IW(LIW)
	REAL*8 WW(LWW)
	COMMON/MY_NAG/XX,YY,ILSFUN2,ILSHES2

C Call LSQFUN to compute the Jaccobian matrix for the solution :
	LJC=IDIM
	CALL LSQFUN(IFLAG,M,N,XC,FVECC,FJACC,LJC,
	1	IW,LIW,WW,LWW)

	DO I=1,N
	DO J=1,N
	SUM=0.0
	  DO K=1,M
	  SUM=SUM+FJACC(K,I)*FJACC(K,J)
	  END DO
	A(I,J)=SUM
	END DO
	END DO

	IA=21
	IB=20
	IFAIL=0
C
C  Matrix inversion with F01ABF
C
	CALL F01ABF(A,IA,N,B,IB,Z,IFAIL)
C Inversion of a real symmetric positive definite matrix A
C IA first dimension of A(IA,p) p>=N
C N order of array A
c B real*8 array used as work space B(IB,p) p>=N
	IF(IFAIL.NE.0)THEN
	PRINT 100,IFAIL
100	FORMAT(' ERROR DURING INVERSION OF THE MATRIX ',
	1	'(IN F01ABF) , IFAIL =',I4)
	RETURN
	ENDIF

	DO I=1,N
	WORK=DABS(FSUMSQ*B(I,I)/(M-N))
	SDEV(I)=DSQRT(WORK)
	END DO

C Test to check if the errors are not too large
	TEST=DMAX1(SDEV(1),SDEV(2),SDEV(3),SDEV(4))

	IF(TEST.GT.10.)THEN
	 PRINT 202
202	 FORMAT(' ERRORS TOO HIGH TO BE REASONABLE')
	ENDIF

C Possibility of printing the covariance matrix

C	DO I=1,N
C	DO J=1,N
C	B(I,J)=B(I,J)/(M-N)
C	END DO
C	END DO
C	PRINT 201
201	FORMAT(2X,10(1H*),'COVARIANCE MATRIX',10(1H*))
C	DO 4 I=1,5
C	PRINT 200,(B(I,J),J=1,I)
200	FORMAT(' ',5E12.4)

	RETURN
	END
C**********************************************************************
	SUBROUTINE CALPOLY(X,Y,XC,KDEGREE)
C For real*8
	REAL*8 X,Y
	REAL*8 XC(KDEGREE+1)
	Y=XC(1)
	WORK=1.

	DO I=2,KDEGREE+1
	WORK=WORK*X
	Y=Y+WORK*XC(I)
	END DO

	RETURN
	END


!Autor: Claudio Iván Esparza Castañeda
!Título: Matriz por escalar
!Descripción: Multiplica un escalar por una matriz
!Fecha: 30/03/2020

Program sumat
  implicit none
  REAL, allocatable, dimension(:, :)::A, B
  iNTEGER, dimension(0:1)::N
  REAL::r
  INTEGER::i, j, k
  WRITE(*, *) "Dimensión de la matriz (filas x columnas)"
  READ(*, *) N(0), N(1)
  allocate(A(1:N(0), 1:N(1)), B(1:N(0), 1:N(1)))
  WRITE(*, *) "Elementos de la matriz:"
  do i=1, N(0)
     do j=1, N(1)
        READ(*, *) A(i, j)
     end do
  end do
  WRITE(*, *) "Escalar"
  READ(*, *) r
  do i=1, N(0)
     do j=1, N(1)
        B(i, j)=r*A(i, j)
     end do
  end do
  WRITE(*, *) "Producto:"
  do i=1, N(0)
     WRITE(*, *) B(i, :)
  end do
  deallocate(A, B)
end Program sumat


      PROGRAM xvander
C     driver for routine vander
      INTEGER N
      PARAMETER(N=5)
      INTEGER i,j
      DOUBLE PRECISION sum,x(N),q(N),w(N),term(N)
      DATA x/1.0d0,1.5d0,2.0d0,2.5d0,3.0d0/
      DATA q/1.0d0,1.5d0,2.0d0,2.5d0,3.0d0/
      call vander(x,w,q,N)
      write(*,*) 'Solution vector:'
      do 11 i=1,N
        write(*,'(5x,a2,i1,a4,e12.6)') 'W(',i,') = ',w(i)
11    continue
      write(*,'(/1x,a)') 'Test of solution vector:'
      write(*,'(1x,t6,a,t19,a)') 'mtrx*sol''n','original'
      sum=0.0
      do 12 i=1,N
        term(i)=w(i)
        sum=sum+w(i)
12    continue
      write(*,'(1x,2f12.4)') sum,q(1)
      do 14 i=2,N
        sum=0.0
        do 13 j=1,N
          term(j)=term(j)*x(j)
          sum=sum+term(j)
13      continue
        write(*,'(1x,2f12.4)') sum,q(i)
14    continue
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xvander.for


!-------------------------------------------------------------------------------
!> Program SCALE-RM Buffer factor Maker
!!
!! @par Description
!!          This program is make of buffer factor
!!
!! @author Team SCALE
!!
!<
!-------------------------------------------------------------------------------
program scaleles_make_bufffact
  !-----------------------------------------------------------------------------
  !
  implicit none

  ! namelists
  integer :: MAXIMUM_ITERATION  = 100
  integer :: NUM_STRETCHED_GRID = 10

  real(8) :: DEFAULT_BUFFFACT = 1.1D0
  real(8) :: GRID_CARTESC_DISTANCE    = 100.0D0
  real(8) :: TOTAL_LENGTH     = 100.0D+3
  real(8) :: LIMIT_ITERATION  = epsilon(0.0D0)

  namelist / MAKE_BUFFFACT / &
    MAXIMUM_ITERATION,  &
    DEFAULT_BUFFFACT,   &
    NUM_STRETCHED_GRID, &
    GRID_CARTESC_DISTANCE,      &
    TOTAL_LENGTH,       &
    LIMIT_ITERATION

  ! works
  integer :: n
  integer :: ierr

  integer :: itr
  integer :: num

  real(8) :: bf
  real(8) :: dx
  real(8) :: L
  real(8) :: EPS

  real(8) :: dbf
  !-----------------------------------------------------------------------------

  ! read namelist
  open(unit=10, file='bufffact.conf', &
       status='old', delim='apostrophe')
  read(unit=10, nml=MAKE_BUFFFACT, iostat=ierr)

  if( ierr < 0 ) then !--- missing
    write(*,*) '*** Not found namelist. Default used.'
  elseif( ierr > 0 ) then !--- fatal error
    write(*,*) 'xxx Not appropriate names in namelist MAKE_BUFFFACT. Check!'
    stop
  endif

  close(unit=10)

  ! initialize
  itr = MAXIMUM_ITERATION
  num = NUM_STRETCHED_GRID

  bf  = DEFAULT_BUFFFACT
  dx  = GRID_CARTESC_DISTANCE
  L   = TOTAL_LENGTH
  EPS = LIMIT_ITERATION

  ! output setting parameter
  write (*,*)
  write (*,*) "-------------------------------------------------------------------------------"
  write (*,*) "### SCALE-RM: make setting of buffer factor ###"
  write (*,*) "maximum iteration number                 ", itr
  write (*,*) "number of stretched grid                 ", num
  write (*,*) "default buffer factor                    ", bf
  write (*,*) "non-stretched grid distance [m]          ", dx
  write (*,*) "total length of stretched region [m]     ", L
  write (*,*) "limit of iteration                       ", EPS
  write (*,*) "-------------------------------------------------------------------------------"
  write (*,*)

  write (*,*) "-------------------------------------------------------------------------------"
  write (*,*) "  # of iteration            buffer factor    diff. of buffer factor            "
  write (*,*) "-------------------------------------------------------------------------------"

  ! Newton-Raphson method
  do n = 1, itr
    dbf = ( bf**dble(num+1)*dx - bf*(L+dx) + L ) / ( bf**dble(num)*dble(num+1)*dx - (L+dx) )
    bf  = bf - dbf

    write (*,'(12x,i5,1x,f24.16,2x,ES24.16)') n, bf, dbf

    if( dbf < EPS ) then
      exit ! stop iteration
    end if
  end do

  write (*,*) "-------------------------------------------------------------------------------"

  open(unit=20, file='result.txt', &
       form='formatted', status='replace' )
  write(unit=20, fmt='(" BUFFFACT  = ",f20.16,"D0,")')  bf
  close(unit=20)

end program scaleles_make_bufffact


module functions

    use omp_lib
    implicit none
    integer :: fevals(0:7)
    real(kind=8) :: k
    save

contains

    real(kind=8) function f(x)
        implicit none
        real(kind=8), intent(in) :: x
        integer thread_num

        ! keep track of number of function evaluations by
        ! each thread:
        thread_num = 0   ! serial mode
        !$ thread_num = omp_get_thread_num()
        fevals(thread_num) = fevals(thread_num) + 1

        f = 1.d0 + x**3 + sin(k*x)

    end function f

end module functions