!
!     file sepx4.f90
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright(c) 2005 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Fishpack                              *
!     *                                                               *
!     *                      A Package of Fortran                     *
!     *                                                               *
!     *                Subroutines and Example Programs               *
!     *                                                               *
!     *               for Modeling Geophysical Processes              *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *        John Adams, Paul Swarztrauber and Roland Sweet         *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!     SUBROUTINE sepx4(iorder, a, b, m, mbdcnd, bda, alpha, bdb, beta, c, d, n,
!    +                  nbdcnd, bdc, bdd, cofx, grhs, usol, idmn, pertrb,
!    +                  ierror)
!
!
!
! DIMENSION OF           bda(n+1), bdb(n+1), bdc(m+1), bdd(m+1),
! ARGUMENTS              usol(idmn, n+1),     grhs(idmn, n+1),
!
!
! LATEST REVISION        May 2016
!
! PURPOSE                sepx4 solves for either the second-order
!                        finite difference approximation or a
!                        fourth-order approximation to a separable
!                        elliptic equation
!
!                          af(x)*uxx+bf(x)*ux+cf(x)*u+uyy = g(x, y)
!
!                        on a rectangle(x greater than or equal to
!                        a and less than or equal to b, y greater than
!                        or equal to c and less than or equal to d).
!                        any combination of periodic or mixed boundary
!                        conditions is allowed.  if boundary
!                        conditions in the x direction are periodic
!                       (see mbdcnd=0 below) then the coefficients
!                        must satisfy
!
!                          af(x)=c1, bf(x)=0, cf(x)=c2 for all x.
!
!                        here c1, c2 are constants, c1>0.
!
!                        the possible boundary conditions are:
!                        in the x-direction:
!                         (0) periodic, u(x+b-a, y)=u(x, y) for
!                              all y, x
!                         (1) u(a, y), u(b, y) are specified for all y
!                         (2) u(a, y), du(b, y)/dx+beta*u(b, y) are
!                              specified for all y
!                         (3) du(a, y)/dx+alpha*u(a, y), du(b, y)/dx+
!                              beta*u(b, y) are specified for all y
!                         (4) du(a, y)/dx+alpha*u(a, y), u(b, y) are
!                              specified for all y
!
!                        in the y-direction:
!                         (0) periodic, u(x, y+d-c)=u(x, y) for all x, y
!                         (1) u(x, c), u(x, d) are specified for all x
!                         (2) u(x, c), du(x, d)/dy are specified for
!                              all x
!                         (3) du(x, c)/dy, du(x, d)/dy are specified for
!                              all x
!                         (4) du(x, c)/dy, u(x, d) are specified for
!                              all x
!
! USAGE                  call sepx4(iorder, a, b, m, mbdcnd, bda, alpha, bdb,
!                                   beta, c, d, n, nbdcnd, bdc, bdd, cofx,
!                                   grhs, usol, idmn, w, pertrb, ierror)
!
! ARGUMENTS
! ON INPUT               iorder
!                          = 2 if a second-order approximation is
!                              sought
!                          = 4 if a fourth-order approximation is
!                              sought
!
! *** CAUTION ***          grhs should be reset if sepx4 was first called
!                          with iorder=2 and will be called again with
!                          iorder=4.  values in grhs are destroyed by the
!                          iorder=2 call.
!
!
!                        a, b
!                          the range of the x-independent variable,
!                          i.e., x is greater than or equal to a
!                          and less than or equal to b.  a must be
!                          less than b.
!
!                        m
!                          the number of panels into which the
!                          interval(a, b) is subdivided.  hence,
!                          there will be m+1 grid points in the x-
!                          direction given by xi=a+(i-1)*dlx
!                          for i=1, 2, ..., m+1 where dlx=(b-a)/m is
!                          the panel width.  m must be less than
!                          idmn and greater than 5.
!
!                        mbdcnd
!                          indicates the type of boundary condition
!                          at x=a and x=b
!                          = 0 if the solution is periodic in x, i.e.,
!                              u(x+b-a, y)=u(x, y)  for all y, x
!                          = 1 if the solution is specified at x=a
!                              and x=b, i.e., u(a, y) and u(b, y) are
!                              specified for all y
!                          = 2 if the solution is specified at x=a
!                              and the boundary condition is mixed at
!                              x=b, i.e., u(a, y) and
!                              du(b, y)/dx+beta*u(b, y) are specified
!                              for all y
!                          = 3 if the boundary conditions at x=a and
!                              x=b are mixed, i.e.,
!                              du(a, y)/dx+alpha*u(a, y) and
!                              du(b, y)/dx+beta*u(b, y) are specified
!                              for all y
!                          = 4 if the boundary condition at x=a is
!                              mixed and the solution is specified
!                              at x=b, i.e., du(a, y)/dx+alpha*u(a, y)
!                              and u(b, y) are specified for all y
!
!                        bda
!                          a one-dimensional array of length n+1 that
!                          specifies the values of
!                          du(a, y)/dx+ alpha*u(a, y) at x=a, when
!                          mbdcnd=3 or 4.
!                          bda(j) = du(a, yj)/dx+alpha*u(a, yj),
!                          j=1, 2, ..., n+1
!                          when mbdcnd has any other value, bda is
!                          a dummy parameter.
!
!                        alpha
!                          the scalar multiplying the solution in case
!                          of a mixed boundary condition at x=a
!                         (see argument bda).  if mbdcnd is not equal
!                          to either 3 or 4, then alpha is a dummy
!                          parameter.
!
!                        bdb
!                          a one-dimensional array of length n+1 that
!                          specifies the values of
!                          du(b, y)/dx+ beta*u(b, y) at x=b.
!                          when mbdcnd=2 or 3
!                          bdb(j) = du(b, yj)/dx+beta*u(b, yj),
!                          j=1, 2, ..., n+1
!                          when mbdcnd has any other value, bdb is
!                          a dummy parameter.
!
!                        beta
!                          the scalar multiplying the solution in
!                          case of a mixed boundary condition at x=b
!                         (see argument bdb).  if mbdcnd is not equal
!                          to 2 or 3, then beta is a dummy parameter.
!
!                        c, d
!                          the range of the y-independent variable,
!                          i.e., y is greater than or equal to c and
!                          less than or equal to d.  c must be less
!                          than d.
!
!                        n
!                          the number of panels into which the
!                          interval(c, d) is subdivided.  hence,
!                          there will be n+1 grid points in the y-
!                          direction given by yj=c+(j-1)*dly for
!                          j=1, 2, ..., n+1 where dly=(d-c)/n is the
!                          panel width.  in addition, n must be
!                          greater than 4.
!
!                        nbdcnd
!                          indicates the types of boundary conditions
!                          at y=c and y=d
!                          = 0 if the solution is periodic in y,
!                              i.e., u(x, y+d-c)=u(x, y) for all x, y
!                          = 1 if the solution is specified at y=c
!                              and y = d, i.e., u(x, c)  and u(x, d)
!                              are specified for all x
!                          = 2 if the solution is specified at y=c
!                              and the boundary condition is mixed
!                              at y=d, i.e., du(x, c)/dy and u(x, d)
!                              are specified for all x
!                          = 3 if the boundary conditions are mixed
!                              at y=cand y=d i.e.,
!                              du(x, d)/dy and du(x, d)/dy are
!                              specified for all x
!                          = 4 if the boundary condition is mixed
!                              at y=c and the solution is specified
!                              at y=d, i.e. du(x, c)/dy+gama*u(x, c)
!                              and u(x, d) are specified for all x
!
!                        bdc
!                          a one-dimensional array of length m+1 that
!                          specifies the value du(x, c)/dy at y=c.
!
!                          when nbdcnd=3 or 4
!                            bdc(i) = du(xi, c)/dy i=1, 2, ..., m+1.
!
!                          when nbdcnd has any other value, bdc is
!                          a dummy parameter.
!
!                        bdd
!                          a one-dimensional array of length m+1 that
!                          specified the value of du(x, d)/dy at y=d.
!
!                          when nbdcnd=2 or 3
!                            bdd(i)=du(xi, d)/dy i=1, 2, ..., m+1.
!
!                          when nbdcnd has any other value, bdd is
!                          a dummy parameter.
!
!                        cofx
!                          a user-supplied subprogram with parameters
!                          x, afun, bfun, cfun which returns the
!                          values of the x-dependent coefficients
!                          af(x), bf(x), cf(x) in the elliptic
!                          equation at x.  if boundary conditions in
!                          the x direction are periodic then the
!                          coefficients must satisfy af(x)=c1, bf(x)=0,
!                          cf(x)=c2 for all x.  here c1>0
!                          and c2 are constants.
!
!                          note that cofx must be declared external
!                          in the calling routine.
!
!                        grhs
!                          a two-dimensional array that specifies the
!                          values of the right-hand side of the
!                          elliptic equation, i.e., grhs(i, j)=g(xi, yi),
!                          for i=2, ..., m, j=2, ..., n.  at the
!                          boundaries, grhs is defined by
!
!                          mbdcnd   grhs(1, j)   grhs(m+1, j)
!                          ------   ---------   -----------
!                            0      g(a, yj)     g(b, yj)
!                            1         *           *
!                            2         *        g(b, yj)  j=1, 2, ..., n+1
!                            3      g(a, yj)     g(b, yj)
!                            4      g(a, yj)        *
!
!                          nbdcnd   grhs(i, 1)   grhs(i, n+1)
!                          ------   ---------   -----------
!                            0      g(xi, c)     g(xi, d)
!                            1         *           *
!                            2         *        g(xi, d)  i=1, 2, ..., m+1
!                            3      g(xi, c)     g(xi, d)
!                            4      g(xi, c)        *
!
!                          where * means these quantites are not used.
!                          grhs should be dimensioned idmn by at least
!                          n+1 in the calling routine.
!
! *** CAUTION              grhs should be reset if sepx4 was first called
!                          with iorder=2 and will be called again with
!                          iorder=4.  values in grhs are destroyed by the
!                          iorder=2 call.
!
!                        usol
!                          a two-dimensional array that specifies the
!                          values of the solution along the boundaries.
!                          at the boundaries, usol is defined by
!
!                          mbdcnd   usol(1, j)   usol(m+1, j)
!                          ------   ---------   -----------
!                            0         *           *
!                            1      u(a, yj)     u(b, yj)
!                            2      u(a, yj)        *     j=1, 2, ..., n+1
!                            3         *           *
!                            4         *        u(b, yj)
!
!                          nbdcnd   usol(i, 1)   usol(i, n+1)
!                          ------   ---------   -----------
!                            0         *           *
!                            1      u(xi, c)     u(xi, d)
!                            2      u(xi, c)        *     i=1, 2, ..., m+1
!                            3         *           *
!                            4         *        u(xi, d)
!
!                          where * means the quantites are not used
!                          in the solution.
!
!                          if iorder=2, the user may equivalence grhs
!                          and usol to save space.  note that in this
!                          case the tables specifying the boundaries
!                          of the grhs and usol arrays determine the
!                          boundaries uniquely except at the corners.
!                          if the tables call for both g(x, y) and
!                          u(x, y) at a corner then the solution must
!                          be chosen.
!                          for example, if mbdcnd=2 and nbdcnd=4,
!                          then u(a, c), u(a, d), u(b, d) must be chosen
!                          at the corners in addition to g(b, c).
!
!                          if iorder=4, then the two arrays, usol and
!                          grhs, must be distinct.
!
!                          usol should be dimensioned idmn by at least
!                          n+1 in the calling routine.
!
!                        idmn
!                          the row(or first) dimension of the arrays
!                          grhs and usol as it appears in the program
!                          calling sepeli.  this parameter is used
!                          to specify the variable dimension of grhs
!                          and usol.  idmn must be at least 7 and
!                          greater than or equal to m+1.
!
!
! ON OUTPUT              usol
!                          contains the approximate solution to the
!                          elliptic equation. usol(i, j) is the
!                          approximation to u(xi, yj) for i=1, 2..., m+1
!                          and j=1, 2, ..., n+1.  the approximation has
!                          error o(dlx**2+dly**2) if called with
!                          iorder=2 and o(dlx**4+dly**4) if called
!                          with iorder=4.
!
!                        pertrb
!                          if a combination of periodic or derivative
!                          boundary conditions(i.e., alpha=beta=0 if
!                          mbdcnd=3) is specified and if cf(x)=0 for
!                          all x then a solution to the discretized
!                          matrix equation may not exist
!                         (reflecting the non-uniqueness of solutions
!                          to the pde).
!                          pertrb is a constant calculated and
!                          subtracted from the right hand side of the
!                          matrix equation insuring the existence of a
!                          solution.  sepx4 computes this solution
!                          which is a weighted minimal least squares
!                          solution to the original problem.  if
!                          singularity is not detected pertrb=ZERO is
!                          returned by sepx4.
!
!                        ierror
!                          an error flag that indicates invalid input
!                          parameters or failure to find a solution
!
!                          =  0 no error
!                          =  1 if a greater than b or c greater
!                               than d
!                          =  2 if mbdcnd less than 0 or mbdcnd
!                               greater than 4
!                          =  3 if nbdcnd less than 0 or nbdcnd
!                               greater than 4
!                          =  4 if attempt to find a solution fails.
!                              (the linear system generated is not
!                               diagonally dominant.)
!                          =  5 if idmn is too small(see discussion
!                               of idmn)
!                          =  6 if m is too small or too large
!                              (see discussion of m)
!                          =  7 if n is too small(see discussion of n)
!                          =  8 if iorder is not 2 or 4
!                          =  9 if intl is not 0 or 1
!                          = 10 if afun is less than or equal to zero
!                               for some interior mesh point xi some
!                               interior mesh point(xi, yj)
!                          = 12 if mbdcnd=0 and af(x)=cf(x)=constant
!                               or bf(x)=0 for all x is not true.
!                          = 20 if the dynamic allocation of real and
!                               complex workspace required for solution
!                               fails(for example if n, m are too large
!                               for your computer)
!
! SPECIAL CONDITIONS     None
!
! I/O                    None
!
! REQUIRED FILES         type_FishpackWorkspace.f90, genbun.f90, type_CyclicReductionUtility.f9090, type_SepAux.f90
!
!
! PRECISION              64-bit double precision
!
!
! STANDARD               Fortran 2008
!
! HISTORY                sepx4 was developed at NCAR by John C.
!                        Adams of the scientific computing division
!                        in October 1978.  The basis of this code is
!                        NCAR routine sepeli.  Both packages were
!                        released on NCAR's public libraries in
!                        January 1980. sepx4 was modified in June 2004
!                        incorporating Fortran 90 dynamical storage
!                        allocation for workspace requirements
!
!
! ALGORITHM              sepx4 automatically discretizes the separable
!                        elliptic equation which is then solved by a
!                        generalized cyclic reduction algorithm in the
!                        subroutine pois. The fourth order solution
!                        is obtained using the technique of defferred
!                        corrections referenced below.
!
! TIMING                 When possible, sepx4 should be used instead
!                        of package sepeli. The increase in speed
!                        is at least a factor of three.
!
! REFERENCES             Keller, H.B., Numerical methods for two-point
!                        boundary-value problems, BLAISDEL (1968),
!                        Waltham, Mass.
!
!                        Swarztrauber, P., and R. Sweet (1975):
!                        Efficient FORTRAN subprograms for the
!                        solution of elliptic partial differential
!                        equations.  NCAR Technical note
!                          NCAR-TN/IA-109, pp. 135-137.
!
module module_sepx4

    use fishpack_precision, only: &
        wp, & ! Working precision
        ip ! Integer precision

    use type_FishpackWorkspace, only: &
        FishpackWorkspace

    use centered_real_linear_systems_solver, only: &
        genbun

    use type_SepAux, only: &
        SepAux, &
        get_coefficients

    ! Explicit typing only!
    implicit none

    ! Everything is private unless stated otherwise
    private
    public :: sepx4

    type, private, extends(SepAux) :: Sepx4Aux
        !---------------------------------------------------------------
        ! Type components
        !---------------------------------------------------------------
        type(FishpackWorkspace), public :: workspace
        !---------------------------------------------------------------
    contains
        !---------------------------------------------------------------
        ! Type-bound procedures
        !---------------------------------------------------------------
        procedure, public  :: initialize_workspace
        procedure, public  :: s4elip
        procedure, private :: is_PDE_singular
        procedure, private :: defer
        !---------------------------------------------------------------
    end type Sepx4Aux

    !---------------------------------------------------------------
    ! Parameters confined to the module
    !---------------------------------------------------------------
    real(wp),    parameter :: ZERO = 0.0_wp
    real(wp),    parameter :: HALF = 0.5_wp
    real(wp),    parameter :: ONE = 1.0_wp
    real(wp),    parameter :: TWO = 2.0_wp
    integer(ip), parameter :: IIWK = 12 !! Size of workspace indices
    !---------------------------------------------------------------

