MODULE DUALSIMP_MOD
! Fortran 90 module for solving the asymetric dual of a problem
!
! max C^T X
! s.t. A X \leq B
!
! where A is dense and the dual solution is unique.
!
! As far as the author knows, this code has tested robust in all situations
! where Y is unique. However, this code exists primarily for learning
! purposes, and has not been thoroughly tested for robustness. Neither does
! it represent the most efficient method for solving LPs of the above form
! in many situations.
!
! Two subroutines are provided:
!
! DUALSIMPLEX for solving an LP when the initial basis is known (Phase II of
!    the simplex algorithm),
!
! and
!
! FEASIBLEBASIS for finding an initial dual feasible basis when none is
!    known (Phase I of the simplex algorithm) by solving the auxiliary
!    problem using DUALSIMPLEX.
!
! Author: Tyler Chang
! Last Update: July, 2019

! Includes the R8 data type for approximately 64-bit precision.
INTEGER, PARAMETER:: R8=SELECTED_REAL_KIND(13)

CONTAINS

SUBROUTINE DUALSIMPLEX (N, M, AT, B, C, IBASIS, X, Y, IERR, &
                      & EPS, IBUDGET, OBASIS)
! Solves a primal problem of the form
!
! maximize     C^T X
! such that  A X \leq B
!
! where A \in R^{M \times N}, C,X \in R^N, and B \in R^M.
!
! Assuming M > N, this is done most efficiently by applying the simplex
! method on the asymmetric dual problem
!
! minimize     B^T Y
! such that  A^T Y = C
! and        Y \geq 0
!
! where Y \in R^M.
!
! To solve the dual problem, the revised simplex algorithm is applied. In
! each iteration of the dual simplex algorithm, a complete LU factorization
! is performed via DGETRF. Dantzig's rule is used to pivot, until either a
! solution is found, or a pivot does not improve the objective. When a pivot
! fails to improve the objective, Bland's rule is used until improvement
! resumes, at which point Dantzig's pivoting strategy is resumed.
!
! This strategy is most effective when A is dense and when M > N. For
! efficient memory access patterns, the constraints are specified by
! inputting A^T instead of A. For efficient linear algebra, LAPACK is
! used for computing LU factorizations and performing triangular solve
! operations, and BLAS is used for computing dot products and matrix-vector
! multiplication.
!
! While a complete LU factorization in each iteration produces maximum
! numerical stability, a Woodbury update could alternatively be performed
! if iteration speed is of greater concern. When M >> N, the cost of the
! LU factorization is negligible compared to other computational costs,
! and the difference in speed would be negligible.
!
! On input:
!
! N is the integer number of variables in the primal problem.
!
! M is the integer number of constraints in the primal problem.
!
! AT(N,M) is the transpose of the real valued constraint matrix A.
!
! B(M) is the real valued vector of upper bounds for the constraints.
!
! C(N) is the real valued cost vector for the objective function.
!
! IBASIS(N) is an integer valued vector containing the indices
! (from AT) of an intitial basis that is dual feasible.
!
! On output:
!
! X(N) is a real valued vector, which contains the primal solution.
!
! Y(M) is a real valued vector, which contains the dual solution.
!
! IERR is an integer valued error flag. The error codes are listed below:
!
! Tens-digit is 0:
!
! These codes indicate expected termination conditions.
!
!  0 : C^T X has been successfully maximized.
!  1 : The dual problem is unbounded, therefore the primal must be infeasible.
!
! Tens-digit is 1:
!
! These codes indicate that the problem dimensions do not agree.
!
! 10 : Illegal problem dimensions: N < 1.
! 11 : Illegal problem dimensions: M < N. If you wish to solve a problem with
!      more variables than constraints, consider using a primal method.
! 12 : N does not match the first dimension of the constraint matrix AT.
! 13 : M does not match the second dimension of the constraint matrix AT.
! 14 : M does not match the length of the upper bounds B.
! 15 : N does not match the length of the cost vector C.
! 16 : N does not match the length of the initial basis IBASIS.
! 17 : N does not match the length of the primal solution vector X.
! 18 : M does not match the length of the dual solution vector Y.
!
! Tens-digit is 2:
!
! These codes indicate that the optional arguments contain illegal values
! or dimensions.
!
! 20 : The optional argument EPS must be strictly positive.
! 21 : The optional argument IBUDGET must be nonnegative.
! 22 : The optional argument OBASIS must be length N.
!
! Tens-digit is 3:
!
! These codes indicate that the initial basis (IBASIS) was not feasible.
!
! 30 : The provided initial basis IBASIS for AT contains indices that are
!      out of the bounds of AT (either greater than M or less than 1).
! 31 : The provided initial basis IBASIS for AT contains duplicate indices,
!      making it rank-deficient.
! 32 : The provided initial basis IBASIS for AT, while not redundant,
!      produced a singularity
! 33 : The provided initial basis IBASIS for AT is not feasible.
!
! Tens-digit is 4:
!
! These codes indicate
!
! 40 : The pivot budget (IBUDGET) was exceeded before a solution could be
!      found. Consider increasing IBUDGET, or increasing the working
!      precision EPS.
! 41 : A pivot has produced a singular basis. Consider increasing the
!      working precision (EPS).
!
! Tens-digit is 5:
!
! These codes indicate a LAPACK error. If one of these errors occurs,
! it most likely indicates a system or compiler failure of some kind.
!
! 50 : The subroutine DGETRF reported an illegal value (rare).
! 51 : The subroutine DGETRS reported an illegal value (rare).
!
! Optional arguments:
!
! EPS contains the working precision for the problem. EPS must be a
! strictly positive real number, and by default EPS is the square-root of
! the unit roundoff.
!
! IBUDGET contains the integer budget for the maximum number of pivots
! allowed. By default, IBUDGET=50,000.
!
! When present, OBASIS(:) returns the integer indices of the final basis
! as listed in AT.

IMPLICIT NONE
! Parameter list.
INTEGER, INTENT(IN) :: N
INTEGER, INTENT(IN) :: M
REAL(KIND=R8), INTENT(IN) :: AT(:,:)
REAL(KIND=R8), INTENT(IN) :: B(:)
REAL(KIND=R8), INTENT(IN) :: C(:)
INTEGER, OPTIONAL, INTENT(INOUT) :: IBASIS(:)
REAL(KIND=R8), INTENT(OUT) :: X(:)
REAL(KIND=R8), INTENT(OUT) :: Y(:)
INTEGER, INTENT(OUT) :: IERR
REAL(KIND=R8), OPTIONAL, INTENT(IN) :: EPS
INTEGER, OPTIONAL, INTENT(IN) :: IBUDGET
INTEGER, OPTIONAL, INTENT(OUT) :: OBASIS(:)
! Local variables.
INTEGER :: I, J, IBUDGETL
REAL(KIND=R8) :: EPSL, NEWSOL, OLDSOL
INTEGER :: IPIV(N), JPIV(M)
REAL(KIND=R8) :: APIV(N,M), BPIV(M), S(M-N), LU(N,N)
! External procedures.
REAL(KIND=R8), EXTERNAL :: DDOT  ! Inner product (BLAS).
EXTERNAL :: DGEMV  ! General matrix vector multiply (BLAS)
EXTERNAL :: DGETRF ! Perform a LU factorization with partial pivoting (LAPACK).
EXTERNAL :: DGETRS ! Use the output of DGETRF to solve a linear system (LAPACK).

! Check inputs for errors.
IF (N < 1) THEN
   IERR = 10; RETURN
ELSE IF (M < N) THEN
   IERR = 11; RETURN
ELSE IF (SIZE(AT,1) .NE. N) THEN
   IERR = 12; RETURN
ELSE IF (SIZE(AT,2) .NE. M) THEN
   IERR = 13; RETURN
ELSE IF (SIZE(B,1) .NE. M) THEN
   IERR = 14; RETURN
ELSE IF (SIZE(C,1) .NE. N) THEN
   IERR = 15; RETURN
ELSE IF (SIZE(IBASIS,1) .NE. N) THEN
   IERR = 16; RETURN
ELSE IF (SIZE(X,1) .NE. N) THEN
   IERR = 17; RETURN
ELSE IF (SIZE(Y,1) .NE. M) THEN
   IERR = 18; RETURN
END IF
! Check for optionals.
IF (PRESENT(EPS)) THEN
   IF(EPS .LE. 0.0_R8) THEN ! Must be strictly positive.
      IERR = 20; RETURN; END IF
   EPSL = EPS
ELSE ! Set the default value.
   EPSL = EPSILON(0.0_R8)
END IF
IF (PRESENT(IBUDGET)) THEN
   IF(IBUDGET < 0) THEN ! Must be nonnegative.
      IERR = 21; RETURN; END IF
   IBUDGETL = IBUDGET
ELSE ! Set the default value.
   IBUDGETL = 50000
END IF
IF (PRESENT(OBASIS)) THEN
   IF(SIZE(OBASIS, 1) .NE. N) THEN ! Must match the size of IBASIS.
      IERR = 22; RETURN; END IF
   OBASIS = 0 ! Initialize to zeros.
END IF

! Check for issues with the initial basis, IBASIS.
IF (ANY(IBASIS < 1) .OR. ANY(IBASIS > M)) THEN ! Check for illegal values.
   IERR = 30; RETURN; END IF
DO I = 1, N ! Check for illegal bases.
   IF (ANY(IBASIS(I+1:N) .EQ. IBASIS(I))) THEN
      IERR = 31; RETURN; END IF
END DO

! Initialize JPIV.
FORALL ( I = 1 : M ) JPIV(I) = I
! Initilaize APIV and BPIV.
APIV(:,:) = AT(:,:)
BPIV(:) = B(:)
! Pivot the indices of APIV and BPIV to match IBASIS.
DO I = 1, N
   ! Locate the current index of the basis element (after swapping).
   DO J = 1, M
      IF (JPIV(J) .EQ. IBASIS(I)) EXIT
   END DO
   ! Pivot APIV and BPIV to match the initial basis specified in IBASIS.
   CALL DSWAP(N, APIV(:,I), 1, APIV(:,J), 1)
   OLDSOL = BPIV(I)
   BPIV(I) = BPIV(J)
   BPIV(J) = OLDSOL
   ! Track the changes in JPIV.
   IPIV(1) = JPIV(I)
   JPIV(I) = JPIV(J)
   JPIV(J) = IPIV(1)
END DO

! Get a solution using the LU factorization.
LU(:,:) = APIV(:,1:N)
CALL DGETRF(N, N, LU, N, IPIV, IERR)
IF (IERR > 0) THEN ! LU is exactly singular.
   IERR = 32; RETURN
ELSE IF (IERR < 0) THEN
   IERR = 50; RETURN; END IF
! Use the LU factorization to get the first N elements of the dual solution.
Y(1:N) = C(:)
CALL DGETRS('N', N, 1, LU, N, IPIV, Y, M, IERR)
IF (IERR .NE. 0) THEN
   IERR = 51; RETURN; END IF
IF (ANY(Y(1:N) .LT. -EPSL)) THEN
   IERR = 33; RETURN; END IF
Y(N+1:M) = 0.0_R8 ! The last N elements are zeros.
! Given S(1:N)=0, use the LU factorization to get the primal solution.
X(:) = BPIV(1:N)
CALL DGETRS('T', N, 1, LU, N, IPIV, X, N, IERR)
IF (IERR .NE. 0) THEN
   IERR = 51; RETURN; END IF
! Get the rest of the slack variables by solving B - A*X for the kernel.
S(:) = BPIV(N+1:M)
CALL DGEMV('T', N, M-N, -1.0_R8, APIV(:,N+1:M), N, X, 1, 1.0_R8, S, 1)
! Check if the KKT conditions have been satisfied.
IF (ALL(S .GE. -EPSL) ) THEN
   IERR = 0
   ! Undo the pivots in Y, so that Y can be output.
   CALL DLAPMT( .FALSE., 1, M, Y, 1, JPIV )
   ! Store the final basis in OBASIS.
   IF(PRESENT(OBASIS)) OBASIS(:) = JPIV(1:N)
   RETURN
END IF

! If not, compute the current solution and begin the iteration.
NEWSOL = DDOT(N, BPIV, 1, Y, 1)
OLDSOL = NEWSOL + 1.0_R8
! Loop until a solution is found.
DO I = 1, IBUDGETL
   ! Choose the pivot rule based on the improvement.
   IF (OLDSOL - NEWSOL > EPSL) THEN
      CALL PIVOT_DANTZIG() ! Use Dantzig's rule when improvement is made.
      IF (IERR .NE. 0) RETURN
   ELSE
      CALL PIVOT_BLAND() ! Use Bland's rule when stalled.
      IF (IERR .NE. 0) RETURN
   END IF
   ! Get a new solution using the LU factorization.
   LU(:,:) = APIV(:,1:N)
   CALL DGETRF(N, N, LU, N, IPIV, IERR)
   IF (IERR > 0) THEN ! LU is exactly singular.
      IERR = 41; RETURN
   ELSE IF (IERR < 0) THEN
      IERR = 50; RETURN; END IF
   ! Use the LU factorization to get the first N elements of the dual solution.
   Y(1:N) = C(:)
   CALL DGETRS('N', N, 1, LU, N, IPIV, Y, M, IERR)
   IF (IERR .NE. 0) THEN
      IERR = 51; RETURN; END IF
   ! Given S(1:N)=0, use the LU factorization to get the primal solution.
   X(:) = BPIV(1:N)
   CALL DGETRS('T', N, 1, LU, N, IPIV, X, N, IERR)
   IF (IERR .NE. 0) THEN
      IERR = 51; RETURN; END IF
   ! Get the rest of the slack variables by solving B - A*X for the kernel.
   S(:) = BPIV(N+1:M)
   CALL DGEMV('T', N, M-N, -1.0_R8, APIV(:,N+1:M), N, X, 1, 1.0_R8, S, 1)
   ! Check if the KKT conditions are satisfied.
   IF (ALL(S .GE. -EPSL) ) THEN
      ! Undo the pivots in Y, so that Y can be output.
      CALL DLAPMT( .FALSE., 1, M, Y, 1, JPIV )
      ! Store the final basis in OBASIS.
      IF(PRESENT(OBASIS)) OBASIS(:) = JPIV(1:N)
      RETURN
   END IF
   ! Save the current solution and update the new solution.
   OLDSOL = NEWSOL
   NEWSOL = DDOT(N, BPIV, 1, Y, 1)
