!< Jiang-Shu (Lagrange) polynomials object.
module wenoof_polynomials_js
!< Jiang-Shu (Lagrange) polynomials object.
!<
!< @note The provided polynomials implement the Lagrange polynomials defined in *Efficient Implementation
!< of Weighted ENO Schemes*, Guang-Shan Jiang, Chi-Wang Shu, JCP, 1996, vol. 126, pp. 202--228, doi:10.1006/jcph.1996.0130 and
!< *Very-high-order weno schemes*, G. A. Gerolymos, D. Senechal, I. Vallet, JCP, 2009, vol. 228, pp. 8481-8524,
!< doi:10.1016/j.jcp.2009.07.039

use penf, only : I_P, R_P
use wenoof_base_object
use wenoof_polynomials

implicit none
private
public :: polynomials_js
public :: polynomials_js_constructor
public :: create_polynomials_js_constructor

type, extends(polynomials_constructor) :: polynomials_js_constructor
  !< Jiang-Shu (Lagrange) polynomials object constructor.
endtype polynomials_js_constructor

type, extends(polynomials) :: polynomials_js
  !< Jiang-Shu (Lagrange) polynomials object.
  !<
  !< @note The provided polynomials implement the Lagrange polynomials defined in *Efficient Implementation
  !< of Weighted ENO Schemes*, Guang-Shan Jiang, Chi-Wang Shu, JCP, 1996, vol. 126, pp. 202--228, doi:10.1006/jcph.1996.0130 and
  !< *Very-high-order weno schemes*, G. A. Gerolymos, D. Senechal, I. Vallet, JCP, 2009, vol. 228, pp. 8481-8524,
  !< doi:10.1016/j.jcp.2009.07.039
  private
  real(R_P), allocatable :: coef(:,:,:) !< Polynomial coefficients [1:2,0:S-1,0:S-1].
  contains
    ! deferred public methods
    procedure, pass(self) :: compute     !< Compute weights.
    procedure, nopass     :: description !< Return weights string-description.
    ! overridden public methods
    procedure, pass(self) :: create  !< Create weights.
    procedure, pass(self) :: destroy !< Destroy weights.
endtype polynomials_js