contains

    subroutine sepx4(iorder, a, b, m, mbdcnd, bda, alpha, bdb, beta, c, &
        d, n, nbdcnd, bdc, bdd, cofx, grhs, usol, idmn, pertrb, &
        ierror)
        !--------------------------------------------------------------
        ! Dummy arguments
        !--------------------------------------------------------------
        integer(ip), intent(in)     :: iorder
        integer(ip), intent(in)     :: m
        integer(ip), intent(in)     :: mbdcnd
        integer(ip), intent(in)     :: n
        integer(ip), intent(in)     :: nbdcnd
        integer(ip), intent(in)     :: idmn
        integer(ip), intent(out)    :: ierror
        real(wp),    intent(in)     :: a
        real(wp),    intent(in)     :: b
        real(wp),    intent(in)     :: alpha
        real(wp),    intent(in)     :: beta
        real(wp),    intent(in)     :: c
        real(wp),    intent(in)     :: d
        real(wp),    intent(out)    :: pertrb
        real(wp),    intent(in)     :: bda(:)
        real(wp),    intent(in)     :: bdb(:)
        real(wp),    intent(in)     :: bdc(:)
        real(wp),    intent(in)     :: bdd(:)
        real(wp),    intent(inout)  :: grhs(:,:)
        real(wp),    intent(out)    :: usol(:,:)
        procedure(get_coefficients) :: cofx
        !--------------------------------------------------------------
        ! Local variables
        !--------------------------------------------------------------
        type(Sepx4Aux) :: aux
        !--------------------------------------------------------------

        ! Check input parameters
        call check_input_parameters(iorder, a, b, m, mbdcnd, c, d, n, nbdcnd, cofx, idmn, ierror)

        if (ierror /= 0) return

        ! Initialize workspace arrays and indices
        call aux%initialize_workspace(n, m, nbdcnd)

        ! Solve system
        associate( &
            i => aux%workspace%workspace_indices, &
            rew => aux%workspace%real_workspace &
            )
            associate( &
                an => rew(i(1):), &
                bn => rew(i(2):), &
                cn => rew(i(3):), &
                dn => rew(i(4):), &
                un => rew(i(5):), &
                zn => rew(i(6):), &
                am => rew(i(7):i(7)), &
                bm => rew(i(8):i(8)), &
                cm => rew(i(9):i(9)), &
                dm => rew(i(10):), &
                um => rew(i(11):), &
                zm => rew(i(12):) &
                )
                call aux%s4elip(iorder, a, b, m, mbdcnd, bda, alpha, bdb, beta, &
                    c, d, n, nbdcnd, bdc, bdd, cofx, an, bn, cn, dn, un, zn, am, bm, &
                    cm, dm, um, zm, grhs, usol, idmn, pertrb, ierror)
            end associate
        end associate

        !
        ! Release memory
        !
        call aux%workspace%destroy()

    end subroutine sepx4

    subroutine initialize_workspace(self, n, m, nbdcnd)
        !--------------------------------------------------------------
        ! Dummy arguments
        !--------------------------------------------------------------
        class(Sepx4Aux), intent(inout) :: self
        integer(ip), intent(in)        :: n, m, nbdcnd
        !--------------------------------------------------------------
        ! Local variables
        !--------------------------------------------------------------
        integer(ip)            :: l, k, length, irwk, icwk
        !--------------------------------------------------------------

        associate( w => self%workspace )
            ! Compute minimum workspace and check workspace length input
            select case (nbdcnd)
                case (0)
                    l = n
                    k = m + 1
                case default
                    l = n + 1
                    k = m + 1
            end select

            ! Compute required real and complex workspace sizes
            call compute_workspace_dimensions(n, l, k, length, irwk, icwk)

            ! Allocate memory for workspace arrays
            call w%create(irwk, icwk, IIWK)

            ! Set workspace indices
            w%workspace_indices = get_workspace_indices(length, l, k)
        end associate

    end subroutine initialize_workspace

    pure subroutine compute_workspace_dimensions(n, l, k, length, irwk, icwk)
        !--------------------------------------------------------------
        ! Dummy arguments
        !--------------------------------------------------------------
        integer(ip), intent(in)  :: n
        integer(ip), intent(in)  :: l
        integer(ip), intent(in)  :: k
        integer(ip), intent(out) :: length
        integer(ip), intent(out) :: irwk
        integer(ip), intent(out) :: icwk
        !--------------------------------------------------------------
        integer(ip) :: log2n
        !--------------------------------------------------------------

        log2n = int(log(real(n + 1, kind=wp))/log(TWO) + HALF, kind=ip)
        length = 4*(n + 1) +(10 + log2n) * k

        ! set real and complex workspace sizes
        irwk = length + 6 * (k + l) + 1
        icwk = 0

    end subroutine compute_workspace_dimensions

    pure function get_workspace_indices(length, l, k) result (return_value)
        !--------------------------------------------------------------
        ! Dummy arguments
        !--------------------------------------------------------------
        integer(ip), intent(in) :: length
        integer(ip), intent(in) :: l
        integer(ip), intent(in) :: k
        integer(ip)             :: return_value(IIWK)
        !--------------------------------------------------------------
        integer(ip) :: j !! Counter
        !--------------------------------------------------------------

        associate( i => return_value)
            i(1) = length + 1

            do j = 1, 6
                i(j+1) = i(j) + l
            end do

            do j = 7, 11
                i(j+1) = i(j) + k
            end do
        end associate

    end function get_workspace_indices

    subroutine s4elip(self, iorder, a, b, m, mbdcnd, bda, alpha, bdb, beta, &
        c, d, n, nbdcnd, bdc, bdd, cofx, an, bn, cn, dn, un, zn, am, bm, &
        cm, dm, um, zm, grhs, usol, idmn, pertrb, ierror)
        !
        ! Purpose:
        !
        !     s4elip sets up vectors and arrays for input to blktri
        !     and computes a second order solution in usol.  a return jump to
        !     sepeli occurrs if iorder=2.  if iorder=4 a fourth order
        !     solution is generated in usol.
        !
        !--------------------------------------------------------------
        ! Dummy arguments
        !--------------------------------------------------------------
        class(Sepx4Aux), intent(inout) :: self
        integer(ip),   intent(in)     :: iorder
        integer(ip),   intent(in)     :: m
        integer(ip),   intent(in)     :: mbdcnd
        integer(ip),   intent(in)     :: n
        integer(ip),   intent(in)     :: nbdcnd
        integer(ip),   intent(in)     :: idmn
        integer(ip),   intent(inout) :: ierror
        real(wp),      intent(in)     :: a
        real(wp),      intent(in)     :: b
        real(wp),      intent(in)     :: alpha
        real(wp),      intent(in)     :: beta
        real(wp),      intent(in)     :: c
        real(wp),      intent(in)     :: d
        real(wp),      intent(out)    :: pertrb
        real(wp),      intent(in)     :: bda(:)
        real(wp),      intent(in)     :: bdb(:)
        real(wp),      intent(in)     :: bdc(:)
        real(wp),      intent(in)     :: bdd(:)
        real(wp),      intent(inout) :: an(:)
        real(wp),      intent(inout) :: bn(:)
        real(wp),      intent(inout) :: cn(:)
        real(wp),      intent(inout) :: dn(:)
        real(wp),      intent(inout) :: un(:)
        real(wp),      intent(inout) :: zn(:)
        real(wp),      intent(inout) :: am(:)
        real(wp),      intent(inout) :: bm(:)
        real(wp),      intent(inout) :: cm(:)
        real(wp),      intent(inout) :: dm(:)
        real(wp),      intent(inout) :: um(:)
        real(wp),      intent(inout) :: zm(:)
        real(wp),      intent(inout) :: grhs(:,:)
        real(wp),      intent(inout) :: usol(:,:)
        procedure(get_coefficients)    :: cofx
        !--------------------------------------------------------------
        ! Local variables
        !--------------------------------------------------------------
        integer(ip) :: i, i1, mp, np, local_error_flag
        real(wp)    :: xi, ai, bi, ci, axi, bxi, cxi
        real(wp)    :: dyj, eyj, fyj, ax1, cxm
        real(wp)    :: dy1, fyn, gama, xnu, prtrb
        logical      :: singular
        !-----------------------------------------------

        ! Associate various quantities
        associate( &
            kswx => self%kswx, &
            kswy => self%kswy, &
            k => self%k, &
            l=>self%l, &
            mit=>self%mit, &
            nit=> self%nit, &
            is=> self%is, &
            ms=> self%ms, &
            js=> self%js, &
            ns=> self%ns, &
            ait => self%ait, &
            bit => self%bit, &
            cit => self%cit, &
            dit => self%dit, &
            dlx => self%dlx, &
            dly => self%dly, &
            tdlx3 => self%tdlx3, &
            tdly3 => self%tdly3, &
            dlx4 => self%dlx4, &
            dly4 => self%dly4 &
            )

            !     set parameters internally
            !
            kswx = mbdcnd + 1
            kswy = nbdcnd + 1
            k = m + 1
            l = n + 1
            ait = a
            bit = b
            cit = c
            dit = d
            dly =(dit - cit)/n
            !
            ! set right hand side values from grhs in usol on the interior
            !     and non-specified boundaries.
            !
            usol(2:m, 2:n) = (dly**2) * grhs(2:m, 2:n)

            if (kswx /= 2 .and. kswx /= 3) then
                usol(1, 2:n) = (dly**2) * grhs(1, 2:n)
            end if

            if (kswx /= 2 .and. kswx /= 5) then
                usol(k, 2:n) = (dly**2) * grhs(k, 2:n)
            end if

            if (kswy /= 2 .and. kswy /= 3) then
                usol(2:m, 1) = (dly**2) * grhs(2:m, 1)
            end if

            if (kswy /= 2 .and. kswy /= 5) then
                usol(2:m, l) = (dly**2) * grhs(2:m, l)
            end if

            if (kswx /= 2 .and. kswx /= 3 .and. kswy /= 2 .and. kswy /= 3) then
                usol(1, 1) = (dly**2) * grhs(1, 1)
            end if

            if (kswx /= 2 .and. kswx /= 5 .and. kswy /= 2 .and. kswy /= 3) then
                usol(k, 1) = (dly**2) * grhs(k, 1)
            end if

            if (kswx /= 2 .and. kswx /= 3 .and. kswy /= 2 .and. kswy /= 5) then
                usol(1, l) = (dly**2) * grhs(1, l)
            end if

            if (kswx /= 2 .and. kswx /= 5 .and. kswy /= 2 .and. kswy /= 5) then
                usol(k, l) = (dly**2) * grhs(k, l)
            end if

            i1 = 1
            !
            ! set switches for periodic or non-periodic boundaries
            !
            if (kswx == 1) then
                mp = 0
            else
                mp = 1
            end if

            np = nbdcnd
            !
            !     set dlx, dly and size of block tri-diagonal system generated
            !     in nint, mint
            !
            dlx =(bit - ait)/m
            mit = k - 1

            if (kswx == 2) then
                mit = k - 2
            end if

            if (kswx == 4) then
                mit = k
            end if

            dly =(dit - cit)/n
            nit = l - 1

            if (kswy == 2) then
                nit = l - 2
            end if

            if (kswy == 4) then
                nit = l
            end if

            tdlx3 = TWO * (dlx**3)
            dlx4 = dlx**4
            tdly3 = TWO * (dly**3)
            dly4 = dly**4
            !
            ! set subscript limits for portion of array to input to blktri
            !
            if (kswx==2 .or. kswx==3) then
                is = 2
            else
                is = 1
            end if

            if (kswy==2 .or. kswy==3) then
                js = 2
            else
                js = 1
            end if

            ns = nit + js - 1
            ms = mit + is - 1
            !
            !     set x - direction
            !
            do i = 1, mit
                xi = ait + real(is + i - 2, kind=wp)*dlx
                call cofx(xi, ai, bi, ci)
                axi =(ai/dlx - HALF*bi)/dlx
                bxi =(-TWO * ai/dlx**2) + ci
                cxi =(ai/dlx + HALF*bi)/dlx
                am(i) = (dly**2) * axi
                bm(i) = (dly**2)*bxi
                cm(i) = (dly**2)*cxi
            end do
            !
            !     set y direction
            !
            dyj = ONE
            eyj = -TWO
            fyj = ONE
            an(:nit) = dyj
            bn(:nit) = eyj
            cn(:nit) = fyj
            !
            !     adjust edges in x direction unless periodic
            !
            ax1 = am(1)
            cxm = cm(mit)
            select case(kswx)
                case(2)
                    !
                    !     dirichlet-dirichlet in x direction
                    !
                    am(1) = ZERO
                    cm(mit) = ZERO
                case(3)
                    !
                    !     dirichlet-mixed in x direction
                    !
                    am(1) = ZERO
                    am(mit) = am(mit) + cxm
                    bm(mit) = bm(mit) - TWO * beta*dlx*cxm
                    cm(mit) = ZERO
                case(4)
                    !
                    !     mixed - mixed in x direction
                    !
                    am(1) = ZERO
                    bm(1) = bm(1) + TWO * dlx * alpha * ax1
                    cm(1) = cm(1) + ax1
                    am(mit) = am(mit) + cxm
                    bm(mit) = bm(mit) - TWO * dlx * beta * cxm
                    cm(mit) = ZERO
                case(5)
                    !
                    !     mixed-dirichlet in x direction
                    !
                    am(1) = ZERO
                    bm(1) = bm(1) + TWO * alpha * dlx * ax1
                    cm(1) = cm(1) + ax1
                    cm(mit) = ZERO
            end select
            !
            !     adjust in y direction unless periodic
            !
            dy1 = an(1)
            fyn = cn(nit)
            gama = ZERO
            xnu = ZERO
            select case(kswy)
                case(2)
                    !
                    !     dirichlet-dirichlet in y direction
                    !
                    an(1) = ZERO
                    cn(nit) = ZERO
                case(3)
                    !
                    !     dirichlet-mixed in y direction
                    !
                    an(1) = ZERO
                    an(nit) = an(nit) + fyn
                    bn(nit) = bn(nit) - TWO * dly * xnu * fyn
                    cn(nit) = ZERO
                case(4)
                    !
                    !     mixed - mixed direction in y direction
                    !
                    an(1) = ZERO
                    bn(1) = bn(1) + TWO * dly * gama * dy1
                    cn(1) = cn(1) + dy1
                    an(nit) = an(nit) + fyn
                    bn(nit) = bn(nit) - TWO * dly * xnu * fyn
                    cn(nit) = ZERO
                case(5)
                    !
                    !     mixed-dirichlet in y direction
                    !
                    an(1) = ZERO
                    bn(1) = bn(1) + TWO * dly * gama * dy1
                    cn(1) = cn(1) + dy1
                    cn(nit) = ZERO
            end select

            if (kswx /= 1) then
                !
                !     adjust usol along x edge
                !
                if (kswx==2 .or. kswx==3) then
                    if (kswx==2 .or. kswx==5) then
                        usol(is,js:ns) = usol(is,js:ns) - ax1*usol(1,js:ns)
                        usol(ms,js:ns) = usol(ms,js:ns) - cxm*usol(k,js:ns)
                    else
                        usol(is,js:ns) = usol(is,js:ns) - ax1*usol(1,js:ns)
                        usol(ms,js:ns) = usol(ms,js:ns) - TWO * dlx*cxm*bdb(js:ns)
                    end if
                else
                    if (kswx==2 .or. kswx==5) then
                        usol(is,js:ns) = usol(is,js:ns) + TWO * dlx*ax1*bda(js:ns)
                        usol(ms,js:ns) = usol(ms,js:ns) - cxm*usol(k,js:ns)
                    else
                        usol(is,js:ns) = usol(is,js:ns) + TWO * dlx*ax1*bda(js:ns)
                        usol(ms,js:ns) = usol(ms,js:ns) - TWO * dlx*cxm*bdb(js:ns)
                    end if
                end if
            end if
            if (kswy /= 1) then
                !
                !     adjust usol along y edge
                !
                if (kswy==2 .or. kswy==3) then
                    if (kswy==2 .or. kswy==5) then
                        usol(is:ms,js) = usol(is:ms,js) - dy1*usol(is:ms, 1)
                        usol(is:ms, ns) = usol(is:ms, ns) - fyn*usol(is:ms, l)
                    else
                        usol(is:ms,js) = usol(is:ms,js) - dy1*usol(is:ms, 1)
                        usol(is:ms, ns) = usol(is:ms, ns) - TWO * dly*fyn*bdd(is:ms)
                    end if
                else
                    if (kswy==2 .or. kswy==5) then
                        usol(is:ms,js) = usol(is:ms,js) + TWO * dly*dy1*bdc(is:ms)
                        usol(is:ms, ns) = usol(is:ms, ns) - fyn*usol(is:ms, l)
                    else
                        usol(is:ms,js) = usol(is:ms,js) + TWO * dly*dy1*bdc(is:ms)
                        usol(is:ms, ns) = usol(is:ms, ns) - TWO * dly*fyn*bdd(is:ms)
                    end if
                end if
            end if
            !
            ! save adjusted edges in grhs if iorder=4
            !
            if (iorder == 4) then
                grhs(is,js:ns) = usol(is,js:ns)
                grhs(ms,js:ns) = usol(ms,js:ns)
                grhs(is:ms,js) = usol(is:ms,js)
                grhs(is:ms, ns) = usol(is:ms, ns)
            end if

            pertrb = ZERO
            !
            ! check if operator is singular
            !
            call self%is_PDE_singular(mbdcnd, nbdcnd, alpha, beta, cofx, singular)
            !
            !     compute non-zero eigenvector in null space of transpose
            !     if singular
            !
            if (singular) then
                call self%septri(mit, am, bm, cm, dm, um, zm)
            end if

            if (singular) then
                call self%septri(nit, an, bn, cn, dn, un, zn)
            end if
            !
            !     adjust right hand side if necessary
            !
            if (singular) then
                call self%seport(usol, zn, zm, pertrb)
            end if

            !
            ! compute solution
            !
            !     save adjusted right hand side in grhs
            grhs(is:ms,js:ns) = usol(is:ms,js:ns)

            call genbun(np, nit, mp, mit, am, bm, cm, idmn, usol(is:,js:), local_error_flag)
            !
            !  Check if error detected in pois
            !     this can only correspond to ierror=12
            if (local_error_flag /= 0) then
                !       set error flag if improper coefficients input to pois
                ierror = 12
                return
            end if

            if (ierror /= 0) return
            !
            ! set periodic boundaries if necessary
            !
            if (kswx == 1) usol(k, :l) = usol(1, :l)

            if (kswy == 1) usol(:k, l) = usol(:k, 1)
            !
            !     minimize solution with respect to weighted least squares
            !     norm if operator is singular
            !
            if (singular) call self%sepmin(usol, zn, zm, prtrb)
            !
            !     return if deferred corrections and a fourth order solution are
            !     not flagged
            !
            if (iorder == 2) return
            !
            ! compute new right hand side for fourth order solution
            !
            call self%defer(cofx, idmn, usol, grhs)

            if (singular) call self%seport(usol, zn, zm, pertrb)
            !
            ! compute solution
            !
            !     save adjusted right hand side in grhs
            grhs(is:ms,js:ns) = usol(is:ms,js:ns)

            call genbun(np, nit, mp, mit, am, bm, cm, idmn, usol(is:,js:), local_error_flag)

            !
            ! check if error detected in pois
            !    this can only correspond to ierror=12
            !
            if (local_error_flag /= 0) then
                !       set error flag if improper coefficients input to pois
                ierror = 12
                return
            end if

            if (ierror /= 0) return
            !
            ! set periodic boundaries if necessary
            !
            if (kswx == 1) usol(k, :l) = usol(1, :l)
            if (kswy == 1) usol(:k, l) = usol(:k, 1)

            !
            !     minimize solution with respect to weighted least squares
            !     norm if operator is singular
            !
            if (singular) call self%sepmin(usol, zn, zm, prtrb)
        end associate

    end subroutine s4elip

    subroutine check_input_parameters(iorder, a, b, m, mbdcnd, c, d, n, nbdcnd, cofx, &
        idmn, ierror)
        !
        ! Purpose:
        !
        ! This program checks the input parameters for errors
        !
        !--------------------------------------------------------------
        ! Dummy arguments
        !--------------------------------------------------------------
        integer(ip), intent(in)    :: iorder
        integer(ip), intent(in)    :: m
        integer(ip), intent(in)    :: mbdcnd
        integer(ip), intent(in)    :: n
        integer(ip), intent(in)    :: nbdcnd
        integer(ip), intent(in)    :: idmn
        integer(ip), intent(out)   :: ierror
        real(wp),    intent(in)    :: a
        real(wp),    intent(in)    :: b
        real(wp),    intent(in)    :: c
        real(wp),    intent(in)    :: d
        procedure(get_coefficients) :: cofx
        !--------------------------------------------------------------
        ! Local variables
        !--------------------------------------------------------------
        integer(ip) :: i
        real(wp)    :: xi, ai, bi, ci
        real(wp)    :: dlx
        !--------------------------------------------------------------

        if (a >= b .or. c >= d) then ! check definition of solution region
            ierror = 1
            return
        else if (mbdcnd < 0 .or. mbdcnd > 4) then ! check boundary switches
            ierror = 2
            return
        else if (nbdcnd < 0 .or. nbdcnd > 4) then
            ierror = 3
            return
        else if (idmn < 7) then ! check first dimension in calling routine
            ierror = 5
            return
        else if (m > idmn - 1 .or. m < 6) then ! check m
            ierror = 6
            return
        else if (n < 5) then ! check n
            ierror = 7
            return
        else if (iorder /= 2 .and. iorder /= 4) then ! Check iorder
            ierror = 8
            return
        end if
        !
        ! Check that equation is elliptic
        !
        dlx =(b - a)/m
        do i = 2, m
            xi = a + real(i - 1, kind=wp) * dlx
            call cofx(xi, ai, bi, ci)

            if (ai > ZERO) cycle

            ierror = 10
            return
        end do
        !
        ! no error found
        !
        ierror = 0

    end subroutine check_input_parameters

    subroutine is_PDE_singular(self, mbdcnd, nbdcnd, alpha, beta, cofx, singlr)
        !
        ! Purpose:
        !
        !     this subroutine checks if the pde sepeli
        !     must solve is a singular operator
        !
        !--------------------------------------------------------------
        ! Dummy arguments
        !--------------------------------------------------------------
        class(Sepx4Aux), intent(inout) :: self
        integer(ip),   intent(in)     :: mbdcnd
        integer(ip),   intent(in)     :: nbdcnd
        real(wp),      intent(in)     :: alpha
        real(wp),      intent(in)     :: beta
        logical ,       intent(out)    :: singlr
        procedure(get_coefficients)    :: cofx
        !--------------------------------------------------------------
        ! Local variables
        !--------------------------------------------------------------
        integer(ip) :: i
        real(wp)    :: xi, ai, bi, ci
        !--------------------------------------------------------------

        ! Associate various quantities
        associate( &
            kswx => self%kswx, &
            kswy => self%kswy, &
            k => self%k, &
            l=>self%l, &
            mit=>self%mit, &
            nit=> self%nit, &
            is=> self%is, &
            ms=> self%ms, &
            js=> self%js, &
            ns=> self%ns, &
            ait => self%ait, &
            bit => self%bit, &
            cit => self%cit, &
            dit => self%dit, &
            dlx => self%dlx, &
            dly => self%dly, &
            tdlx3 => self%tdlx3, &
            tdly3 => self%tdly3, &
            dlx4 => self%dlx4, &
            dly4 => self%dly4 &
            )

            singlr = .false.
            !
            !     check if the boundary conditions are
            !     entirely periodic and/or mixed
            !
            if (mbdcnd /=0 .and. mbdcnd /=3 .or. nbdcnd /=0 .and. nbdcnd /= 3) return
            !
            !     check that mixed conditions are pure neuman
            !
            if (mbdcnd == 3 .and. (alpha /= ZERO .or. beta /= ZERO)) return
            !
            !     check that non-derivative coefficient functions
            !     are zero
            !
            do i = is, ms
                xi = ait + real(i - 1, kind=wp)*dlx
                call cofx(xi, ai, bi, ci)
                if (ci == ZERO) cycle
                return
            end do
            !
            !     the operator must be singular if this point is reached
            !
            singlr = .true.

        end associate

    end subroutine is_PDE_singular

    subroutine defer(self, cofx, idmn, usol, grhs)
        !
        ! Purpose:
        !
        !     this subroutine first approximates the truncation error given by
        !     trun1(x, y)=dlx**2*tx+dly**2*ty where
        !     tx=afun(x)*uxxxx/12 + bfun(x)*uxxx/6 on the interior and
        !     at the boundaries if periodic(here uxxx, uxxxx are the third
        !     and fourth partial derivatives of u with respect to x).
        !     tx is of the form afun(x)/3 * (uxxxx/4+uxxx/dlx)
        !     at x=a or x=b if the boundary condition there is mixed.
        !     tx=ZERO along specified boundaries.  ty has symmetric form
        !     in y with x, afun(x), bfun(x) replaced by y, dfun(y), efun(y).
        !     the second order solution in usol is used to approximate
        !    (via second order finite differencing) the truncation error
        !     and the result is added to the right hand side in grhs
        !     and then transferred to usol to be used as a new right
        !     hand side when calling blktri for a fourth order solution.
        !
        !--------------------------------------------------------------
        ! Dummy arguments
        !--------------------------------------------------------------
        class(Sepx4Aux), intent(inout) :: self
        integer(ip),   intent(in)     :: idmn
        real(wp),      intent(inout) :: usol(:,:)
        real(wp),      intent(inout) :: grhs(:,:)
        procedure(get_coefficients)    :: cofx
        !--------------------------------------------------------------
        ! Local variables
        !--------------------------------------------------------------
        integer(ip) :: i, j
        real(wp)    :: xi, ai, bi, ci
        real(wp)    :: uxxx, uxxxx, uyyy, uyyyy, tx, ty
        !--------------------------------------------------------------

        ! Associate various quantities
        associate( &
            kswx => self%kswx, &
            kswy => self%kswy, &
            k => self%k, &
            l=>self%l, &
            mit=>self%mit, &
            nit=> self%nit, &
            is=> self%is, &
            ms=> self%ms, &
            js=> self%js, &
            ns=> self%ns, &
            ait => self%ait, &
            bit => self%bit, &
            cit => self%cit, &
            dit => self%dit, &
            dlx => self%dlx, &
            dly => self%dly, &
            tdlx3 => self%tdlx3, &
            tdly3 => self%tdly3, &
            dlx4 => self%dlx4, &
            dly4 => self%dly4 &
            )

            !     compute truncation error approximation over the entire mesh
            !
            do i = is, ms
                xi = ait + real(i - 1, kind=wp)*dlx
                call cofx(xi, ai, bi, ci)
                do j = js, ns
                    !
                    !     compute partial derivative approximations at(xi, yj)
                    !
                    call self%sepdx(usol, i, j, uxxx, uxxxx)
                    call self%sepdy(usol, idmn, i, j, uyyy, uyyyy)
                    tx = ai*(uxxxx/12) + bi*(uxxx/6)
                    ty = uyyyy/12
                    !
                    !     reset form of truncation if at boundary which is non-periodic
                    !
                    if (kswx /= 1 .and. (i==1 .or. i==k)) then
                        tx = (ai/3) * ((uxxxx/4) + uxxx/dlx)
                    end if

                    if (kswy /= 1 .and. (j==1 .or. j==l)) then
                        ty = ((uyyyy/4)+uyyy/dly)/3
                    end if

                    grhs(i, j) = grhs(i, j) + (dly**2)*((dlx**2)*tx + (dly**2)*ty)
                end do
            end do
            !
            !     reset the right hand side in usol
            !
            usol(is:ms,js:ns) = grhs(is:ms,js:ns)

        end associate

    end subroutine defer