END DO
! Budget expired.
IERR = 40
RETURN

CONTAINS

SUBROUTINE PIVOT_DANTZIG()
! Pivot using Dantzig's minimum ratio method for fast convergence.
!
! On input, assume that APIV(:,:) contains the basis and kernel of AT,
! in that order. Also, assume that LU contains the LU factorization
! of the basis and IPIV contains the corresponding pivot indices.
! Also assume that Y contains a dual feasible solution and S contains
! the non-basic slack variables.
!
! Given the above, compute the entering and exiting indices (IENTER and IEXIT)
! and update APIV(:,:) and BPIV(:) accordingly, tracking the pivots in JPIV.
INTEGER :: IENTER, IEXIT
REAL(KIND=R8) :: W(N), CURRMIN
! Compute the entering index.
IENTER = MINLOC(S, 1) + N
! Build a weight vector for the entering vertex using the LU factorization.
W(:) = APIV(:,IENTER)
CALL DGETRS('N', N, 1, LU, N, IPIV, W, N, IERR)
IF (IERR .NE. 0) THEN
   IERR = 51; RETURN; END IF
! Compute the weight ratios and choose the exiting index.
CURRMIN = HUGE(0.0_R8)
IEXIT = 0
DO J = 1, N
   IF (W(J) .LT. EPSL) CYCLE
   W(J) = Y(J) / W(J)
   IF (W(J) < CURRMIN) THEN
      CURRMIN = W(J)
      IEXIT = J
   END IF
END DO
! Check that an exiting index was found.
IF (IEXIT .EQ. 0) THEN
   IERR = 1
   RETURN
END IF
! Perform the pivot operation on both AT and B.
CALL DSWAP(N, APIV(:,IEXIT), 1, APIV(:,IENTER), 1) ! Pivot AT using DSWAP.
W(1) = BPIV(IEXIT) ! Pivot B using W(1) as a temp variable.
BPIV(IEXIT) = BPIV(IENTER)
BPIV(IENTER) = W(1)
! Record the pivot in JPIV(:).
J = JPIV(IENTER)
JPIV(IENTER) = JPIV(IEXIT)
JPIV(IEXIT) = J
RETURN
END SUBROUTINE PIVOT_DANTZIG

SUBROUTINE PIVOT_BLAND()
! Pivot using Bland's anticycling rule to guarantee convergence on degenerate
! point sets.
!
! On input, assume that APIV(:,:) contains the basis and kernel of AT,
! in that order. Also, assume that LU contains the LU factorization
! of the basis and IPIV contains the corresponding pivot indices.
! Also assume that Y contains a dual feasible solution and S contains
! the non-basic slack variables.
!
! Given the above, compute the entering and exiting indices (IENTER and IEXIT)
! and update APIV(:,:) and BPIV(:) accordingly, tracking the pivots in JPIV.
INTEGER :: IENTER, IEXIT
REAL(KIND=R8) :: W(N), CURRMIN
! Compute the entering index. It is the first negative entry in the kernel.
DO J = 1, M-N
   IF(S(J) < -EPSL) THEN
      IENTER = J+N; EXIT; END IF
END DO
! Build a weight vector for the entering vertex using the LU factorization.
W(:) = APIV(:,IENTER)
CALL DGETRS('N', N, 1, LU, N, IPIV, W, N, IERR)
IF (IERR .NE. 0) THEN
   IERR = 51; RETURN; END IF
! Compute the weight ratios and choose the exiting index.
CURRMIN = HUGE(0.0_R8)
IEXIT = 0
DO J = 1, N
   IF (W(J) .LT. EPSL) CYCLE
   W(J) = Y(J) / W(J)
   IF (W(J) - CURRMIN < -EPSL) THEN
      CURRMIN = W(J)
      IEXIT = J
   END IF
END DO
! Check that an exiting index was found.
IF (IEXIT .EQ. 0) THEN
   IERR = 1
   RETURN
END IF
! Perform the pivot operation on both AT and B.
CALL DSWAP(N, APIV(:,IEXIT), 1, APIV(:,IENTER), 1) ! Pivot AT using DSWAP.
W(1) = BPIV(IEXIT) ! Pivot B using W(1) as a temp variable.
BPIV(IEXIT) = BPIV(IENTER)
BPIV(IENTER) = W(1)
! Record the pivot in JPIV(:).
J = JPIV(IENTER)
JPIV(IENTER) = JPIV(IEXIT)
JPIV(IEXIT) = J
RETURN
END SUBROUTINE PIVOT_BLAND

END SUBROUTINE DUALSIMPLEX

SUBROUTINE FEASIBLEBASIS (N, M, AT, C, BASIS, IERR, EPS, IBUDGET)
! Implement the simplex method to find a dual feasible basis for a primal
! problem of the form
!
! maximize     C^T X
! such that  A X \leq B
!
! where A \in R^{M \times N}, X \in R^N, and B \in R^M.
!
! The asymmetric dual problem is then of the form
!
! minimize     B^T Y
! such that  A^T Y = C
! and        Y \geq 0
!
! where Y \in R^M.
!
! A basis V \in R^{N \times N} for A^T is dual feasible if V Y = C is
! solvable with Y \geq 0.
!
! Find the indices of A corresponding to V by solving the auxiliary problem
!
! minimize     SUM(Z)
! such that  A_AUX [Z^T Y^T]^T = C
! and        Z \geq 0, Y \geq 0.
!
! where Z \in R^N and A_AUX = [ SIGN_N | A^T ] \in R^{N \times N+M}.
! Here, SIGN_N denotes the N-by-N identity matrix, except that when
! C(I) < 0 then SIGN_N(I,I) = -1.
!
! Trivially, columns 1, ..., N of A_AUX provide an initial basis for this
! problem, with solution Z = ABS(B) and Y = 0. When SUM(Z) has been minimized,
! if SUM(Z) > 0, the problem is infeasible. Otherwise, if SUM(Z) = 0, then
! a feasible basis is given by the columns of A^T that are in the basis of
! A_AUX.
!
! Uses DUALSIMPLEX to solve the auxiliary problem.
!
! On input:
!
! N is the integer number of variables in the primal problem.
!
! M is the integer number of constraints in the primal problem.
!
! AT(N,M) is the transpose of the real valued constraint matrix A.
!
! C(N) is the real valued cost vector for the objective function.
!
! On output:
!
! BASIS(N) is an integer valued vector, which contains the indices of a
! dual feasible basis for AT.
!
! IERR is an integer valued error flag. The error codes are listed below:
!
! Tens-digit is 0:
!
! These codes indicate expected termination conditions.
!
!  0 : C^T X has been successfully maximized.
!  1 : The dual problem is unbounded, therefore the primal must be infeasible.
!  2 : The dual problem is infeasible, the primal may be unbounded or
!      infeasible.
!
! Tens-digit is 1:
!
! These codes indicate that the problem dimensions do not agree.
!
! 10 : Illegal problem dimensions: N < 1.
! 11 : Illegal problem dimensions: M < N. If you wish to solve a problem with
!      more variables than constraints, consider using a primal method.
! 12 : N does not match the first dimension of the constraint matrix AT.
! 13 : M does not match the second dimension of the constraint matrix AT.
! 15 : N does not match the length of the cost vector C.
! 16 : N does not match the length of the output BASIS.
!
! Tens-digit is 2:
!
! These codes indicate that the optional arguments contain illegal values
! or dimensions.
!
! 20 : The optional argument EPS must be strictly positive.
! 21 : The optional argument IBUDGET must be nonnegative.
!
! Tens-digit is 4:
!
! These codes indicate
!
! 40 : The pivot budget (IBUDGET) was exceeded before a solution could be
!      found. Consider increasing IBUDGET, or increasing the working
!      precision EPS.
! 41 : A pivot has produced a singular basis. Consider increasing the
!      working precision (EPS).
!
! Tens-digit is 5:
!
! These codes indicate a LAPACK error. If one of these errors occurs,
! it most likely indicates a system or compiler failure of some kind.
!
! 50 : The subroutine DGETRF reported an illegal value (rare).
! 51 : The subroutine DGETRS reported an illegal value (rare).
!
! Optional arguments:
!
! EPS contains the working precision for the problem. EPS must be a
! strictly positive real number, and by default EPS is the square-root of
! the unit roundoff.
!
! IBUDGET contains the integer budget for the maximum number of pivots
! allowed. By default, IBUDGET=50,000.

IMPLICIT NONE
! Parameter list.
INTEGER, INTENT(IN) :: N
INTEGER, INTENT(IN) :: M
REAL(KIND=R8), INTENT(IN) :: AT(:,:)
REAL(KIND=R8), INTENT(IN) :: C(:)
INTEGER, INTENT(OUT) :: BASIS(:)
INTEGER, INTENT(OUT) :: IERR
REAL(KIND=R8), OPTIONAL, INTENT(IN) :: EPS
INTEGER, OPTIONAL, INTENT(IN) :: IBUDGET
! Local variables.
INTEGER :: I, IDX, IBUDGETL, IBASIS(N)
REAL(KIND=R8) :: EPSL
REAL(KIND=R8) :: A_AUX(N,N+M)
REAL(KIND=R8) :: B_AUX(N+M)
REAL(KIND=R8) :: Y_AUX(M+N)
REAL(KIND=R8) :: X(N)
! External (BLAS) function DDOT for inner products.
REAL(KIND=R8), EXTERNAL :: DDOT

! Check inputs for errors.
IF (N < 1) THEN
   IERR = 10; RETURN
ELSE IF (M < N) THEN
   IERR = 11; RETURN
ELSE IF (SIZE(AT,1) .NE. N) THEN
   IERR = 12; RETURN
ELSE IF (SIZE(AT,2) .NE. M) THEN
   IERR = 13; RETURN
ELSE IF (SIZE(C,1) .NE. N) THEN
   IERR = 15; RETURN
ELSE IF (SIZE(BASIS,1) .NE. N) THEN
   IERR = 16; RETURN
END IF
! Check for optionals.
IF (PRESENT(EPS)) THEN
   IF(EPS .LE. 0.0_R8) THEN ! Must be strictly positive.
      IERR = 20; RETURN; END IF
   EPSL = EPS
ELSE ! Set the default value.
   EPSL = EPSILON(0.0_R8)
END IF
IF (PRESENT(IBUDGET)) THEN
   IF(IBUDGET < 0) THEN ! Must be nonnegative.
      IERR = 21; RETURN; END IF
   IBUDGETL = IBUDGET
ELSE ! Set the default value.
   IBUDGETL = 50000
END IF

! Copy AT into A_AUX to solve Phase 1 problem and zero B_AUX.
A_AUX(:,N+1:N+M) = AT(:,:)
B_AUX(1:N) = 1.0_R8
B_AUX(N+1:N+M) = 0.0_R8
! Create artificial variables to solve the problem.
A_AUX(:,1:N) = 0.0_R8
FORALL ( I = 1 : N ) A_AUX(I,I) = SIGN(1.0_R8, C(I))
! Set IBASIS.
FORALL (I = 1 : N) IBASIS(I) = I
! Get solution.
CALL DUALSIMPLEX(N, N+M, A_AUX, B_AUX, C, IBASIS, X, Y_AUX, IERR, &
   & EPS=EPSL, IBUDGET=IBUDGETL, OBASIS=BASIS)
IF (IERR .NE. 0) RETURN
! Check for infeasible dual solution.
IF (DDOT(N, Y_AUX, 1, B_AUX, 1) > EPSL) THEN; IERR = 2; RETURN; END IF
BASIS(:) = BASIS(:) - N
! Check that all basis elements are legal (in case of degeneracies).
DO I = 1, N
   IF (BASIS(I) < 1) THEN
      IDX = 1 ! Find an available legal basis element.
      DO WHILE (ANY(BASIS(:) .EQ. IDX)); IDX = IDX + 1; END DO
      BASIS(I) = IDX
   END IF
END DO
RETURN

END SUBROUTINE FEASIBLEBASIS

END MODULE DUALSIMP_MOD


c     program DRDHTCC
c>> 1994-10-19 DRDHTCC  Krogh  Changes to use M77CON
c>> 1987-12-09 DRDHTCC  Lawson  Initial Code.
c     Demo driver for DHTCC, Householder transformations.
c--D replaces "?": DR?HTCC, ?HTCC, ?MATP
      integer IDIM, JDIM, J, M, N
      parameter(IDIM = 3, JDIM = 5, M = 3, N = 2)
      double precision D(IDIM,JDIM), UPARAM, ZERO
      parameter(ZERO = 0.0D0)
      data (D(1,J),J=1,5) /  0.870D0,  0.796D0,    1.0D0, 0.0D0, 0.0D0 /
      data (D(2,J),J=1,5) /  0.571D0, -0.804D0,    0.0D0, 1.0D0, 0.0D0 /
      data (D(3,J),J=1,5) / -0.960D0,  0.346D0,    0.0D0, 0.0D0, 1.0D0 /
c     ------------------------------------------------------------------
      print*,'DRDHTCC..  Demonstrate computation of a QR decomposition.'
      print*,'Given matrix A, compute orthogonal Q and triangular R'
      print*,'such that A = Q * R.'
      call DMATP(D,IDIM,M,N,'0 A =')
      do 20002 J=1,N
         call DHTCC(1,J,J+1,M,D(1,J),UPARAM,D(1,J+1),IDIM,M+N-J)
20002 continue
      call DMATP(D(1,N+1),IDIM,M,M,'0 Q [Transposed] =')
      D(2,1) = ZERO
      D(3,1) = ZERO
      D(3,2) = ZERO
      call DMATP(D,IDIM,M,N,'0 R =')
      stop
      end


program Apollonius
  implicit none

  integer, parameter :: dp = selected_real_kind(15)

  type circle
    real(dp) :: x
    real(dp) :: y
    real(dp) :: radius
  end type

  type(circle) :: c1 , c2, c3, r

  c1 = circle(0.0, 0.0, 1.0)
  c2 = circle(4.0, 0.0, 1.0)
  c3 = circle(2.0, 4.0, 2.0)

  write(*, "(a,3f12.8))") "External tangent:", SolveApollonius(c1, c2, c3, 1, 1, 1)
  write(*, "(a,3f12.8))") "Internal tangent:", SolveApollonius(c1, c2, c3, -1, -1, -1)