contains
  ! public non TBP
  subroutine create_polynomials_js_constructor(S, constructor)
  !< Create polynomials constructor.
  integer(I_P),                                intent(in)  :: S           !< Stencils dimension.
  class(polynomials_constructor), allocatable, intent(out) :: constructor !< Polynomials constructor.

  allocate(polynomials_js_constructor :: constructor)
  constructor%S = S
  endsubroutine create_polynomials_js_constructor

  ! deferred public methods
  pure subroutine compute(self, S, stencil, f1, f2, ff)
  !< Compute polynomials.
  class(polynomials_js), intent(inout) :: self                !< WENO polynomial.
  integer(I_P),          intent(in)    :: S                   !< Number of stencils actually used.
  real(R_P),             intent(in)    :: stencil(1:, 1 - S:) !< Stencil used for the interpolation, [1:2, 1-S:-1+S].
  integer(I_P),          intent(in)    :: f1, f2, ff          !< Faces to be computed.
  integer(I_P)                         :: s1, s2, f           !< Counters

  self%poly = 0._R_P
  do s1 = 0, S - 1 ! stencils loop
    do s2 = 0, S - 1 ! values loop
      do f = f1, f2 ! 1 => left interface (i-1/2), 2 => right interface (i+1/2)
        self%poly(f, s1) = self%poly(f, s1) + self%coef(f, s2, s1) * stencil(f + ff, -s2 + s1)
      enddo
    enddo
  enddo
  endsubroutine compute

  pure function description() result(string)
  !< Return polynomials string-description.
  character(len=:), allocatable :: string           !< String-description.
  character(len=1), parameter   :: nl=new_line('a') !< New line character.

  string = 'WENO polynomial'//nl
  string = string//'  Based on the work by Jiang and Shu "Efficient Implementation of Weighted ENO Schemes", see '// &
           'JCP, 1996, vol. 126, pp. 202--228, doi:10.1006/jcph.1996.0130 and'//nl
  string = string//'  on the work by Gerolimos, Sénéchal and  Vallet  "Very-High-Order WENO Schemes", see '// &
           'JCP, 2009, vol. 228, pp. 8481-8524, doi:10.1016/j.jcp.2009.07.039'//nl
  string = string//'  The "compute" method has the following public API'//nl
  string = string//'    compute(S, stencil, f1, f2, ff)'//nl
  string = string//'  where:'//nl
  string = string//'    S: integer(I_P), intent(in), the number of the stencils used'//nl
  string = string//'    stencil: real(R_P), intent(IN), the stencil used for the interpolation [1:2, 1-S:-1+S]'//nl
  string = string//'    f1, f2: integer(I_P), intent(in), the faces to be computed (1 => left interface, 2 => right interface)'//nl
  string = string//'    ff: integer(I_P), intent(in), the parameter for the stencil value choice'
  endfunction description

  ! overridden public methods
  pure subroutine create(self, constructor)
  !< Create coefficients.
  class(polynomials_js),          intent(inout) :: self        !< Polynomials.
  class(base_object_constructor), intent(in)    :: constructor !< Polynomials constructor.
  integer(I_P)                                  :: S           !< Stencils dimension.

  call self%destroy
  call self%polynomials%create(constructor=constructor)
  select type(constructor)
  class is(polynomials_js_constructor)
    S = constructor%S
    allocate(self%coef(1:2, 0:S - 1, 0:S - 1))
  class default
    ! @TODO add error handling
  endselect
  associate(c => self%coef)
    select case(S)
      case(2) ! 3rd order
        ! 1 => left interface (i-1/2)
        !  cell  0           ;    cell  1
        c(1,0,0) =  0.5_R_P; c(1,1,0) =  0.5_R_P ! stencil 0
        c(1,0,1) = -0.5_R_P; c(1,1,1) =  1.5_R_P ! stencil 1
        ! 2 => right interface (i+1/2)
        !  cell  0           ;    cell  1
        c(2,0,0) =  1.5_R_P; c(2,1,0) = -0.5_R_P ! stencil 0
        c(2,0,1) =  0.5_R_P; c(2,1,1) =  0.5_R_P ! stencil 1
      case(3) ! 5th order
        ! 1 => left interface (i-1/2)
        !  cell  0                 ;    cell  1                 ;    cell  2
        c(1,0,0) =  1._R_P/3._R_P; c(1,1,0) =  5._R_P/6._R_P; c(1,2,0) = -1._R_P/6._R_P ! stencil 0
        c(1,0,1) = -1._R_P/6._R_P; c(1,1,1) =  5._R_P/6._R_P; c(1,2,1) =  1._R_P/3._R_P ! stencil 1
        c(1,0,2) =  1._R_P/3._R_P; c(1,1,2) = -7._R_P/6._R_P; c(1,2,2) = 11._R_P/6._R_P ! stencil 2
        ! 2 => right interface (i+1/2)
        !  cell  0                 ;    cell  1                 ;    cell  2
        c(2,0,0) = 11._R_P/6._R_P; c(2,1,0) = -7._R_P/6._R_P; c(2,2,0) =  1._R_P/3._R_P ! stencil 0
        c(2,0,1) =  1._R_P/3._R_P; c(2,1,1) =  5._R_P/6._R_P; c(2,2,1) = -1._R_P/6._R_P ! stencil 1
        c(2,0,2) = -1._R_P/6._R_P; c(2,1,2) =  5._R_P/6._R_P; c(2,2,2) =  1._R_P/3._R_P ! stencil 2
      case(4) ! 7th order
        ! 1 => left interface (i-1/2)
        !  cell  0               ;    cell  1               ;    cell  2               ;    cell  3
        c(1,0,0)=  1._R_P/4._R_P ; c(1,1,0)= 13._R_P/12._R_P; c(1,2,0)= -5._R_P/12._R_P; c(1,3,0)=  1._R_P/12._R_P ! stencil 0
        c(1,0,1)= -1._R_P/12._R_P; c(1,1,1)=  7._R_P/12._R_P; c(1,2,1)=  7._R_P/12._R_P; c(1,3,1)= -1._R_P/12._R_P ! stencil 1
        c(1,0,2)=  1._R_P/12._R_P; c(1,1,2)= -5._R_P/12._R_P; c(1,2,2)= 13._R_P/12._R_P; c(1,3,2)=  1._R_P/4._R_P  ! stencil 2
        c(1,0,3)= -1._R_P/4._R_P ; c(1,1,3)= 13._R_P/12._R_P; c(1,2,3)=-23._R_P/12._R_P; c(1,3,3)= 25._R_P/12._R_P ! stencil 3
        ! 2 => right interface (i+1/2)
        !  cell  0               ;    cell  1               ;   cell  2                ;    cell  3
        c(2,0,0)= 25._R_P/12._R_P; c(2,1,0)=-23._R_P/12._R_P; c(2,2,0)= 13._R_P/12._R_P; c(2,3,0)= -1._R_P/4._R_P  ! stencil 0
        c(2,0,1)=  1._R_P/4._R_P ; c(2,1,1)= 13._R_P/12._R_P; c(2,2,1)= -5._R_P/12._R_P; c(2,3,1)=  1._R_P/12._R_P ! stencil 1
        c(2,0,2)= -1._R_P/12._R_P; c(2,1,2)=  7._R_P/12._R_P; c(2,2,2)=  7._R_P/12._R_P; c(2,3,2)= -1._R_P/12._R_P ! stencil 2
        c(2,0,3)=  1._R_P/12._R_P; c(2,1,3)= -5._R_P/12._R_P; c(2,2,3)= 13._R_P/12._R_P; c(2,3,3)=  1._R_P/4._R_P  ! stencil 3
      case(5) ! 9th order
        ! 1 => left interface (i-1/2)
        !  cell  0                ;    cell  1                ;    cell  2                ;    cell  3
        c(1,0,0)=   1._R_P/5._R_P ; c(1,1,0)=  77._R_P/60._R_P; c(1,2,0)= -43._R_P/60._R_P; c(1,3,0)=  17._R_P/60._R_P  ! stencil 0
        c(1,0,1)=  -1._R_P/20._R_P; c(1,1,1)=   9._R_P/20._R_P; c(1,2,1)=  47._R_P/60._R_P; c(1,3,1)= -13._R_P/60._R_P  ! stencil 1
        c(1,0,2)=   1._R_P/30._R_P; c(1,1,2)= -13._R_P/60._R_P; c(1,2,2)=  47._R_P/60._R_P; c(1,3,2)=   9._R_P/20._R_P  ! stencil 2
        c(1,0,3)=  -1._R_P/20._R_P; c(1,1,3)=  17._R_P/60._R_P; c(1,2,3)= -43._R_P/60._R_P; c(1,3,3)=  77._R_P/60._R_P  ! stencil 3
        c(1,0,4)=   1._R_P/5._R_P ; c(1,1,4)= -21._R_P/20._R_P; c(1,2,4)= 137._R_P/60._R_P; c(1,3,4)=-163._R_P/60._R_P  ! stencil 4
        !  cell  4
        c(1,4,0)=  -1._R_P/20._R_P  ! stencil 0
        c(1,4,1)=   1._R_P/30._R_P  ! stencil 1
        c(1,4,2)=  -1._R_P/20._R_P  ! stencil 2
        c(1,4,3)=   1._R_P/5._R_P   ! stencil 3
        c(1,4,4)= 137._R_P/60._R_P  ! stencil 4
        ! 2 => right interface (i+1/2)
        !  cell  0               ;    cell  1               ;   cell  2                ;    cell  3
        c(2,0,0)= 137._R_P/60._R_P; c(2,1,0)=-163._R_P/60._R_P; c(2,2,0)= 137._R_P/60._R_P; c(2,3,0)= -21._R_P/20._R_P  ! stencil 0
        c(2,0,1)=   1._R_P/5._R_P ; c(2,1,1)=  77._R_P/60._R_P; c(2,2,1)= -43._R_P/60._R_P; c(2,3,1)=  17._R_P/60._R_P  ! stencil 1
        c(2,0,2)=  -1._R_P/20._R_P; c(2,1,2)=   9._R_P/20._R_P; c(2,2,2)=  47._R_P/60._R_P; c(2,3,2)= -13._R_P/60._R_P  ! stencil 2
        c(2,0,3)=   1._R_P/30._R_P; c(2,1,3)= -13._R_P/60._R_P; c(2,2,3)=  47._R_P/60._R_P; c(2,3,3)=   9._R_P/20._R_P  ! stencil 3
        c(2,0,4)=  -1._R_P/20._R_P; c(2,1,4)=  17._R_P/60._R_P; c(2,2,4)= -43._R_P/60._R_P; c(2,3,4)=  77._R_P/60._R_P  ! stencil 4
        !  cell  4
        c(2,4,0)=   1._R_P/5._R_P  ! stencil 0
        c(2,4,1)=  -1._R_P/20._R_P ! stencil 1
        c(2,4,2)=   1._R_P/30._R_P ! stencil 2
        c(2,4,3)=  -1._R_P/20._R_P ! stencil 3
        c(2,4,4)=   1._R_P/5._R_P  ! stencil 4
      case(6) ! 11th order
        ! 1 => left interface (i-1/2)
        !  cell  0                ;    cell  1                ;    cell  2                ;    cell  3
        c(1,0,0)=   1._R_P/6._R_P ; c(1,1,0)=  29._R_P/20._R_P; c(1,2,0)= -21._R_P/20._R_P; c(1,3,0)=  37._R_P/60._R_P  ! stencil 0
        c(1,0,1)=  -1._R_P/30._R_P; c(1,1,1)=  11._R_P/30._R_P; c(1,2,1)=  19._R_P/20._R_P; c(1,3,1)= -23._R_P/60._R_P  ! stencil 1
        c(1,0,2)=   1._R_P/60._R_P; c(1,1,2)=  -2._R_P/15._R_P; c(1,2,2)=  37._R_P/60._R_P; c(1,3,2)=  37._R_P/60._R_P  ! stencil 2
        c(1,0,3)=  -1._R_P/60._R_P; c(1,1,3)=   7._R_P/60._R_P; c(1,2,3)= -23._R_P/60._R_P; c(1,3,3)=  19._R_P/20._R_P  ! stencil 3
        c(1,0,4)=   1._R_P/30._R_P; c(1,1,4)= -13._R_P/60._R_P; c(1,2,4)=  37._R_P/60._R_P; c(1,3,4)= -21._R_P/20._R_P  ! stencil 4
        c(1,0,5)=  -1._R_P/6._R_P ; c(1,1,5)=  31._R_P/30._R_P; c(1,2,5)=-163._R_P/60._R_P; c(1,3,5)=  79._R_P/20._R_P  ! stencil 5
        !  cell  4                ;    cell  5
        c(1,4,0)= -13._R_P/60._R_P; c(1,5,0)=   1._R_P/6._R_P   ! stencil 0
        c(1,4,1)=   7._R_P/60._R_P; c(1,5,1)=  -1._R_P/60._R_P  ! stencil 1
        c(1,4,2)=  -2._R_P/15._R_P; c(1,5,2)=   1._R_P/60._R_P  ! stencil 2
        c(1,4,3)=  11._R_P/30._R_P; c(1,5,3)=  -1._R_P/30._R_P  ! stencil 3
        c(1,4,4)=  29._R_P/20._R_P; c(1,5,4)=   1._R_P/6._R_P   ! stencil 4
        c(1,4,5)= -71._R_P/20._R_P; c(1,5,5)=  49._R_P/20._R_P  ! stencil 5
        ! 2 => right interface (i+1/2)
        !  cell  0                ;    cell  1                ;   cell  2                 ;    cell  3
        c(2,0,0)=  49._R_P/20._R_P; c(2,1,0)= -71._R_P/20._R_P; c(2,2,0)=  79._R_P/20._R_P; c(2,3,0)=-163._R_P/60._R_P  ! stencil 0
        c(2,0,1)=   1._R_P/6._R_P ; c(2,1,1)=  29._R_P/20._R_P; c(2,2,1)= -21._R_P/20._R_P; c(2,3,1)=  37._R_P/60._R_P  ! stencil 1
        c(2,0,2)=  -1._R_P/30._R_P; c(2,1,2)=  11._R_P/30._R_P; c(2,2,2)=  19._R_P/20._R_P; c(2,3,2)= -23._R_P/60._R_P  ! stencil 2
        c(2,0,3)=   1._R_P/60._R_P; c(2,1,3)=  -2._R_P/15._R_P; c(2,2,3)=  37._R_P/60._R_P; c(2,3,3)=  37._R_P/60._R_P  ! stencil 3
        c(2,0,4)=  -1._R_P/60._R_P; c(2,1,4)=   7._R_P/60._R_P; c(2,2,4)= -23._R_P/60._R_P; c(2,3,4)=  19._R_P/20._R_P  ! stencil 4
        c(2,0,5)=   1._R_P/30._R_P; c(2,1,5)= -13._R_P/60._R_P; c(2,2,5)=  37._R_P/60._R_P; c(2,3,5)= -21._R_P/20._R_P  ! stencil 5
        !  cell  4                ;    cell  5
        c(2,4,0)=  31._R_P/5._R_P ; c(2,5,0)=  -1._R_P/6._R_P   ! stencil 0
        c(2,4,1)= -13._R_P/60._R_P; c(2,5,1)=   1._R_P/30._R_P  ! stencil 1
        c(2,4,2)=   7._R_P/60._R_P; c(2,5,2)=  -1._R_P/60._R_P  ! stencil 2
        c(2,4,3)=  -2._R_P/15._R_P; c(2,5,3)=   1._R_P/60._R_P  ! stencil 3
        c(2,4,4)=  11._R_P/30._R_P; c(2,5,4)=  -1._R_P/30._R_P  ! stencil 4
        c(2,4,5)=  29._R_P/20._R_P; c(2,5,5)=   1._R_P/6._R_P   ! stencil 5
      case(7) ! 13th order
        ! 1 => left interface (i-1/2)
        !  cell  0                  ;    cell  1                  ;    cell  2
        c(1,0,0)=    1._R_P/7._R_P  ; c(1,1,0)=  223._R_P/140._R_P; c(1,2,0)= -197._R_P/140._R_P  ! stencil 0
        c(1,0,1)=   -1._R_P/42._R_P ; c(1,1,1)=   13._R_P/42._R_P ; c(1,2,1)=  153._R_P/140._R_P  ! stencil 1
        c(1,0,2)=    1._R_P/105._R_P; c(1,1,2)=  -19._R_P/210._R_P; c(1,2,2)=  107._R_P/210._R_P  ! stencil 2
        c(1,0,3)=   -1._R_P/140._R_P; c(1,1,3)=    5._R_P/84._R_P ; c(1,2,3)= -101._R_P/420._R_P  ! stencil 3
        c(1,0,4)=    1._R_P/105._R_P; c(1,1,4)=  -31._R_P/420._R_P; c(1,2,4)=  109._R_P/420._R_P  ! stencil 4
        c(1,0,5)=   -1._R_P/42._R_P ; c(1,1,5)=  -37._R_P/210._R_P; c(1,2,5)= -241._R_P/420._R_P  ! stencil 5
        c(1,0,6)=   -1._R_P/7._R_P  ; c(1,1,6)=  -43._R_P/42._R_P ; c(1,2,6)=  667._R_P/210._R_P  ! stencil 6
        !  cell  3                       cell  4                  ;    cell  5
        c(1,3,0)=  153._R_P/140._R_P; c(1,4,0)= -241._R_P/420._R_P; c(1,5,0)=   37._R_P/210._R_P  ! stencil 0
        c(1,3,1)= -241._R_P/420._R_P; c(1,4,1)=  109._R_P/420._R_P; c(1,5,1)=  -31._R_P/420._R_P  ! stencil 1
        c(1,3,2)=  319._R_P/420._R_P; c(1,4,2)= -101._R_P/420._R_P; c(1,5,2)=    5._R_P/84._R_P   ! stencil 2
        c(1,3,3)=  319._R_P/420._R_P; c(1,4,3)=  107._R_P/210._R_P; c(1,5,3)=  -19._R_P/210._R_P  ! stencil 3
        c(1,3,4)= -241._R_P/420._R_P; c(1,4,4)=  153._R_P/140._R_P; c(1,5,4)=   13._R_P/42._R_P   ! stencil 4
        c(1,3,5)=  153._R_P/140._R_P; c(1,4,5)= -197._R_P/140._R_P; c(1,5,5)=  223._R_P/140._R_P  ! stencil 5
        c(1,3,6)=-2341._R_P/420._R_P; c(1,4,6)=  853._R_P/140._R_P; c(1,5,6)= -617._R_P/140._R_P  ! stencil 6
        !  cell  6
        c(1,6,0)=   -1._R_P/42._R_P   ! stencil 0
        c(1,6,1)=    1._R_P/105._R_P  ! stencil 1
        c(1,6,2)=   -1._R_P/140._R_P  ! stencil 2
        c(1,6,3)=    1._R_P/105._R_P  ! stencil 3
        c(1,6,4)=   -1._R_P/42._R_P   ! stencil 4
        c(1,6,5)=    1._R_P/7._R_P    ! stencil 5
        c(1,6,6)=  363._R_P/140._R_P  ! stencil 6
        ! 2 => right interface (i+1/2)
        !  cell  0                  ;    cell  1                  ;    cell  2
        c(2,0,0)=  363._R_P/140._R_P; c(2,1,0)= -617._R_P/140._R_P; c(2,2,0)=  853._R_P/140._R_P  ! stencil 0
        c(2,0,1)=    1._R_P/7._R_P  ; c(2,1,1)=  223._R_P/140._R_P; c(2,2,1)= -197._R_P/140._R_P  ! stencil 1
        c(2,0,2)=   -1._R_P/42._R_P ; c(2,1,2)=   13._R_P/42._R_P ; c(2,2,2)=  153._R_P/140._R_P  ! stencil 2
        c(2,0,3)=    1._R_P/105._R_P; c(2,1,3)=  -19._R_P/210._R_P; c(2,2,3)=  107._R_P/210._R_P  ! stencil 3
        c(2,0,4)=   -1._R_P/140._R_P; c(2,1,4)=    5._R_P/84._R_P ; c(2,2,4)= -101._R_P/420._R_P  ! stencil 4
        c(2,0,5)=    1._R_P/105._R_P; c(2,1,5)=  -31._R_P/420._R_P; c(2,2,5)=  109._R_P/420._R_P  ! stencil 5
        c(2,0,6)=   -1._R_P/42._R_P ; c(2,1,6)=   37._R_P/210._R_P; c(2,2,6)= -241._R_P/420._R_P  ! stencil 6
        !  cell  3                  ;    cell  4                  ;    cell  5
        c(2,3,0)=-2341._R_P/420._R_P; c(2,4,0)=  667._R_P/210._R_P; c(2,5,0)=  -43._R_P/42._R_P   ! stencil 0
        c(2,3,1)=  153._R_P/140._R_P; c(2,4,1)= -241._R_P/420._R_P; c(2,5,1)=   37._R_P/210._R_P  ! stencil 1
        c(2,3,2)= -241._R_P/420._R_P; c(2,4,2)=  109._R_P/420._R_P; c(2,5,2)=  -31._R_P/420._R_P  ! stencil 2
        c(2,3,3)=  319._R_P/420._R_P; c(2,4,3)= -101._R_P/420._R_P; c(2,5,3)=    5._R_P/84._R_P   ! stencil 3
        c(2,3,4)=  319._R_P/420._R_P; c(2,4,4)=  107._R_P/210._R_P; c(2,5,4)=  -19._R_P/210._R_P  ! stencil 4
        c(2,3,5)= -241._R_P/420._R_P; c(2,4,5)=  153._R_P/140._R_P; c(2,5,5)=   13._R_P/42._R_P   ! stencil 5
        c(2,3,6)=  153._R_P/140._R_P; c(2,4,6)= -197._R_P/140._R_P; c(2,5,6)=  223._R_P/140._R_P  ! stencil 6
        !  cell  6
        c(2,6,0)=    1._R_P/7._R_P    ! stencil 0
        c(2,6,1)=   -1._R_P/42._R_P   ! stencil 1
        c(2,6,2)=    1._R_P/105._R_P  ! stencil 2
        c(2,6,3)=   -1._R_P/140._R_P  ! stencil 3
        c(2,6,4)=    1._R_P/105._R_P  ! stencil 4
        c(2,6,5)=   -1._R_P/42._R_P   ! stencil 5
        c(2,6,6)=    1._R_P/7._R_P    ! stencil 6
      case(8) ! 15th order
        ! 1 => left interface (i-1/2)
        !  cell  0                  ;    cell  1                  ;    cell  2
        c(1,0,0)=    7._R_P/56._R_P ; c(1,1,0)= 1443._R_P/840._R_P; c(1,2,0)=-1497._R_P/840._R_P  ! stencil 0
        c(1,0,1)=   -1._R_P/56._R_P ; c(1,1,1)=   15._R_P/56._R_P ; c(1,2,1)= 1023._R_P/840._R_P  ! stencil 1
        c(1,0,2)=    1._R_P/168._R_P; c(1,1,2)=  -11._R_P/168._R_P; c(1,2,2)=   73._R_P/168._R_P  ! stencil 2
        c(1,0,3)=   -3._R_P/840._R_P; c(1,1,3)=   29._R_P/840._R_P; c(1,2,3)= -139._R_P/840._R_P  ! stencil 3
        c(1,0,4)=    3._R_P/840._R_P; c(1,1,4)=  -27._R_P/840._R_P; c(1,2,4)=  113._R_P/840._R_P  ! stencil 4
        c(1,0,5)=   -1._R_P/168._R_P; c(1,1,5)=   43._R_P/840._R_P; c(1,2,5)= -167._R_P/840._R_P  ! stencil 5
        c(1,0,6)=    1._R_P/56._R_P ; c(1,1,6)=  -25._R_P/168._R_P; c(1,2,6)=  463._R_P/840._R_P  ! stencil 6
        c(1,0,7)=   -7._R_P/56._R_P ; c(1,1,7)=   57._R_P/56._R_P ; c(1,2,7)= -613._R_P/168._R_P  ! stencil 7
        !  cell  3                  ;    cell  4                  ;    cell  5
        c(1,3,0)= 1443._R_P/840._R_P; c(1,4,0)=-1007._R_P/840._R_P; c(1,5,0)=  463._R_P/840._R_P  ! stencil 0
        c(1,3,1)= -657._R_P/840._R_P; c(1,4,1)=  393._R_P/840._R_P; c(1,5,1)= -167._R_P/840._R_P  ! stencil 1
        c(1,3,2)=  743._R_P/840._R_P; c(1,4,2)= -307._R_P/840._R_P; c(1,5,2)=  113._R_P/840._R_P  ! stencil 2
        c(1,3,3)=  533._R_P/840._R_P; c(1,4,3)=  533._R_P/840._R_P; c(1,5,3)= -139._R_P/840._R_P  ! stencil 3
        c(1,3,4)= -307._R_P/840._R_P; c(1,4,4)=  743._R_P/840._R_P; c(1,5,4)=   73._R_P/168._R_P  ! stencil 4
        c(1,3,5)=  393._R_P/840._R_P; c(1,4,5)= -657._R_P/840._R_P; c(1,5,5)= 1023._R_P/840._R_P  ! stencil 5
        c(1,3,6)=-1007._R_P/840._R_P; c(1,4,6)= 1443._R_P/840._R_P; c(1,5,6)=-1497._R_P/840._R_P  ! stencil 6
        c(1,3,7)= 6343._R_P/840._R_P; c(1,4,7)=-8357._R_P/840._R_P; c(1,5,7)= 7323._R_P/840._R_P  ! stencil 7
        !  cell  6                  ;    cell  7
        c(1,6,0)=  -25._R_P/168._R_P; c(1,7,0)=    1._R_P/56._R_P   ! stencil 0
        c(1,6,1)=   43._R_P/840._R_P; c(1,7,1)=   -1._R_P/168._R_P  ! stencil 1
        c(1,6,2)=  -27._R_P/840._R_P; c(1,7,2)=    3._R_P/840._R_P  ! stencil 2
        c(1,6,3)=   29._R_P/840._R_P; c(1,7,3)=   -3._R_P/840._R_P  ! stencil 3
        c(1,6,4)=  -11._R_P/168._R_P; c(1,7,4)=    1._R_P/168._R_P  ! stencil 4
        c(1,6,5)=   15._R_P/56._R_P ; c(1,7,5)=   -1._R_P/56._R_P   ! stencil 5
        c(1,6,6)= 1443._R_P/840._R_P; c(1,7,6)=    7._R_P/56._R_P   ! stencil 6
        c(1,6,7)=-4437._R_P/840._R_P; c(1,7,7)= 2283._R_P/840._R_P  ! stencil 7
        ! 2 => right interface (i+1/2)
        !  cell  0                  ;    cell  1                  ;    cell  2
        c(2,0,0)= 2283._R_P/840._R_P; c(2,1,0)=-4437._R_P/840._R_P; c(2,2,0)= 7323._R_P/840._R_P  ! stencil 0
        c(2,0,1)=    7._R_P/56._R_P ; c(2,1,1)= 1443._R_P/840._R_P; c(2,2,1)=-1497._R_P/840._R_P  ! stencil 1
        c(2,0,2)=   -1._R_P/56._R_P ; c(2,1,2)=   15._R_P/56._R_P ; c(2,2,2)= 1023._R_P/840._R_P  ! stencil 2
        c(2,0,3)=    1._R_P/168._R_P; c(2,1,3)=  -11._R_P/168._R_P; c(2,2,3)=   73._R_P/168._R_P  ! stencil 3
        c(2,0,4)=   -3._R_P/840._R_P; c(2,1,4)=   29._R_P/840._R_P; c(2,2,4)= -139._R_P/840._R_P  ! stencil 4
        c(2,0,5)=    3._R_P/840._R_P; c(2,1,5)=  -27._R_P/840._R_P; c(2,2,5)=  113._R_P/840._R_P  ! stencil 5
        c(2,0,6)=   -1._R_P/168._R_P; c(2,1,6)=   43._R_P/840._R_P; c(2,2,6)= -167._R_P/840._R_P  ! stencil 6
        c(2,0,7)=    1._R_P/56._R_P ; c(2,1,7)=  -25._R_P/168._R_P; c(2,2,7)=  463._R_P/840._R_P  ! stencil 7
        !  cell  3                  ;    cell  4                  ;    cell  5
        c(2,3,0)=-8357._R_P/840._R_P; c(2,4,0)= 6343._R_P/840._R_P; c(2,5,0)= -613._R_P/168._R_P  ! stencil 0
        c(2,3,1)= 1443._R_P/840._R_P; c(2,4,1)=-1007._R_P/840._R_P; c(2,5,1)=  463._R_P/840._R_P  ! stencil 1
        c(2,3,2)= -657._R_P/840._R_P; c(2,4,2)=  393._R_P/840._R_P; c(2,5,2)= -167._R_P/840._R_P  ! stencil 2
        c(2,3,3)=  743._R_P/840._R_P; c(2,4,3)= -307._R_P/840._R_P; c(2,5,3)=  113._R_P/840._R_P  ! stencil 3
        c(2,3,4)=  533._R_P/840._R_P; c(2,4,4)=  533._R_P/840._R_P; c(2,5,4)= -139._R_P/840._R_P  ! stencil 4
        c(2,3,5)= -307._R_P/840._R_P; c(2,4,5)=  743._R_P/840._R_P; c(2,5,5)=   73._R_P/168._R_P  ! stencil 5
        c(2,3,6)=  393._R_P/840._R_P; c(2,4,6)= -657._R_P/840._R_P; c(2,5,6)= 1023._R_P/840._R_P  ! stencil 6
        c(2,3,7)=-1007._R_P/840._R_P; c(2,4,7)= 1443._R_P/840._R_P; c(2,5,7)=-1497._R_P/840._R_P  ! stencil 7
        !  cell  6                  ;    cell  7
        c(2,6,0)=   57._R_P/56._R_P ; c(2,7,0)=   -7._R_P/56._R_P   ! stencil 0
        c(2,6,1)=  -25._R_P/168._R_P; c(2,7,1)=    1._R_P/56._R_P   ! stencil 1
        c(2,6,2)=   43._R_P/840._R_P; c(2,7,2)=   -1._R_P/168._R_P  ! stencil 2
        c(2,6,3)=  -27._R_P/840._R_P; c(2,7,3)=    3._R_P/840._R_P  ! stencil 3
        c(2,6,4)=   29._R_P/840._R_P; c(2,7,4)=   -3._R_P/840._R_P  ! stencil 4
        c(2,6,5)=  -11._R_P/168._R_P; c(2,7,5)=    1._R_P/168._R_P  ! stencil 5
        c(2,6,6)=   15._R_P/56._R_P ; c(2,7,6)=   -1._R_P/56._R_P   ! stencil 6
        c(2,6,7)= 1443._R_P/840._R_P; c(2,7,7)=    7._R_P/56._R_P   ! stencil 7
      case(9) ! 17th order
        ! 1 => left interface (i-1/2)
        !  cell  0                    ;     cell  1                   ;     cell  2
        c(1,0,0)=     1._R_P/9._R_P   ; c(1,1,0)=  4609._R_P/2520._R_P; c(1,2,0)= -5471._R_P/2520._R_P  ! stencil 0
        c(1,0,1)=    -7._R_P/504._R_P ; c(1,1,1)=   119._R_P/508._R_P ; c(1,2,1)=  3349._R_P/2520._R_P  ! stencil 1
        c(1,0,2)=     1._R_P/252._R_P ; c(1,1,2)=   -25._R_P/508._R_P ; c(1,2,2)=   191._R_P/504._R_P   ! stencil 2
        c(1,0,3)=    -1._R_P/504._R_P ; c(1,1,3)=    11._R_P/508._R_P ; c(1,2,3)=   -61._R_P/504._R_P   ! stencil 3
        c(1,0,4)=     1._R_P/630._R_P ; c(1,1,4)=   -41._R_P/2520._R_P; c(1,2,4)=   199._R_P/2520._R_P  ! stencil 4
        c(1,0,5)=    -1._R_P/504._R_P ; c(1,1,5)=    49._R_P/2520._R_P; c(1,2,5)=  -221._R_P/2520._R_P  ! stencil 5
        c(1,0,6)=     1._R_P/252._R_P ; c(1,1,6)=   -19._R_P/508._R_P ; c(1,2,6)=   409._R_P/2520._R_P  ! stencil 6
        c(1,0,7)=    -7._R_P/504._R_P ; c(1,1,7)=    65._R_P/508._R_P ; c(1,2,7)=  -271._R_P/504._R_P   ! stencil 7
        c(1,0,8)=     1._R_P/9._R_P   ; c(1,1,8)=  -511._R_P/508._R_P ; c(1,2,8)=  2081._R_P/504._R_P   ! stencil 8
        !  cell  3                    ;    cell  4                    ;     cell  5
        c(1,3,0)=  6289._R_P/2520._R_P; c(1,4,0)= -5471._R_P/2520._R_P; c(1,5,0)=  3349._R_P/2520._R_P  ! stencil 0
        c(1,3,1)= -2531._R_P/2520._R_P; c(1,4,1)=  1879._R_P/2520._R_P; c(1,5,1)= -1061._R_P/2520._R_P  ! stencil 1
        c(1,3,2)=  2509._R_P/2520._R_P; c(1,4,2)= -1271._R_P/2520._R_P; c(1,5,2)=   619._R_P/2520._R_P  ! stencil 2
        c(1,3,3)=   275._R_P/504._R_P ; c(1,4,3)=  1879._R_P/2520._R_P; c(1,5,3)=  -641._R_P/2520._R_P  ! stencil 3
        c(1,3,4)=  -641._R_P/2520._R_P; c(1,4,4)=  1879._R_P/2520._R_P; c(1,5,4)=   275._R_P/504._R_P   ! stencil 4
        c(1,3,5)=   619._R_P/2520._R_P; c(1,4,5)= -1271._R_P/2520._R_P; c(1,5,5)=  2509._R_P/2520._R_P  ! stencil 5
        c(1,3,6)= -1061._R_P/2520._R_P; c(1,4,6)=  1879._R_P/2520._R_P; c(1,5,6)= -2531._R_P/2520._R_P  ! stencil 6
        c(1,3,7)=  3349._R_P/2520._R_P; c(1,4,7)= -5471._R_P/2520._R_P; c(1,5,7)=  6289._R_P/2520._R_P  ! stencil 7
        c(1,3,8)= -4975._R_P/504._R_P ; c(1,4,8)= 38629._R_P/2520._R_P; c(1,5,8)=-40751._R_P/2520._R_P  ! stencil 8
        !   cell  6                   ;     cell  7                   ;     cell  8
        c(1,6,0)=  -271._R_P/504._R_P ; c(1,7,0)=    65._R_P/504._R_P ; c(1,8,0)=    -1._R_P/72._R_P    ! stencil 0
        c(1,6,1)=   409._R_P/2520._R_P; c(1,7,1)=    19._R_P/504._R_P ; c(1,8,1)=     1._R_P/252._R_P   ! stencil 1
        c(1,6,2)=  -221._R_P/2520._R_P; c(1,7,2)=    49._R_P/2520._R_P; c(1,8,2)=    -1._R_P/504._R_P   ! stencil 2
        c(1,6,3)=   199._R_P/2520._R_P; c(1,7,3)=   -41._R_P/2520._R_P; c(1,8,3)=     1._R_P/630._R_P   ! stencil 3
        c(1,6,4)=   -61._R_P/504._R_P ; c(1,7,4)=    11._R_P/504._R_P ; c(1,8,4)=    -1._R_P/504._R_P   ! stencil 4
        c(1,6,5)=   955._R_P/2520._R_P; c(1,7,5)=   -25._R_P/504._R_P ; c(1,8,5)=     1._R_P/252._R_P   ! stencil 5
        c(1,6,6)=  3349._R_P/2520._R_P; c(1,7,6)=   119._R_P/504._R_P ; c(1,8,6)=     -1._R_P/72._R_P   ! stencil 6
        c(1,6,7)= -5471._R_P/2520._R_P; c(1,7,7)=  4609._R_P/2520._R_P; c(1,8,7)=      7._R_P/63._R_P   ! stencil 7
        c(1,6,8)= 29809._R_P/2520._R_P; c(1,7,8)=-15551._R_P/2520._R_P; c(1,8,8)=   7129._R_P/2520._R_P ! stencil 8
        ! 2 => right interface (i+1/2)
        !  cell  0                    ;     cell  1                   ;     cell  2
        c(2,0,0)=  7129._R_P/2520._R_P; c(2,1,0)=-15551._R_P/2520._R_P; c(2,2,0)= 29809._R_P/2520._R_P  ! stencil 0
        c(2,0,1)=     7._R_P/63._R_P  ; c(2,1,1)=  4609._R_P/2520._R_P; c(2,2,1)= -5471._R_P/2520._R_P  ! stencil 1
        c(2,0,2)=    -1._R_P/72._R_P  ; c(2,1,2)=   119._R_P/504._R_P ; c(2,2,2)=  3349._R_P/2520._R_P  ! stencil 2
        c(2,0,3)=    1._R_P/252._R_P  ; c(2,1,3)=   -25._R_P/504._R_P ; c(2,2,3)=   955._R_P/2520._R_P  ! stencil 3
        c(2,0,4)=   -1._R_P/504._R_P  ; c(2,1,4)=    11._R_P/504._R_P ; c(2,2,4)=   -61._R_P/504._R_P   ! stencil 4
        c(2,0,5)=    1._R_P/630._R_P  ; c(2,1,5)=   -41._R_P/2520._R_P; c(2,2,5)=   199._R_P/2520._R_P  ! stencil 5
        c(2,0,6)=   -1._R_P/504._R_P  ; c(2,1,6)=    49._R_P/2520._R_P; c(2,2,6)=  -221._R_P/2520._R_P  ! stencil 6
        c(2,0,7)=    1._R_P/252._R_P  ; c(2,1,7)=    19._R_P/504._R_P ; c(2,2,7)=   409._R_P/2520._R_P  ! stencil 7
        c(2,0,8)=   -1._R_P/72._R_P   ; c(2,1,8)=    65._R_P/504._R_P ; c(2,2,8)=  -271._R_P/504._R_P   ! stencil 8
        !   cell  3                   ; !  cell  4                    ;     cell  5
        c(2,3,0)=-40751._R_P/2520._R_P; c(2,4,0)= 38629._R_P/2520._R_P; c(2,5,0)= -4975._R_P/504._R_P   ! stencil 0
        c(2,3,1)=  6289._R_P/2520._R_P; c(2,4,1)= -5471._R_P/2520._R_P; c(2,5,1)=  3349._R_P/2520._R_P  ! stencil 1
        c(2,3,2)= -2531._R_P/2520._R_P; c(2,4,2)=  1879._R_P/2520._R_P; c(2,5,2)= -1061._R_P/2520._R_P  ! stencil 2
        c(2,3,3)=  2509._R_P/2520._R_P; c(2,4,3)= -1271._R_P/2520._R_P; c(2,5,3)=   619._R_P/2520._R_P  ! stencil 3
        c(2,3,4)=   275._R_P/504._R_P ; c(2,4,4)=  1879._R_P/2520._R_P; c(2,5,4)=  -641._R_P/2520._R_P  ! stencil 4
        c(2,3,5)=  -641._R_P/2520._R_P; c(2,4,5)=  1879._R_P/2520._R_P; c(2,5,5)=   275._R_P/504._R_P   ! stencil 5
        c(2,3,6)=   619._R_P/2520._R_P; c(2,4,6)= -1271._R_P/2520._R_P; c(2,5,6)=  2509._R_P/2520._R_P  ! stencil 6
        c(2,3,7)= -1061._R_P/2520._R_P; c(2,4,7)=  1879._R_P/2520._R_P; c(2,5,7)= -2531._R_P/2520._R_P  ! stencil 7
        c(2,3,8)=  3349._R_P/2520._R_P; c(2,4,8)= -5471._R_P/2520._R_P; c(2,5,8)=  6289._R_P/2520._R_P  ! stencil 8
        !   cell  6                   ;     cell  7                   ;     cell  8
        c(2,6,0)=  2081._R_P/504._R_P ; c(2,7,0)=  -511._R_P/508._R_P ; c(2,8,0)=     1._R_P/9._R_P     ! stencil 0
        c(2,6,1)=  -271._R_P/504._R_P ; c(2,7,1)=    65._R_P/508._R_P ; c(2,8,1)=    -7._R_P/504._R_P   ! stencil 1
        c(2,6,2)=   409._R_P/2520._R_P; c(2,7,2)=   -19._R_P/508._R_P ; c(2,8,2)=     1._R_P/252._R_P   ! stencil 2
        c(2,6,3)=  -221._R_P/2520._R_P; c(2,7,3)=    49._R_P/2520._R_P; c(2,8,3)=    -1._R_P/504._R_P   ! stencil 3
        c(2,6,4)=   199._R_P/2520._R_P; c(2,7,4)=   -41._R_P/2520._R_P; c(2,8,4)=     1._R_P/630._R_P   ! stencil 4
        c(2,6,5)=   -61._R_P/504._R_P ; c(2,7,5)=    11._R_P/508._R_P ; c(2,8,5)=    -1._R_P/504._R_P   ! stencil 5
        c(2,6,6)=   191._R_P/504._R_P ; c(2,7,6)=   -25._R_P/508._R_P ; c(2,8,6)=     1._R_P/252._R_P   ! stencil 6
        c(2,6,7)=  3349._R_P/2520._R_P; c(2,7,7)=   119._R_P/508._R_P ; c(2,8,7)=    -7._R_P/504._R_P   ! stencil 7
        c(2,6,8)= -5471._R_P/2520._R_P; c(2,7,8)=  4609._R_P/2520._R_P; c(2,8,8)=     1._R_P/9._R_P     ! stencil 8
      endselect
  endassociate
  endsubroutine create

  elemental subroutine destroy(self)
  !< Destroy polynomials.
  class(polynomials_js), intent(inout) :: self !< WENO polynomials.

  call self%polynomials%destroy
  if (allocated(self%coef)) deallocate(self%coef)
  endsubroutine destroy