end module module_sepx4
!
! REVISION HISTORY
!
! September 1973    Version 1
! April     1976    Version 2
! January   1978    Version 3
! December  1979    Version 3.1
! February  1985    Documentation upgrade
! November  1988    Version 3.2, FORTRAN 77 changes
! June      2004    Version 5.0, Fortran 90 changes
! May       2016    Fortran 2008 changes


program tsp_digits
    implicit none
    integer :: n, i, j, c, v, distance, min_distance
    integer, allocatable :: d(:, :), route(:), min_route(:)
    logical :: is_unique

    print '(a)', "How many places?"
    read *, n

    allocate(d(n, n))
    print '(a)', "Distances between the places are"
    do i = 1, n
        read *, d(i, :)
    end do

    allocate(route(n))
    route(:) = [(1, i = 1, n)]
    allocate(min_route(n))
    min_route(:) = huge(0)

    min_distance = huge(0)
    c = n
    permutation: do while (0 < c)
        ! Is permutation unique?
        is_unique = .true.
        unique: do i = 1, n
            v = route(i)
            do j = i + 1, n
                if (v == route(j)) then
                    is_unique = .false.
                    exit unique
                end if
            end do
        end do unique

        ! If it is unique, then find the distance, check if it is smaller than
        ! the one you've remembered, if so, then remember this distance and the
        ! corresponding route.
        if (is_unique) then
            distance = d(route(n), route(1))
            do i = 2, n
                distance = distance + d(route(i - 1), route(i))
            end do
            if (distance < min_distance) then
                min_distance = distance
                min_route(:) = route(:)
            end if
        end if
        ! Increment the permutation.  The last number is the fastest.  Index `c`
        ! points to the current city.  If route(c) exceeds the number of cities,
        ! it becomes 1 again and the cities to the left are incremented
        ! gradually.  Then the current city is again the last one.  Stop the
        ! process once the current city index is 0, that is, when the route is
        ! [n, ..., n].
        increment: do while (0 < c)
            route(c) = route(c) + 1
            if (route(c) > n) then
                route(c) = 1
                c = c - 1
            else
                exit increment
            end if
        end do increment
        if (0 < c) c = n
    end do permutation

    print '(a, i0, a)', "The minimum value ", min_distance, " is for the route:"
    print '(*(i2, 2x))', min_route(:)

    deallocate(min_route)
    deallocate(d)
    deallocate(route)