contains

function SolveApollonius(c1, c2, c3, s1, s2, s3) result(res)
  type(circle) :: res
  type(circle), intent(in) :: c1, c2, c3
  integer, intent(in) :: s1, s2, s3

  real(dp) :: x1, x2, x3, y1, y2, y3, r1, r2, r3
  real(dp) :: v11, v12, v13, v14
  real(dp) :: v21, v22, v23, v24
  real(dp) :: w12, w13, w14
  real(dp) :: w22, w23, w24
  real(dp) :: p, q, m, n, a, b, c, det

  x1 = c1%x; x2 = c2%x; x3 = c3%x
  y1 = c1%y; y2 = c2%y; y3 = c3%y
  r1 = c1%radius; r2 = c2%radius; r3 = c3%radius

  v11 = 2*x2 - 2*x1
  v12 = 2*y2 - 2*y1
  v13 = x1*x1 - x2*x2 + y1*y1 - y2*y2 - r1*r1 + r2*r2
  v14 = 2*s2*r2 - 2*s1*r1

  v21 = 2*x3 - 2*x2
  v22 = 2*y3 - 2*y2
  v23 = x2*x2 - x3*x3 + y2*y2 - y3*y3 - r2*r2 + r3*r3
  v24 = 2*s3*r3 - 2*s2*r2

  w12 = v12/v11
  w13 = v13/v11
  w14 = v14/v11

  w22 = v22/v21-w12
  w23 = v23/v21-w13
  w24 = v24/v21-w14

  p = -w23/w22
  q = w24/w22
  m = -w12*P - w13
  n = w14 - w12*q

  a = n*n + q*q - 1
  b = 2*m*n - 2*n*x1 + 2*p*q - 2*q*y1 + 2*s1*r1
  c = x1*x1 + m*m - 2*m*x1 + p*p + y1*y1 - 2*p*y1 - r1*r1

  det = b*b - 4*a*c
  res%radius = (-b-sqrt(det)) / (2*a)
  res%x = m + n*res%radius
  res%y = p + q*res%radius

end function
end program


submodule(nf_random) nf_random_submodule
  implicit none

  real, parameter :: pi = 4 * atan(1.d0)

contains

  module function randn_1d(i) result(x)
    integer, intent(in) :: i
    real :: x(i)
    real :: u(i), v(i)
    call random_number(u)
    call random_number(v)
    x = sqrt(-2 * log(u)) * cos(2 * pi * v)
  end function randn_1d

  module function randn_2d(i, j) result(x)
    integer, intent(in) :: i, j
    real :: x(i,j)
    real :: u(i,j), v(i,j)
    call random_number(u)
    call random_number(v)
    x = sqrt(-2 * log(u)) * cos(2 * pi * v)
  end function randn_2d

  module function randn_4d(i, j, k, l) result(x)
    integer, intent(in) :: i, j, k, l
    real :: x(i,j,k,l)
    real :: u(i,j,k,l), v(i,j,k,l)
    call random_number(u)
    call random_number(v)
    x = sqrt(-2 * log(u)) * cos(2 * pi * v)
  end function randn_4d

end submodule nf_random_submodule


REAL*8 function kern_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
kern_num = cos(x_a - x_b)*cos(y_a - y_b)
end function
REAL*8 function dkdx_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
dkdx_num = -sin(x_a - x_b)*cos(y_a - y_b)
end function
REAL*8 function dkdy_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
dkdy_num = -sin(y_a - y_b)*cos(x_a - x_b)
end function
REAL*8 function dkdx0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
dkdx0_num = sin(x_a - x_b)*cos(y_a - y_b)
end function
REAL*8 function dkdy0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
dkdy0_num = sin(y_a - y_b)*cos(x_a - x_b)
end function
REAL*8 function d2kdxdx0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d2kdxdx0_num = cos(x_a - x_b)*cos(y_a - y_b)
end function
REAL*8 function d2kdydy0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d2kdydy0_num = cos(x_a - x_b)*cos(y_a - y_b)
end function
REAL*8 function d2kdxdy0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d2kdxdy0_num = -sin(x_a - x_b)*sin(y_a - y_b)
end function
REAL*8 function d3kdxdx0dy0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d3kdxdx0dy0_num = sin(y_a - y_b)*cos(x_a - x_b)
end function
REAL*8 function d3kdydy0dy0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d3kdydy0dy0_num = sin(y_a - y_b)*cos(x_a - x_b)
end function
REAL*8 function d3kdxdy0dy0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d3kdxdy0dy0_num = sin(x_a - x_b)*cos(y_a - y_b)
end function
INTEGER*4 function dkdlx_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
dkdlx_num = 0
end function
INTEGER*4 function dkdly_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
dkdly_num = 0
end function
INTEGER*4 function d3kdxdx0dlx_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d3kdxdx0dlx_num = 0
end function
INTEGER*4 function d3kdydy0dlx_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d3kdydy0dlx_num = 0
end function
INTEGER*4 function d3kdxdy0dlx_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d3kdxdy0dlx_num = 0
end function
INTEGER*4 function d3kdxdx0dly_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d3kdxdx0dly_num = 0
end function
INTEGER*4 function d3kdydy0dly_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d3kdydy0dly_num = 0
end function
INTEGER*4 function d3kdxdy0dly_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d3kdxdy0dly_num = 0
end function


C-----------------------------------------------------------------------
      SUBROUTINE MOVECT(FLAT,FLON,TLAT,TLON,CROT,SROT)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:  MOVECT     MOVE A VECTOR ALONG A GREAT CIRCLE
C   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-04-10
C
C ABSTRACT: THIS SUBPROGRAM PROVIDES THE ROTATION PARAMETERS
C           TO MOVE A VECTOR ALONG A GREAT CIRCLE FROM ONE
C           POSITION TO ANOTHER WHILE CONSERVING ITS ORIENTATION
C           WITH RESPECT TO THE GREAT CIRCLE.  THESE ROTATION
C           PARAMETERS ARE USEFUL FOR VECTOR INTERPOLATION.
C
C PROGRAM HISTORY LOG:
C   96-04-10  IREDELL
C 1999-04-08  IREDELL  GENERALIZE PRECISION
C
C USAGE:    CALL MOVECT(FLAT,FLON,TLAT,TLON,CROT,SROT)
C
C   INPUT ARGUMENT LIST:
C     FLAT     - REAL LATITUDE IN DEGREES FROM WHICH TO MOVE THE VECTOR
C     FLON     - REAL LONGITUDE IN DEGREES FROM WHICH TO MOVE THE VECTOR
C     TLAT     - REAL LATITUDE IN DEGREES TO WHICH TO MOVE THE VECTOR
C     TLON     - REAL LONGITUDE IN DEGREES TO WHICH TO MOVE THE VECTOR
C
C   OUTPUT ARGUMENT LIST:
C     CROT     - REAL CLOCKWISE VECTOR ROTATION COSINE
C     SROT     - REAL CLOCKWISE VECTOR ROTATION SINE
C                (UTO=CROT*UFROM-SROT*VFROM;
C                 VTO=SROT*UFROM+CROT*VFROM)
C
C REMARKS: THIS SUBPROGRAM IS CORRECT TO SEVEN DIGITS ON THE CRAYS.
C          USE DOUBLE PRECISION IF BETTER PRECISION IS REQUIRED.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C
C$$$
      INTEGER,PARAMETER:: KD=SELECTED_REAL_KIND(15,45)
      REAL(KIND=KD):: PI,DPR,CRDLIM
      REAL(KIND=KD):: CTLAT,STLAT,CFLAT,SFLAT,CDLON,SDLON,CRD
      REAL(KIND=KD):: SRD2RN,STR,CTR,SFR,CFR
      PARAMETER(PI=3.14159265358979,DPR=180./PI)
      PARAMETER(CRDLIM=0.9999999)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  COMPUTE COSINE OF THE RADIAL DISTANCE BETWEEN THE POINTS.
      CTLAT=COS(TLAT/DPR)
      STLAT=SIN(TLAT/DPR)
      CFLAT=COS(FLAT/DPR)
      SFLAT=SIN(FLAT/DPR)
      CDLON=COS((FLON-TLON)/DPR)
      SDLON=SIN((FLON-TLON)/DPR)
      CRD=STLAT*SFLAT+CTLAT*CFLAT*CDLON
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  COMPUTE ROTATIONS AT BOTH POINTS WITH RESPECT TO THE GREAT CIRCLE
C  AND COMBINE THEM TO GIVE THE TOTAL VECTOR ROTATION PARAMETERS.
      IF(ABS(CRD).LE.CRDLIM) THEN
        SRD2RN=-1/(1-CRD**2)
        STR=CFLAT*SDLON
        CTR=CFLAT*STLAT*CDLON-SFLAT*CTLAT
        SFR=CTLAT*SDLON
        CFR=CTLAT*SFLAT*CDLON-STLAT*CFLAT
        CROT=SRD2RN*(CTR*CFR-STR*SFR)
        SROT=SRD2RN*(CTR*SFR+STR*CFR)
C  USE A DIFFERENT APPROXIMATION FOR NEARLY COINCIDENT POINTS.
C  MOVING VECTORS TO ANTIPODAL POINTS IS AMBIGUOUS ANYWAY.
      ELSE
        CROT=CDLON
        SROT=SDLON*STLAT
      ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      END


      double precision function pythag(a, b)
*
*     PURPOSE
*        computes sqrt(a^2 + b^2) with accuracy and
*        without spurious underflow / overflow problems
*
*     MOTIVATION
*        This work was motivated by the fact that the original Scilab
*        PYTHAG, which implements Moler and Morrison's algorithm is slow.
*        Some tests showed that the Kahan's algorithm, is superior in
*        precision and moreover faster than the original PYTHAG.  The speed
*        gain partly comes from not calling DLAMCH.
*
*     REFERENCE
*        This is a Fortran-77 translation of an algorithm by William Kahan,
*        which appears in his article "Branch cuts for complex elementary
*        functions, or much ado about nothing's sign bit",
*        Editors: Iserles, A. and Powell, M. J. D.
*        in "States of the Art in Numerical Analysis"
*        Oxford, Clarendon Press, 1987
*        ISBN 0-19-853614-3
*
*     AUTHOR
*        Bruno Pincon <Bruno.Pincon@iecn.u-nancy.fr>,
*        Thanks to Lydia van Dijk <lvandijk@hammersmith-consulting.com>
*
      implicit none

*     PARAMETERS
      double precision a, b

*     EXTERNAL FUNCTIONS
      integer          isanan
      external         isanan
      double precision dlamch
      external         dlamch

*     CONSTANTS
      double precision r2, r2p1, t2p1
*     These constants depend upon the floating point arithmetic of the
*     machine.  Here, we give them assuming radix 2 and a 53 bits wide
*     mantissa, correspond to IEEE 754 double precision format.  YOU
*     MUST RE-COMPUTE THESE CONSTANTS FOR A MACHINE THAT HAS DIFFERENT
*     CHARACTERISTIC!
*
*     (1) r2 must approximate sqrt(2) to machine precision.  The near
*         floating point from sqrt(2) is exactly:
*
*              r2 = (1.0110101000001001111001100110011111110011101111001101)_2
*                 = (1.4142135623730951454746218587388284504413604736328125)_10
*         sqrt(2) = (1.41421356237309504880168872420969807856967187537694807317...)_10
*
*     (2) r2p1 must approximate 1+sqrt(2) to machine precision.
*         The near floating point is exactly:
*
*          r2p1 = (10.011010100000100111100110011001111111001110111100110)_2
*               = (2.41421356237309492343001693370752036571502685546875)_10
*     sqrt(2)+1 = (2.41421356237309504880168872420969807856967187537694...)_10
*
*     (3) t2p1 must approximate 1+sqrt(2)-r2p1 to machine precision,
*         this is
*                 1.25371671790502177712854645019908198073176679... 10^(-16)
*         and the near float is exactly:
*                 (5085679199899093/40564819207303340847894502572032)_10
*          t2p1 = (1.253716717905021735741793363204945859....)_10
*
      parameter (  r2 = 1.41421356237309504d0,
     $           r2p1 = 2.41421356237309504d0,
     $           t2p1 = 1.25371671790502177d-16)
*     LOCAL VARIABLES
      double precision x, y
      double precision s, t, temp

*     STATIC VARIABLES
      double precision rmax
      save             rmax

      logical          first
      save             first
      data             first /.true./

*     TEXT
*     Initialize rmax with computed largest non-overflowing number
      if (first) then
          rmax = dlamch('o')
          first = .false.
      endif

*     Test for arguments being NaN
      if (isanan(a) .eq. 1) then
          pythag = a
          return
      endif
      if (isanan(b) .eq. 1) then
          pythag = b
          return
      endif

      x = abs(a)
      y = abs(b)

*     Order x and y such that 0 <= y <= x
      if (x .lt. y) then
          temp = x
          x = y
          y = temp
      endif

*     Test for overflowing x
      if (x .gt. rmax) then
          pythag = x
          return
      endif

*     Handle generic case
      t = x - y
      if (t .ne. x) then
          if (t .gt. y) then
*             2 < x/y < 2/epsm
              s = x / y
              s = s + sqrt(1d0 + s*s)
          else
*             1 <= x/y <= 2
              s = t / y
              t = (2d0 + s) * s
              s = ( ( t2p1 + t/(r2 + sqrt(2d0 + t)) ) + s ) + r2p1
          endif
          pythag = x + y/s
      else
          pythag = x
      endif
      end


C**********************************************************************
      subroutine  CURVEG(NC, NV, K1, A, B, NN, TSTEP, NT, T,V,X,Y,NSTEP)