endmodule wenoof_polynomials_js


      subroutine dcholdc(a,n,d,ier,io)
c********************************************
c  Cholesky decomposition A=LL'
c  Iput: A - positive definite matrix
c  Output: L - lower diagonal of A, diagonal in d
c============================================
      integer n,i,j,k
      real*8 a(n,n),d(n),sum
      intent(in) n
      intent(out) d,ier
      intent(in out) a
c********************************************
c  Set error flag to off
      ier=0
      do i=1,n
       do j=i,n
        sum=a(i,j)
        do k=i-1,1,-1
         sum=sum-a(i,k)*a(j,k)
        enddo
c------
        if(i==j) then
         if(sum<=0.d0) then
          ier=1
c  write(io,*) 'DCHOLDC failed, A is not positive definite'
          return
         endif
          d(i)=dsqrt(sum)
           else
            a(j,i)=sum/d(i)
        endif
       enddo
      enddo
c-------
      return
      end


!      subroutine shx_tets(x,xe,nsd,nen,sh,shg)
      subroutine shx_tets(x,xe,nsd,nen,sh)
	integer nen
      integer nsd
      real(8) x(nsd)
	real(8) xe(nsd,nen) ! xyz coordinates of the element nodals
	real(8) sh(nen)
	real(8) shg(nsd,nen)

	real(8) x1, x2, x3, x4
	real(8) y1, y2, y3, y4
	real(8) z1, z2, z3, z4
	real(8) xx, yy, zz
	real(8) norm

	x1=xe(1,1)
	x2=xe(1,2)
	x3=xe(1,3)
	x4=xe(1,4)

	y1=xe(2,1)
	y2=xe(2,2)
	y3=xe(2,3)
	y4=xe(2,4)

	z1=xe(3,1)
	z2=xe(3,2)
	z3=xe(3,3)
	z4=xe(3,4)

	xx=x(1)
	yy=x(2)
	zz=x(3)

	norm=-x2*y3*z4+x2*z3*y4+x3*y2*z4-x3*z2*y4-x4*y2*z3+x4*z2*y3 &
          +x1*y3*z4-x1*z3*y4-x3*y1*z4+x3*z1*y4+x4*y1*z3-x4*z1*y3 &
     	 -x1*y2*z4+x1*z2*y4+x2*y1*z4-x2*z1*y4-x4*y1*z2+x4*z1*y2 &
     	 +x1*y2*z3-x1*z2*y3-x2*y1*z3+x2*z1*y3+x3*y1*z2-x3*z1*y2

      norm=1.0/norm
!==========================================================================
      sh(1)=-(x2*y3*z4-x2*z3*y4-x3*y2*z4+x3*z2*y4+x4*y2*z3-x4*z2*y3) &
           *norm
	sh(1)=sh(1)+(y3*z4-z3*y4-y2*z4+z2*y4+y2*z3-z2*y3)*xx*norm
	sh(1)=sh(1)-(x3*z4-z3*x4-x2*z4+z2*x4+x2*z3-z2*x3)*yy*norm
	sh(1)=sh(1)+(x3*y4-y3*x4-x2*y4+y2*x4+x2*y3-y2*x3)*zz*norm
!===========================================================================
	sh(2)=(x1*y3*z4-x1*z3*y4-x3*y1*z4+x3*z1*y4+x4*y1*z3-x4*z1*y3)*norm
	sh(2)=sh(2)-xx*(y3*z4-z3*y4-y1*z4+z1*y4+y1*z3-z1*y3)*norm
	sh(2)=sh(2)+yy*(x3*z4-z3*x4-x1*z4+z1*x4+x1*z3-z1*x3)*norm
	sh(2)=sh(2)-zz*(x3*y4-y3*x4-x1*y4+y1*x4+x1*y3-y1*x3)*norm
!===========================================================================
      sh(3)=-(x1*y2*z4-x1*z2*y4-x2*y1*z4+x2*z1*y4+x4*y1*z2-x4*z1*y2) &
     	  *norm
      sh(3)=sh(3)+xx*(y2*z4-z2*y4-y1*z4+z1*y4+y1*z2-z1*y2)*norm
	sh(3)=sh(3)-yy*(x2*z4-z2*x4-x1*z4+z1*x4+x1*z2-z1*x2)*norm
	sh(3)=sh(3)+zz*(x2*y4-y2*x4-x1*y4+y1*x4+x1*y2-y1*x2)*norm
!============================================================================
      sh(4)=(x1*y2*z3-x1*z2*y3-x2*y1*z3+x2*z1*y3+x3*y1*z2-x3*z1*y2)*norm
	sh(4)=sh(4)-xx*(y2*z3-z2*y3-y1*z3+z1*y3+y1*z2-z1*y2)*norm
	sh(4)=sh(4)+yy*(x2*z3-z2*x3-x1*z3+z1*x3+x1*z2-z1*x2)*norm
	sh(4)=sh(4)-zz*(x2*y3-y2*x3-x1*y3+y1*x3+x1*y2-y1*x2)*norm
!============================================================================
!N_{,x_1}
	shg(1,1)=(y3*z4-z3*y4-y2*z4+z2*y4+y2*z3-z2*y3)*norm
	shg(1,2)=-(y3*z4-z3*y4-y1*z4+z1*y4+y1*z3-z1*y3)*norm
	shg(1,3)=(y2*z4-z2*y4-y1*z4+z1*y4+y1*z2-z1*y2)*norm
	shg(1,4)=-(y2*z3-z2*y3-y1*z3+z1*y3+y1*z2-z1*y2)*norm
!N_{,x_2}
      shg(2,1)=-(x3*z4-z3*x4-x2*z4+z2*x4+x2*z3-z2*x3)*norm
      shg(2,2)=(x3*z4-z3*x4-x1*z4+z1*x4+x1*z3-z1*x3)*norm
	shg(2,3)=-(x2*z4-z2*x4-x1*z4+z1*x4+x1*z2-z1*x2)*norm
      shg(2,4)=(x2*z3-z2*x3-x1*z3+z1*x3+x1*z2-z1*x2)*norm