end program tsp_digits


program Fibonacci

    Number1 = 0
    Number2 = 1
    buffer  = 0

    do x = 2, 47, 1
        print *,  Number2
        Number1 = Number2
        Number2 = Number2 + buffer
        buffer  = Number1
    end do

end program Fibonacci


cc Copyright (C) 2004-2009: Leslie Greengard and June-Yub Lee
cc Contact: greengard@cims.nyu.edu
cc
cc This software is being released under a FreeBSD license
cc (see license.txt in this directory).
cc
c tweaked Alex Barnett to call FINUFFT 2/17/17
c dyn malloc; type 2 uses same input data fk0, other bugs 3/8/17
c
c Compile with (multithreaded version):
c gfortran nufft3d_demo.f dirft3d.f -o nufft3d_demo ../lib/libfinufft.a
c          -lstdc++ -lfftw3 -lfftw3_omp -lm -fopenmp
c
      program nufft3d_demo
      implicit none
c
      integer i,ier,iflag,j,k1,k2,k3,mx,ms,mt,mu,n1,n2,n3,nj,nk
      real*8, allocatable :: xj(:),yj(:),zj(:),sk(:),tk(:),uk(:)
      real*8 err,pi,eps,salg,ealg
      real*8 t0,t1,second
      parameter (pi=3.141592653589793238462643383279502884197d0)
      complex*16, allocatable :: cj(:),cj0(:),cj1(:),fk0(:),fk1(:)