C***********************************************************************
C   THE PROGRAM GENERATES NEW POINTS ON A CURVE BY LINEAR INTERPOLATION
C   USING AN ARITHMETIC OR A HALFLOGARITHMIC SCALE
C
C        NV(I)     =    NUMBER OF VALUES ON CURVE I
C        NC        =    NUMBER OF CURVES
C        K1        =    SWITCH    K1 = 1  ARITHMETIC SCALE
C                                 K1 = 2  HALFLOGARITHMIC SCALE
C        A,B       =    PARAMETERS FOR CALCULATING NEW VALUES
C                       Y = A*X + B
C        X,Y       =    KNOWN POINTS ON CURVE
C        T         =    VALUES ON ABSISSA WHERE NEW POINTS ARE GENERATED
C        V         =    NEW ORDINATE VALUES
C
C        ARITHMETIC SCALE  K1 = 1
C        NN        =    NUMBER OF INTERVALS
C        TSTEP     =    LARGEST VALUE IN EACH INTERVAL
C        NT        =    NUMBER OF STEPS IN EACH INTERVAL
C
C        HALFLOGARITHMIC SCALE
C        NN        =    NUMBER OF VALUES IN EACH LOG10
C
C   CODED BY PER B SCHNABEL SEPT 1970
C
C***********************************************************************
C
      dimension X(27,20),Y(27,20),A(27,20),B(27,20),NV(27),TSTEP(27)
      dimension NT(27), T(200), V(27,200)
C
      XMIN = 100000000.
      XMAX = 0.
      do L= 1,NC
        M = NV(L)
        if (XMAX .lt. X(L,M))   XMAX = X(L,M)
        if (XMIN .gt. X(L,1)) XMIN = X(L,1)
        M = M - 1
        do I = 1,M
          X1 = X(L,I)
          X2 = X(L,I+1)
          if (K1 .eq. 2)  X1 = ALOG10(X1)
          if (K1 .eq. 2)  X2 = ALOG10(X2)
          X(L,I) = X(L,I+1)
          A(L,I) = (Y(L,I+1) - Y(L,I))/(X2 - X1)
          B(L,I) = -A(L,I)*X1 + Y(L,I)
        end do
      end do
C
      call STEPG(K1, NN, TSTEP, NT, XMIN, XMAX, T, NSTEP)
C
      do L = 1,NC
        M = NV(L) - 1
        do I = 1,NSTEP
          do J = 1,M
            if (T(I) .lt. X(L,J))  go to  31
          end do
          J = M
   31     TT = T(I)
          if (K1 .eq. 2) TT = ALOG10(TT)
          V(L,I) = A(L,J)*TT  + B(L,J)
        end do
      end do
      return
      end


subroutine heat_init(blockno, mbc,mx,my,meqn, &
                           xlower,ylower,dx,dy,q)
    IMPLICIT NONE

    INTEGER mbc,mx,my, meqn, blockno
    DOUBLE PRECISION xlower,ylower,dx,dy
    DOUBLE PRECISION q(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)

    INTEGER i,j, m
    DOUBLE PRECISION xc,yc, heat_qexact, qe

    do i = 1-mbc,mx+mbc
        do j = 1-mbc,my+mbc
            xc = xlower + (i-0.5)*dx
            yc = ylower + (j-0.5)*dy
            qe = heat_qexact(xc,yc)
            q(i,j,1) = qe
        end do
    end do

end subroutine heat_init


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!  This file contains code for constructing Gauss-Jacobi quadrature rules.  The n-point
!  Gauss-Jacobi rule associated with the parameters (da,db) is the quadrature rule
!
!         1                           n
!    \int (1-x)^da (1+x)^db p(x) ~  \sum p(x_j) w_j                                       (1)
!        -1                          j=1
!
!  which is exact when p is a polynomial of degree 2n-1.  The n-point modified
!  Gauss-Jacoi quadrature rule is
!
!        \pi
!    \int    cos(t/2)^(2db+1) sin(t/2)^(2da+1) p(cos(t)) dt ~
!         0                                                                               (2)
!
!                    n
!                  \sum sin(t/2)^(2db+1) cos(t/2)^(2da+1) p(cos(t_j)) w_j .
!                   j=1
!
!  It is exact when p is a polynomial of degree less than or equal to 2n-1.  Note that
!  the importance of the modified rule is that it integrates products of the functions
!  obtained by introducing the change of variables x = cos(t) into Jacobi's differential
!  equation.
!
!  The following subroutines should be regarded as publicly callable:
!
!    jacobi_quad -  construct the quadrature rule (1)
!
!    jacobi_quad_mod - construct the quadrature rule (2)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

subroutine jacobi_quad(n,da,db,xs,whts)
use chebyshev
implicit double precision (a-h,o-z)
integer, intent(in)           :: n
double precision, intent(in)  :: da,db
double precision, intent(out) :: xs(n),whts(n)

!
!  Return the n-point Gauss-Jacobi rule (1).
!
!  Input parameters:
!    n - the length of the desired quadrature rule
!    (da,db) - the parameters for Jacobi's differential equation
!
!  Output parameters:
!    xs - this user-supplied vector of length n will contain the nodes of the
!      Gauss-Jacobi quadrature rule
!    whts - this user-supplied vector of length n will contain the quadrature
!      weights
!

double precision, allocatable :: ab(:,:),avals(:,:),psivals(:,:)
double precision, allocatable :: abinv(:,:),alphainv(:,:),alphainvp(:,:)

double precision, allocatable :: avals2(:,:),psivals2(:,:)
double precision, allocatable :: abinv2(:,:),alphainv2(:,:),alphainvp2(:,:)

type(chebexps_data)           :: chebdata
data  pi        / 3.14159265358979323846264338327950288d0 /

dnu = n
p   = dnu+(da+db+1)/2
k   = 20
call chebexps(k,chebdata)

!
!  Construct the phase function
!

nints = 50
allocate(ab(2,nints))
call jacobi_phase_disc(nints,ab)

allocate(avals(k,nints),psivals(k,nints))
allocate(avals2(k,nints),psivals2(k,nints))

call  jacobi_phase(chebdata,dnu,da,db,nints,ab,avals,psivals)
psivals = psivals*dnu
avals   = 1/avals**2

call  jacobi_phase(chebdata,dnu,db,da,nints,ab,avals2,psivals2)
psivals2 = psivals2*dnu
avals2   = 1/avals2**2

!
!  add dnu*t
!

do int=1,nints
a = ab(1,int)
b = ab(2,int)
psivals(:,int)  = psivals(:,int)  +  dnu * (chebdata%xs * (b-a)/2 + (b+a)/2)
psivals2(:,int) = psivals2(:,int) +  dnu * (chebdata%xs * (b-a)/2 + (b+a)/2)
end do

! determine the number of roots in (0,pi/2)

nroots = (psivals(k,nints/2)-psivals(1,1)) / pi

!
! Invert the phase function
!

allocate(abinv(2,nints),alphainv(k,nints),alphainvp(k,nints))

call jacobi_phase_inverse(nints,ab,chebdata%k,chebdata%xs,chebdata%aintl,chebdata%u, &
 psivals,avals,abinv,alphainv,alphainvp)

allocate(abinv2(2,nints),alphainv2(k,nints),alphainvp2(k,nints))

call jacobi_phase_inverse(nints,ab,chebdata%k,chebdata%xs,chebdata%aintl,chebdata%u, &
 psivals2,avals2,abinv2,alphainv2,alphainvp2)

!
!  Calculate the roots of P_n^(da,db)(cos(t)) in (0,pi)
!

dconst = pi *2.0d0**(da+db+1.0d0)

xs   = 0
whts = 0

xx   = pi/2
int0 = 1
do i=1,nroots
do int=int0,nints-1
if (xx .lt. abinv(2,int)) exit
end do
a    = abinv(1,int)
b    = abinv(2,int)
int0 = int
call chebeval(a,b,k,chebdata%xs,alphainv(:,int),xx,t)
xs(n-i+1)   = t
xx          =  xx + pi
end do

xx   = pi/2
int0 = 1
do i=1,n-nroots
do int=int0,nints-1
if (xx .lt. abinv2(2,int)) exit
end do
a    = abinv2(1,int)
b    = abinv2(2,int)
int0 = int
call chebeval(a,b,k,chebdata%xs,alphainv2(:,int),xx,t)
xs(i)   = t
xx      =  xx + pi
end do

!
!  Evaluate the corresponding weights
!

int0 = 1
do i=1,nroots
idx = n-i+1
t = xs(idx)

do int=int0,nints-1
if (t .lt. ab(2,int)) exit
end do
a    = ab(1,int)
b    = ab(2,int)
int0 = int
call chebeval(a,b,k,chebdata%xs,avals(:,int),t,apval)
r         = cos(t/2)**(2*db+1) * sin(t/2)**(2*da+1)
whts(idx) = dconst * r/apval

end do

int0 = 1
do i=1,n-nroots
idx = i
t   = xs(idx)

do int=int0,nints-1
if (t .lt. ab(2,int)) exit
end do
a    = ab(1,int)
b    = ab(2,int)
int0 = int
call chebeval(a,b,k,chebdata%xs,avals2(:,int),t,apval)
r         = cos(t/2)**(2*da+1) * sin(t/2)**(2*db+1)
whts(idx) = dconst * r/apval
xs(idx)   = pi-t
end do

xs = cos(xs)

end subroutine

subroutine jacobi_quad_mod(n,da,db,xs,whts)
use chebyshev
implicit double precision (a-h,o-z)
integer, intent(in)           :: n
double precision, intent(in)  :: da,db
double precision, intent(out) :: xs(n),whts(n)

!
!  Return the n-point modified Gauss-Jacobi rule (2).
!
!  Input parameters:
!    n - the length of the desired quadrature rule
!    (da,db) - the parameters for Jacobi's differential equation
!
!  Output parameters:
!    xs - this user-supplied vector of length n will contain the nodes of the
!      Gauss-Jacobi quadrature rule
!    whts - this user-supplied vector of length n will contain the quadrature
!      weights
!

double precision, allocatable :: ab(:,:),avals(:,:),psivals(:,:)
double precision, allocatable :: abinv(:,:),alphainv(:,:),alphainvp(:,:)

double precision, allocatable :: avals2(:,:),psivals2(:,:)
double precision, allocatable :: abinv2(:,:),alphainv2(:,:),alphainvp2(:,:)

type(chebexps_data)           :: chebdata
data  pi        / 3.14159265358979323846264338327950288d0 /

dnu = n
p   = dnu+(da+db+1)/2
k   = 20
call chebexps(k,chebdata)

!
!  Construct the phase function
!

nints = 50
allocate(ab(2,nints))
call jacobi_phase_disc(nints,ab)

allocate(avals(k,nints),psivals(k,nints))
allocate(avals2(k,nints),psivals2(k,nints))

call  jacobi_phase(chebdata,dnu,da,db,nints,ab,avals,psivals)
psivals = psivals*dnu
avals   = 1/avals**2

call  jacobi_phase(chebdata,dnu,db,da,nints,ab,avals2,psivals2)
psivals2 = psivals2*dnu
avals2   = 1/avals2**2

!
!  add dnu*t
!

do int=1,nints
a = ab(1,int)
b = ab(2,int)
psivals(:,int)  = psivals(:,int)  +  dnu * (chebdata%xs * (b-a)/2 + (b+a)/2)
psivals2(:,int) = psivals2(:,int) +  dnu * (chebdata%xs * (b-a)/2 + (b+a)/2)
end do

! determine the number of roots in (0,pi/2)

nroots = (psivals(k,nints/2)-psivals(1,1)) / pi

!
! Invert the phase function
!

allocate(abinv(2,nints),alphainv(k,nints),alphainvp(k,nints))

call jacobi_phase_inverse(nints,ab,chebdata%k,chebdata%xs,chebdata%aintl,chebdata%u, &
 psivals,avals,abinv,alphainv,alphainvp)

allocate(abinv2(2,nints),alphainv2(k,nints),alphainvp2(k,nints))

call jacobi_phase_inverse(nints,ab,chebdata%k,chebdata%xs,chebdata%aintl,chebdata%u, &
 psivals2,avals2,abinv2,alphainv2,alphainvp2)

!
!  Calculate the roots of P_n^(da,db)(cos(t)) in (0,pi)
!

xs   = 0
whts = 0

xx   = pi/2
int0 = 1
do i=1,nroots
do int=int0,nints-1
if (xx .lt. abinv(2,int)) exit
end do
a    = abinv(1,int)
b    = abinv(2,int)
int0 = int
call chebeval(a,b,k,chebdata%xs,alphainv(:,int),xx,t)
xs(i)       = t
xx          =  xx + pi
end do

xx   = pi/2
int0 = 1
do i=1,n-nroots
idx = n-i+1
do int=int0,nints-1
if (xx .lt. abinv2(2,int)) exit
end do
a    = abinv2(1,int)
b    = abinv2(2,int)
int0 = int
call chebeval(a,b,k,chebdata%xs,alphainv2(:,int),xx,t)
xs(idx)      = t
xx          =  xx + pi
end do

!
!  Evaluate the corresponding weights
!

int0 = 1
do i=1,nroots
t = xs(i)
do int=int0,nints-1
if (t .lt. ab(2,int)) exit
end do
a    = ab(1,int)
b    = ab(2,int)
int0 = int
call chebeval(a,b,k,chebdata%xs,avals(:,int),t,apval)
!r         = cos(t/2)**(2*db+1) * sin(t/2)**(2*da+1)
whts(i)  = pi/apval
end do

int0 = 1
do i=1,n-nroots
idx = n-i+1
t   = xs(idx)

do int=int0,nints-1
if (t .lt. ab(2,int)) exit
end do
a    = ab(1,int)
b    = ab(2,int)
int0 = int
call chebeval(a,b,k,chebdata%xs,avals2(:,int),t,apval)
whts(idx) = pi /apval
xs(idx)   = pi-t
end do

! do i=1,n
! print *,xs(i),whts(i)
! end do
!xs = cos(xs)

end subroutine

subroutine jacobi_quad_mod2(n,da,db,xs,whts)
use chebyshev
implicit double precision (a-h,o-z)
integer, intent(in)           :: n
double precision, intent(in)  :: da,db
double precision, intent(out) :: xs(n),whts(n)

!
!  Return the modin-point Gauss-Jacobi rule (2).
!
!  Input parameters:
!    n - the length of the desired quadrature rule
!    (da,db) - the parameters for Jacobi's differential equation
!
!  Output parameters:
!    xs - this user-supplied vector of length n will contain the nodes of the
!      Gauss-Jacobi quadrature rule
!    whts - this user-supplied vector of length n will contain the quadrature
!      weights
!

double precision, allocatable :: ab(:,:),avals(:,:),psivals(:,:)
double precision, allocatable :: abinv(:,:),alphainv(:,:),alphainvp(:,:)
type(chebexps_data)           :: chebdata
data  pi        / 3.14159265358979323846264338327950288d0 /