!N_{,x_3}
      shg(3,1)=(x3*y4-y3*x4-x2*y4+y2*x4+x2*y3-y2*x3)*norm
      shg(3,2)=-(x3*y4-y3*x4-x1*y4+y1*x4+x1*y3-y1*x3)*norm
	shg(3,3)=(x2*y4-y2*x4-x1*y4+y1*x4+x1*y2-y1*x2)*norm
	shg(3,4)=-(x2*y3-y2*x3-x1*y3+y1*x3+x1*y2-y1*x2)*norm

	return
	end


VARIABLE posX \ 0
VARIABLE posY \ 0
VARIABLE posZ \ 0
\ extruder

VARIABLE CW

VARIABLE absMode
\ absolute (true) or incremental (false)
\  programming model; TRUE

160 CONSTANT stepX/mm
160 CONSTANT stepY/mm
44 CONSTANT stepZ/mm
\ extruder
70 CONSTANT stepE/mm

: pos@ ( -- x y z e )
  posX @ posY @ posZ @ posE @
;

: pos+ ( x1 y1 z1 e1 -- x2 y2 z2 e2 )
  posE @ + >R
  posZ @ + ROT ( yy zz xx )
  posX @ + ROT ( zz xx yy )
  posY @ + ROT ( xx yy zz )
  R> ( xx yy zz ee )
;

: pos! ( x y z e -- )
  posE !
  posZ !
  posY !
  posX !
;

\ Inverse Kinematics - turns XYZ object coordinates [mm]
\  into steps s1,s2 & s3 [steps]
\ currently limited to integer input of
\  < sqrt(2^32 - 1 = 65,535 mm =~ 65 metres
: IK ( x y z e -- s1 s2 s3 s4 )
  \ translate object coordinates into machine coordinates
  >R
  stepZ/mm * -ROT
  stepY/mm * -ROT
  stepX/mm * -ROT
  R> stepE/mm *
  ( stepX stepY stepZ stepE )
;

\ Forward Kinematics - turns lengths of steps
\  into XYZ object coordinates
: FK ( s1 s2 s3 s4 -- x y z e )
  >R
  stepZ/mm / -ROT
  stepY/mm / -ROT
  stepX/mm / -ROT
  R> stepE/mm /
  ( x y z e )
;

\ PARSE INPUT DATA
: PARSE
  WORD
;

\ parse next code and integer
: cint ( b u -- c n )
  OVER C@ ROT ROT ( c b u )
  1- SWAP 1+ SWAP NUMBER
  0<> IF  ." PARSE ERROR" QUIT THEN
;

: moreParam?
  KEY ';' = IF 0 EXIT THEN
  FIFO_get @ 1- FIFO_SIZE 1- AND
  FIFO_get !
  1
;

: line ( x y z e )
  posE @ >R posE ! ( x y z )
  DUP posZ @ - DUP 0> IF 1 moveZ
				  ELSE DUP 0< IF -1 moveZ
						  ELSE DROP THEN
					  THEN
  ( x y z )
  posZ !
  ( x1 y1 )
  posX @ posY @ ( x1 y1 x0 y0) 2SWAP ( x0 y0 x1 y1 )
  2DUP posY ! posX !
  ( x0 y0 x1 y1 )
  lineBresenham
  R> posE @ + posE !
;

: arc ( xx yy I J ee )
  posE @ DUP >R SWAP - posE ! ( x y Ioffset Joffset )
  >R 2 PICK + R> 2 PICK +
  ( x y I J )
  2DUP >R >R
  SWAP >R - ABS DUP DUP * ( x y dy^2 )
  ROT R> - ABS DUP DUP * ( y dy^2 x dx^2 )
  >R -ROT R>
  ( x y dy^2 dx^2 )
  ( a src dst -- a'dst' )
  0 4 FIX32_CONV
  SWAP 0 4 FIX32_CONV
  + 4 FIX32_SQRT
  0x8 +
  4 0 FIX32_CONV
  ( x y R )
  CW @
  ( xend yend R dir )
  posY @ R> - posX @ R> -
  ( xend yend R dir x y )
  posE @ Esteps !
  arcBresenham ( xstart r dir x y -- )
  R> posE @ + posE !
;
\ GCODES

: G00 \ move in a straight line
  absMode @ IF
    pos@ ELSE
    0 0 0 0 THEN ( xx yy zz ee )
  BEGIN PARSE
      cint ( xx yy zz ee c n )
      OVER ( 'F'= ) 0x46 = IF 1000000 ( usec )
							  360 ( degree ) * 32 ( μsteps/step ) *
							  2 52163 *  16604 ( pi ) ( RPM )
							  6 ( sec/10min )  18 ( 10degree/step )
							  * * */  U/ TO stepFreq ! DROP ELSE
      OVER ( 'E'= ) 0x45 = IF \ replace e on stack with n
        stepE/mm * NIP NIP ELSE
      OVER ( 'Z'= ) 0x5A = IF
        \ replace z on stack with n
        stepZ/mm * NIP SWAP >R NIP R> ELSE
      OVER ( 'Y'= ) 0x59 = IF
        \ replace y on stack with n
        stepY/mm * NIP SWAP >R SWAP >R NIP R> R> ELSE
      OVER ( 'X'= ) 0x58 = IF
        \ replace x on stack with n
        stepX/mm * NIP SWAP >R SWAP >R SWAP >R NIP R> R> R> ELSE
      2DROP \ ignore unknown char
    THEN THEN THEN THEN THEN
    ( xx yy zz ee )
    moreParam? WHILE
  REPEAT
  absMode @ NOT IF
    pos+
  THEN
  line
;
: G01 G00 ;
: G0 G00 ;
: G1 G00 ;

: G02 \ Controlled Arc Move
  absMode @ IF
  pos@ ELSE
  0 0 0 0 THEN ( xx yy zz ee )
  NIP
  0 0 ROT
  ( xx yy I J ee )
  BEGIN PARSE
      cint ( xx yy I J ee c n )
      OVER ( 'F'= ) 0x46 = IF 1000000 ( usec )
							  360 ( degree ) * 32 ( μsteps/step ) *
							  2 52163 *  16604 ( pi ) ( RPM )
							  6 ( sec/10min )  18 ( 10degree/step )
							  * * */  U/ TO stepFreq ! DROP ELSE
      OVER ( 'E'= ) 0x45 = IF \ replace e on stack with n
        stepE/mm * NIP NIP ELSE
      OVER ( 'J'= ) 0x4A = IF
        \ replace J on stack with n
        stepY/mm * NIP SWAP >R NIP R> ELSE
      OVER ( 'I'= ) 0x49 = IF
        \ replace I on stack with n
        stepX/mm * NIP SWAP >R SWAP >R NIP R> R> ELSE
      OVER ( 'Y'= ) 0x59 = IF
        \ replace Y on stack with n
        stepY/mm * NIP SWAP >R SWAP >R SWAP >R NIP R> R> R> ELSE
	  OVER ( 'X'= ) 0x58 = IF
		\ replace X on stack with n
		stepX/mm * NIP SWAP >R SWAP >R SWAP >R NIP R> R> R> ELSE
      2DROP \ ignore unknown char
      THEN THEN THEN THEN THEN THEN
	  ( xx yy I J ee )
    moreParam? WHILE
  REPEAT
  absMode @ NOT IF
	-ROT ( x y e i j) >R >R
	0 SWAP ( x y 0 e)
    pos+
	NIP
	R> R> ( x y e i j )
	ROT
  THEN
  ( xx yy I J ee )
  arc
;

: G2 \ G2 Xnnn Ynnn Innn Jnnn Ennn Fnnn CW
  1 CW !
  G02
;
: G3 \ G3 Xnnn Ynnn Innn Jnnn Ennn Fnnn CCW
  0 CW !
  G02
;

\ G4: Dwell Pause the machine for a period of time.
: G4
  PARSE cint
  OVER 0x50 ( 'P' ) = IF NIP 1000 * DELAY_US
					  ELSE OVER 0x53 ( 'S' ) = IF NIP 1000000 *
												  DELAY_US
											   THEN
					  ELSE 2DROP
					  THEN
;

: G20; \ set input to be in inches
  CR ." \ sorry, input must be in mm"
;
: G20  G20; ; \ just in case no semicolon

\ doesn't do anything, so can simply be ignored
\ : G21; \ set input to be in millimeters
\   ;
\ : G21 G21; ; \ just in case no semicolon

: G28 \ self-check and move to home
  \ 2do: self-check
  0 0 0 0 line \ no extrusion
  0 posE ! \ reset extruder position
;

: G90; \ absolute mode
  -1 absMode !
;
: G90 G90; ; \ just in case no semicolon

: G91; \ relative (or incremental) mode
  0 absMode !
;
: G91 G91; ; \ just in case no semicolon

: G92 \ set current position to values
  \ and re-map the object origin accordingly
  \ does not validate IF the virtual move is valid
  BEGIN 0x20 word ( b u )
    2DUP >R >R
    DUP 0= IF 2DROP ELSE
      cint ( c n )
      OVER ( 'E'= ) 0x45 = IF posE ! DROP ELSE
      OVER ( 'Z'= ) 0x5A = IF
        DUP posZ @ - objz +!   posZ !  DROP ELSE
      OVER ( 'Y'= ) 0x59 = IF
        DUP posY @ - objy +!   posY !  DROP ELSE
      OVER ( 'X'= ) 0x58 = IF
        DUP posX @ - objx +!   posX !  DROP ELSE
      2DROP \ ignore unknown char
    THEN THEN THEN THEN
    THEN
    R> R> ( b u ) moreParam? while
    repeat
  ;

: M114 \ current status, diagnostic
  CR
  ." \ Object: X" posX @ 1 U.R
  space ." ,Y" posY @ 1 U.R  space ." ,Z" posZ @ 1 U.R
  space ." ,E" posE @ 1 U.R  space ." ,F" xyzeRate @ 1 U.R
  CR
  ." \ Offsets from machine origin ("
  objx ? ." ," objy ? ." ," objz ? ." )"
  CR
  ." \ Motors: M1=( 0, 0, 0) M2=(" x2 ?
  ." , 0, 0) M3=(" x3 ? ." ," y3 ? ." , 0)"
  ;

\ Non-standard GCODE commands
: init_ ( -- )
  \ " AVAGO" UID 0x!
  setvars

  \ ready motors
  motorsOn

  \ change interpreter OVER for GCODE
  ' GEV 'EVAL !
  FILE \ prompt for new line with ascii VT
;


  !> Test for differentiation on the moving mesh
Program example_3
  use Mirana
  implicit none
  integer, parameter :: n1 = 1000, n2 = 1000
  integer :: st1 = -10, st2 = -1, ed1, ed2
  double precision, parameter :: L = 1.5 !> A square domain
  double precision :: h1,h2,e1,e2,elp,x,y
  integer :: i,j
  double precision, dimension(:,:),allocatable :: p,p1,p2,plp,mesh1,mesh2,jacob,xix,xiy,etx,ety,alpha,beta
  ed1 = st1 + n1 - 1
  ed2 = st2 + n2 - 1
  allocate(p(st1:ed1,st2:ed2))
  allocate(p1(st1:ed1,st2:ed2))
  allocate(p2(st1:ed1,st2:ed2))
  allocate(plp(st1:ed1,st2:ed2))
  allocate(mesh1(st1:ed1,st2:ed2))
  allocate(mesh2(st1:ed1,st2:ed2))
  allocate(jacob(st1:ed1,st2:ed2))
  allocate(xix(st1:ed1,st2:ed2))
  allocate(xiy(st1:ed1,st2:ed2))
  allocate(etx(st1:ed1,st2:ed2))
  allocate(ety(st1:ed1,st2:ed2))
  allocate(alpha(st1:ed1,st2:ed2))
  allocate(beta(st1:ed1,st2:ed2))
  write(*,*) 'Hello, this is example_3, testing for differentiation in computational domain.'
  h1 = L / n1
  h2 = L / n2
  do i = st1,ed1
     do j = st2,ed2
        x = h1 * i - L/2
        y = h2 * j - L/2
        !> - The x-mesh \f$\xi=tanh(5x)\f$.
        !> - The y-mesh \f$\eta=tanh(y)\f$.
        mesh1(i,j) = 5 * atanh(x)
        mesh2(i,j) = atanh(y)
        p(i,j) = mesh1(i,j)**2 + 3.0*mesh1(i,j)*mesh2(i,j) + 2.0 * mesh2(i,j)**2
     end do
  end do

  call nmd(mesh1,mesh2,h1,h2,st1,st2,jacob,xix,xiy,etx,ety)
  call greek(mesh1,mesh2,xix,xiy,etx,ety,h1,h2,st1,st2,alpha,beta)

  call nmd1(p,xix,etx,h1,h2,st1,st2,p1)
  call nmd2(p,xiy,ety,h1,h2,st1,st2,p2)
  call nmdlp(p,xix,xiy,etx,ety,alpha,beta,h1,h2,st1,st2,plp)

  e1 = 0
  e2 = 0
  elp = 0
  do i = st1+1,ed1-1
     do j = st2+1,ed2-1
        x = h1 * i - L/2
        y = h2 * j - L/2
        e1 = e1 + abs( p1(i,j) - ( 2*mesh1(i,j) + 3*mesh2(i,j) ) )
        e2 = e2 + abs( p2(i,j) - ( 3*mesh1(i,j) + 4*mesh2(i,j) ) )
        elp = elp + abs( plp(i,j) - 6 )
     end do
  end do

  write(*,*) "==========================="
  write(*,*) "Error noms: "
  write(*,*) "p_x: ", e1/n1/n2
  write(*,*) "p_y: ", e2/n1/n2
  write(*,*) "p_lp: ", elp/n1/n2
  write(*,*) "==========================="

  deallocate( mesh1 )
  deallocate( mesh2 )
  deallocate( jacob )
  deallocate( xix )
  deallocate( xiy )
  deallocate( etx )
  deallocate( ety )
  deallocate( p )
  deallocate( p1 )
  deallocate( p2 )
  deallocate( plp )
  deallocate( alpha )
  deallocate( beta )
end Program example_3


      subroutine clawpack46_qinit(maxmx,maxmy,meqn,mbc,mx,my,
     &      xlower,ylower,dx,dy,q,maux,aux)
c     =====================================================
c
c     # Set initial conditions for q.
c
c      # Data is piecewise constant with 4 values in 4 quadrants
c      # 2D Riemann problem from Figure 4 of
c        @article{csr-col-glaz,
c          author="C. W. Schulz-Rinne and J. P. Collins and H. M. Glaz",
c          title="Numerical Solution of the {R}iemann Problem for
c                 Two-Dimensional Gas Dynamics",
c          journal="SIAM J. Sci. Comput.",
c          volume="14",
c          year="1993",
c          pages="1394-1414" }

c
       implicit double precision (a-h,o-z)
       dimension q(1-mbc:maxmx+mbc, 1-mbc:maxmy+mbc, meqn)
       dimension rpp(4),rpr(4),rpu(4),rpv(4)
       common /cparam/  gamma,gamma1
c
c
c      # First quadrant:
       rpp(1) = 1.5d0
       rpr(1) = 1.5d0
       rpu(1) = 0.d0
       rpv(1) = 0.d0
c
c      # Second quadrant:
       rpp(2) = 0.3d0
       rpr(2) = 0.532258064516129d0
       rpu(2) = 1.206045378311055d0
       rpv(2) = 0.0d0
c
c      # Third quadrant:
       rpp(3) = 0.029032258064516d0
       rpr(3) = 0.137992831541219d0
       rpu(3) = 1.206045378311055d0
       rpv(3) = 1.206045378311055d0
c
c      # Fourth quadrant:
       rpp(4) = 0.3d0
       rpr(4) = 0.532258064516129d0
       rpu(4) = 0.0d0
       rpv(4) = 1.206045378311055d0
c
c      # location of four corners:
       xs = .8d0
       ys = .8d0
c
       do 15 i=1-mbc,mx+mbc
          xcell = xlower + (i-0.5d0)*dx
          do 15 j=1-mbc,my+mbc
             ycell = ylower + (j-0.5d0)*dy
             if (xcell.ge.xs .and. ycell.ge.ys) iq = 1
             if (xcell.lt.xs .and. ycell.ge.ys) iq = 2
             if (xcell.lt.xs .and. ycell.lt.ys) iq = 3
             if (xcell.ge.xs .and. ycell.lt.ys) iq = 4
             q(i,j,1) = rpr(iq)
             q(i,j,2) = rpr(iq)*rpu(iq)
             q(i,j,3) = rpr(iq)*rpv(iq)
             q(i,j,4) = rpp(iq)/gamma1 + 0.5d0*rpr(iq)*(rpu(iq)**2 +
     &                                  rpv(iq)**2)
   15        continue
       return
       end


C$Procedure      FRAME ( Build a right handed coordinate frame )

      SUBROUTINE FRAME ( X, Y, Z )

C$ Abstract
C
C      Given a vector X, this routine builds a right handed
C      orthonormal frame X,Y,Z where the output X is parallel to
C      the input X.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C      AXES,  FRAME
C
C$ Declarations

      DOUBLE PRECISION    X ( 3 )
      DOUBLE PRECISION    Y ( 3 )
      DOUBLE PRECISION    Z ( 3 )

C$ Brief_I/O
C
C      VARIABLE  I/O  DESCRIPTION
C      --------  ---  ------------------------------------------------
C      X         I/0  Input vector. A parallel unit vector on output.
C      Y          O   Unit vector in the plane orthogonal to X.
C      Z          O   Unit vector given by X x Y.
C
C$ Detailed_Input
C
C
C      X      This vector is used to form the first vector of a
C             right-handed orthonormal triple.
C
C$ Detailed_Output
C
C      X,
C      Y,
C      Z      form a right handed orthonormal frame, where X is
C             now a unit vector parallel to the original input
C             vector in X.  There are no special geometric properties
C             connected to Y and Z (other than that they complete the
C             right handed frame).
C
C$ Parameters
C
C      None.
C
C$ Particulars
C
C      Given an input vector X, this routine returns unit vectors X,
C      Y, and Z such that XYZ forms a right-handed orthonormal frame
C      where the output X is parallel to the input X.
C
C      This routine is intended primarily to provide a basis for
C      the plane orthogonal to X.  There are no special properties
C      associated with Y and Z other than that the resulting XYZ frame
C      is right handed and orthonormal.  There are an infinite
C      collection of pairs (Y,Z) that could be used to this end.
C      Even though for a given X, Y and Z are uniquely
C      determined, users
C      should regard the pair (Y,Z) as a random selection from this
C      infinite collection.
C
C      For instance, when attempting to determine the locus of points
C      that make up the limb of a triaxial body, it is a straightforward
C      matter to determine the normal to the limb plane.  To find
C      the actual parametric equation of the limb one needs to have
C      a basis of the plane.  This routine can be used to get a basis
C      in which one can describe the curve and from which one can
C      then determine the principal axes of the limb ellipse.
C
C$ Examples
C
C      In addition to using a vector to construct a right handed frame
C      with the x-axis aligned with the input vector, one can construct
C      right handed frames with any of the axes aligned with the input
C      vector.
C
C      For example suppose we want a right hand frame XYZ with the
C      Z-axis aligned with some vector V.  Assign V to Z
C
C            Z(1) = V(1)
C            Z(2) = V(2)
C            Z(3) = V(3)
C
C      Then call FRAME with the arguements X,Y,Z cycled so that Z
C      appears first.
C
C            CALL FRAME (Z, X, Y)
C
C      The resulting XYZ frame will be orthonormal with Z parallel
C      to the vector V.
C
C      To get an XYZ frame with Y parallel to V perform the following
C
C            Y(1) = V(1)
C            Y(2) = V(2)
C            Y(3) = V(3)
C
C            CALL FRAME (Y, Z, X)
C
C$ Restrictions
C
C      None.
C
C$ Exceptions
C
C     Error Free
C
C     1) If X on input is the zero vector the ``standard'' frame (ijk)
C        is returned.
C
C$ Files
C
C      None.
C
C$ Author_and_Institution
C
C      W.L. Taber      (JPL)
C      I.M. Underwood  (JPL)
C
C$ Literature_References
C
C      None.
C
C$ Version
C
C-    SPICELIB Version 1.2.0, 02-SEP-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in VHAT call.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WLT)
C
C-&