c
c     --------------------------------------------------
c     create some test data
c     --------------------------------------------------
c
      ms = 24/2
      mt = 16/2
      mu = 18/2
      n1 = 16/2
      n2 = 18/2
      n3 = 24/2
      nj = n1*n2*n3
      nk = ms*mt*mu
c     first alloc everything
      allocate(fk0(nk))
      allocate(fk1(nk))
      allocate(sk(nk))
      allocate(tk(nk))
      allocate(uk(nk))
      allocate(xj(nj))
      allocate(yj(nj))
      allocate(zj(nj))
      allocate(cj(nj))
      allocate(cj0(nj))
      allocate(cj1(nj))
      do k3 = -n3/2, (n3-1)/2
         do k2 = -n2/2, (n2-1)/2
            do k1 = -n1/2, (n1-1)/2
               j =  (k1+n1/2+1) + (k2+n2/2)*n1 + (k3+n3/2)*n1*n2
               xj(j) = pi*dcos(-pi*k1/n1)
               yj(j) = pi*dcos(-pi*k2/n2)
               zj(j) = pi*dcos(-pi*k3/n3)
               cj(j) = dcmplx(dsin(pi*j/n1),dcos(pi*j/n2))
            enddo
         enddo
      enddo
c
c     -----------------------
c     start tests
c     -----------------------
c
      iflag = 1
      print*,'Starting 3D testing: ', 'nj =',nj, 'ms,mt,mu =',ms,mt,mu
      do i = 1,4
         if (i.eq.1) eps=1d-4
         if (i.eq.2) eps=1d-8
         if (i.eq.3) eps=1d-12
         if (i.eq.4) eps=1d-16
c extended/quad precision tests
         if (i.eq.5) eps=1d-20
         if (i.eq.6) eps=1d-24
         if (i.eq.7) eps=1d-28
         if (i.eq.8) eps=1d-32
	 print*,' '
	 print*,' Requested precision eps =',eps
	 print*,' '
c
c     -----------------------
c     call 3D Type 1 method
c     -----------------------
c
         call dirft3d1(nj,xj,yj,zj,cj,iflag,ms,mt,mu,fk0)
         call finufft3d1_f(nj,xj,yj,zj,cj,iflag,eps,ms,mt,mu,fk1,ier)
         print *, ' ier = ',ier
         call errcomp(fk0,fk1,nk,err)
         print *, ' type 1 err = ',err
c
c     -----------------------
c      call 3D Type 2 method
c     -----------------------
         call dirft3d2(nj,xj,yj,zj,cj0,iflag,ms,mt,mu,fk0)
         call finufft3d2_f(nj,xj,yj,zj,cj1,iflag,eps,ms,mt,mu,fk0,ier)
         print *, ' ier = ',ier
         call errcomp(cj0,cj1,nj,err)
         print *, ' type 2 err = ',err
c
c     -----------------------
c      call 3D Type3 method
c     -----------------------
         do k1 = 1, nk
            sk(k1) = 12*(dcos(k1*pi/nk))
            tk(k1) = 8*(dsin(-pi/2+k1*pi/nk))
            uk(k1) = 10*(dcos(k1*pi/nk))
         enddo

         call dirft3d3(nj,xj,yj,zj,cj,iflag,nk,sk,tk,uk,fk0)
         call finufft3d3_f(nj,xj,yj,zj,cj,iflag,eps,nk,sk,tk,uk,fk1,ier)
         print *, ' ier = ',ier
         call errcomp(fk0,fk1,nk,err)
         print *, ' type 3 err = ',err
      enddo
      stop
      end
c
c
c
c
c
      subroutine errcomp(fk0,fk1,n,err)
      implicit none
      integer k,n
      complex*16 fk0(n), fk1(n)
      real *8 salg,ealg,err
c
      ealg = 0d0
      salg = 0d0
      do k = 1, n
         ealg = ealg + cdabs(fk1(k)-fk0(k))**2
         salg = salg + cdabs(fk0(k))**2
      enddo
      err =sqrt(ealg/salg)
      return
      end


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cc                                                                    cc
cc               mnregr : regrid test program                         cc
cc                                                                    cc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      real x(11),y(11),z(121),tx(17),ty(17),c(300),wrk(850),f(121),
     * wk(132)
      integer iwrk(60),iw(22)
      real ai,fp,s,xb,xe,yb,ye
      integer kx,ky,kwrk,lwrk,m,mx,my,m1,m2,nc,nx,nxest,ny,nyest,
     * i,ier,is,iopt,j
c  we fetch the number of x-coordinates of the grid.
      read(5,900) mx
c  we fetch the x-coordinates of the grid.
      read(5,905) (x(i),i=1,mx)
c  we fetch the number of y-coordinates of the grid.
      read(5,900) my
c  we fetch the y-coordinates of the grid.
      read(5,905) (y(i),i=1,my)
c  we fetch the function values at the grid points.
      m = mx*my
      read(5,910) (z(i),i=1,m)
c  printing of the input data.
      write(6,915)
      write(6,920) (y(i),i=1,6)
      write(6,925)
      m1 = 1
      do 10 i=1,mx
        m2 = m1+5
        write(6,930) x(i),(z(j),j=m1,m2)
        m1 = m1+my
  10  continue
      write(6,920) (y(i),i=7,my)
      write(6,925)
      m1 = 7
      do 20 i=1,mx
        m2 = m1+4
        write(6,930) x(i),(z(j),j=m1,m2)
        m1 = m1+my
  20  continue
c  we set up the boundaries of the approximation domain.
      xb = x(1)
      yb = y(1)
      xe = x(mx)
      ye = y(my)
c  we set up the dimension information
      nxest = 17
      nyest = 17
      lwrk = 850
      kwrk = 60
c  main loop for the different spline approximations
      do 300 is=1,6
        go to (110,120,130,140,150,160),is
c  we start computing the least-squares bicubic polynomial
 110    iopt = 0
        kx = 3
        ky = 3
        s = 10.
        go to 200
c  iopt=1 from the second call on
 120    iopt = 1
        s = 0.22
        go to 200
c  overfitting (s too small)
 130    s = 0.1
        go to 200
c  an interpolating spline
 140    s = 0.
        go to 200
c  we change the degrees of the spline
 150    kx = 5
        ky = 5
        s = 0.2
        iopt = 0
        go to 200
c  finally we also calculate a least-squares spline approximation
c  with specified knots.
 160    iopt = -1
        kx = 3
        ky = 3
        nx = 11
        ny = 11
        j = kx+2
        do 170 i=1,3
          ai = i-2
          tx(j) = ai*0.5
          ty(j) = tx(j)
          j = j+1
 170    continue
c  determination of the spline approximation.
 200    call regrid(iopt,mx,x,my,y,z,xb,xe,yb,ye,kx,ky,s,nxest,
     *   nyest,nx,tx,ny,ty,c,fp,wrk,lwrk,iwrk,kwrk,ier)
c  printing of the fitting results.
        if(iopt.ge.0) go to 210
        write(6,935) kx,ky
        go to 220
 210    write(6,940) kx,ky
        write(6,945) s
 220    write(6,950) fp,ier
        write(6,955) nx
        write(6,960)
        write(6,965) (tx(i),i=1,nx)
        write(6,970) ny
        write(6,960)
        write(6,965) (ty(i),i=1,ny)
        nc = (nx-kx-1)*(ny-ky-1)
        write(6,975)
        write(6,980) (c(i),i=1,nc)
c  evaluation of the spline approximation.
        call bispev(tx,nx,ty,ny,c,kx,ky,x,mx,y,my,f,
     *   wk,132,iw,22,ier)
        write(6,985)
        write(6,920) (y(i),i=1,my,2)
        write(6,925)
        m1 = 1
        do 230 i=1,mx,2
          m2 = m1+my-1
          write(6,930) x(i),(f(j),j=m1,m2,2)
          m1 = m1+2*my
 230    continue
 300  continue
      stop
c  format statements.
 900  format(i2)
 905  format(11f5.1)
 910  format(11f7.4)
 915  format(15h1the input data)
 920  format(1h0,8x,1hy,4x,6(4x,f4.1))
 925  format(1h ,7x,1hx)
 930  format(6x,f4.1,5x,6f8.4)
 935  format(32h0least-squares spline of degrees,2i3)
 940  format(28h0smoothing spline of degrees,2i3)
 945  format(20h smoothing factor s=,f7.2)
 950  format(1x,23hsum squared residuals =,e15.6,5x,11herror flag=,i3)
 955  format(1x,42htotal number of knots in the x-direction =,i3)
 960  format(1x,22hposition of the knots )
 965  format(5x,10f6.2)
 970  format(1x,42htotal number of knots in the y-direction =,i3)
 975  format(23h0b-spline coefficients )
 980  format(5x,8f9.4)
 985  format(1h0,37hspline values at selected grid points)
      end