dnu = n
p   = dnu+(da+db+1)/2
k   = 20
call chebexps(k,chebdata)

!
!  Construct the phase function
!

nints = 50
allocate(ab(2,nints))
call jacobi_phase_disc(nints,ab)

allocate(avals(k,nints),psivals(k,nints))
call  jacobi_phase(chebdata,dnu,da,db,nints,ab,avals,psivals)
#ifdef OVERDNU
psivals = psivals*dnu
#endif
avals   = 1/avals**2

!
!  add p*t and multiply by p
!

do int=1,nints
a = ab(1,int)
b = ab(2,int)
psivals(:,int) = psivals(:,int) +  dnu * (chebdata%xs * (b-a)/2 + (b+a)/2)
end do

!
! Invert the phase function
!

allocate(abinv(2,nints),alphainv(k,nints),alphainvp(k,nints))

call jacobi_phase_inverse(nints,ab,chebdata%k,chebdata%xs,chebdata%aintl,chebdata%u, &
 psivals,avals,abinv,alphainv,alphainvp)

!
!  Calculate the roots of P_n^(da,db)(cos(t)) in (0,pi)
!

xx   = pi/2
int0 = 1
do i=1,n
do int=int0,nints-1
if (xx .lt. abinv(2,int)) exit
end do
a    = abinv(1,int)
b    = abinv(2,int)
int0 = int
call chebeval(a,b,k,chebdata%xs,alphainv(:,int),xx,xs(i))
xx = xx + pi
end do

!
!  Evaluate the corresponding weights
!

dconst = pi

int0 = 1
do i=1,n
idx = i
t = xs(idx)

do int=int0,nints-1
if (t .lt. ab(2,int)) exit
end do
a    = ab(1,int)
b    = ab(2,int)
int0 = int
call chebeval(a,b,k,chebdata%xs,avals(:,int),t,apval)
whts(idx) = dconst/apval

end do

end subroutine

subroutine jacobi_phase_inverse(nints,ab,k,xscheb,chebintl,ucheb,alpha,alphap,&
    abinv,alphainv,alphainvp)
use chebyshev
implicit double precision (a-h,o-z)

integer, intent(in)                        :: nints,k
double precision, intent(in)               :: xscheb(k),ab(2,nints),chebintl(k,k)
double precision, intent(in)               :: alpha(k,nints),alphap(k,nints),ucheb(k,k)
double precision, intent(out)              :: alphainv(k,nints),alphainvp(k,nints),abinv(2,nints)

!
!  Compute the inverse of the phase function alpha via Newton's method.
!
!  Input parameters:
!    (nints,ab) - the discretization scheme for representing the phase
!      function alpha
!    k - the number of terms in the piecewise Chebyshev expansions used to
!      represent the solution
!    xscheb - the nodes of the k-point Chebyshev grid on the interval [-1,1]
!    chebintl - the left Chebyshev spectral integration matrix as returned by
!      chebexps
!    chebintr - the right Chebyshev spectral integration matrix as returned by
!      chebexps
!    ucheb - the values-to-coefficients matrix returned by chebexps
!
!  Output parameters:
!
!    (nints,abinv) - the discretization scheme used to represent the inverse of
!      alpha
!   alphainv - a (k,nints) array specifying the values of the inverse of
!     alpha at the nodes of the k-point Chebyshev grids on the intervals
!     in the discretization scheme
!
!   alphainvp - a (k,nints) array specifying the values of the derivative of
!     the inverse of alpha at the nodes of the k-point Chebyshev grids on the
!     intervals in the discretization scheme
!
!

eps0     = epsilon(0.0d0)
maxiters = 12
eps0     = sqrt(eps0)
nextra   = 3

!
!  Form the initial list of intervals for the inverse function.
!

do int=1,nints
a = ab(1,int)
b = ab(2,int)

call chebpw_eval(nints,ab,k,xscheb,alpha,a,a0)
call chebpw_eval(nints,ab,k,xscheb,alpha,b,b0)

abinv(1,int) = a0
abinv(2,int) = b0

end do

!
!  Use Newton's method to evaluate the inverse at each of the Chebyhev nodes
!  on the grid defined by abinv; start at the right-hand side since alpha
!  is monotonically increasing.
!

do int = nints,1,-1

a0 = abinv(1,int)
b0 = abinv(2,int)
a  = ab(1,int)
b  = ab(2,int)

do i = k,1,-1

x  = (b0-a0)/2*xscheb(i) + (b0+a0)/2
t  = (b-a)/2*xscheb(i) + (b+a)/2

do iter=1,maxiters+1

if (iter .eq. maxiters+1) then
call prina("in kummer_phase_invert: maximum number of Newton iterations exceeded")
stop
endif

call chebpw_eval(nints,ab,k,xscheb,alpha,t,val)
call chebpw_eval(nints,ab,k,xscheb,alphap,t,der)

delta = (val-x)/der

if (abs(delta) .lt. eps0*(1+abs(t))) exit
t     = t - delta

end do

do iextra=1,nextra

call chebpw_eval(nints,ab,k,xscheb,alpha,t,val)
call chebpw_eval(nints,ab,k,xscheb,alphap,t,der)

delta = (val-x)/der
t     = t - delta

end do

alphainv(i,int)  = t
alphainvp(i,int) = 1.0d0/der

end do
end do

end subroutine


!---------------------------------------------------------------!
!
!     Written by Quinn MacPherson 8/4/17
!---------------------------------------------------------------!
subroutine y2_calc(u, Y2real)
   use params, only: dp, pi
   implicit none

!real(dp), parameter :: pi=3.14159265359_dp

   real(dp), intent(in) :: u(3)
   real(dp), intent(out), dimension(-2:2) :: Y2real
   real(dp), parameter, dimension(-2:2) :: coefficient = (/0.5_dp*sqrt(15.0_dp/pi), &
                                                           0.5_dp*sqrt(15.0_dp/pi), &
                                                           0.25_dp*sqrt(5.0_dp/pi), &
                                                           0.5_dp*sqrt(15.0_dp/pi), &
                                                           0.25_dp*sqrt(15.0_dp/pi)/)
   Y2real(-2) = coefficient(-2)*u(1)*u(2)
   Y2real(-1) = coefficient(-1)*u(2)*u(3)
   Y2real(0) = coefficient(0)*(2*u(3)**2 - u(1)**2 - u(2)**2)
   Y2real(1) = coefficient(1)*u(3)*u(1)
   Y2real(2) = coefficient(2)*(u(1)**2 - u(2)**2)
   RETURN
END

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


! created by EverLookNeverSee@GitHub on 05/26/20
! This program computes slope of the chord in given function.

!               y = sqrt(x) ,       if 0 =< x =< 1
! y = f(x) -->
!               y = e ** (1 - x) ,  if x > 1

function f(x)
    if (x >= 0. .and. x<= 1.) then
        f = sqrt(x)
    elseif (x > 1.) then
        f = exp(1. - x)
    else
        print *, "Function not defined."
    end if
    return
end function f

program main
    slope = (f(0.5) - f(2.)) / 0.5 - 2.0
    print *, slope
end program main


! =============================================================================
!               This module contains all ellipse operations.
! =============================================================================
module parcel_ellipse
    use constants, only : pi   &
                        , fpi  &
                        , zero &
                        , two  &
                        , f12  &
                        , f14
    implicit none

    contains

        ! Obtain the largest eigenvalue (i.e. the semi-major axis squared [a**2])
        ! @param[in] B11 is the B matrix (1, 1) element
        ! @param[in] B12 is the B matrix (1, 2) element
        ! @param[in] B22 is the B matrix (2, 2) element
        ! @returns the largest eigenvalue
        function get_eigenvalue(B11, B12, B22) result(a2)
            double precision, intent(in) :: B11
            double precision, intent(in) :: B12
            double precision, intent(in) :: B22
            double precision             :: a2

            a2 = f12 * (B11 + B22) + dsqrt(f14 * (B11 - B22) ** 2 + B12 ** 2)
        end function get_eigenvalue

        ! Obtain the eigenvector of the largest eigenvalue
        ! @param[in] a2 is the largest eigenvalue
        ! @param[in] B11 is the B matrix (1, 1) element
        ! @param[in] B12 is the B matrix (1, 2) element
        ! @param[in] B22 is the B matrix (2, 2) element
        ! @returns the eigenvector
        function get_eigenvector(a2, B11, B12, B22) result(evec)
            double precision, intent(in) :: a2
            double precision, intent(in) :: B11
            double precision, intent(in) :: B12
            double precision, intent(in) :: B22
            double precision             :: evec(2)

            evec(1) = a2 - B22
            evec(2) = B12

            if (dabs(evec(1)) + dabs(evec(2)) == zero) then
                if (B11 > B22) then
                    evec(1) = evec(1) + epsilon(evec(1))
                else
                    evec(2) = evec(2) + epsilon(evec(2))
                endif
            endif

            evec = evec / norm2(evec)

        end function get_eigenvector

        ! used in unit tests only
        function get_angle(B11, B12, volume) result(angle)
            double precision, intent(in) :: B11
            double precision, intent(in) :: B12
            double precision, intent(in) :: volume
            double precision             :: B22
            double precision             :: a2
            double precision             :: evec(2)
            double precision             :: angle

            B22 = get_B22(B11, B12, volume)

            a2 = get_eigenvalue(B11, B12, B22)

            evec = get_eigenvector(a2, B11, B12, B22)

            angle = datan2(evec(2), evec(1))

        end function get_angle

        ! Obtain the B22 matrix element
        ! @param[in] B11 is the B matrix (1, 1) element
        ! @param[in] B12 is the B matrix (1, 2) element
        ! @param[in] volume of the parcel
        ! @returns B22
        elemental function get_B22(B11, B12, volume) result(B22)
            double precision, intent(in) :: B11
            double precision, intent(in) :: B12
            double precision, intent(in) :: volume
            double precision             :: B22
            double precision             :: ab

            ab = get_ab(volume)

            B22 = (ab ** 2 + B12 ** 2) / B11

        end function get_B22

        ! Obtain the product of the semi-minor and semi-major axis.
        ! @param[in] volume of the parcel
        ! @returns ab = volume / pi
        elemental function get_ab(volume) result(ab)
            double precision, intent(in) :: volume
            double precision             :: ab

            ab = volume * fpi
        end function

        ! Obtain the aspect ratio a/b of the parcel(s).
        ! @param[in] a2 is the largest eigenvalue
        ! @param[in] volume of the parcel(s)
        ! @returns lam = a/b
        elemental function get_aspect_ratio(a2, volume) result(lam)
            double precision, intent(in) :: a2
            double precision, intent(in) :: volume
            double precision             :: lam

            lam = (a2 / volume) * pi
        end function

        ! Obtain the ellipse support points for par2grid and grid2par
        ! @param[in] position vector of the parcel
        ! @param[in] volume of the parcel
        ! @param[in] B matrix elements of the parcel
        ! @returns the parcel support points
        function get_ellipse_points(position, volume, B) result(points)
            double precision, intent(in) :: position(2)
            double precision, intent(in) :: volume
            double precision, intent(in) :: B(2)        ! B11, B12
            double precision             :: B22
            double precision             :: c
            double precision             :: a2
            double precision             :: evec(2)
            double precision             :: h(2)
            double precision             :: points(2, 2)

            B22 = get_B22(B(1), B(2), volume)

            a2 = get_eigenvalue(B(1), B(2), B22)

            c = dsqrt(dabs(two * a2 - B(1) - B22))

            evec = get_eigenvector(a2, B(1), B(2), B22)

            h = f12 * c * evec

            points(:, 1) = position - h
            points(:, 2) = position + h

        end function get_ellipse_points