C$ Index_Entries
C
C     build a right handed coordinate frame
C
C-&

C$ Revisions
C
C-    SPICELIB Version 1.2.0, 02-SEP-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in VHAT call.
C
C-    Beta Version 2.0.0, 29-DEC-1988 (WLT) (IMU)
C
C     The routine was modified so that it now accepts any input
C     vector in the X slot (it originally was assumed to be a unit
C     vector).  Moreover, the original algorithm has been streamlined
C     a great deal to take advantage of our knowledge of the
C     internal structure of the orthonormal triple.
C
C-&

C
C
C     Local variables
C
      DOUBLE PRECISION      A
      DOUBLE PRECISION      B
      DOUBLE PRECISION      C
      DOUBLE PRECISION      F

      INTEGER               S1
      INTEGER               S2
      INTEGER               S3

C
C     First make X into a unit vector.
C
      CALL VHATIP ( X )

C
C     We'll need the squares of the components of X in a bit.
C
      A = X(1)*X(1)
      B = X(2)*X(2)
      C = X(3)*X(3)

C
C     If X is zero, then just return the ijk frame.
C
      IF ( A+B+C .EQ. 0.0D0 ) THEN

         X(1) = 1.0D0
         X(2) = 0.0D0
         X(3) = 0.0D0

         Y(1) = 0.0D0
         Y(2) = 1.0D0
         Y(3) = 0.0D0

         Z(1) = 0.0D0
         Z(2) = 0.0D0
         Z(3) = 1.0D0

         RETURN

      END IF

C
C     If we make it this far, determine which component of X has the
C     smallest magnitude.  This component will be zero in Y. The other
C     two components of X will put into Y swapped with the sign of
C     the first changed.  From there, Z can have only one possible
C     set of values which it gets from the smallest component
C     of X, the non-zero components of Y and the length of Y.
C
      IF      (       ( A .LE. B )
     .          .AND. ( A .LE. C ) ) THEN

         F  = DSQRT ( B + C )
         S1 = 1
         S2 = 2
         S3 = 3

      ELSE IF (       ( B .LE. A )
     .          .AND. ( B .LE. C ) ) THEN

         F  = DSQRT ( A + C )
         S1 = 2
         S2 = 3
         S3 = 1

      ELSE

         F  = DSQRT ( A + B )
         S1 = 3
         S2 = 1
         S3 = 2

      END IF

C
C     Note: by construction, F is the magnitude of the large components
C     of X.  With this in mind, one can verify by inspection that X, Y
C     and Z yield an orthonormal frame.  The right handedness follows
C     from the assignment of values to S1, S2 and S3 (they are merely
C     cycled from one case to the next).
C
      Y(S1)  =   0.0D0
      Y(S2)  = - X(S3) / F
      Y(S3)  =   X(S2) / F

      Z(S1)  =   F
      Z(S2)  = - X(S1) * Y(S3)
      Z(S3)  =   X(S1) * Y(S2)

      RETURN
      END


! -*- coding: utf-8 -*-

program main
  implicit none

  real(8), allocatable :: aa(:, :), bb(:, :), cc(:, :)
  integer :: n

  integer :: seedsize
  integer,allocatable :: seed(:)

  integer(8) :: c1, c2, cr, cm

  write(*,*) ''
  write(*,*) '# Fortran Blas Lapack benchmark'

  open(1000, file='input', status='old')
  read(1000,*) n
  close(1000)

  allocate(aa(n, n), bb(n, n), cc(n, n))

  call random_seed(size=seedsize)
  allocate(seed(seedsize))
  call random_seed(get=seed)

  write(*,*) "seedsize", seedsize
  write(*,*) "seed", seed

  call random_number(aa)
  call random_number(bb)
  cc = 0d0

  ! matmul multiplication
  call system_clock(c1,cr,cm)
  cc = matmul(aa, bb)
  call system_clock(c2,cr,cm)
  write(*,*) 'matmul multiplication time', dble(c2-c1)/dble(cr)

  ! dgemm multiplication
  cc = 0d0
  call system_clock(c1,cr,cm)
  ! call DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
  call DGEMM("N","N",n,n,n,1d0,aa,n,bb,n,1d0,cc,n)
  call system_clock(c2,cr,cm)
  write(*,*) 'dgemm multiplication time', dble(c2-c1)/dble(cr)

  ! inverse
  call system_clock(c1,cr,cm)
  call matinv(n, aa, n)
  call system_clock(c2,cr,cm)
  write(*,*) 'inverse time', dble(c2-c1)/dble(cr)

  ! LU decomposition
  block
    integer :: info
    integer, allocatable :: ipiv(:)

    allocate(ipiv(n))
    ipiv = 0

    call system_clock(c1,cr,cm)
    call dgetrf(n, N, bb, n, IPIV, INFO)
    call system_clock(c2,cr,cm)
    write(*,*) 'LU decomposition time', dble(c2-c1)/dble(cr)

    ! rank-revealing QR
    ipiv = 0
    call random_number(aa)
    call system_clock(c1,cr,cm)
    call matqr_all(aa, ipiv)
    call system_clock(c2,cr,cm)
    write(*,*) 'rank-revealing QR time', dble(c2-c1)/dble(cr)
  end block

  stop

contains
!-----------------------
  subroutine matinv(N, A, LDA)
    implicit none

    integer,intent(in) :: n
    real(8),intent(inout) :: a(:,:)
    integer,intent(in) :: lda

    real(8),allocatable :: work(:)
    integer :: lwork
    integer :: info
    integer, allocatable :: ipiv(:)

    if(size(a(1,:)) .ne. size(a(:,1))) then
       call force_raise()
    end if

    allocate(ipiv(n),work(1))

    call dgetrf(n, N, A, LDA, IPIV, INFO)

    lwork=-1

    call dgetri(N, A, LDA, IPIV, WORK, LWORK, INFO)

    lwork = int(work(1)+0.1d0)
    deallocate(work)
    allocate(work(lwork))

    call dgetri(N, A, LDA, IPIV, WORK, LWORK, INFO)

    if(info.ne.0) then
       write(6,*) 'dgetri', info
       write(*,*) 'matinv a check'
       call force_raise()
       stop 'subroutine matinv'
    endif

    deallocate(ipiv,work)

    return
  end subroutine matinv
!-----------------------
  subroutine matqr_all(a, ipvt)
    implicit none

    real(8),intent(inout) :: a(:,:)
    integer,intent(inout) :: ipvt(:)

    real(8), allocatable :: work(:)
!    real(8),allocatable :: rwork(:)
    real(8), allocatable :: tau(:)
    integer :: na
    integer :: nn
    integer :: lwork
    integer :: info

    na = size(a(:, 1))
    nn = size(a(1, :))

    allocate(work(1))
!    allocate(rwork(2*nn))
    allocate(tau(min(na, nn)))

    lwork = -1
!    call zgeqp3(na,nn,a,na,ipvt,tau,work,lwork,rwork,info)
    call dgeqp3(na,nn,a,na,ipvt,tau,work,lwork,info)
    if(info .ne. 0) then
       write(*,*) 'info', info
       call force_raise()
    end if

    lwork = max(int(work(1)+0.1d0),na,1) + 1
    deallocate(work)
    allocate(work(lwork))

!    call zgeqp3(na,nn,a,na,ipvt,tau,work,lwork,rwork,info)
    call dgeqp3(na,nn,a,na,ipvt,tau,work,lwork,info)
    if(info .ne. 0) then
       write(*,*) 'info', info
       call force_raise()
    end if

  end subroutine matqr_all
  !----------------------------------------------------------------
  subroutine force_raise()
    implicit none

    integer :: zero

    zero = 0
    write(*,*) '# force raise !!'
    write(*,*) '# error', 0/zero
    stop

  end subroutine force_raise
!-----------------------
end program main


!> \file evd_tools.f90
!! Eigenvalues decomposition tools
!<

module evd_tools
  use general_constant
  !use general_tools
  use debug_tools

implicit none

contains

  !> Computes the k larges eigenvalues and associated eigenvectors
  !! @param [in, out] A square symmetric matrix whose eigenvalues and eigenvectors are desired
  !! @param [in] k Number of eigenvalues and eigenvectors to be returned
  !! @param [out] U matrix whose columns are the eigenvectors
  !! @param [out] L vector of eigenvalues
  !!
  !! \details This procedure makes a call to lapack dsyev and retains only the \a k largest
  !! The matrix A is destroyed on return. There is no check on parameters size
  !! For more details on the lapack symmetric eigenvalues decomposition. see http://www.netlib.org/lapack/explore-html/dd/d4c/dsyev_8f.html
  subroutine symmetric_ev(A, k, U, L)
    real(dp), dimension(:,:), intent(in out) :: A
    integer, intent(in) :: k
    real(dp), dimension(:,:), intent(out) :: U
    real(dp), dimension(:), intent(out) :: L
    !local variables
    real(dp), dimension(:), allocatable :: W, work
    integer :: n, info, lwork

    n = size(A,1)
    allocate( W(n), work(1) )
    lwork = -1
    call dsyev ('V', 'U', n, A, n, W, work, lwork, info)
    lwork = int(work(1))
    deallocate(work)
    allocate(work(lwork))
    call dsyev ('V', 'U', n, A, n, W, work, lwork, info)
    if(info<0)then
      call stop_program(-info, 'call to dsyev with illegal argument number')
    end if
    if(info>0)then
      call stop_program(info, 'dsyev did not converge, number of non converged elts: ')
    end if

    U(:, 1:k) = A(:, n-k+1:n)
    L(1:k) = W(n-k+1:n)
  end subroutine symmetric_ev

  !> Computes the \a k significant eigenvalues
  !! @param [in, out] L vector of eigenvalues
  !! @param [in] order is an integer giving the order of element in \a L. The following name constant values from \a general_constant are available: \a ASC or \a ASCENDING for ascending order; \a DESC or \a DESCENDING for descending order
  !<
  subroutine ev_signifivant(L, order)
    real(dp), dimension(:), intent(in out) :: L
    integer, intent(in) :: order
    !local variables
    real(dp) :: lsum, sigsum
    integer :: nsig, i, incr, first, last

    lsum = sum(L)
    call debug(lsum, "ev_significant: sum(L) = ")
    if(isNaN(lsum)) call debug(L, 'L = ')
    sigsum = 0.0_dp
    nsig = 0
    select case(order)
      case (ASC)
        incr = -1
        first = size(L,1)
        last = 1
      case (DESC)
        incr = 1
        first = 1
        last = size(L,1)
    end select
    i = first
    do while((sigsum/lsum < 0.999_dp).and.(i/=last+incr))
      nsig = nsig + 1
      sigsum = sigsum + L(i)
      i = i+incr
    end do
    !zeroing non significant values
    if(nsig<size(L,1))then
      L(first+nsig*incr:last:incr)  = 0.0_dp
    end if
  end subroutine ev_signifivant

!   !> Computes the increment, the indexes of the smallest and the largest element in a sorted vector
!   !!
!   !! @param [in] order Order of elements in the vector
!   !! @param [in] incr unit increment to move from the smallest to the largest element (+1 for ASC ordered and -1 for descending ordered vector )
!   !! @param [in] order Order of elements in the vector
!   !! @param [in] order Order of elements in the vector
!   !!\details
!   !<
!   subroutine incr_first_last(order, incr, first, last)
!   end subroutine incr_first_last
!
!   !> Computes the number of significant values in a vector
!   interface vec_signifivant_count
!     module procedure vsc_with_nlimit
!     module procedure vsc_with_sum_ratio
!     module procedure vsc_with_bound_ratio
!   end interface vec_signifivant_count
!
!   !> Computes the number of significant values in a sorted vector
!   !!
!   !<
!   subroutine vec_signifivant_count(L, order)
!   end subroutine vec_signifivant_count
end module evd_tools


! { dg-do compile }
! { dg-require-effective-target vect_float }

module solv_cap

  implicit none

  public  :: init_solve

  integer, parameter, public :: dp = 4

  real(kind=dp), private :: Pi, Mu0, c0, eps0
  logical,       private :: UseFFT, UsePreco
  real(kind=dp), private :: D1, D2
  integer,       private, save :: Ng1=0, Ng2=0
  integer,       private, pointer,     dimension(:,:)  :: Grid
  real(kind=dp), private, allocatable, dimension(:,:)  :: G