MODULE rational_mathematics
  use num_types
  use vector_matrix_utilities
  use utilities, only: ralloc

implicit none
private
public gcd, SmithNormalForm, HermiteNormalForm, is_a_rational_in_range,&
       SmithNormalForm_li, get_rationals_in_range

! Overloaded procedure for computing the greatest common denominator
INTERFACE gcd
   MODULE PROCEDURE gcd_2ints, gcd_rank1, gcd_3ints, gcd_4ints
END INTERFACE

CONTAINS

  !!This routine takes an integer 3x3 matrix and computes its
  !!Smith Normal Form.
  !!<parameter name="H" regular="True">Input matrix.</parameter>
  !!<parameter name="A" regular="True">Left Transform.</parameter>
  !!<parameter name="M" regular="true">Smith Normal Form matrix.</parameter>
  !!<parameter name="B" regular="True">Right Transform.</parameter>
  !!<parameter name="err_" regular="True">Returns 1 if overflow occures.</parameter>
  subroutine SmithNormalForm_li(H,A,M,B,err_)
    integer, intent(in) :: H(3,3)
    integer, intent(out) :: M(3,3)
    integer(li), intent(out), dimension(3,3) :: A, B
    integer, optional, intent(out) :: err_

    integer :: i, row, col, min_val, j, check(9)
    integer :: multiple, tmpVec(3)
    integer(li) :: tmpVec_li(3)
    logical :: is_snf, new_pivot, OverFlowCheck
    integer :: itCnt, min_row

    OverFlowCheck = .False.
    if (present(err_)) OverFlowCheck = .True.

    if(determinant(H)<1) stop "SmithNormalForm routine failed because the input matrix had a negative determinant"
    A = 0; B = 0; M = H ! M starts out as H, the input matrix
    forall(i=1:3); A(i,i) = 1; B(i,i) = 1; end forall ! A & B = identity

    j=1
    itCnt = 0
    is_snf = .False.
    new_pivot = .True.
    do while (is_snf .eqv. .False. .and. j<4)
       itCnt = itCnt + 1
       if (itCnt>=100) stop "ERROR bad programming in SmithNormalForm"

       if (new_pivot) then
          call get_min_val(M, j, min_val, row, col)
       end if

       do i=1,3
          if (i==col) cycle
          multiple = nint(real(M(row,i),dp)/real(min_val,dp))
          if (multiple==0) cycle
          M(:,i) = M(:,i)-multiple*M(:,col)
          B(:,i) = B(:,i)-multiple*B(:,col)
       end do

       do i=1,3
          if (i==row) cycle
          multiple = nint(real(M(i,col),dp)/real(min_val,dp))
          if (multiple==0) cycle
          M(i,:) = M(i,:)-multiple*M(row,:)
          A(i,:) = A(i,:)-multiple*A(row,:)
       end do

       new_pivot = .True.
       if ((count(M(:,col)==0)==2) .and. (count(M(row,:)==0)==2)) then
          if (all(mod(M(j:,j:),min_val)==0)) then
             if (j < col) then
                tmpVec_li = B(:,j); B(:,j) = B(:,col); B(:,col) = tmpVec_li
                tmpVec = M(:,j); M(:,j) = M(:,col); M(:,col) = tmpVec
             end if
             if (j < row) then
                tmpVec_li = A(j,:); A(j,:) = A(row,:); A(row,:) = tmpVec_li
                tmpVec = M(j,:); M(j,:) = M(row,:); M(row,:) = tmpVec
             end if
             j = j + 1
          else
             new_pivot = .False.
             call get_min_loc(M, min_val, j, min_row)
             M(row,:) = M(row,:) + M(min_row,:)
             A(row,:) = A(row,:) + A(min_row,:)
          end if
       end if

       check = reshape(M,(/9/))
       if (all(check((/2,3,4,6,7,8/))==0) .and. all(check((/1,5,9/))/=0)) then
          if (mod(M(2,2),M(1,1))==0 .and. mod(M(3,3),M(2,2))==0) then
             is_snf = .True.
          end if
       end if
    end do

    do i=1,3
       if (M(i,i) < 0) then
          M(i,:) = -M(i,:)
          A(i,:) = -A(i,:)
       end if
    end do

    if (any(matmul(matmul(A,H),B)/=M)) stop "END: Transformation matrices didn't work"
    check = reshape(M,(/9/))
    if (any(check((/2,3,4,6,7,8/))/=0)) stop "Not diagonal"
    if (mod(M(2,2),M(1,1))/=0 .or. mod(M(3,3),M(2,2))/=0) stop "SNF conditions not met"
    if (OverFlowCheck) then
       if ((any(abs(real(A,dp)) > 1E17)) .or. (any(abs(real(B,dp)) > 1E17))) then
          write(*,*) "Warning Values in SmithNormalForm overflowing standard ints."
          err_ = 1
       else
          err_ = 0
       end if
    else
       if ((any(abs(real(A,dp)) > 1E17)) .or. (any(abs(real(B,dp)) > 1E17))) stop "Warning Values in SmithNormalForm overflowing standard ints."
    end if
  ENDSUBROUTINE SmithNormalForm_Li

  !!Finds the minimal value in the sub matrix of A where the
  !!sub matrix consits of every row and colum greater than or equal to
  !!diag.
  !!<parameter name="A" regular="true">The input matrix.</parameter>
  !!<parameter name="diag" regular="true">The row/column number we
  !!want to be below.</parameter>
  !!<parameter name="min_val" regular="true">The smallest value in A
  !!that's not in an empty row or column.</parameter>
  !!<parameter name="row" regular="true">The row with the lowest value
  !!in it.</parameter>
  !!<parameter name="col" regular="true">The column with the lowest
  !!value in it.</parameter>
  subroutine get_min_val(A, diag, min_val, row, col)
    integer, intent(in) :: A(3,3), diag
    integer, intent(out) :: min_val, row, col

    integer :: temp_A(3,3), i, tmploc(2)
    logical :: found

    found = .False.
    temp_A = abs(A)
    do i=1,9
       tmploc = minloc(temp_A, temp_A>0)
       row = tmploc(1)
       col = tmploc(2)
       min_val = A(row,col)
       if (row >= diag .and. col >= diag) then
          found = .True.
          exit
       else
          temp_A(row, col) = -1
       end if
    end do

    if (found .eqv. .False.) stop "Failed to find minimal value in get_min_val."
  end subroutine get_min_val

  !!Finds the row of the smallest value not divisible by a
  !!pivot within the sub matrix of A consisting of the row and column
  !!numbers greater than or equal to diag.
  !!<parameter name="A" regular="true">The input matrix.</parameter>
  !!<parameter name="pivot" regular="true">The pivot.</parameter>
  !!<parameter name="diag" regular="true">The row/column number we
  !!want to be below.</parameter>
  !!<parameter name="row" regular="true">The row with the lowest value
  !!in it.</parameter>
  subroutine get_min_loc(A, pivot, diag, row)
    integer, intent(in) :: A(3,3), pivot, diag
    integer, intent(out) :: row

    integer :: temp_A(3,3), i, tmploc(2), mod_p(3,3), col
    logical :: found

    found = .False.
    temp_A = abs(A)
    mod_p = mod(A,pivot)
    do i=1,9
       tmploc = minloc(temp_A, temp_A>0)
       row = tmploc(1)
       col = tmploc(2)
       if (row >= diag .and. col >= diag .and. mod_p(row,col) /= 0) then
          found = .True.
          exit
       else
          temp_A(row, col) = -1
       end if
    end do

    if (found .eqv. .False.) stop "Failed to find minimal value in get_min_val."
  end subroutine get_min_loc

  !!This routine takes an integer 3x3 matrix and computes its
  !!Smith Normal Form.
  !!<parameter name="H" regular="True">Input matrix.</parameter>
  !!<parameter name="A" regular="True">Left Transform.</parameter>
  !!<parameter name="M" regular="true">Smith Normal Form matrix.</parameter>
  !!<parameter name="B" regular="True">Right Transform.</parameter>
  !!<parameter name="err_" regular="True">Returns 1 if overflow occures.</parameter>
  subroutine SmithNormalForm(H,A,M,B,err_)
    integer, intent(in) :: H(3,3)
    integer, intent(out), dimension(3,3) :: M, A, B
    integer, optional, intent(out) :: err_

    integer :: i, row, col, min_val, j, check(9)
    integer :: multiple, tmpVec(3)
    logical :: is_snf, new_pivot, OverFlowCheck
    integer :: itCnt, min_row

    OverFlowCheck = .False.
    if (present(err_)) OverFlowCheck = .True.

    if(determinant(H)<1) stop "SmithNormalForm routine failed because the input matrix had a negative determinant"
    A = 0; B = 0; M = H ! M starts out as H, the input matrix
    forall(i=1:3); A(i,i) = 1; B(i,i) = 1; end forall ! A & B = identity

    j=1
    itCnt = 0
    is_snf = .False.
    new_pivot = .True.
    do while (is_snf .eqv. .False. .and. j<4)
       itCnt = itCnt + 1
       if (itCnt>=100) stop "ERROR bad programming in SmithNormalForm"

       if (new_pivot) then
          call get_min_val(M, j, min_val, row, col)
       end if

       do i=1,3
          if (i==col) cycle
          multiple = nint(real(M(row,i),dp)/real(min_val,dp))
          if (multiple==0) cycle
          M(:,i) = M(:,i)-multiple*M(:,col)
          B(:,i) = B(:,i)-multiple*B(:,col)
       end do

       do i=1,3
          if (i==row) cycle
          multiple = nint(real(M(i,col),dp)/real(min_val,dp))
          if (multiple==0) cycle
          M(i,:) = M(i,:)-multiple*M(row,:)
          A(i,:) = A(i,:)-multiple*A(row,:)
       end do

       new_pivot = .True.
       if ((count(M(:,col)==0)==2) .and. (count(M(row,:)==0)==2)) then
          if (all(mod(M(j:,j:),min_val)==0)) then
             if (j < col) then
                tmpVec = B(:,j); B(:,j) = B(:,col); B(:,col) = tmpVec
                tmpVec = M(:,j); M(:,j) = M(:,col); M(:,col) = tmpVec
             end if
             if (j < row) then
                tmpVec = A(j,:); A(j,:) = A(row,:); A(row,:) = tmpVec
                tmpVec = M(j,:); M(j,:) = M(row,:); M(row,:) = tmpVec
             end if
             j = j + 1
          else
             new_pivot = .False.
             call get_min_loc(M, min_val, j, min_row)
             M(row,:) = M(row,:) + M(min_row,:)
             A(row,:) = A(row,:) + A(min_row,:)
          end if
       end if

       check = reshape(M,(/9/))
       if (all(check((/2,3,4,6,7,8/))==0) .and. all(check((/1,5,9/))/=0)) then
          if (mod(M(2,2),M(1,1))==0 .and. mod(M(3,3),M(2,2))==0) then
             is_snf = .True.
          end if
       end if
    end do

    do i=1,3
       if (M(i,i) < 0) then
          M(i,:) = -M(i,:)
          A(i,:) = -A(i,:)
       end if
    end do
    if (any(matmul(matmul(A,H),B)/=M)) stop "END: Transformation matrices didn't work"
    check = reshape(M,(/9/))
    if (any(check((/2,3,4,6,7,8/))/=0)) stop "Not diagonal"
    if (mod(M(2,2),M(1,1))/=0 .or. mod(M(3,3),M(2,2))/=0) stop "SNF conditions not met"
    if (OverFlowCheck) then
       if ((any(abs(A) > 1E9)) .or. (any(abs(B) > 1E9))) then
          write(*,*) "Warning Values in SmithNormalForm overflowing standard ints."
          err_ = 1
       else
          err_ = 0
       end if
    else
       if ((any(abs(A) > 1E9)) .or. (any(abs(B) > 1E9))) stop "Warning Values in SmithNormalForm overflowing standard ints."
    end if
  ENDSUBROUTINE SmithNormalForm

  !!Find the Hermite normal form of a a given integer
  !!matrix. Similar to the SNF finder above but a little simpler. This
  !!routine is not very elegant, just brute force. Don't be
  !!disappointed.
  !!<parameter name="S" regular="true">The 3x3 integer matrix
  !!describing the relationship between two commensurate
  !!lattices.</parameter>
  !!<parameter name="H" regular="true">The resulting HNF
  !!matrix.</parameter>
  !!<parameter name="B" regular="true">The transformation matrix such
  !!that $H = SB$.</parameter>
  subroutine HermiteNormalForm(S,H,B)
    integer, intent(in) :: S(3,3)
    integer, intent(out), dimension(3,3) :: H, B

    !!<local name="tempcol">When two columns need to be swapped,
    !!tempcol mediates the swap.</local>
    !!<local name="check">Stores the HNF as a vector; only used as
    !!failsafe for meeting HNF criteria.</local>
    !!<local name="maxidx, minidx">The indices of max/min values in a
    !!column.</local>
    !!<local name="multiple">When reducing the columns to HNF form,
    !!the multiplicative relationship between two elements of two
    !!columns; reused.</local>
    !!<local name="minm">The smallest element in row 1 of the HNF
    !!being constructed.</local>

    integer :: i, minm, maxidx, minidx, multiple, j,  check(9), tempcol(3)

    if (determinant(S) == 0) stop "Singular matrix passed to HNF routine"
    B = 0; H = S ! H starts out as S, the input matrix
    forall(i=1:3); B(i,i) = 1; end forall ! B = identity

    do ! Keep doing column operations until all elements in row 1 are
       ! zero except the one on the diagonal.
       ! Divide the column with the smallest value into the largest
       do while (count(H(1,:)/=0) > 1) ! Keep going until only zeros beyond first element
          call get_minmax_indices(H(1,:),minidx,maxidx)
          minm = H(1,minidx)
          ! Subtract a multiple of the column containing the smallest element from
          ! the row containing the largest element
          multiple = H(1,maxidx)/minm ! Factor to multiply by
          H(:,maxidx) = H(:,maxidx) - multiple*H(:,minidx)
          B(:,maxidx) = B(:,maxidx) - multiple*B(:,minidx)
          if (any(matmul(S,B)/=H)) stop "COLS: Transformation matrices didn't work"
       enddo ! End of step row 1
       if (H(1,1) == 0) call swap_column(H,B,1) ! swap columns if (1,1) is zero
       if (H(1,1)<0)then; H(:,1) = -H(:,1); B(:,1) = -B(:,1) ! Change sign if (1,1) is negative
       endif
       if (count(H(1,:)/=0) > 1) stop "Didn't zero out the rest of the row"
       if (any(matmul(S,B)/=H)) stop "COLSWAP: Transformation matrices didn't work"
       exit
    enddo
    ! Now work on element H(2,3)
    do
       do while (H(2,3)/=0)
          if (H(2,2) == 0) then
             tempcol = H(:,2); H(:,2) = H(:,3); H(:,3) = tempcol
             tempcol = B(:,2); B(:,2) = B(:,3); B(:,3) = tempcol
             if (H(2,3) == 0) exit
          endif
          if (abs(H(2,3))<abs(H(2,2))) then; maxidx = 2; minidx = 3
          else; maxidx = 3; minidx = 2; endif
          multiple = H(2,maxidx)/H(2,minidx)
          H(:,maxidx) = H(:,maxidx) - multiple*H(:,minidx)
          B(:,maxidx) = B(:,maxidx) - multiple*B(:,minidx)
          if (any(matmul(S,B)/=H)) stop "COLS: Transformation matrices didn't work"
       enddo
       if (H(2,2) == 0) then
          tempcol = H(:,2); H(:,2) = H(:,3); H(:,3) = tempcol
       endif
       if (H(2,2)<0) then ! Change signs
       H(:,2) = -H(:,2); B(:,2) = -B(:,2); endif
       if (H(2,3)/=0) stop "Didn't zero out last element"

       if (any(matmul(S,B)/=H)) stop "COLSWAP: Transformation matrices didn't work"
       exit
    enddo
    if (H(3,3)<0) then ! Change signs
       H(:,3) = -H(:,3); B(:,3) = -B(:,3);
    endif
    check = reshape(H,(/9/))
    if (any(check((/4,7,8/))/=0)) stop "Not lower triangular"
    if (any(matmul(S,B)/=H)) stop "END PART1: Transformation matrices didn't work"

    ! Now that the matrix is in lower triangular form, make sure the lower off-diagonal
    ! elements are non-negative but less than the diagonal elements
    do while (H(2,2) <= H(2,1) .or. H(2,1)<0)
       if (H(2,2) <= H(2,1)) then; multiple = 1
       else; multiple = -1; endif
       H(:,1) = H(:,1) - multiple*H(:,2)
       B(:,1) = B(:,1) - multiple*B(:,2)
    enddo
    do j = 1,2
       do while (H(3,3) <= H(3,j) .or. H(3,j)<0)
          if (H(3,3) <= H(3,j)) then; multiple = 1
          else; multiple = -1; endif
          H(:,j) = H(:,j) - multiple*H(:,3)
          B(:,j) = B(:,j) - multiple*B(:,3)
       enddo
    enddo
    if (any(matmul(S,B)/=H)) stop "END: Transformation matrices didn't work"
    check = reshape(H,(/9/))
    if (any(check((/4,7,8/))/=0)) stop "Not lower triangular"
    if (any(check((/2,3,6/))<0)) stop "Negative elements in lower triangle"
    if (check(2) > check(5) .or. check(3) > check(9) .or. check(6) > check(9)) stop "Lower triangular elements bigger than diagonal"
  ENDSUBROUTINE HermiteNormalForm

  ! !!Support routines for the Smith and Hermite normal form finders.
  ! !!<parameter name="A" regular="true"></parameter>
  ! !!<parameter name="M" regular="true"></parameter>
  ! !!<parameter name="k" regular="true"></parameter>
  ! subroutine swap_row(A,M,k) ! Swap rows of M (and A)
  !   integer, intent(inout) :: M(3,3), A(3,3)
  !   integer, intent(in) :: k
  !   integer :: tmpRow(3), maxidx(1)

  !   maxidx = maxloc(abs(M(k:,k)))+k-1  ! find index of the non-zero element in col k
  !   tmpRow = A(k,:); A(k,:) = A(maxidx(1),:); A(maxidx(1),:) = tmpRow
  !   tmpRow = M(k,:); M(k,:) = M(maxidx(1),:); M(maxidx(1),:) = tmpRow
  ! endsubroutine swap_row

  !!Swaps the column 'k' with whichever column has the
  !!highest value (out of the columns to the right of 'k' in row
  !!'k'). The swap is performed in both matrices 'M' and
  !!'B'.
  !!<parameter name="M" regular="true">The matrix being
  !!transformed.</parameter>
  !!<parameter name="B" regular="true">Usually a matrix to keep track
  !!of the transformation steps on 'M'.</parameter>
  !!<parameter name="k" regular="true">The column to swap, as
  !!described in summary.</parameter>
  subroutine swap_column(M,B,k)
    integer, intent(inout) :: M(3,3), B(3,3)
    integer, intent(in) :: k
    integer :: tmpCol(3), maxidx(1)

    maxidx = maxloc(abs(M(k,k:)))+k-1 ! find index of the non-zero element in row k
    tmpCol = B(:,k); B(:,k) = B(:,maxidx(1)); B(:,maxidx(1)) = tmpCol
    tmpCol = M(:,k); M(:,k) = M(:,maxidx(1)); M(:,maxidx(1)) = tmpCol
  endsubroutine swap_column

  ! !!Finds the indices corresponding the maximum and second
  ! !!maximum Values in an integer vector.
  ! !!<parameter name="invec" regular="true">Input vector</parameter>
  ! !!<parameter name="max" regular="true">Location of maximum
  ! !!value</parameter>
  ! !!<parameter name="smax" regular="true">Location of second maximum
  ! !!value</parameter>
  ! subroutine get_max2max_indices(invec,smax,max)
  !   integer, intent(in) :: invec(3)
  !   integer, intent(out) :: max, smax

  !   integer :: tmpmax(1), tmpmax2(1), vec(3)
  !   vec = abs(invec)
  !   ! Search from the right for the max, this prevents inifinite
  !   ! looping in the SNF routine.
  !   tmpmax = 4 - maxloc(vec(3:1:-1),vec(3:1:-1)>0)
  !   vec(tmpmax(1)) = 0
  !   tmpmax2 = maxloc(vec, vec>0)!4 - maxloc(vec(3:1:-1),vec(3:1:-1)>0)
  !   smax = tmpmax2(1)
  !   max = tmpmax(1)
  ! endsubroutine get_max2max_indices

  !!Finds the indices corresponding the minimum and maximum
  !!values in an integer vector.
  !!<parameter name="invec" regular="true"></parameter>
  !!<parameter name="min" regular="true"></parameter>
  !!<parameter name="max" regular="true"></parameter>
  subroutine get_minmax_indices(invec,min,max)
    integer, intent(in) :: invec(3)
    integer, intent(out) :: min, max

    integer :: tmpmin(1), tmpmax(1), vec(3)
    vec = abs(invec)
    tmpmin = minloc(vec,vec>0)
    ! Search from the right for the max so it will be different from the minimum
    ! even if the min and max are the same value
    tmpmax = 4 - maxloc(vec(3:1:-1),vec(3:1:-1)>0)
    min = tmpmin(1)
    max = tmpmax(1)
  endsubroutine get_minmax_indices

  !!This function finds the greatest common denominator of
  !!several integers. This case works for two integers, given as
  !!separate arguments
  !!<parameter name="x1" ></parameter>
  !!<parameter name="x2" ></parameter>
  function gcd_2ints(x1, x2) result(divisor)
    integer, intent(in) :: x1, x2
    integer :: divisor

    integer :: a, b
    a = abs(x1); b = abs(x2) ! Make sure inputs are positive
    if (b>a) call swap(a,b)

    do ! Keep dividing a by b, until one of them is zero
       if (b>a) call swap(a,b) ! Keep the bigger number in a's place
       if (b == 0) exit ! we're done when b == 0
       a = mod(a,b) ! Divide a by b and keep only the remainder
    enddo
    divisor = a

  contains
    !!Swaps x and y.
    !!<parameter name="x" regular="true"></parameter>
    !!<parameter name="y" regular="true"></parameter>
    subroutine swap(x,y) ! Swap two values
      integer :: x,y,tmp
      tmp = x; x = y; y = tmp
    endsubroutine swap
  end function gcd_2ints

  !!This function finds the greatest common denominator of
  !!several integers.This case works on a list of integers (a rank-1
  !!array).
  !!<parameter name="x" regular="true"></parameter>
  function gcd_rank1(x) result(divisor)
    integer, intent(in) :: x(:)
    integer :: divisor

    integer :: a(size(x)), N, indx(1), big2

    N = size(x); a = abs(x)
    if (any(a<0)) stop "GCD requires non-negative integers"
    do ! Divide the biggest number by the second biggest until
       ! the second biggest is zero
       indx = maxloc(a)  ! Find the location of the biggest number
       if (all(a == a(indx(1)))) then ! check if all numbers are the same
          big2 = a(indx(1))
       else   ! The "real" around 'a' is a workaround for a problem in the Absoft compiler
          big2 = int(maxval(real(a),mask=a < a(indx(1)))) ! Find the size of the 2nd biggest number
       endif
       if (big2 == 0) exit
       a(indx(1)) = mod(a(indx(1)),big2)
    enddo
    divisor = a(indx(1)) ! The divisor is the number left when every other member==0
  endfunction gcd_rank1

  !!This function finds the greatest common denominator of
  !!several integers. This case works on 3 integers, not in an array.
  !!<parameter name="x1" ></parameter>
  !!<parameter name="x2" ></parameter>
  !!<parameter name="x3" ></parameter>
  function gcd_3ints(x1,x2,x3)
    integer, intent(in) :: x1,x2,x3
    integer :: gcd_3ints
    gcd_3ints = gcd_rank1((/x1,x2,x3/))
  end function gcd_3ints

  !!This function finds the greatest common denominator of
  !!several integers. This case works on 4 integers, not in an array.
  !!<parameter name="x1" ></parameter>
  !!<parameter name="x2" ></parameter>
  !!<parameter name="x3" ></parameter>
  !!<parameter name="x4" ></parameter>
  function gcd_4ints(x1,x2,x3,x4)
    integer, intent(in) :: x1,x2,x3,x4
    integer :: gcd_4ints
    gcd_4ints = gcd_rank1((/x1,x2,x3,x4/))
  end function gcd_4ints

  !!This function checks to see if there is a rational number
  !!in a range (assume a 1-D range. This isn't general for ternaries,
  !!etc.)
  !!<parameter name="range" regular="true"></parameter>
  !!<parameter name="n" regular="true"></parameter>
  !!<parameter name="eps_" regular="true"></parameter>
  function is_a_rational_in_range(range,n,eps_)
    integer :: range(3)
    integer :: n
    real(dp), optional :: eps_
    logical :: is_a_rational_in_range
    integer :: j2
    real(dp) :: eps,left,right

    is_a_rational_in_range = .false.

    if (present(eps_)) then
       eps = eps_
    else
       eps = 1e-12_dp
    endif
    left  = real(range(1),dp)/range(3) - eps
    right = real(range(2),dp)/range(3) + eps
    do j2 = 0, n ! numerators
       if      (real(j2,dp)/n > left &
            .and. real(j2,dp)/n < right) then ! there is a rational in the range
          is_a_rational_in_range = .true.
          return
       endif
    enddo
    ! If the loops end, then the if condition was never met and
    ! there isn't a rational number in the range
  endfunction is_a_rational_in_range

  !!This routine generates all of the rational numbers of a
  !!given numerator that lie within a specified range. (assume a 1-D
  !!range. This isn't general for ternaries, etc.)
  !!<parameter name="range" regular="true"></parameter>
  !!<parameter name="n" regular="true"></parameter>
  !!<parameter name="numerators"></parameter>
  !!<parameter name="eps_" regular="true"></parameter>
  subroutine get_rationals_in_range(range,n,numerators,eps_)
    integer, intent(in) :: range(3)
    integer, intent(in) :: n
    integer, pointer :: numerators(:)
    real(dp), optional, intent(in) :: eps_
    integer :: j, cR
    real(dp) :: eps,left,right

    nullify(numerators)

    if (present(eps_)) then
       eps = eps_
    else
       eps = 1e-12_dp
    endif
    left  = real(range(1),dp)/range(3) - eps
    right = real(range(2),dp)/range(3) + eps
    allocate(numerators(n+1))
    numerators = 0

    cR = 0
    do j = 0, n ! numerators
       if      (real(j,dp)/n > left &
            .and. real(j,dp)/n < right) then ! there is a rational in the range
          cR = cR + 1
          numerators(cR) = j
       endif
    enddo
    if (cR==0) stop "get_rationals_in_range didn't find any in the range"
    numerators => ralloc(numerators,cR)
  end subroutine get_rationals_in_range

END MODULE rational_mathematics


      subroutine apprgrdn(n,g,x,f,fun,deltax,obj)
c Subroutine APPRGRDN performs the finite difference approximation
c of the gradient <g> at a point <x>.
c f      is the calculated function value at a point <x>,
c <fun>  is the name of a subroutine that calculates function values,
c deltax is an array of the relative stepsizes.
c obj    is the flag indicating whether the gradient of the objective
c        function (1) or the constraint function (0) is to be calculated.
c
      implicit none
      double precision x(*), g(*), f, deltax(*)
      double precision lowbndobj,lowbndcnt,d,y,fi,one,ten,half
      integer n, i, j
      logical center,obj
      external fun
      data lowbndobj /2.d-10/, lowbndcnt /5.d-15/
      data one /1.d0/, ten /1.d1/, half /.5d0/
      do i=1,n
         y=x(i)
         d=dmax1(lowbndcnt,dabs(y))
         d=deltax(i)*d
         if (obj) then
           if (dabs(d).lt.lowbndobj) then
              d=lowbndobj*dsign(one,deltax(i))
              center=.true.
           else
              center=.false.
           endif
         else
           if (dabs(d).lt.lowbndcnt) then
              d=lowbndcnt*dsign(one,deltax(i))
           endif
         endif
         x(i)=y+d
         call fun(x,fi)
         if (obj) then
          if (fi.eq.f) then
           do j=1,3
              d=d*ten
              x(i)=y+d
              call fun(x,fi)
              if (fi.ne.f) exit
           enddo
          endif
         endif
         g(i)=(fi-f)/d
         if (obj) then
           if (center) then
              x(i)=y-d
              call fun(x,fi)
              g(i)=half*(g(i)+(f-fi)/d)
           endif
         endif
         x(i)=y
      enddo
      end


      subroutine xmult (k, kp, ls, lb, xm1, xm2)

      implicit double precision (a-h, o-z)
      complex*16 xm1, xm2, alslb
      include '../HEADERS/const.h'
c     xm1, xm2 both either real or pure imaginary
      integer a, ap

c     see Grant eq. 6.30. calculate the factors
c     <k|alpha*A( l, L)|k'> = (-)**(j-m) * 3j( j L j'; -m p m')*R_k,k'
c     R_k,k'(l,L) = \int dr (xm1*P_k*Q_k'+ xm2*Q_k*P_k') * j_l(wr)

c     set the factor in front of bessel function (eq.6.26)
      if (ls+1.eq.lb) then
c        e.g. dipole and quadrupole transition
         aa = (2*lb-1) * (lb+1) / 2.d0
         alslb = coni**ls * sqrt(aa)
      elseif (ls-1.eq.lb) then
c        e.g. cross dipole-octupole
         aa = (2*lb+3) * lb / 2.d0
         alslb = coni**ls * sqrt(aa)
      elseif (ls.eq.lb) then
c        e.g. magnetic dipole
         alslb = coni**ls * (2*lb+1) /sqrt(2.d0)
      else
         alslb = 0
      endif

c     set all angular momenta
      j2 = 2*abs(k) -1
      a = 1
      if (k.gt.0) a=-1
      jp2 = 2*abs(kp) -1
      ap = 1
      if (kp.gt.0) ap=-1

c     calculate xm1 (beta=1 in eq.6.30)
c     check out 2 Kronecker symbols
      lam = (j2-a) / 2
      lamp = (jp2+ap) / 2
      if ( 2*lam.eq.j2-a .and. 2*lamp.eq.jp2+ap) then
         call ninej (lam, lamp, ls, j2,jp2, lb, aa)
         xm1 = alslb * aa * cwig3j(lam, ls, lamp, 0, 0, 1) * (-1)**lam
     1        * sqrt(6.d0*(j2+1)*(jp2+1)*(2*lb+1)*(2*lam+1)*(2*lamp+1) )
         xm1 = xm1 * coni
      else
         xm1 = 0
      endif

c     calculate xm2 (beta=-1 in eq.6.30)
c     check out 2 Kronecker symbols
      lam = (j2+a) / 2
      lamp = (jp2-ap) / 2
      if ( 2*lam.eq.j2+a .and. 2*lamp.eq.jp2-ap) then
         call ninej (lam, lamp, ls, j2,jp2, lb, aa)
         xm2 = alslb * aa * cwig3j(lam, ls, lamp, 0, 0, 1) * (-1)**lam
     1       * sqrt(6.d0*(j2+1)*(jp2+1)*(2*lb+1)*(2*lam+1)*(2*lamp+1) )
c        factor -1 due to complex conjugation of i*Q_k
         xm2 = - coni * xm2
      else
         xm2 = 0
      endif

      return
      end

      subroutine ninej (lam, lamp, ls, j2,jp2, lb, aa)
      implicit double precision (a-h, o-z)
c     calculate 9j-symbol in 6.30 of Grant using eq. C.41 in Messiah

      if (ls.gt.lb) then
        aa = - (ls+lb+1)* sixj(1,2,2*lb,ls+lb,2*ls) *
     1       sixj(2*lb, ls+lb, 2*lamp, jp2, j2) *
     1       sixj(ls+lb,2*ls, 2*lam, j2, 2*lamp)
      elseif (ls.lt.lb) then
        aa = - (ls+lb+1)* sixj(1,2,2*lb,ls+lb,2*ls) *
     1       sixj(ls+lb, 2*lb, jp2, 2*lamp, j2) *
     1       sixj(2*ls, ls+lb, j2, 2*lam, 2*lamp)
      else
c       ls=lb (magnetic dipole)
        aa = -(2*ls+2) * sixj(1,2,2*lb,2*lb+1,2*lb) *
     1       sixj(2*lb, 2*lb+1, 2*lamp, jp2, j2) *
     1       sixj(2*lb, 2*lb+1, j2, 2*lam, 2*lamp)
        aa = aa -(2*ls) * sixj(1,2,2*lb,2*lb-1,2*lb) *
     1       sixj(2*lb-1, 2*lb, jp2, 2*lamp, j2) *
     1       sixj(2*lb-1, 2*lb, 2*lam, j2, 2*lamp)
      endif

      return
      end

      double precision function sixj(j1,j2,j3,j4,j5)
      implicit double precision (a-h, o-z)
c     calculate 6j symbols in eq. c.38, c39 of Messiah
c     all input angular momenta are multiplied by 2 and
c     j2 should be equal to j1+1
      integer g2

      aa = 0
      if (j2.eq.j1+1) then
        if (j4.eq.j3+1) then
c         eq.c.38
          g2 = j5 - 1
          if (g2.ge.abs(j1-j3) .and. g2.le.j1+j3) then
            aa = (1.d0 + (g2+j1-j3)/2.d0) * (1.d0 +(g2-j1+j3)/2.d0) /
     1           (j1+1) /(j1+2)/(j3+1)/(j3+2)
            aa = sqrt(aa) * (-1)**(nint(1+(g2+j1+j3)/2.d0))
          endif
        elseif(j3.eq.j4+1) then
c         eq.c.39
          g2 = j5
          if (g2.ge.abs(j1-j4) .and. g2.le.j1+j4) then
            aa = (1.d0 - (g2-j1-j4)/2.d0) * (2.d0 +(g2+j1+j4)/2.d0) /
     1           (j1+1) /(j1+2)/(j4+1)/(j4+2)
            aa = sqrt(aa) * (-1)**(nint(1+(g2+j1+j4)/2.d0))
          endif
        endif
      endif
      sixj = aa

      return
      end