end module parcel_ellipse


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c ... file islapgc.f
c
c     this file includes documentation and code for
c     subroutine islapgc         i
c
c ... files which must be loaded with islapgc.f
c
c     sphcom.f, hrfft.f, shagc.f, shsgc.f
c
c     subroutine islapgc(nlat,nlon,isym,nt,xlmbda,sf,ids,jds,a,b,
c    +mdab,ndab,wshsgc,lshsgc,work,lwork,pertrb,ierror)
c
c     islapgc inverts the laplace or helmholz operator on a Gaussian
c     grid using o(n**2) storage. given the
c     spherical harmonic coefficients a(m,n) and b(m,n) of the right
c     hand side slap(i,j), islapgc computes a solution sf(i,j) to
c     the following helmhotz equation :
c
c           2                2
c     [d(sf(i,j))/dlambda /sint + d(sint*d(sf(i,j))/dtheta)/dtheta]/sint
c
c                   - xlmbda * sf(i,j) = slap(i,j)
c
C*PL*ERROR* Comment line too long
c      where sf(i,j) is computed at the Gaussian colatitude point theta(i)
c      (see nlat as an input argument) and longitude
c
c                 lambda(j) = (j-1)*2*pi/nlon
c
c            for i=1,...,nlat and j=1,...,nlon.
c
c
c     input parameters
c
c     nlat   the number of points in the gaussian colatitude grid on the
C*PL*ERROR* Comment line too long
c            full sphere. these lie in the interval (0,pi) and are computed
C*PL*ERROR* Comment line too long
c            in radians in theta(1) <...< theta(nlat) by subroutine gaqd.
C*PL*ERROR* Comment line too long
c            if nlat is odd the equator will be included as the grid point
c            theta((nlat+1)/2).  if nlat is even the equator will be
c            excluded as a grid point and will lie half way between
c            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
c            note: on the half sphere, the number of grid points in the
c            colatitudinal direction is nlat/2 if nlat is even or
c            (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct longitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than zero. the axisymmetric case corresponds to nlon=1.
c            the efficiency of the computation is improved when nlon
c            is a product of small prime numbers.
c
C*PL*ERROR* Comment line too long
c     isym   this parameter should have the same value input to subroutine
C*PL*ERROR* Comment line too long
c            shagc to compute the coefficients a and b for the scalar field
c            slap.  isym is set as follows:
c
c            = 0  no symmetries exist in slap about the equator. scalar
c                 synthesis is used to compute sf on the entire sphere.
c                 i.e., in the array sf(i,j) for i=1,...,nlat and
c                 j=1,...,nlon.
c
c           = 1  sf and slap are antisymmetric about the equator. the
c                synthesis used to compute sf is performed on the
c                northern hemisphere only.  if nlat is odd, sf(i,j) is
c                computed for i=1,...,(nlat+1)/2 and j=1,...,nlon.  if
c                nlat is even, sf(i,j) is computed for i=1,...,nlat/2
c                and j=1,...,nlon.
c
c
c           = 2  sf and slap are symmetric about the equator. the
c                synthesis used to compute sf is performed on the
c                northern hemisphere only.  if nlat is odd, sf(i,j) is
c                computed for i=1,...,(nlat+1)/2 and j=1,...,nlon.  if
c                nlat is even, sf(i,j) is computed for i=1,...,nlat/2
c                and j=1,...,nlon.
c
c
c   nt       the number of solutions. in the program that calls islapgc
c            the arrays sf,a, and b can be three dimensional in which
c            case multiple solutions are computed. the third index
c            is the solution index with values k=1,...,nt.
c            for a single solution set nt=1. the description of the
c            remaining parameters is simplified by assuming that nt=1
c            and sf,a,b are two dimensional.
c
c   xlmbda   a one dimensional array with nt elements. if xlmbda is
c            is identically zero islapgc solves poisson's equation.
c            if xlmbda > 0.0 islapgc solves the helmholtz equation.
c            if xlmbda < 0.0 the nonfatal error flag ierror=-1 is
c            returned. negative xlambda could result in a division
c            by zero.
c
c   ids      the first dimension of the array sf as it appears in the
C*PL*ERROR* Comment line too long
c            program that calls islapgc.  if isym = 0 then ids must be at
c            least nlat.  if isym > 0 and nlat is even then ids must be
c            at least nlat/2. if isym > 0 and nlat is odd then ids must
c            be at least (nlat+1)/2.
c
c   jds      the second dimension of the array sf as it appears in the
c            program that calls islapgc. jds must be at least nlon.
c
c
c   a,b      two or three dimensional arrays (see input parameter nt)
c            that contain scalar spherical harmonic coefficients
c            of the scalar field slap. a,b must be computed by shagc
c            prior to calling islapgc.
c
c
c   mdab     the first dimension of the arrays a and b as it appears
c            in the program that calls islapgc.  mdab must be at
c            least min0(nlat,(nlon+2)/2) if nlon is even or at least
c            min0(nlat,(nlon+1)/2) if nlon is odd.
c
c   ndab     the second dimension of the arrays a and b as it appears
c            in the program that calls islapgc. ndbc must be at least
c            least nlat.
c
c            mdab,ndab should have the same values input to shagc to
c            compute the coefficients a and b.
c
c     wshsgc an array which must be initialized by subroutine shsgci
c            once initialized, wshsgc can be used repeatedly by islapgc
c            as long as nlon and nlat remain unchanged.  wshsgc must
c            not be altered between calls of islapgc.
c
c
c    lshsgc  the dimension of the array wshsgc as it appears in the
c            program that calls islapgc.  let
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lshsgc must be at least
c
c               nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15
c
c     work   a work array that does not have to be saved.
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls islapgc. define
c
c               l2 = nlat/2                    if nlat is even or
c               l2 = (nlat+1)/2                if nlat is odd
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            if isym = 0 let
c
c               lwkmin = nlat*(2*nt*nlon+max0(6*l2,nlon)+2*nt*l1+1).
c
c            if isym > 0 let
c
C*PL*ERROR* Comment line too long
c               lwkmin = l2*(2*nt*nlon+max0(6*nlat,nlon))+nlat*(2*nt*l1+1)
c
c
c     then lwork must be greater than or equal to lwkmin (see ierror=10)
c
c     **************************************************************
c
c     output parameters
c
c
C*PL*ERROR* Comment line too long
c    sf      a two or three dimensional arrays (see input parameter nt) that
c            inverts the scalar laplacian in slap.  sf(i,j) is given at
c            the colatitude
c
c                 theta(i) = (i-1)*pi/(nlat-1)
c
c            and longitude
c
c                 lambda(j) = (j-1)*2*pi/nlon
c
c            for i=1,...,nlat and j=1,...,nlon.
c
c   pertrb  a one dimensional array with nt elements (see input
c           parameter nt). in the discription that follows we assume
c           that nt=1. if xlmbda > 0.0 then pertrb=0.0 is always
c           returned because the helmholtz operator is invertible.
c           if xlmbda = 0.0 then a solution exists only if a(1,1)
c           is zero. islapgc sets a(1,1) to zero. the resulting
c           solution sf(i,j) solves poisson's equation with
c           pertrb = a(1,1)/(2.*sqrt(2.)) subtracted from the
c           right side slap(i,j).
c
C*PL*ERROR* Comment line too long
c  ierror    a parameter which flags errors in input parameters as follows:
c
c            = 0  no errors detected
c
c            = 1  error in the specification of nlat
c
c            = 2  error in the specification of nlon
c
c            = 3  error in the specification of ityp
c
c            = 4  error in the specification of nt
c
c            = 5  error in the specification of ids
c
c            = 6  error in the specification of jds
c
c            = 7  error in the specification of mdbc
c
c            = 8  error in the specification of ndbc
c
c            = 9  error in the specification of lshsgc
c
c            = 10 error in the specification of lwork
c
c
c **********************************************************************
c
c     end of documentation for islapgc
c
c **********************************************************************
c
      SUBROUTINE DISLAPGC(NLAT,NLON,ISYM,NT,XLMBDA,SF,IDS,JDS,A,B,MDAB,
     +                   NDAB,WSHSGC,LSHSGC,WORK,LWORK,PERTRB,IERROR)
      DOUBLE PRECISION XLMBDA
      DOUBLE PRECISION SF
      DOUBLE PRECISION A
      DOUBLE PRECISION B
      DOUBLE PRECISION WSHSGC
      DOUBLE PRECISION WORK
      DOUBLE PRECISION PERTRB
      DIMENSION SF(IDS,JDS,NT),A(MDAB,NDAB,NT),B(MDAB,NDAB,NT)
      DIMENSION WSHSGC(LSHSGC),WORK(LWORK),XLMBDA(NT),PERTRB(NT)
c
c     check input parameters
c
      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.4) RETURN
      IERROR = 3
      IF (ISYM.LT.0 .OR. ISYM.GT.2) RETURN
      IERROR = 4
      IF (NT.LT.0) RETURN
      IERROR = 5
      IMID = (NLAT+1)/2
      IF ((ISYM.EQ.0.AND.IDS.LT.NLAT) .OR.
     +    (ISYM.GT.0.AND.IDS.LT.IMID)) RETURN
      IERROR = 6
      IF (JDS.LT.NLON) RETURN
      IERROR = 7
      MMAX = MIN0(NLAT,NLON/2+1)
      IF (MDAB.LT.MMAX) RETURN
      IERROR = 8
      IF (NDAB.LT.NLAT) RETURN
      IERROR = 9
c
c     set and verify saved work space length
c
c
      L1 = MIN0(NLAT, (NLON+2)/2)
      L2 = (NLAT+1)/2
      LWMIN = NLAT* (2*L2+3*L1-2) + 3*L1* (1-L1)/2 + NLON + 15
      IF (LSHSGC.LT.LWMIN) RETURN
      IERROR = 10
c
c     set and verify unsaved work space length
c
      LS = NLAT
      IF (ISYM.GT.0) LS = IMID
      NLN = NT*LS*NLON
      MN = MMAX*NLAT*NT
c     lwmin = nln+ls*nlon+2*mn+nlat
c     if (lwork .lt. lwmin) return
      IF (ISYM.EQ.0) THEN
          LWMIN = NLAT* (2*NT*NLON+MAX0(6*L2,NLON)+2*L1*NT+1)
      ELSE
          LWMIN = L2* (2*NT*NLON+MAX0(6*NLAT,NLON)) + NLAT* (2*L1*NT+1)
      END IF
      IF (LWORK.LT.LWMIN) RETURN
      IERROR = 0
c
c     check sign of xlmbda
c
      DO K = 1,NT
          IF (XLMBDA(K).LT.0.0D0) THEN
              IERROR = -1
          END IF
      END DO
c
c     set work space pointers
c
      IA = 1
      IB = IA + MN
      IFN = IB + MN
      IWK = IFN + NLAT
      LWK = LWORK - 2*MN - NLAT
      CALL DISLPGC1(NLAT,NLON,ISYM,NT,XLMBDA,SF,IDS,JDS,A,B,MDAB,NDAB,
     +             WORK(IA),WORK(IB),MMAX,WORK(IFN),WSHSGC,LSHSGC,
     +             WORK(IWK),LWK,PERTRB,IERROR)
      RETURN
      END

      SUBROUTINE DISLPGC1(NLAT,NLON,ISYM,NT,XLMBDA,SF,IDS,JDS,A,B,MDAB,
     +                   NDAB,AS,BS,MMAX,FNN,WSAV,LSAV,WK,LWK,PERTRB,
     +                   IERROR)
      DOUBLE PRECISION XLMBDA
      DOUBLE PRECISION SF
      DOUBLE PRECISION A
      DOUBLE PRECISION B
      DOUBLE PRECISION AS
      DOUBLE PRECISION BS
      DOUBLE PRECISION FNN
      DOUBLE PRECISION WSAV
      DOUBLE PRECISION WK
      DOUBLE PRECISION PERTRB
      DOUBLE PRECISION FN
      DIMENSION SF(IDS,JDS,NT),A(MDAB,NDAB,NT),B(MDAB,NDAB,NT)
      DIMENSION AS(MMAX,NLAT,NT),BS(MMAX,NLAT,NT),FNN(NLAT)
      DIMENSION WSAV(LSAV),WK(LWK),XLMBDA(NT),PERTRB(NT)
c
c     set multipliers and preset synthesis coefficients to zero
c
      DO N = 1,NLAT
          FN = DBLE(N-1)
          FNN(N) = FN* (FN+1.0D0)
          DO M = 1,MMAX
              DO K = 1,NT
                  AS(M,N,K) = 0.0D0
                  BS(M,N,K) = 0.0D0
              END DO
          END DO
      END DO

      DO K = 1,NT
c
c     compute synthesis coefficients for xlmbda zero or nonzero
c
          IF (XLMBDA(K).EQ.0.0D0) THEN
              DO N = 2,NLAT
                  AS(1,N,K) = -A(1,N,K)/FNN(N)
                  BS(1,N,K) = -B(1,N,K)/FNN(N)
              END DO
              DO M = 2,MMAX
                  DO N = M,NLAT
                      AS(M,N,K) = -A(M,N,K)/FNN(N)
                      BS(M,N,K) = -B(M,N,K)/FNN(N)
                  END DO
              END DO
          ELSE
c
c     xlmbda nonzero so operator invertible unless
c     -n*(n-1) = xlmbda(k) < 0.0  for some n
c
              PERTRB(K) = 0.0D0
              DO N = 1,NLAT
                  AS(1,N,K) = -A(1,N,K)/ (FNN(N)+XLMBDA(K))
                  BS(1,N,K) = -B(1,N,K)/ (FNN(N)+XLMBDA(K))
              END DO
              DO M = 2,MMAX
                  DO N = M,NLAT
                      AS(M,N,K) = -A(M,N,K)/ (FNN(N)+XLMBDA(K))
                      BS(M,N,K) = -B(M,N,K)/ (FNN(N)+XLMBDA(K))
                  END DO
              END DO
          END IF
      END DO
c
c     synthesize as,bs into sf
c
      CALL DSHSGC(NLAT,NLON,ISYM,NT,SF,IDS,JDS,AS,BS,MMAX,NLAT,WSAV,
     +            LSAV,WK,LWK,IERROR)
      RETURN
      END


program ex4p2_dist1
    use mt_mod
    implicit none
    integer, parameter:: ik=selected_int_kind(11), rk=selected_real_kind(11,100), counts=100, distrs=10000
    integer :: err, i, j, k
    integer(kind=ik), dimension(39) :: x, y
    real(kind=rk), dimension(1000) :: h=0
    integer(kind=ik), dimension(distrs, counts) :: D_k=0
    real(kind=rk) :: mean_t, mean_w=0, dx_bar=1, u, x_low, x_up, x_bar

    call init_genrand64(int(1234765, ik))

    !Read data
    open(1, action="read", file="distr1.dat", status="old")
    do i=1, 39
        read(1, *) x(i), y(i)
    end do
    close(1)

    !True mean (weighted)
    do j=1, size(y)
        mean_t=mean_t+y(j)*x(j)
    end do
    mean_t=mean_t/real(sum(y), rk)

    !Generate synthetic data to D_k and store their means to h
    do i=1, distrs
        D_k(i,:) = 0
        do j=1, counts
            u=real(sum(y), rk)*genrand64_real3()
            k=1
            do
                if(F_k(int(k-1, ik))<u.and.u<=F_k(int(k, ik))) exit
                k=k+1
            end do
            D_k(i,k) = D_k(i,k) + 1
        end do

        do j=1, counts
            mean_w=mean_w+D_k(i,j)*j
        end do
        mean_w=mean_w/sum(D_k(i,:))*39

        j=int(mean_w/dx_bar)
        h(j) = h(j) + 1
        mean_w=0
    end do

    !Lower and upper uncertainties
    do k=1, size(h)
        if(H_k(k)<0.165.and.H_k(k)>=0.155) then
            x_low=k
            exit
        end if
    end do

    do k=1, size(h)
        if(H_k(k)<0.845.and.H_k(k)>=0.835) then
            x_up=k
            exit
        end if
    end do

    !Results
    print*, "Lower and upper uncertainty respectively:"
    print*, mean_t-x_low, x_up-mean_t
    print*, "Error assuming Gaussian shape:"
    do i=1, size(x)
        x(i)=x(i)*x(i)
    end do
    x_bar=sum(x)/real(size(x), rk)
    print*,1/sqrt(real(size(x),rk))*sqrt(x_bar-mean_t**2)

    !Save data, this part was changed as needed
    open(1, action="write", file="data_distr1.txt", status="replace", position="append")
    do i=1, size(h)
        write(1, *) H_k(i), i
    end do
    close(1)

contains

!Cumulative function F
real(kind=rk) function F_k(k)
    implicit none
    integer(kind=ik), intent(in) :: k
    F_k=sum(y(:k))
end function

!Cumulative function H
real(kind=rk) function H_k(k)
    implicit none
    integer, intent(in) :: k
    H_k=sum(h(:k))/real(sum(h), rk)
end function

end program ex4p2_dist1