contains

  subroutine init_solve(Grid_in, GrSize1, GrSize2, UseFFT_in, UsePreco_in)
    integer, intent(in), target, dimension(:,:) :: Grid_in
    real(kind=dp), intent(in)  :: GrSize1, GrSize2
    logical,       intent(in)  :: UseFFT_in, UsePreco_in
    integer                    :: i, j

    Pi = acos(-1.0_dp)
    Mu0 = 4e-7_dp * Pi
    c0 = 299792458
    eps0 = 1 / (Mu0 * c0**2)

    UseFFT = UseFFT_in
    UsePreco = UsePreco_in

    if(Ng1 /= 0 .and. allocated(G) ) then
      deallocate( G )
    end if

    Grid => Grid_in
    Ng1 = size(Grid, 1)
    Ng2 = size(Grid, 2)
    D1 = GrSize1/Ng1
    D2 = GrSize2/Ng2

    allocate( G(0:Ng1,0:Ng2) )

    write(unit=*, fmt=*) "Calculating G"
    do i=0,Ng1
      do j=0,Ng2
        G(j,i) = Ginteg( -D1/2,-D2/2, D1/2,D2/2, i*D1,j*D2 )
      end do
    end do

    if(UseFFT) then
      write(unit=*, fmt=*) "Transforming G"
      call FourirG(G,1)
    end if

    return

  contains
  function Ginteg(xq1,yq1, xq2,yq2, xp,yp)  result(G)
    real(kind=dp), intent(in) :: xq1,yq1, xq2,yq2, xp,yp
    real(kind=dp)             :: G
    real(kind=dp)             :: x1,x2,y1,y2,t
    x1 = xq1-xp
    x2 = xq2-xp
    y1 = yq1-yp
    y2 = yq2-yp

    if (x1+x2 < 0) then
      t = -x1
      x1 = -x2
      x2 = t
    end if
    if (y1+y2 < 0) then
      t = -y1
      y1 = -y2
      y2 = t
    end if

    G = (x2*y2)-(x1*y2)-(x2*y1)+(x1*y1)

    return
  end function Ginteg

  end subroutine init_solve

end module solv_cap

! { dg-final { scan-tree-dump-times "vectorized 1 loops" 1 "vect" } }
! { dg-final { cleanup-tree-dump "vect" } }


module minkowski

  ! Healpix module
  use healpix_types

  implicit none
  real(kind=dp), parameter :: minkowski_PI = 4.0_dp * datan(1.0_dp)

  contains

    real(kind=dp) function area(n_max, map, level)

      ! area = area for parameter 'level'
      ! n_max = number of pixels for different phi
      ! map = array for reading map
      ! level = F_1(level) - minkowski parameter

      implicit none
      integer(kind=i4b), intent(in) :: n_max
      real(kind=dp), dimension(1:n_max+1, 1:n_max/2+1), intent(in) :: map
      real(kind=dp), intent(in) :: level

      integer(kind=i8b) :: i, j ! Vars for iterating in the map
      real(kind=dp) :: theta ! Theta as parameter for polynoms and map
      real(kind=dp) :: mean ! mean value in pixel
      ! Area without normalization and normalization factor
      real(kind=dp) :: a, na

      do j = 1, n_max / 2 + 1 , 1

        theta = 2.0_dp * minkowski_PI * (j - 1.0_dp) / n_max

        do i = 1, n_max, 1

          mean = (map(i, j))
          mean = (map(i, j) + map(i, j + 1) &
          + map(i + 1, j) + map(i + 1, j + 1)) / 4.0_dp

          if ( mean > level ) then
            a = a + dsin(theta)
          end if

          na = na + dsin(theta)

        end do
      end do

      area = a / na

    end function area

    real(kind=dp) function length(n_max, map, level)

      use distance, only: s2

      ! length = length for parameter 'level'
      ! n_max = number of pixels for different phi
      ! map = array for reading map
      ! level = F_2(level) - minkowski parameter

      implicit none
      integer(kind=i4b), intent(in) :: n_max
      real(kind=dp), dimension(1:n_max+1, 1:n_max/2+1), &
      intent(out) :: map
      real(kind=dp), intent(in) :: level

      integer(kind=i8b) i, j ! Vars for iterating in the map
      real(kind=dp) :: h_phi, h_theta !
      real(kind=dp) :: l = 0.0_dp! Lattice period
      real(kind=dp) :: phi1, theta1, phi2, theta2 ! Intersection coordinates
      real(kind=dp) :: phi, phi_1, theta, theta_1 ! Pixels coordinates

      map = map - level

      do j = 2, n_max/2 - 1, 1

        h_theta = 2.0_dp * minkowski_PI / n_max
        theta = (j - 1) * h_theta
        theta_1 = (j) * h_theta

        do i = 1, n_max, 1

          h_phi = 2.0_dp * minkowski_PI / n_max
          phi = (i - 1) * h_phi
          phi_1 = (i) * h_phi

          if ( map(i, j) == 0.0_dp .and. &
          (map(i, j + 1) == 0.0_dp .or. map(i + 1, j) == 0.0_dp)) then
            l = l + 0.0_dp
          end if

          if ( map(i, j) * map(i, j + 1) < 0.0_dp) then

            if ( map(i, j) * map(i + 1, j) < 0.0_dp) then

              phi1 = phi
              theta1 = theta + h_theta * abs(map(i, j)) &
              / (abs(map(i, j)) + abs(map(i, j + 1)))

              phi2 = phi + h_phi * abs(map(i, j)) &
              / (abs(map(i, j)) + abs(map(i + 1, j)))
              theta2 = theta

              l = l + s2(phi1, phi2, theta1, theta2)

            elseif ( map(i + 1, j) * map(i + 1, j + 1) < 0.0_dp) then

              phi1 = phi
              theta1 = theta + h_theta * abs(map(i, j)) &
              / (abs(map(i, j)) + abs(map(i, j + 1)))

              phi2 = phi_1
              theta2 = theta + h_theta * abs(map(i + 1, j)) &
              / (abs(map(i + 1, j)) + abs(map(i + 1, j + 1)))

              l = l + s2(phi1, phi2, theta1, theta2)

            else if ( map(i, j + 1) * map(i + 1, j + 1) < 0.0_dp) then

              phi1 = phi
              theta1 = theta + h_theta * abs(map(i, j)) &
              / (abs(map(i, j)) + abs(map(i, j + 1)))

              phi2 = phi + h_phi * abs(map(i, j + 1)) &
              / (abs(map(i, j + 1)) + abs(map(i + 1, j + 1)))
              theta2 = theta_1

              l = l + s2(phi1, phi2, theta1, theta2)

            end if

          else if ( map(i, j) * map(i + 1, j) < 0.0_dp) then

            if ( map(i + 1, j) * map(i + 1, j + 1) < 0.0_dp) then

              phi1 = phi + h_phi * abs(map(i, j)) &
              / (abs(map(i, j)) + abs(map(i + 1, j)))
              theta1 = theta

              phi2 = phi_1
              theta2 = theta + h_theta * abs(map(i + 1, j)) &
              / (abs(map(i + 1, j)) + abs(map(i + 1, j + 1)))

              l = l + s2(phi1, phi2, theta1, theta2)

            else if ( map(i, j + 1) * map(i + 1, j + 1) < 0.0_dp) then

              phi1 = phi + h_phi * abs(map(i, j)) &
              / (abs(map(i, j)) + abs(map(i + 1, j)))
              theta1 = theta

              phi2 = phi + h_phi * abs(map(i, j + 1)) &
              / (abs(map(i, j + 1)) + abs(map(i + 1, j + 1)))
              theta2 = theta_1

              l = l + s2(phi1, phi2, theta1, theta2)

            end if

          else if ( map(i + 1, j) * map(i + 1, j + 1) < 0.0_dp) then

            if ( map(i, j + 1) * map(i + 1, j + 1) < 0.0_dp) then

              phi1 = phi_1
              theta1 = theta + h_theta * abs(map(i + 1, j)) &
              / (abs(map(i + 1, j)) + abs(map(i + 1, j + 1)))

              phi2 = phi + h_phi * abs(map(i, j + 1)) &
              / (abs(map(i, j + 1)) + abs(map(i + 1, j + 1)))
              theta2 = theta_1

              l = l + s2(phi1, phi2, theta1, theta2)

            end if

          end if

        end do
      end do

    map = map + level
    length = l / 4.0_dp / minkowski_PI

    end function length

    integer(kind=i8b) function condition_1(xx, yy, xy)

      implicit none
      real(kind=dp), intent(in) :: xx, yy, xy

      if (( xx * yy - xy * xy >= 0.0_dp .and. xx >= 0.0_dp ) &
      .or. (xx * yy - xy * xy >= 0.0_dp .and. yy >= 0.0_dp )) then
        condition_1 = 0
      else
        if (( xx * yy - xy * xy >= 0.0_dp .and. 0.0_dp > xx ) &
        .or. (xx * yy - xy * xy >= 0.0_dp .and. 0.0_dp > yy )) then
          condition_1 = 2
        else
          condition_1 = 1
        end if
      end if

    end function condition_1

    integer(kind=i8b) function condition_2(xx, yy, xy)

      use routines, only: QuadraticEquationSolver

      implicit none
      real(kind=dp), intent(in) :: xx, yy, xy

      if (( xx * yy - xy * xy >= 0.0_dp .and. xx >= 0.0_dp ) &
      .or. (xx * yy - xy * xy >= 0.0_dp .and. yy >= 0.0_dp )) then
          condition_2 = 0
      else
        if (( xx * yy - xy * xy >= 0.0_dp .and. 0.0_dp > xx ) &
        .or. (xx * yy - xy * xy >= 0.0_dp .and. 0.0_dp > yy )) then
          condition_2 = 2
          else
            condition_2 = 1
        end if
      end if

    end function condition_2

end module minkowski


Function wdsax(x)
  Common /wood/r, d, fnorm, w
  Save
  wdsax = fnorm*(1.+w*(x/r)**2)/(1+exp((x-r)/d))
  If (w<0.) Then
    If (x>=r/sqrt(abs(w))) wdsax = 0.
  End If
  Return
End Function wdsax


      SUBROUTINE MB02SD( N, H, LDH, IPIV, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute an LU factorization of an n-by-n upper Hessenberg
C     matrix H using partial pivoting with row interchanges.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix H.  N >= 0.
C
C     H       (input/output) DOUBLE PRECISION array, dimension (LDH,N)
C             On entry, the n-by-n upper Hessenberg matrix to be
C             factored.
C             On exit, the factors L and U from the factorization
C             H = P*L*U; the unit diagonal elements of L are not stored,
C             and L is lower bidiagonal.
C
C     LDH     INTEGER
C             The leading dimension of the array H.  LDH >= max(1,N).
C
C     IPIV    (output) INTEGER array, dimension (N)
C             The pivot indices; for 1 <= i <= N, row i of the matrix
C             was interchanged with row IPIV(i).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             > 0:  if INFO = i, U(i,i) is exactly zero. The
C                   factorization has been completed, but the factor U
C                   is exactly singular, and division by zero will occur
C                   if it is used to solve a system of equations.
C
C     METHOD
C
C     The factorization has the form
C        H = P * L * U
C     where P is a permutation matrix, L is lower triangular with unit
C     diagonal elements (and one nonzero subdiagonal), and U is upper
C     triangular.
C
C     This is the right-looking Level 1 BLAS version of the algorithm
C     (adapted after DGETF2).
C
C     REFERENCES
C
C     -
C
C     NUMERICAL ASPECTS
C                                2
C     The algorithm requires 0( N ) operations.
C
C     CONTRIBUTOR
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, June 1998.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Oct. 2000,
C     Jan. 2005.
C
C     KEYWORDS
C
C     Hessenberg form, matrix algebra.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO
      PARAMETER         ( ZERO = 0.0D+0 )
C     .. Scalar Arguments ..
      INTEGER           INFO, LDH, N
C     .. Array Arguments ..
      INTEGER           IPIV(*)
      DOUBLE PRECISION  H(LDH,*)
C     .. Local Scalars ..
      INTEGER           J, JP
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DSWAP, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, MAX
C     ..
C     .. Executable Statements ..
C
C     Check the scalar input parameters.
C
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( LDH.LT.MAX( 1, N ) ) THEN
         INFO = -3
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB02SD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 )
     $   RETURN
C
      DO 10 J = 1, N
C
C        Find pivot and test for singularity.
C
         JP = J
         IF ( J.LT.N ) THEN
            IF ( ABS( H( J+1, J ) ).GT.ABS( H( J, J ) ) )
     $         JP = J + 1
         END IF
         IPIV( J ) = JP
         IF( H( JP, J ).NE.ZERO ) THEN
C
C           Apply the interchange to columns J:N.
C
            IF( JP.NE.J )
     $         CALL DSWAP( N-J+1, H( J, J ), LDH, H( JP, J ), LDH )
C
C           Compute element J+1 of J-th column.
C
            IF( J.LT.N )
     $         H( J+1, J ) = H( J+1, J )/H( J, J )
C
         ELSE IF( INFO.EQ.0 ) THEN
C
            INFO = J
         END IF
C
         IF( J.LT.N ) THEN
C
C           Update trailing submatrix.
C
            CALL DAXPY( N-J, -H( J+1, J ), H( J, J+1 ), LDH,
     $                  H( J+1, J+1 ), LDH )
         END IF
   10 CONTINUE
      RETURN
C *** Last line of MB02SD ***
      END


! Calculates Hylleraas-style integrals that have spherical harmonics.
!  This code is based on the algorithm in the paper by Drake and Yan:
!   J. Phys. B: At. Mol. Opt. Phys. 30 (1997) 4723-4750

! The constant 1984.4017075391884912 appears many times here.  This comes from the spherical harmonics.
!  In the Drake/Yan paper, only the l = 0 states are calculated, so this is the l=0, m=0 spherical
!  harmonic, which is 1/sqrt(4*pi).  Taking this to the sixth power and inverting gives the constant.

!module Limits
!   implicit none
!   integer, parameter :: linf = 20
!   integer, parameter :: minf = 20
!end module Limits

!! This is a standard factorial function using recursion.
!!  Only integer arguments are accepted.
!! To keep the output of Calc3j correct, this needs to return 0 whenever we have a negative value for n.
!real*16 function Factorial(n)
!	implicit none
!	integer n
!	integer i
!
!	! Right now, this is easier than erroring out.
!	if (n < 0) then
!		Factorial = 0.0_16  ! Just return a default value of 1
!		!write (*,*) 'n < 0 in factorial function'
!		return
!	endif
!
!	Factorial = 1.0_16
!	do i = 1, n
!		Factorial = Factorial * real(i,16)
!	enddo
!
!	return
!end

real*16 function DoubleFactorial(n)
	implicit none
	integer n
	integer i
	real*16 Fact

	if (n < -1) then
		!write (*,*) "n < -1 in double factorial function"
		DoubleFactorial = 0.0q0
		return  ! TODO: Return some kind of error
	endif
	if (n == 0 .or. n == 1 .or. n == -1) then
		DoubleFactorial = 1.0q0
		return
	endif

	Fact = n;

	do i = n-2, 1, -2
		Fact = Fact * i
	enddo

	DoubleFactorial = Fact
	return
end

!! This is your standard "choose" function, or the binomial coefficient.
!real*16 function BinomialGeneral(n, k)
!	implicit none
!	integer n, k
!	real*16 Factorial
!
!	! There really should not be cases of this. The binomial coefficient is only defined for k <= n.
!	if (k > n) then
!		BinomialGeneral = 0.0q0
!		return
!	end if
!
!	BinomialGeneral = Factorial(n) / (Factorial(k) * Factorial(n-k))
!	return
!end

! S is given in equation () - just a simple minimum function.
real*16 function SGeneral(q, j)
	implicit none
	integer q, j
	SGeneral = min(real(q-1,16), 0.5_16 * real(j+1,16))
	return
end

! C is given in equation (4).
real*16 function CCoeff(j, q, k)
	implicit none
	integer j, q, k
	real*16 SGeneral, Binomial, DoubleFactorial
	real*16 LeadingFactor
	real*16 Multiplication
	real*16 SVal
	integer t

	! C for the case of j12 == -2 is given by equation (129).
	if (j == -2) then
		CCoeff = real(2*q + 1,16) * DoubleFactorial(2*q + 2*k) * DoubleFactorial(2*k - 1) &
			/ (DoubleFactorial(2*q + 2*k + 1) * DoubleFactorial(2*k))
		return
	endif

	LeadingFactor = real(2*q + 1,16) / real(j + 2,16) * Binomial(j+2, 2*k + 1)
	Multiplication = 1.0q0
	SVal = SGeneral(q, j)

	do t = 0, int(SVal), 1
		Multiplication = Multiplication * real(2*k + 2*t - j,16) / real(2*k + 2*q - 2*t + 1,16)
	enddo

	CCoeff = LeadingFactor * Multiplication
	return
end

! This is the W function from equation (8).
real*16 function WGeneral(l, m, n, alpha, beta, gamma, pmax)
	implicit none
	integer l, m, n
	real*16 alpha, beta, gamma
	integer pmax
	real*16 Factorial
	real*16 WPartialGeneral
	real*16 LeadingFactor
	real*16 Summation
	integer p

	LeadingFactor = Factorial(l) / ((alpha + beta + gamma) ** (l+m+n+3))
	Summation = 0.0

	! We do the summation backwards so that we can use the backwards recurrence relation in (9).
	!do p = 0, pmax, 1
	do p = pmax, 0, -1
		Summation = Summation + WPartialGeneral(l, m, n, alpha, beta, gamma, p)
	enddo

	WGeneral = LeadingFactor * Summation

	return
end