SUBROUTINE eta_nonlinear_standing(H,Lx,x,omega,time,eta,etax,etaxx,etat)
!
USE Precision
USE Constants
IMPLICIT NONE
REAL(KIND=long), INTENT(IN)  :: H,Lx,x,omega,time
REAL(KIND=long), INTENT(OUT) :: eta,etax
REAL(KIND=long), INTENT(OUT) :: etaxx,etat
! REAL(KIND=long), OPTIONAL :: y,etay,etayy !Boundary fitted ?
! Local variables
REAL(KIND=long) :: kx, half_H, sinkx
!
REAL(KIND=long) :: HH,k,w,ky,y,Ly
!
y = zero ; Ly = zero ; ky = zero
kx    = two*pi/Lx
k = SQRT(kx**2+ky**2)
w = omega
HH = H
!
eta   =  half*HH*COS(w*time)*COS(kx*X)*COS(ky*Y)
etax  = -kx*half*HH*COS(w*time)*SIN(kx*X)*COS(ky*Y)
etaxx = -kx**2*half*HH*COS(w*time)*COS(kx*X)*COS(ky*Y)
etat  = -half*w*HH*SIN(w*time)*COS(kx*X)*COS(ky*Y)

END SUBROUTINE eta_nonlinear_standing


	!--------------------------------------------------------------------
	!
	!
	! PURPOSE
	!
	! This program solves nonlinear Klein-Gordon equation in 3 dimensions
	! u_{tt}-(u_{xx}+u_{yy}+u_{zz})+u=Es*|u|^2u
	! using a second order implicit-explicit time stepping scheme.
	!
	! The boundary conditions are u(x=-Lx*pi,y,z)=u(x=Lx*\pi,y,z),
	!	u(x,y=-Ly*pi,z)=u(x,y=Ly*pi,z),u(x,y,z=-Ly*pi)=u(x,y,z=Ly*pi),
	! The initial condition is u=0.5*exp(-x^2-y^2-z^2)*sin(10*x+12*y)
	!
	! .. Parameters ..
	!  Nx				= number of modes in x - power of 2 for FFT
	!  Ny				= number of modes in y - power of 2 for FFT
	!  Nz				= number of modes in z - power of 2 for FFT
	!  Nt				= number of timesteps to take
	!  Tmax				= maximum simulation time
	!  plotgap			= number of timesteps between plots
	!  FFTW_IN_PLACE 	= value for FFTW input
	!  FFTW_MEASURE 	= value for FFTW input
	!  FFTW_EXHAUSTIVE 	= value for FFTW input
	!  FFTW_PATIENT 	= value for FFTW input
	!  FFTW_ESTIMATE 	= value for FFTW input
	!  FFTW_FORWARD     = value for FFTW input
	!  FFTW_BACKWARD	= value for FFTW input
	!  pi = 3.14159265358979323846264338327950288419716939937510d0
	!  Lx				= width of box in x direction
	!  Ly				= width of box in y direction
	!  Lz				= width of box in z direction
	!  ES				= +1 for focusing and -1 for defocusing
	! .. Scalars ..
	!  i				= loop counter in x direction
	!  j				= loop counter in y direction
	!  k				= loop counter in z direction
	!  n				= loop counter for timesteps direction
	!  allocatestatus	= error indicator during allocation
	!  start			= variable to record start time of program
	!  finish			= variable to record end time of program
	!  count_rate		= variable for clock count rate
	!  planfz			= Forward 1d fft plan
	!  planbz			= Backward 1d fft plan
	!  planfxy			= Forward 2d fft plan
	!  planbxy			= Backward 2d fft plan
	!  planfxyz			= Forward 3d fft plan
	!  planbxyz			= Backward 3d fft plan
	!  dt				= timestep
	!  modescalereal	= Number to scale after backward FFT
	!  ierr				= error code
	!  plotnum			= number of plot
	!  numthreads		= total number of OpenMP threads
	!  mythreadid		= thread number
	! .. Arrays ..
	!  unew 			= approximate solution
	!  vnew 			= Fourier transform of approximate solution
	!  u 				= approximate solution
	!  v 				= Fourier transform of approximate solution
	!  uold 			= approximate solution
	!  vold 			= Fourier transform of approximate solution
	!  nonlin 			= nonlinear term, u^3
	!  nonlinhat 		= Fourier transform of nonlinear term, u^3
	! .. Vectors ..
	!  kx				= fourier frequencies in x direction
	!  ky				= fourier frequencies in y direction
	!  kz				= fourier frequencies in z direction
	!  x				= x locations
	!  y				= y locations
	!  z				= z locations
	!  time				= times at which save data
	!  en				= total energy
	!  enstr			= strain energy
	!  enpot			= potential energy
	!  enkin			= kinetic energy
	!  name_config		= array to store filename for data to be saved
	!  lowxv			= array with entries of array to be used by each thread
	!  upxv				= array with entries of array to be used by each thread
	!  lowzv			= array with entries of array to be used by each thread
	!  upzv				= array with entries of array to be used by each thread
	!
	! REFERENCES
	!
	! ACKNOWLEDGEMENTS
	!
	! ACCURACY
	!
	! ERROR INDICATORS AND WARNINGS
	!
	! FURTHER COMMENTS
	! Check that the initial iterate is consistent with the
	! boundary conditions for the domain specified
	!--------------------------------------------------------------------
	! External routines required
	!	getgrid.f90	-- Get initial grid of points
	! 	initialdata.f90 -- Get initial data
	!	enercalc.f90 -- Subroutine to calculate the energy
	!	savedata.f90 -- Save initial data
	!	storeold.f90 -- Store old data
	! External libraries required
	! 	FFTW3	 -- Fast Fourier Transform in the West Library
	!			(http://www.fftw.org/)
	! 	OpenMP library

	PROGRAM Kg
	USE omp_lib
	IMPLICIT NONE
	! Declare variables
	INTEGER(kind=4), PARAMETER	:: Nx=64
	INTEGER(kind=4), PARAMETER 	:: Ny=64
	INTEGER(kind=4), PARAMETER 	:: Nz=64
	INTEGER(kind=4), PARAMETER	:: Nt=20
	INTEGER(kind=4), PARAMETER	:: plotgap=10
	REAL(kind=8), PARAMETER		:: &
		pi=3.14159265358979323846264338327950288419716939937510d0
	REAL(kind=8), PARAMETER		::  Lx=64.0d0
	REAL(kind=8), PARAMETER		::  Ly=64.0d0
	REAL(kind=8), PARAMETER		::  Lz=64.0d0
	REAL(kind=8), PARAMETER		::  Es=1.0d0
	REAL(kind=8)				::  dt=0.050d0/REAL(Nt,kind(0d0))
	COMPLEX(kind=8), DIMENSION(:), ALLOCATABLE	::  kx,ky,kz
	REAL(kind=8),  	 DIMENSION(:), ALLOCATABLE	::  x,y,z
	COMPLEX(kind=8), DIMENSION(:,:,:), ALLOCATABLE::  u,nonlin,vtemp1
	COMPLEX(kind=8), DIMENSION(:,:,:), ALLOCATABLE::  v,nonlinhat,vtemp2
	COMPLEX(kind=8), DIMENSION(:,:,:), ALLOCATABLE::  uold
	COMPLEX(kind=8), DIMENSION(:,:,:), ALLOCATABLE::  vold
	COMPLEX(kind=8), DIMENSION(:,:,:), ALLOCATABLE::  unew
	COMPLEX(kind=8), DIMENSION(:,:,:), ALLOCATABLE::  vnew
	REAL(kind=8), DIMENSION(:,:,:), ALLOCATABLE :: savearray
	REAL(kind=8), DIMENSION(:), ALLOCATABLE	::  time,enkin,enstr,enpot,en
	INTEGER(kind=4), DIMENSION(:), ALLOCATABLE :: lowxv, upxv, lowzv, upzv
	REAL(kind=8) :: modescalereal
	INTEGER(kind=4)	::  ierr,i,j,k,n,allocatestatus,numthreads,mythreadid
	INTEGER(kind=4)	::  start, finish, count_rate, plotnum
	INTEGER(kind=4), PARAMETER	::  FFTW_IN_PLACE = 8, FFTW_MEASURE = 0, &
		FFTW_EXHAUSTIVE = 8, FFTW_PATIENT = 32, FFTW_ESTIMATE = 64
	INTEGER(kind=4),PARAMETER	::  FFTW_FORWARD = -1, FFTW_BACKWARD=1
	INTEGER(kind=8)	::  planfxy,planbxy,planfz,planbz
	CHARACTER*100	::  name_config
	! Start short parallel region to count threads
	!$OMP PARALLEL
    numthreads=omp_get_num_threads()
    !$OMP END PARALLEL
    PRINT *,'There are ',numthreads,' threads.'
	ALLOCATE(kx(1:Nx),ky(1:Ny),kz(1:Nz),x(1:Nx),y(1:Ny),z(1:Nz),u(1:Nx,1:Ny,1:Nz),&
			v(1:Nz,1:Ny,1:Nx),nonlin(1:Nx,1:Ny,1:Nz),nonlinhat(1:Nz,1:Ny,1:Nx),&
			uold(1:Nx,1:Ny,1:Nz),vold(1:Nz,1:Ny,1:Nx),vtemp1(1:Nx,1:Ny,1:Nz),&
			vtemp2(1:Nz,1:Ny,1:Nx),unew(1:Nx,1:Ny,1:Nz),vnew(1:Nz,1:Ny,1:Nx),&
			savearray(1:Nx,1:Ny,1:Nz),time(1:1+Nt/plotgap),enkin(1:1+Nt/plotgap),&
			enstr(1:1+Nt/plotgap),enpot(1:1+Nt/plotgap),en(1:1+Nt/plotgap),&
			lowxv(1:numthreads),upxv(1:numthreads),lowzv(1:numthreads),upzv(1:numthreads),&
			stat=allocatestatus)
	IF (allocatestatus .ne. 0) stop
	PRINT *,'allocated arrays'

	! set up ffts
	CALL dfftw_plan_dft_2d_(planfxy,Nx,Ny,u(1:Nx,1:Ny,1),vtemp1(1:Nx,1:Ny,1),&
							FFTW_FORWARD,FFTW_ESTIMATE)
 	CALL dfftw_plan_dft_2d_(planbxy,Nx,Ny,vtemp1(1:Nx,1:Ny,1),u(1:Nx,1:Ny,1),&
 							FFTW_BACKWARD,FFTW_ESTIMATE)
	CALL dfftw_plan_dft_(planfxy,Nx,Ny,v(1:Nz,1:Ny,1),vold(1:Nx,1:Ny,1),&
							FFTW_FORWARD,FFTW_ESTIMATE)
 	CALL dfftw_plan_dft_(planbz,Nz,vold(1:Nz,1,1),v(1:Nz,1,1),&
 							FFTW_BACKWARD,FFTW_ESTIMATE)
	PRINT *,'Setup FFTs'
	DO i=1,numthreads
		lowxv(i)=1+(i-1)*Nx/numthreads
	END DO
	DO i=1,numthreads
		upxv(i)=i*Nx/numthreads
	END DO
	DO k=1,numthreads
		lowzv(k)=1+(k-1)*Nz/numthreads
	END DO
	DO k=1,numthreads
		upxv(k)=k*Nz/numthreads
	END DO
	upxv(numthreads)=Nx
	upzv(numthreads)=Nz

	! setup fourier frequencies
	CALL getgrid(Nx,Ny,Nz,Lx,Ly,Lz,pi,name_config,x,y,z,kx,ky,kz)
	PRINT *,'Setup grid and fourier frequencies'
	!$OMP PARALLEL PRIVATE(i,j,k)
	! setup array ranges
	mythreadid=omp_get_thread_num()
	CALL initialdata(Nx,Ny,Nz,mythreadid,numthreads,lowxv,lowzv,upxv,upzv,&
				x,y,z,u,uold)
	!$OMP MASTER
	plotnum=1
	name_config = 'data/u'
	!$OMP END MASTER
	DO k=lowzv(mythreadid),upzv(mythreadid)
		DO j=1,Ny
			DO i=1,Nx
				savearray(i,j,k)=REAL(unew(i,j,k),kind(0d0))
			END DO
		END DO
	END DO
	!$OMP MASTER
	CALL savedata(Nx,Ny,Nz,plotnum,name_config,savearray)
	!$OMP END MASTER
	! forward transform
	CALL forwardfft(Nx,Ny,Nz,planfz,planfxy,mythreadid,numthreads,&
					lowxv,lowzv,upxv,upzv,u,v,vtemp1,vtemp2)
	CALL forwardfft(Nx,Ny,Nz,planfz,planfxy,mythreadid,numthreads,&
					lowxv,lowzv,upxv,upzv,uold,vold,vtemp1,vtemp2)
	!$OMP MASTER
	modescalereal=1.0d0/REAL(Nx,KIND(0d0))
	modescalereal=modescalereal/REAL(Ny,KIND(0d0))
	modescalereal=modescalereal/REAL(Nz,KIND(0d0))
	!$OMP END MASTER

	CALL enercalc(Nx,Ny,Nz,planbxy,planbz,planfxy,planfz,dt,Es,&
			modescalereal,enkin(plotnum),enstr(plotnum),enpot(plotnum),&
			en(plotnum),mythreadid,numthreads,lowxv,lowzv,upxv,upzv,&
			kx,ky,kz,nonlin,nonlinhat,vtemp1,vtemp2,v,vold,u,uold)
	!$OMP MASTER
	PRINT *,'Got initial data, starting timestepping'
	time(plotnum)=0.0d0
  	CALL system_clock(start,count_rate)
	!$OMP END MASTER
	DO n=1,Nt
		DO k=lowzv(mythreadid),upzv(mythreadid)
			DO j=1,Ny
				DO i=1,Nx
					nonlin(i,j,k)=(abs(u(i,j,k))*2)*u(i,j,k)
				END DO
			END DO
		END DO
		CALL forwardfft(Nx,Ny,Nz,planfz,planfxy,mythreadid,numthreads,&
					   lowxv,lowzv,upxv,upzv,nonlin,nonlinhat,vtemp1,vtemp2)

		DO i=lowxv(mythreadid),upxv(mythreadid)
			DO j=1,Ny
				DO k=1,Nz
					vnew(k,j,i)=&
					( 0.25d0*(kx(i)*kx(i) + ky(j)*ky(j)+ kz(k)*kz(k)-1.0d0)&
					*(2.0d0*v(k,j,i)+vold(k,j,i))&
					+(2.0d0*v(k,j,i)-vold(k,j,i))/(dt*dt)&
					+Es*nonlinhat(k,j,i) )&
					/(1/(dt*dt)-0.25*(kx(i)*kx(i)+ ky(j)*ky(j)+ kz(k)*kz(k)-1.0d0))
				END DO
			END DO
		END DO
		CALL backwardfft(Nx,Ny,Nz,planbz,planbxy,mythreadid,numthreads,&
					lowxv,lowzv,upxv,upzv,vnew,unew,vtemp1,vtemp2)

		! normalize result
		DO k=lowzv(mythreadid),upzv(mythreadid)
			DO j=1,Ny
				DO i=1,Nx
					unew(i,j,k)=unew(i,j,k)*modescalereal
				END DO
			END DO
		END DO
		IF (mod(n,plotgap)==0) then
			!$OMP MASTER
			plotnum=plotnum+1
			time(plotnum)=n*dt
			PRINT *,'time',n*dt
			!$OMP END MASTER
			CALL enercalc(Nx,Ny,Nz,planbxy,planbz,planfxy,planfz,dt,Es,&
				modescalereal,enkin(plotnum),enstr(plotnum),enpot(plotnum),&
				en(plotnum),mythreadid,numthreads,lowxv,lowzv,upxv,upzv,kx,ky,kz,&
				nonlin,nonlinhat,vtemp1,vtemp2,v,vold,u,uold)
			DO k=lowzv(mythreadid),upzv(mythreadid)
				DO j=1,Ny
					DO i=1,Nx
						savearray(i,j,k)=REAL(unew(i,j,k),kind(0d0))
					END DO
				END DO
			END DO
			!$OMP BARRIER
			!$OMP MASTER
			CALL savedata(Nx,Ny,Nz,plotnum,name_config,savearray)
			!$OMP END MASTER
		END IF
			! .. Update old values ..
		!$OMP BARRIER
		CALL storeold(Nx,Ny,Nz,mythreadid,numthreads,&
					lowxv,lowzv,upxv,upzv,unew,u,uold,vnew,v,vold)
		!$OMP BARRIER
	END DO
	!$OMP END PARALLEL
	PRINT *,'Finished time stepping'
	CALL system_clock(finish,count_rate)
	PRINT*,'Program took ',&
		REAL(finish-start,kind(0d0))/REAL(count_rate,kind(0d0)),&
		'for Time stepping'
	CALL saveresults(Nt,plotgap,time,en,enstr,enkin,enpot)

	! Save times at which output was made in text format
	PRINT *,'Saved data'

	CALL dfftw_destroy_plan_(planbxy)
	CALL dfftw_destroy_plan_(planfxy)
	CALL dfftw_destroy_plan_(planbz)
	CALL dfftw_destroy_plan_(planfz)
	CALL dfftw_cleanup()
	DEALLOCATE(kx,ky,kz,x,y,z,u,&
			v,nonlin,nonlinhat,&
			uold,vold,vtemp1,&
			vtemp2,unew,vnew,&
			savearray,time,enkin,&
			enstr,enpot,en,&
			lowxv,upxv,lowzv,upzv,&
			stat=allocatestatus)
	IF (allocatestatus .ne. 0) STOP
	PRINT *,'Deallocated arrays'
	PRINT *,'Program execution complete'
	END PROGRAM Kg


!---------------------------------------------------------------------!
! OWNER: Ithaca Combustion Enterprise, LLC                            !
! COPYRIGHT: © 2012, Ithaca Combustion Enterprise, LLC                !
! LICENSE: BSD 3-Clause License (The complete text of the license can !
!  be found in the `LICENSE-ICE.txt' file included in the ISAT-CK7    !
!  source directory.)                                                 !
!---------------------------------------------------------------------!

subroutine ell_pt_modify( n, c, gg, p )

!  Modify the ellipsoid E so that its boundary intersects the given
!  point p.  The ellipsoid E is given by: { x | norm(G^T * (x-c) ) <=1 ),
!  where G is an n x n lower triangular matrix.  The array gg contains
!  the matrix G in packed format.
!  Method:
!  1/ transform to y-space in which E is the unit ball: (p-c) transforms to yp.
!  2/ generate the modified ellipsoid in y-space in terms of a rank-one
!     modification of the identity: one principal axis is yp.
!  3/ transform back to x-space and form the modified G.

!  S.B. Pope  12/24/05

implicit none

integer, parameter        :: k_dp = kind(1.d0)
integer, intent(in)       :: n
real(k_dp), intent(in)    :: c(n), p(n)
real(k_dp), intent(inout) :: gg((n*(n+1))/2)

integer    :: i, j, k
real(k_dp) :: yp(n), ypnorm, v(n), q(n,n), g(n,n), gamma

!  Transform to y-space: y = G^T * [x-c]
yp = p-c
call dtpmv( 'L', 'T', 'N', n, gg, yp, 1 )  !  yp = G^T * [p-c]

!  Transform to z-space:  z = Q^T * y,  where yp = Q * R
ypnorm = sqrt( sum(yp*yp) )

if( ypnorm == 0.d0 ) then  ! degenerate case p = c
   gg = 0.d0  !  set G = I * 1.d30
   k  = 0
   do j = 1, n
      do i = j,n
         k = k + 1
	     if( i == j ) gg(k) = 1.d30
      end do
   end do
   return
endif

!  The modified ellipsoid is { y | y^T B^2 y <=1 }
!  B = I + gamma * yp * yp^2

gamma = (1.d0/ypnorm - 1.d0) / ypnorm**2

!  Transform back to x
g = 0.d0
k = 0  !  unpack g
do j = 1, n
   do i = j,n
      k = k + 1
	  g(i,j) = gg(k)
   end do
end do

! q = G*B = G + (gamma*G*yp)*yp^T

v = gamma * matmul( g, yp )

do i = 1, n
do j = 1, n
   q(i,j) = g(i,j) + v(i)*yp(j)
end do
end do

call ell_bbt2chol( n, q, gg )

return
end subroutine ell_pt_modify


	program jacobitst
c
c	what's a row and what's a column?
c	this shows that, in evect(i,j) i is component, j is vector #
c
	real aa(3,3),evect(3,3),eval(3)
	data aa /9*0./
c
	aa(1,1) = 1.
	aa(2,2) = 2.
	aa(3,3) = 1.
	aa(1,2) = .5
	aa(2,1) = aa(1,2)
	call jacobi(aa,3,3,eval,evect,nrot)
	print*,eval
	do j = 1,3
	  print*,evect(1,j),evect(2,j),evect(3,j)
	enddo
	call eigsrt(eval,evect,3,3)
	print*,eval
	do j = 1,3
	  print*,evect(1,j),evect(2,j),evect(3,j)
	enddo
	stop
	end


program euler_094
   use EulerCommon
   integer(int64) :: L = 10**9
   integer(int64) :: a, c, s, p, m
   integer(int64) :: new(4)

   a = 1
   c = 1
   s = 0
   p = 0
   m = 1
   ! use generating function n(i) = 4*n(i-1) - n(i-2); cf. wiki on Heronian Triangles
   do while (p < L)
      ! if the next line doesn't work, get a better compiler
      new = [c, 4*c - a + 2*m, -m, s + p]
      a = new(1); c = new(2); m = new(3); s = new(4)
      p = 3*c - m
   end do

   print *,s

end program euler_094ents here


!PR fortran/32238
! { dg-do compile }
! { dg-final { cleanup-modules "bug_test" } }

module bug_test

contains
  subroutine bug(c)

  implicit none

  integer, parameter :: fp = selected_real_kind(13)
  complex(kind=fp)              :: c(:,:)
  where( abs( aimag( c ) ) < 1.e-10_fp )                             &
  &    c = cmplx( real( c , fp ) , 0._fp , fp )
  where( abs( real( c , fp ) ) < 1.e-10_fp )                         &
  &    c = cmplx( 0._fp , aimag( c ) , fp )

  return
  end subroutine bug

end module bug_test


program problem92
  implicit none
  integer, parameter           :: mlimit=10000000,tlimit=1000000
  integer*1, dimension(mlimit) :: memo
  integer                      :: i,answer

  do i=1,mlimit
     memo(i)=0
  end do
  memo(1)=1
  memo(89)=89

  do i=1,mlimit
     call trajectory(i)
  end do

  answer=0
  do i=1,mlimit-1
     if(memo(i)==89) answer=answer+1
  end do

  print *, answer

contains

  subroutine trajectory(n)
    implicit none
    integer, intent(in)        :: n
    integer, dimension(tlimit) :: history
    integer                    :: i,current

    current=n
    i=0
    do while(memo(current)/=1 .and. memo(current)/=89) ! follow trajectory
       i=i+1
       history(i)=current
       current=step(current)
    end do
    do i=i,1,-1 ! record results in memo
       memo(history(i))=memo(current)
    end do

  end subroutine trajectory

  pure function step(n)
    implicit none
    integer, intent(in) :: n
    integer             :: step,remaining

    step=0
    remaining=n
    do while (remaining>0)
       step=step+mod(remaining,10)**2
       remaining=remaining/10
    end do

  end function step

end program problem92


c read data from a text file and fit a gaussian to it

      program fitgausfile

      parameter (NMAX=10000)

      real xd(NMAX),yd(NMAX),yerr(NMAX),yfit(NMAX)
      real pars(4),errpars(4),dydp(4)
      integer ifit(4)
      character fname*80

c file is assumed sorted with x increasing

      call pgbeg(0,"?",1,1)
      call pgscf(2)
      call pgsch(1.5)

 100  continue
      write(*,'("File with x,y,yerr [quit]: ",$)')
      read(*,'(a)') fname
      if (fname(1:3) .eq. '   ') go to 666
      open(2,file=fname,status='old',err=100)

      np = 1
 200  continue
      read(2,*,err=220,end=220) xd(np),yd(np),yerr(np)
      np = np + 1
      go to 200
 220  continue
      np = np-1
      close(2)
      write(*,'("Read ",i5," points")') np

c plot data
c      wxmin = 1.e10
c      wxmax = -1.e10
      wxmin = xd(1)
      wxmax = xd(np)
      wymin = 1.e10
      wymax = -1.e10
      do i=1,np
         wymin = min(wymin,yd(i))
         wymax = max(wymax,yd(i))
      end do
      wxmarg = (wxmax-wxmin) / 100.
      wymarg = (wymax-wymin) / 40.
      call pgenv(wxmin-wxmarg,wxmax+wxmarg,wymin-wymarg,
     $     wymax+wymarg,0,1)
      call pgpt(np,xd,yd,17)
      call pgerrb(6,np,xd,yd,yerr,0.0)

      write(*,'("x range to fit: ",$)')
      read(*,*) xmin,xmax
      call locate(xd,np,xmin,ixmin)
      ixmin = max(ixmin,1)
      call locate(xd,np,xmax,ixmax)
      ixmax = min(ixmax,np)
      nfit = ixmax-ixmin+1

      iguess=1
      do i=1,4
         ifit(i) = 1
      end do
      call fitgaus(xd(ixmin),yd(ixmin),yerr(ixmin),nfit,
     $     pars,errpars,ifit,iguess,chisq)
      do i=1,4
         write (*,*) pars(i)," +- ", errpars(i)
      end do
      write(*,*) "chisq = ",chisq

c compute and plot fit
      do i=ixmin,ixmax
         call gausfunc(xd(i),pars,yfit(i),dydp,4)
      end do
      call pgqci(indexc)
      call pgsci(2)
      call pgline(nfit,xd(ixmin),yfit(ixmin))
      call pgsci(indexc)

c write out data, fit, subtracted

      open(3,file='fitgausfile.out',status='unknown')
      do i=1,np
c         call gausfunc(xd(i),pars,gfitval,dydp,4)
c         write(3,*) i,xd(i),yd(i),yerr(i),gfitval,yd(i)-gfitval
         call gausfunc(xd(i),pars,yfit(i),dydp,4)
         write(3,*) i,xd(i),yd(i),yerr(i),yfit(i),yd(i)-yfit(i)
      end do
      close(3)

      go to 100

 666  continue

      end


C The program below uses ZVODE to solve the following system of 2 ODEs:
C dz/dt = i*z; dw/dt = -i*w*w*z,z(0) = 1; w(0) = 1/2.1,  t = 0 to 2*pi.
C Solution: w = 1/(z + 1.1), z = exp(it).  As z traces the unit circle,
C w traces a circle of radius 10/2.1 with center at 11/2.1.

      SUBROUTINE FEX (NEQ, T, Y, YDOT, RPAR, IPAR)
      INTEGER NEQ, IPAR(*)
      DOUBLE COMPLEX Y(NEQ), YDOT(NEQ), RPAR(*), CMP
      DOUBLE PRECISION T
      character(len=100) msg

c the imaginary unit i
      CMP = DCMPLX(0.0D0,1.0D0)

      YDOT(1) = CMP*Y(1)
      YDOT(2) = -CMP*Y(2)*Y(2)*Y(1)

      RETURN
      END

      SUBROUTINE JEX (NEQ, T, Y, ML, MU, PD, NRPD, RPAR, IPAR)
      INTEGER NEQ, ML, MU, NRPD, IPAR(*)
      DOUBLE COMPLEX Y(NEQ), PD(NRPD,NEQ), RPAR(*), CMP
      DOUBLE PRECISION T
c the imaginary unit i
      CMP = DCMPLX(0.0D0,1.0D0)

      PD(2,3) = -2.0D0*CMP*Y(1)*Y(2)
      PD(2,1) = -CMP*Y(2)*Y(2)
      PD(1,1) = CMP
      RETURN
      END


program linear_transform
    implicit none
    real, dimension(5) :: values
    real, dimension(2) :: a = [ 1.1, 2.2 ], &
                          x = [ 0.5, 2.0 ], &
                          b = [ -1.2, 2.5 ]
    integer :: i

    call random_number(values)
    print *, values
    print *, lin_transform(values, 2.0, 1.0)
    print *, lin_transform(x, a, b)

contains

    elemental real function lin_transform(x, a, b)
        implicit none
        real, intent(in) :: x, a, b

        lin_transform = a*x + b
    end function lin_transform

end program linear_transform