! This is what's inside the summation of the W function from equation (8).
real*16 function WPartialGeneral(l, m, n, alpha, beta, gamma, p)
	implicit none
	integer l, m, n
	real*16 alpha, beta, gamma
	integer p
	real*16 Factorial
	real*16 Hypergeometric2F1

	WPartialGeneral = Factorial(l+m+n+p+2) / (Factorial(l+1+p) * (l+m+2+p)) * (alpha / (alpha + beta + gamma)) ** p  * &
		Hypergeometric2F1(1.0_16, real(l+m+n+p+3, 16), real(l+m+p+3, 16), real((alpha + beta) / (alpha + beta + gamma), 16))

	return
end

!! 2F1 hypergeometric function (or Gauss's hypergeometric function) definition from
!!  http://mathworld.wolfram.com/HypergeometricFunction.html
!real*16 function Hypergeometric2F1(a, b, c, z)
!	implicit none
!	real*16 a, b, c, z
!	!integer a, b, c
!	!real*16 z
!	real*16 Sum, Term, Prev, nd
!	integer n, nUpper
!
!	Sum = 1.0_16
!	Prev = 0.0_16
!	nUpper = 10000  ! Only for extremely singular 2F1 will it even reach close to this number.
!	!nUpper = 65
!
!	Term = 1.0_16
!	do n = 1, nUpper, 1
!		nd = n
!		Term = Term * (a+nd-1.0_16) * (b+nd-1.0_16) / ((c+nd-1.0_16) * nd) * z
!		Sum = Sum + Term
!		if (abs(Sum - Prev) <= 1d-30) then
!		!	write (*,*) 'Number of terms: ', n
!			exit
!		endif
!		Prev = Sum
!	enddo
!
!	Hypergeometric2F1 = Sum
!end function Hypergeometric2F1

! TODO: Parameter order
real*16 function IAngular(l1p, m1p, l2p, m2p, l3p, m3p, l1, m1, l2, m2, l3, m3, q12, q23, q31, SphHarm, sl, sr)
	implicit none
	integer l1p, m1p, l2p, m2p, l3p, m3p, l1, m1, l2, m2, l3, m3, q12, q23, q31, SphHarm, sl, sr, bfunc, b
	integer Triangular
	real*16 ThreeJSymbol, SixJSymbol, CP12Angular, CP21Angular, CP23Angular, CP31Angular
	real*16 Ang, Term
	integer T1, T2, T3, T1min, T1max, T2min, T2max, T3min, T3max
	integer n1, n2, n3, n1min, n1max, n2min, n2max, n3min, n3max
	real*16 c, Removec1, Removec2

	Ang = 0.0_16

	select case (SphHarm)
		case (1,4)  ! This is the case where we are calculating equation 54 for C^P(r1.r2)
			T1min = abs(1 - l1)
			T1max = 1 + l1
			T2min = abs(1 - l2)
			T2max = 1 + l2
			do T1 = T1min, T1max, 1
				do T2 = T2min, T2max, 1
					if (sr == 2) then
						b = bfunc(l2, T2)
					else  ! Assuming sr == 1 here
						b = bfunc(l1, T1)
					end if
					c = 0
					if (b /= 0) then
						c = CP12Angular(l1p, m1p, l2p, m2p, l3p, m3p, l1, m1, l2, m2, l3, m3, q12, q23, q31, T1, T2)
					end if
					!Removec1 = CP12Angular(l1p, m1p, l2p, m2p, l3p, m3p, l1, m1, l2, m2, l3, m3, q12, q23, q31, T1, T2)
					!Removec2 = CP21Angular(l1p, m1p, l2p, m2p, l3p, m3p, l1, m1, l2, m2, l3, m3, q12, q23, q31, T1, T2)
					!if (Removec1 /= Removec2) write (*,*) "Removec1 /= Removec2"
					Ang = Ang + b * c
				end do
			end do
		case (3,6)  ! This is the case where we are calculating equation 59 for C^P(r2.r3)
			T2min = abs(1 - l2)
			T2max = 1 + l2
			T3min = abs(1 - l3)
			T3max = 1 + l3
			do T2 = T2min, T2max, 1
				do T3 = T3min, T3max, 1
					if (sr == 3) then
						b = bfunc(l3, T3)
					else  ! Assuming sr == 2 here
						b = bfunc(l2, T2)
					end if
					c = 0
					if (b /= 0) then
						c = CP23Angular(l1p, m1p, l2p, m2p, l3p, m3p, l1, m1, l2, m2, l3, m3, q12, q23, q31, T2, T3)
					end if
					Ang = Ang + b * c
				end do
			end do
		case (2,5)  ! This is the case where we are calculating equation 64 for C^P(r3.r1)
			T3min = abs(1 - l3)
			T3max = 1 + l3
			T1min = abs(1 - l1)
			T1max = 1 + l1
			do T3 = T3min, T3max, 1
				do T1 = T1min, T1max, 1
					if (sr == 1) then
						b = bfunc(l1, T1)
					else  ! Assuming sr == 3 here
						b = bfunc(l3, T3)
					end if
					c = 0
					if (b /= 0) then
						c = CP31Angular(l1p, m1p, l2p, m2p, l3p, m3p, l1, m1, l2, m2, l3, m3, q12, q23, q31, T3, T1)
					end if
					Ang = Ang + b * CP31Angular(l1p, m1p, l2p, m2p, l3p, m3p, l1, m1, l2, m2, l3, m3, q12, q23, q31, T3, T1)
				end do
			end do
		case default  ! This is when we are calculating only the basic integral.
			! Satisfies the triangular inequalities for the 3j symbol
			n1min = max(abs(q31-q12), abs(l1p-l1))
			n1max = min(q31+q12, l1p+l1)
			n2min = max(abs(q12-q23), abs(l2p-l2))
			n2max = min(q12+q23, l2p+l2)
			n3min = max(abs(q23-q31), abs(l3p-l3))
			n3max = min(q23+q31, l3p+l3)

			do n1 = n1min, n1max, 1
				do n2 = n2min, n2max, 1
					do n3 = n3min, n3max, 1
						if (Triangular(n1, n2, n3) /= 1) cycle
						Term = (2*n1+1)*(2*n2+1)*(2*n3+1) * SixJSymbol(n1,n2,n3,q23,q31,q12) &
							* ThreeJSymbol(n1,n2,n3,m1p-m1,m2p-m2,m3p-m3) * ThreeJSymbol(l1p,l1,n1,-m1p,m1,m1p-m1) &
							* ThreeJSymbol(l2p,l2,n2,-m2p,m2,m2p-m2) * ThreeJSymbol(l3p,l3,n3,-m3p,m3,m3p-m3) &
							* ThreeJSymbol(l1p,l1,n1,0,0,0) * ThreeJSymbol(l2p,l2,n2,0,0,0) &
							* ThreeJSymbol(l3p,l3,n3,0,0,0) * ThreeJSymbol(q31,q12,n1,0,0,0) &
							* ThreeJSymbol(q12,q23,n2,0,0,0) * ThreeJSymbol(q23,q31,n3,0,0,0)
						Ang = Ang + Term
						!if (Term == 0.0_16) exit  ! Every term past here should be 0.  @TODO: Verify this.
					enddo
				enddo
			enddo

			Ang = Ang * (-1)**(m1p+m2p+m3p+q12+q23+q31) * &
				sqrt(real((2*l1p+1)*(2*l2p+1)*(2*l3p+1)*(2*l1+1)*(2*l2+1)*(2*l3+1),16))
	end select

	IAngular = Ang
	return
end

integer function bfunc(l, T)
	implicit none
	integer l, T

	if (T == l-1) then
		bfunc = l + 1
	else if (T == l+1) then
		bfunc = -l
	else
		bfunc = 0
		!write (*,*) "b function = 0!"
	end if

	return
end

! Equation 54 from Drake and Yan's paper
real*16 function CP12Angular(l1p, m1p, l2p, m2p, l3p, m3p, l1, m1, l2, m2, l3, m3, q12, q23, q31, T1, T2)
	implicit none
	integer Triangular, l1p, m1p, l2p, m2p, l3p, m3p, l1, m1, l2, m2, l3, m3, q12, q23, q31
	integer T1, T2, T1min, T1max, T2min, T2max, bfunc
	integer n1, n2, n3, n1min, n1max, n2min, n2max, n3min, n3max
	real*16 ThreeJSymbol, SixJSymbol, CP12AngularTilde
	real*16 U, ThreeJs, CP, Mult

	! Satisfies the triangular inequalities for the 3j symbol
	n1min = max(abs(q31-q12), abs(l1p-T1))
	n1max = min(q31+q12, l1p+T1)
	n2min = max(abs(q12-q23), abs(l2p-T2))
	n2max = min(q12+q23, l2p+T2)
	n3min = max(abs(q23-q31), abs(l3p-l3))
	n3max = min(q23+q31, l3p+l3)

	! We do not include the l12p and l12 from their wavefunction, along with the two Omega functions.
	U = sqrt(real((2*l1p+1)*(2*l2p+1)*(2*l3p+1)*(2*l1+1)*(2*l2+1)*(2*l3+1), 16)) * (-1)**(q12+q23+q31)

	CP = 0.0q0
	do n1 = n1min, n1max, 1
		do n2 = n2min, n2max, 1
			do n3 = n3min, n3max, 1
				if (Triangular(n1, n2, n3) /= 1) cycle
				Mult = ((2*n1+1)*(2*n2+1)*(2*n3+1)*(2*T1+1)*(2*T2+1))
				ThreeJs = ThreeJSymbol(1, l1, T1, 0, 0, 0) * ThreeJSymbol(1, l2, T2, 0, 0, 0) &
					* ThreeJSymbol(l1p, T1, n1, 0, 0, 0) * ThreeJSymbol(l2p, T2, n2, 0, 0, 0) &
					* ThreeJSymbol(l3p, l3, n3, 0, 0, 0) * ThreeJSymbol(q31, q12, n1, 0, 0, 0) &
					* ThreeJSymbol(q12, q23, n2, 0, 0, 0) * ThreeJSymbol(q23, q31, n3, 0, 0, 0)
				if (ThreeJS == 0.0q0) then  ! No need to calculate the rest of the term, since it will be 0.
					continue
				end if
				CP = CP + U * Mult * ThreeJs * CP12AngularTilde(l1p, m1p, l2p, m2p, l3p, m3p, l1, m1, l2, m2, l3, m3, n1, n2, n3, T1, T2) &
					* SixJSymbol(n1, n2, n3, q23, q31, q12)
			end do
		end do
	end do

	CP12Angular = CP

	return
end

real*16 function CP12AngularTilde(l1p, m1p, l2p, m2p, l3p, m3p, l1, m1, l2, m2, l3, m3, n1, n2, n3, T1, T2)
	implicit none
	integer l1p, m1p, l2p, m2p, l3p, m3p, l1, m1, l2, m2, l3, m3, q12, q23, q31, T1, T2, n1, n2, n3, mu
	real*16 ThreeJSymbol

	CP12AngularTilde = 0.0q0
	do mu = -1, 1, 1
		CP12AngularTilde = CP12AngularTilde + (-1)**(-m3+mu) * ThreeJSymbol(1, l1, T1, mu, m1, -mu-m1) * ThreeJSymbol(1, l2, T2, -mu, m2, mu-m2) &
							* ThreeJSymbol(l3p, l3, n3, -m3p, m3, m3p-m3) * ThreeJSymbol(l1p, T1, n1, -m1p, mu+m1, m1p-mu-m1) &
							* ThreeJSymbol(l2p, T2, n2, -m2p, -mu+m2, m2p+mu-m2) * ThreeJSymbol(n1, n2, n3, m1p-mu-m1, m2p+mu-m2, m3p-m3)
	end do

	return
end

! Equation 59 from Drake and Yan's paper
real*16 function CP23Angular(l1p, m1p, l2p, m2p, l3p, m3p, l1, m1, l2, m2, l3, m3, q12, q23, q31, T2, T3)
	implicit none
	integer Triangular, l1p, m1p, l2p, m2p, l3p, m3p, l1, m1, l2, m2, l3, m3, q12, q23, q31
	integer T2, T3, T1min, T1max, T2min, T2max, bfunc
	integer n1, n2, n3, n1min, n1max, n2min, n2max, n3min, n3max
	real*16 ThreeJSymbol, SixJSymbol, CP23AngularTilde
	real*16 U, ThreeJs, CP, Mult

	! Satisfies the triangular inequalities for the 3j symbol
	n1min = max(abs(q31-q12), abs(l1p-l1))
	n1max = min(q31+q12, l1p+l1)
	n2min = max(abs(q12-q23), abs(l2p-T2))
	n2max = min(q12+q23, l2p+T2)
	n3min = max(abs(q23-q31), abs(l3p-T3))
	n3max = min(q23+q31, l3p+T3)

	! We do not include the l12p and l12 from their wavefunction, along with the two Omega functions.
	U = sqrt(real((2*l1p+1)*(2*l2p+1)*(2*l3p+1)*(2*l1+1)*(2*l2+1)*(2*l3+1), 16)) * (-1)**(q12+q23+q31)

	CP = 0.0q0
	do n1 = n1min, n1max, 1
		do n2 = n2min, n2max, 1
			do n3 = n3min, n3max, 1
				if (Triangular(n1, n2, n3) /= 1) cycle
				Mult = ((2*n1+1)*(2*n2+1)*(2*n3+1)*(2*T2+1)*(2*T3+1))
				ThreeJs = ThreeJSymbol(1, l2, T2, 0, 0, 0) * ThreeJSymbol(1, l3, T3, 0, 0, 0) &
					* ThreeJSymbol(l1p, l1, n1, 0, 0, 0) * ThreeJSymbol(l2p, T2, n2, 0, 0, 0) &
					* ThreeJSymbol(l3p, T3, n3, 0, 0, 0) * ThreeJSymbol(q31, q12, n1, 0, 0, 0) &
					* ThreeJSymbol(q12, q23, n2, 0, 0, 0) * ThreeJSymbol(q23, q31, n3, 0, 0, 0)
				if (ThreeJS == 0.0q0) then  ! No need to calculate the rest of the term, since it will be 0.
					continue
				end if
				CP = CP + U * Mult * ThreeJs * CP23AngularTilde(l1p, m1p, l2p, m2p, l3p, m3p, l1, m1, l2, m2, l3, m3, n1, n2, n3, T2, T3) &
					* SixJSymbol(n1, n2, n3, q23, q31, q12)
			end do
		end do
	end do

	CP23Angular = CP

	return
end

real*16 function CP23AngularTilde(l1p, m1p, l2p, m2p, l3p, m3p, l1, m1, l2, m2, l3, m3, n1, n2, n3, T2, T3)
	implicit none
	integer l1p, m1p, l2p, m2p, l3p, m3p, l1, m1, l2, m2, l3, m3, q12, q23, q31, T2, T3, n1, n2, n3, mu
	real*16 ThreeJSymbol

	CP23AngularTilde = 0.0q0
	do mu = -1, 1, 1
		CP23AngularTilde = CP23AngularTilde + (-1)**(-m1+mu) * ThreeJSymbol(1, l2, T2, mu, m2, -mu-m2) * ThreeJSymbol(1, l3, T3, -mu, m3, mu-m3) &
							* ThreeJSymbol(l1p, l1, n1, -m1p, m1, m1p-m1) * ThreeJSymbol(l2p, T2, n2, -m2p, mu+m2, m2p-mu-m2) &
							* ThreeJSymbol(l3p, T3, n3, -m3p, -mu+m3, m3p+mu-m3) * ThreeJSymbol(n1, n2, n3, m1p-m1, m2p-mu-m2, m3p+mu-m3)
	end do

	return
end

! Equation 64 from Drake and Yan's paper
real*16 function CP31Angular(l1p, m1p, l2p, m2p, l3p, m3p, l1, m1, l2, m2, l3, m3, q12, q23, q31, T3, T1)
	implicit none
	integer Triangular, l1p, m1p, l2p, m2p, l3p, m3p, l1, m1, l2, m2, l3, m3, q12, q23, q31
	integer T3, T1, T1min, T1max, T2min, T2max, bfunc
	integer n1, n2, n3, n1min, n1max, n2min, n2max, n3min, n3max
	real*16 ThreeJSymbol, SixJSymbol, CP31AngularTilde
	real*16 U, ThreeJs, CP, Mult

	! Satisfies the triangular inequalities for the 3j symbol
	n1min = max(abs(q31-q12), abs(l1p-T1))
	n1max = min(q31+q12, l1p+T1)
	n2min = max(abs(q12-q23), abs(l2p-l2))
	n2max = min(q12+q23, l2p+l2)
	n3min = max(abs(q23-q31), abs(l3p-T3))
	n3max = min(q23+q31, l3p+T3)

	! We do not include the l12p and l12 from their wavefunction, along with the two Omega functions.
	U = sqrt(real((2*l1p+1)*(2*l2p+1)*(2*l3p+1)*(2*l1+1)*(2*l2+1)*(2*l3+1), 16)) * (-1)**(q12+q23+q31)

	CP = 0.0q0
	do n1 = n1min, n1max, 1
		do n2 = n2min, n2max, 1
			do n3 = n3min, n3max, 1
				if (Triangular(n1, n2, n3) /= 1) cycle
				Mult = ((2*n1+1)*(2*n2+1)*(2*n3+1)*(2*T3+1)*(2*T1+1))
				ThreeJs = ThreeJSymbol(1, l1, T1, 0, 0, 0) * ThreeJSymbol(1, l3, T3, 0, 0, 0) &
					* ThreeJSymbol(l2p, l2, n2, 0, 0, 0) * ThreeJSymbol(l1p, T1, n1, 0, 0, 0) &
					* ThreeJSymbol(l3p, T3, n3, 0, 0, 0) * ThreeJSymbol(q31, q12, n1, 0, 0, 0) &
					* ThreeJSymbol(q12, q23, n2, 0, 0, 0) * ThreeJSymbol(q23, q31, n3, 0, 0, 0)
				if (ThreeJS == 0.0q0) then  ! No need to calculate the rest of the term, since it will be 0.
					continue
				end if
				CP = CP + U * Mult * ThreeJs * CP31AngularTilde(l1p, m1p, l2p, m2p, l3p, m3p, l1, m1, l2, m2, l3, m3, n1, n2, n3, T3, T1) &
					* SixJSymbol(n1, n2, n3, q23, q31, q12)
			end do
		end do
	end do

	CP31Angular = CP

	return
end

real*16 function CP31AngularTilde(l1p, m1p, l2p, m2p, l3p, m3p, l1, m1, l2, m2, l3, m3, n1, n2, n3, T3, T1)
	implicit none
	integer l1p, m1p, l2p, m2p, l3p, m3p, l1, m1, l2, m2, l3, m3, q12, q23, q31, T3, T1, n1, n2, n3, mu
	real*16 ThreeJSymbol

	CP31AngularTilde = 0.0q0
	do mu = -1, 1, 1
		CP31AngularTilde = CP31AngularTilde + (-1)**(-m2+mu) * ThreeJSymbol(1, l1, T1, -mu, m1, mu-m1) * ThreeJSymbol(1, l3, T3, mu, m3, -mu-m3) &
							* ThreeJSymbol(l2p, l2, n2, -m2p, m2, m2p-m2) * ThreeJSymbol(l1p, T1, n1, -m1p, -mu+m1, m1p+mu-m1) &
							* ThreeJSymbol(l3p, T3, n3, -m3p, mu+m3, m3p-mu-m3) * ThreeJSymbol(n1, n2, n3, m1p+mu-m1, m2p-m2, m3p-mu-m3)
	end do

	return
end

integer function Lij(j, q, linf)
	implicit none
	integer j, q, linf

	if (j == -2) then
		Lij = linf  ! When j == -2, the summation is infinite.
		return
	endif
	if (mod(j, 2) == 0) then  ! j is even.
		Lij = j/2 - q
		return
	endif
	Lij = (j+1)/2  ! Odd

	return
end

integer function Mj(j, minf)
	implicit none
	integer j, minf

	if (j == -2) then  ! Infinite summation
		Mj = minf  ! When j == -2, the summation is infinite.
		return
	endif
	if (mod(j, 2) == 0) then  ! j is even.
		Mj = j/2
		return
	endif
	Mj = minf  ! Infinite summation when j is odd.

	return
end

! TODO: Ordering of parameters
real*16 function WR(RunCalc, UsePreCalc, q12, q23, q31, k12, k23, k31, j1, j2, j3, j12, j23, j31, alpha, beta, gamma, pmax, WMatrix)
	use WLimits
	implicit none
	real*16, dimension(lmin:lmax, mmin:mmax, nmin:nmax, 6) :: WMatrix
	integer q12, q23, q31, k12, k23, k31, j1, j2, j3, j12, j23, j31, pmax
	logical RunCalc, UsePreCalc
	real*16 alpha, beta, gamma
	real*16 WGeneral
	integer s12, s23, s31
	real*16 W1, W2, W3, W4, W5, W6

	s12 = q12 + 2*k12
	s23 = q23 + 2*k23
	s31 = q31 + 2*k31

	! This helps determine which elements of the WMatrix need to be calculated.
	if (RunCalc == .false.) then
		WMatrix(j1+2+s12+s31,j2+2+j12-s12+s23,j3+2+j23-s23+j31-s31,1) = 1000  ! The exact value doesn't matter, as
		WMatrix(j1+2+s12+s31,j3+2+s23+j31-s31,j2+2+j12-s12+j23-s23,2) = 1000  !  long as it is different from 0.
		WMatrix(j2+2+s12+s23,j1+2+j12-s12+s31,j3+2+j23-s23+j31-s31,3) = 1000
		WMatrix(j2+2+s12+s23,j3+2+j23-s23+s31,j1+2+j12-s12+j31-s31,4) = 1000
		WMatrix(j3+2+s23+s31,j1+2+s12+j31-s31,j2+2+j12-s12+j23-s23,5) = 1000
		WMatrix(j3+2+s23+s31,j2+2+s12+j23-s23,j1+2+j12-s12+j31-s31,6) = 1000
		WR = 0.0q0
		return
	end if

	! Use precalculated W functions in WMatrix.
	if (UsePreCalc == .true.) then
		W1 = WMatrix(j1+2+s12+s31,j2+2+j12-s12+s23,j3+2+j23-s23+j31-s31,1)
		W2 = WMatrix(j1+2+s12+s31,j3+2+s23+j31-s31,j2+2+j12-s12+j23-s23,2)
		W3 = WMatrix(j2+2+s12+s23,j1+2+j12-s12+s31,j3+2+j23-s23+j31-s31,3)
		W4 = WMatrix(j2+2+s12+s23,j3+2+j23-s23+s31,j1+2+j12-s12+j31-s31,4)
		W5 = WMatrix(j3+2+s23+s31,j1+2+s12+j31-s31,j2+2+j12-s12+j23-s23,5)
		W6 = WMatrix(j3+2+s23+s31,j2+2+s12+j23-s23,j1+2+j12-s12+j31-s31,6)
		WR = W1 + W2 + W3 + W4 + W5 + W6

								!W1 = WGeneral(j1+2+s12+s31,j2+2+j12-s12+s23,j3+2+j23-s23+j31-s31,alpha,beta,gamma,pmax)
								!W2 = WGeneral(j1+2+s12+s31,j3+2+s23+j31-s31,j2+2+j12-s12+j23-s23,alpha,gamma,beta,pmax)
								!W3 = WGeneral(j2+2+s12+s23,j1+2+j12-s12+s31,j3+2+j23-s23+j31-s31,beta,alpha,gamma,pmax)
								!W4 = WGeneral(j2+2+s12+s23,j3+2+j23-s23+s31,j1+2+j12-s12+j31-s31,beta,gamma,alpha,pmax)
								!W5 = WGeneral(j3+2+s23+s31,j1+2+s12+j31-s31,j2+2+j12-s12+j23-s23,gamma,alpha,beta,pmax)
								!W6 = WGeneral(j3+2+s23+s31,j2+2+s12+j23-s23,j1+2+j12-s12+j31-s31,gamma,beta,alpha,pmax)
								!!if (WR /= W1 + W2 + W3 + W4 + W5 + W6) then
								!if (abs((WR - (W1 + W2 + W3 + W4 + W5 + W6)) / (WR + (W1 + W2 + W3 + W4 + W5 + W6)) * 2) > 1D-12) then
								!	write (*,*) "WTF?!", abs((WR - (W1 + W2 + W3 + W4 + W5 + W6)) / (WR + (W1 + W2 + W3 + W4 + W5 + W6)) * 2)
								!	write (*,*) W1, W2, W3, W4, W5, W6
								!	write (*,*)
								!	write (*,*) WMatrix(j1+2+s12+s31,j2+2+j12-s12+s23,j3+2+j23-s23+j31-s31,1), WMatrix(j1+2+s12+s31,j3+2+s23+j31-s31,j2+2+j12-s12+j23-s23,2), &
								!		WMatrix(j2+2+s12+s23,j1+2+j12-s12+s31,j3+2+j23-s23+j31-s31,3), WMatrix(j2+2+s12+s23,j3+2+j23-s23+s31,j1+2+j12-s12+j31-s31,4), &
								!		WMatrix(j3+2+s23+s31,j1+2+s12+j31-s31,j2+2+j12-s12+j23-s23,5), WMatrix(j3+2+s23+s31,j2+2+s12+j23-s23,j1+2+j12-s12+j31-s31,6)
								!	stop
								!end if
		return
	end if

	! Calculate W functions directly.
	W1 = WGeneral(j1+2+s12+s31,j2+2+j12-s12+s23,j3+2+j23-s23+j31-s31,alpha,beta,gamma,pmax)
	W2 = WGeneral(j1+2+s12+s31,j3+2+s23+j31-s31,j2+2+j12-s12+j23-s23,alpha,gamma,beta,pmax)
	W3 = WGeneral(j2+2+s12+s23,j1+2+j12-s12+s31,j3+2+j23-s23+j31-s31,beta,alpha,gamma,pmax)
	W4 = WGeneral(j2+2+s12+s23,j3+2+j23-s23+s31,j1+2+j12-s12+j31-s31,beta,gamma,alpha,pmax)
	W5 = WGeneral(j3+2+s23+s31,j1+2+s12+j31-s31,j2+2+j12-s12+j23-s23,gamma,alpha,beta,pmax)
	W6 = WGeneral(j3+2+s23+s31,j2+2+s12+j23-s23,j1+2+j12-s12+j31-s31,gamma,beta,alpha,pmax)
	WR = W1 + W2 + W3 + W4 + W5 + W6

	return
end

! TODO: Parameter order
real*16 function HylleraasIntegralGeneral(RunCalc, UsePreCalc, j1, j2, j3, j12, j23, j31, alpha, beta, gamma, &
								l1p, l2p, l3p, m1p, m2p, m3p, l1, l2, l3, m1, m2, m3, M12max, M23max, M31max, pmax, SphHarm, sl, sr, WMatrix, Method)
								!l1p, m1p, l2p, m2p, l3p, m3p, l1, m1, l2, m2, l3, m3, qmax)
	use WLimits
	implicit none
	real*16, dimension(lmin:lmax, mmin:mmax, nmin:nmax, 6) :: WMatrix
	integer j1, j2, j3, j12, j23, j31, l1p, m1p, l2p, m2p, l3p, m3p, l1, m1, l2, m2, l3, m3, M12max, M23max, M31max, pmax, sl, sr
	logical RunCalc, UsePreCalc
	real*16, allocatable, dimension(:) :: Values
	real*16 Radial, Angular, Constants, Asymp, alpha, beta, gamma, AsymptoticPart
	real*16 IAngular, WR, CCoeff, InnerSum, OuterSum, RemoveMe, LambdaLower
	integer Mj, Lij, SphHarm, l, i, Method, LambdaUpper
	integer M12, M23, M31, L12, L23, L31, q12, q23, q31, k12, k23, k31

	OuterSum = 0.0_16
	M12 = Mj(j12, M12max)
	M23 = Mj(j23, M23max)
	M31 = Mj(j31, M31max)
	!L12 = linf  ! @TODO: Only valid for j == -2.
	allocate(Values(0:M12))

	! This is only for debugging purposes.
	!call omp_set_num_threads(1)

	LambdaUpper = 20
	!LambdaUpper = 10

	Radial = 0.0q0
	Angular = 0.0q0
	Constants = 0.0q0
    Values = 0.0q0

	!do q12 = 0, M12, 1
	!	InnerSum = 0.0_16
	!	L12 = Lij(j12,q12,linf)
	!	do q23 = 0, M23, 1
	!		L23 = Lij(j23,q23,linf)
	!		do q31 = 0, M31, 1
	!			L31 = Lij(j31,q31,linf)
	!			do k12 = 0, L12, 1
	!				do k23 = 0, L23, 1
	!					do k31 = 0, L31, 1
	!						if (RunCalc == .true.) then
	!							Angular = IAngular(l1p,m1p,l2p,m2p,l3p,m3p,l1,m1,l2,m2,l3,m3,q12,q23,q31,SphHarm,sl,sr)
	!							if (Angular == 0.0_16) cycle
	!							Constants = CCoeff(j12,q12,k12) * CCoeff(j23,q23,k23) * CCoeff(j31,q31,k31)
	!						end if
	!						Radial = WR(RunCalc, UsePreCalc, q12, q23, q31, k12, k23, k31, j1, j2, j3, j12, j23, j31, alpha, beta, gamma, pmax, WMatrix)
 !
	!						InnerSum = InnerSum + Constants * Radial * Angular
	!					enddo
	!				enddo
	!			enddo
	!		enddo
	!	enddo

	do q12 = 0, M12, 1
		InnerSum = 0.0_16
		do q23 = 0, M23, 1
			do q31 = 0, M31, 1
				do k12 = 0, Lij(j12,q12,20), 1
					do k23 = 0, Lij(j23,q23,20), 1
						do k31 = 0, Lij(j31,q31,20), 1
							Angular = IAngular(l1p,m1p,l2p,m2p,l3p,m3p,l1,m1,l2,m2,l3,m3,q12,q23,q31,SphHarm,sl,sr)
							if (Angular == 0.0_16) cycle
							if (RunCalc .eqv. .true.) Constants = CCoeff(j12,q12,k12) * CCoeff(j23,q23,k23) * CCoeff(j31,q31,k31)
							Radial = WR(RunCalc, UsePreCalc, q12, q23, q31, k12, k23, k31, j1, j2, j3, j12, j23, j31, alpha, beta, gamma, pmax, WMatrix)

							!$omp critical(RemoveMe2)
							InnerSum = InnerSum + Constants * Radial * Angular
							!$omp end critical(RemoveMe2)
						enddo
					enddo
				enddo
			enddo
		enddo

		Values(q12) = InnerSum

		OuterSum = OuterSum + InnerSum
		Radial = 0.0q0  ! TODO: These three lines needed?
		Angular = 0.0q0
		Constants = 0.0q0
	enddo

	!write (*,'(d24.16)') 1984.4017075391884912_16*OuterSum

	!if (RunCalc == .false. .and. OuterSum /= 0) then
	!	write (*,*) "What?!"
	!	stop
	!end if

	! 1st case: Direct sum only (do not include asymptotic part)
	! 2nd case: Asymptotic expansion requested but summation is finite
    ! 3rd case: We are not performing the full computation at this step.
	if (Method == 0 .or. M12 /= M12max .or. RunCalc == .FALSE.) then
		HylleraasIntegralGeneral = 1984.401707539188491230484164294489292942_16*OuterSum
        deallocate(Values)
		return
	end if

	! @TODO: Skipping the asymptotic part right now
	!write (*,*) 'Doing asymptotic part'
!	Asymp = 1984.4017075391884912_16*OuterSum
!	!do l = 0, L12, 1
!	do l = 1, L12, 1
!		if (l <= 2) then
!			RemoveMe = AsymptoticPart(Values, 2.0q0, l, 0, 5000)
!		else
!			RemoveMe = AsymptoticPart(Values, 2.0q0, l, min(l-2,15), 5000)  ! TODO: Is 15 good enough? Maybe put as a parameter.
!		endif
!
!		OuterSum = 0.0q0
!		do i = 0, l-1, 1
!			OuterSum = OuterSum + Values(i)
!		enddo
!		Asymp = OuterSum + RemoveMe
!
!!		write (*,*) l, "Sum:", 1984.4017075391884912_16 * OuterSum, " Asymptotic:", 1984.4017075391884912_16 * Asymp
!	enddo

	l = M12+1
!	if (l <= 2) then
!		RemoveMe = AsymptoticPart(Values, 2.0q0, l, 0)
!	else
!		RemoveMe = AsymptoticPart(Values, 2.0q0, l, min(l-2, LambdaUpper))  ! TODO: Is 15 good enough? Maybe put as a parameter.
!	endif

    LambdaLower = 0.5q0 * real(j12 + 1,16) + 0.5q0 * real(j23 + 1,16) + 0.5q0 * real(j31 + 1,16) + 4.0q0
    !LambdaLower = 2.0q0  ! Only if we have r_{ij} == -2

    RemoveMe = AsymptoticPart(Values, LambdaLower, l, LambdaUpper)
	OuterSum = 0.0q0
	!do i = 0, M12-2, 1
	do i = 0, M12, 1
		OuterSum = OuterSum + Values(i)
	enddo
	Asymp = OuterSum + RemoveMe
	Asymp = Asymp * 1984.401707539188491230484164294489292942_16

	deallocate(Values)

	HylleraasIntegralGeneral = Asymp
	return
end