module project
use config, only: ftol, gtol, atol, ptol
use math
use generic_list
use geom_utils
use evaluate
use modify
use divide
use geom_results
implicit none

private
public :: project_point_to_curve, project_point_to_surface

! Point projection data.
type proj_data
    double precision :: u0
    double precision :: v0
end type proj_data

type proj_ptr
    type(proj_data), pointer :: proj
end type proj_ptr

contains

subroutine project_point_to_curve(pnt, n, p, uk, cpw, ends, all_pnts, flag)
    !> Project a point to a curve.
    !> pnt - Point to project.
    !> n - Numer of control points - 1.
    !> p - Degree.
    !> uk - Knot vector.
    !> cpw - Control points.
    !> ends - Option to project to nearest end point of curve if no
    !> all_pnts - Option to return only the nearest point during the
    !> subdivision process (False), or all points (True).
    !> orthogonal projections are found.
    !> flag - Status flag.

    !f2py intent(in) pnt, n, p, uk, cpw, ends, all_pnts
    !f2py intent(out) flag
    !f2py depend(n, p) uk
    !f2py depend(n) cpw

    ! Input
    logical, intent(in) :: ends, all_pnts
    integer, intent(in) :: n, p
    double precision, intent(in) :: pnt(0:2)
    double precision, intent(in) :: uk(0:n + p + 1)
    double precision, intent(in) :: cpw(0:n, 0:3)

    ! Output
    integer, intent(out) :: flag

    ! Working
    integer :: i, j
    integer :: nsol
    double precision :: dmin

    integer :: nbez
    double precision :: qw(0:n + p + 1, 0:p, 0:3), ab(0:n + p + 1, 0:1)

    logical :: is_cand
    double precision :: qwi(0:p, 0:3), abi(0:1)

    logical :: unique
    double precision :: di, d0, d1
    double precision :: p0(0:2), p1(0:2), vi(0:2)

    ! MINPACK
    integer :: info
    double precision :: ucheck
    double precision :: x(1), fvec(1), fjac(1, 1), wa(7)

    ! Generic list for storing results.
    type(list_node_t), pointer :: pc_list => null()
    type(proj_ptr) :: pc_ptr

    ! Initialize
    flag = 0
    nsol = 0
    dmin = 0.0d0
    call list_init(pc_list)

    ! Step 1: Decompose curve into Bezier segments.
    call decompose_curve(n, p, uk, cpw, nbez, qw, ab)

    ! Step 2: Perform recursive subdivision on candidate curves.
    do i = 0, nbez - 1
        qwi = qw(i, :, :)
        abi = ab(i, :)
        is_cand = candidate_curve(p, qwi)
        if (is_cand) then
            call subdivide(p, qwi, abi)
        end if
    end do

    ! Allocate result arrays.
    call reset_results()
    allocate(points_(nsol, 3))
    allocate(params1d_(nsol))
    allocate(dproj_(nsol))
    points_(:, :) = 0.0d0
    params1d_(:) = 0.0d0
    dproj_(:) = 0.0d0

    ! Step 3: Refine projection points.
    do i = 1, nsol
        ! Get next
        pc_list = list_next(pc_list)
        pc_ptr = transfer(list_get(pc_list), pc_ptr)
        x(1) = pc_ptr%proj%u0
        ! Call MINPACK hybrj driver.
        call hybrj1(obj, 1, x, fvec, fjac, 1, 1.490120d-8, info, wa, 7)
        ! if (info .ne. 1) then
        !     print *, "Unsuccessful solution in Fortran curve projection."
        ! end if
        ! Check parameter.
        ucheck = x(1)
        call check_param(n, p, uk, ucheck)
        x(1) = ucheck
        if (info .eq. 1) then
            ! Get point and add to results only if unique.
            call curve_point(n, p, uk, cpw, x(1), p0)
            unique = .true.
            do j = 1, npts_
                p1 = points_(j, :)
                vi = p1 - p0
                di = norm(vi)
                if ((di .le. gtol) .and. (dabs(x(1) - params1d_(j)) .le. ptol)) then
                    unique = .false.
                    exit
                end if
            end do
            if (unique) then
                npts_ = npts_ + 1
                points_(npts_, :) = p0
                params1d_(npts_) = x(1)
                vi = pnt - p0
                di = norm(vi)
                dproj_(npts_) = di
            end if
        end if
    end do

    if (npts_ .gt. 0) then
        ! Normal completion.
        flag = 1
        return
    end if

    if (ends .eqv. .false.) then
        ! No points and no endpoints.
        flag = 0
        call set_empty_results()
        return
    end if

    ! Select nearest endpoint if no solutions are found.
    call reset_results()
    allocate(points_(1, 3))
    allocate(params1d_(1))
    allocate(dproj_(1))

    points_(:, :) = 0.0d0
    params1d_(:) = 0.0d0
    dproj_(:) = 0.0d0

    call curve_point(n, p, uk, cpw, uk(p), p0)
    call curve_point(n, p, uk, cpw, uk(n + 1), p1)
    vi = pnt - p0
    d0 = norm(vi)
    vi = pnt - p1
    d1 = norm(vi)
    if (d0 .le. d1) then
        npts_ = 1
        points_(1, :) = p0
        params1d_(1) = uk(p)
        dproj_(1) = d0
    else
        npts_ = 1
        points_(1, :) = p1
        params1d_(1) = uk(n + 1)
        vi = pnt - p0
        di = norm(vi)
        dproj_(1) = d1
    end if
    flag = 1

    ! Internal subroutines for recursive subdivision.
    contains

    recursive subroutine subdivide(n, cpw, ab)
        ! Recursive subdivision.
        integer, intent(in) :: n
        double precision, intent(in) :: cpw(0:n, 0:3), ab(0:1)

        logical :: flat, candidate
        double precision :: cp(0:n, 0:2), w(0:n), &
                            qw1(0:n, 0:3), qw2(0:n, 0:3), &
                            ab1(0:1), ab2(0:1)

        call dehomogenize_array1d(n, cpw, cp, w)

        call is_curve_flat(n, cp, ftol, flat)

        if (flat) then
            call project(n, cp, ab)
        else
            call split_bezier_curve(cpw, n, 0.50d0, ab(0), ab(1), &
                                    qw1, ab1(0), ab1(1), &
                                    qw2, ab2(0), ab2(1))

            candidate = candidate_curve(n, qw1)
            if (candidate) then
                call subdivide(n, qw1, ab1)
            end if

            candidate = candidate_curve(n, qw2)
            if (candidate) then
                call subdivide(n, qw2, ab2)
            end if
        end if

    end subroutine subdivide

    subroutine project(n, cp, ab)
        ! Project point to line.
        integer, intent(in) :: n
        double precision, intent(in) :: cp(0:n, 0:2), ab(0:1)

        double precision :: uil, uig, vdot, di
        double precision :: v0(0:2), v1(0:2), vi(0:2)

        v0 = cp(n, :) - cp(0, :)
        v1 = pnt - cp(0, :)
        vdot = dot_product(v0, v0)
        if (vdot .le. 0.0d0) then
            return
        end if
        uil = dot_product(v1, v0) / vdot
        uig = local_to_global_param(ab(0), ab(1), uil)

        if (all_pnts) then
            ! Store result.
            allocate(pc_ptr%proj)
            pc_ptr%proj%u0 = uig
            call list_insert(pc_list, transfer(pc_ptr, list_data))
            nsol = nsol + 1
        else
            vi = pnt - (cp(0, :) + uil * v0)
            di = norm(vi)
            if (nsol .eq. 0) then
                ! Store result.
                allocate(pc_ptr%proj)
                pc_ptr%proj%u0 = uig
                call list_insert(pc_list, transfer(pc_ptr, list_data))
                nsol = 1
                dmin = di
            else
                if (di .lt. dmin) then
                    ! Retrieve second node and store result.
                    pc_ptr = transfer(list_get(list_next(pc_list)), pc_ptr)
                    pc_ptr%proj%u0 = uig
                    nsol = 1
                    dmin = di
                end if
            end if
        end if

    end subroutine project

    function candidate_curve(n, cpw) result(candidate)
        ! Test for potential projection to curve.
        integer, intent(in) :: n
        double precision, intent(in) :: cpw(0:n, 0:3)

        logical :: candidate

        double precision :: cp(0:n, 0:2), w(0:n)

        call dehomogenize_array1d(n, cpw, cp, w)
        candidate = point_nearest_bezier_curve(n, cp, pnt)

    end function candidate_curve

    subroutine obj(ni, x, fvec, fjac, ldfjac, iflag)
        ! Objective function for point refinement.

        ! Input/Output
        integer, intent(in) :: ni, ldfjac, iflag
        double precision, intent(in) :: x(1)
        double precision, intent(out) :: fvec(1), fjac(1, 1)

        ! Working
        double precision :: cders(0:2, 0:2)
        double precision :: pi(0:2), cu(0:2), cuu(0:2)

        ! Evaluate curve point and derivatives.
        call rat_curve_derivs(n, p, uk, cpw, x(1), 2, cders)
        pi = cders(0, :)
        cu = cders(1, :)
        cuu = cders(2, :)

        ! Calculate function at x and return in fvec.
        if (iflag .eq. 1) then
            fvec(1) = dot_product(cu, pi - pnt)
            return
        end if

        ! Calculate the jacobian at x and return in fjac.
        if (iflag .eq. 2) then
            fjac(1, 1) = dot_product(cuu, pi - pnt) + dot_product(cu, cu)
            return
        end if
    end subroutine obj

end subroutine project_point_to_curve

subroutine project_point_to_surface(pnt, n, p, uk, m, q, vk, cpw, ends, all_pnts, flag)
    !> Project a point to a surface.
    !> pnt - Point to project.
    !> n - Number of control points - 1 in u-direction.
    !> p - Degree in u-direction.
    !> uk - Knot vector in u-direction.
    !> m - Number of control points - 1 in v-direction.
    !> q - Degree in v-direction.
    !> vk - Knot vector in v-direction.
    !> cpw - Control points.
    !> ends - Option to project to nearest end curve if no
    !> orthogonal projections are found.
    !> all_pnts - Option to return only the nearest point during the
    !> subdivision process (False), or all points (True).
    !> flag - Status flag.

    !f2py intent(in) pnt, n, p, uk, m, q, vk, cpw, ends
    !f2py intent(in) all_pnts
    !f2py intent(out) flag
    !f2py depend(n, p) uk
    !f2py depend(m, q) vk
    !f2py depend(n, m) cpw

    ! Input
    logical, intent(in) :: ends, all_pnts
    integer, intent(in) :: n, p, m, q
    double precision, intent(in) :: pnt(0:2)
    double precision, intent(in) :: uk(0:n + p + 1)
    double precision, intent(in) :: vk(0:m + q + 1)
    double precision, intent(in) :: cpw(0:n, 0:m, 0:3)

    ! Output
    integer, intent(out) :: flag

    ! Working
    integer :: i, j
    integer :: nsol, nsub
    double precision :: dmin

    integer :: nbez_u
    double precision :: qw_u(0:n + p + 1, 0:p, 0:m, 0:3)
    double precision :: ab_u(0:n + p + 1, 0:1)

    integer :: nbez_v
    double precision :: qw_v(0:m + q + 1, 0:p, 0:q, 0:3)
    double precision :: ab_v(0:m + q + 1, 0:1)

    double precision :: uk_ui(0:2 * p - 1)
    double precision :: qw_ui(0:p, 0:m, 0:3)

    logical :: is_cand
    double precision :: qwi(0:p, 0:q, 0:3)
    double precision :: abi(0:1, 0:1)

    logical :: unique
    double precision :: di, dp
    double precision :: p0(0:2), p1(0:2), vi(0:2), duv(0:1)

    ! MINPACK
    integer :: info
    double precision :: ucheck, vcheck
    double precision :: x(2), fvec(2), fjac(2, 2), wa(15)

    ! Projection to boundary curves if needed.
    integer :: cpts
    double precision :: u, v
    double precision :: cpoints(0:2)
    double precision :: cparams(0:1)
    double precision :: cdist
    double precision, allocatable :: qw(:, :)

    ! Generic list for storing results.
    type(list_node_t), pointer :: ps_list => null()
    type(proj_ptr) :: ps_ptr

    ! Initialize
    nsol = 0
    dmin = 0.0d0
    call list_init(ps_list)

    ! Step 1: Decompose surface into u-direction Bezier strips.
    ! u-direction.
    call decompose_surface(n, p, uk, m, q, vk, cpw, 'u', n + p + 1, p, m, &
                           nbez_u, qw_u, ab_u)

    ! Step 2: Perform recursive subdivision on candidate Bezier patches.
    nsub = 0
    do i = 0, nbez_u - 1
        ! Decompose each strip in v-direction.
        qw_ui = qw_u(i, :, :, :)
        uk_ui(0:p) = ab_u(i, 0)
        uk_ui(p + 1:) = ab_u(i, 1)
        call decompose_surface(p, p, uk_ui, m, q, vk, qw_ui, 'v', m + q + 1, &
                               p, q, nbez_v, qw_v, ab_v)

        ! Check each patch and subdivide if candidate.
        do j = 0, nbez_v - 1
            qwi = qw_v(j, :, :, :)
            abi(0, :) = ab_u(i, :)
            abi(1, :) = ab_v(j, :)
            is_cand = candidate_surface(p, q, qwi)
            if (is_cand) then
                call subdivide(p, q, qwi, abi)
            end if
        end do
    end do

    ! Return if no projection found and end curve option if false.
    if ((nsol .eq. 0) .and. (ends .eqv. .false.)) then
        flag = 0
        call set_empty_results()
        return
    end if

    ! Allocate result arrays.
    call reset_results()
    allocate(points_(nsol, 3))
    allocate(params2d_(nsol, 2))
    allocate(dproj_(nsol))
    points_(:, :) = 0.0d0
    params2d_(:, :) = 0.0d0
    dproj_(:) = 0.0d0

    ! Step 3: Refine projection points.
    do i = 1, nsol
        ! Get next
        ps_list = list_next(ps_list)
        ps_ptr = transfer(list_get(ps_list), ps_ptr)
        x(1) = ps_ptr%proj%u0
        x(2) = ps_ptr%proj%v0
        ! Call MINPACK hybrj driver.
        call hybrj1(obj, 2, x, fvec, fjac, 2, 1.490120d-8, info, wa, 15)
        ! if (info .ne. 1) then
        !     print *, "Unsuccessful solution in Fortran surface projection.", info
        ! end if
        ! Check parameter.
        ucheck = x(1)
        call check_param(n, p, uk, ucheck)
        x(1) = ucheck
        vcheck = x(2)
        call check_param(m, q, vk, vcheck)
        x(2) = vcheck
        if (info .eq. 1) then
            ! Get point and add to results only if unique.
            call surface_point(n, p, uk, m, q, vk, cpw, x(1), x(2), p0)
            unique = .true.
            do j = 1, npts_
                p1 = points_(j, :)
                vi = p1 - p0
                di = norm(vi)
                duv = x - params2d_(j, :)
                dp = norm(duv)
                if ((di .le. gtol) .and. (dp .le. ptol)) then
                    unique = .false.
                    exit
                end if
            end do
            if (unique) then
                npts_ = npts_ + 1
                points_(npts_, :) = p0
                params2d_(npts_, :) = x(:)
                vi = pnt - p0
                di = norm(vi)
                dproj_(npts_) = di
            end if
        end if
    end do

    ! Normal completion.
    if (npts_ > 0) then
        flag = 1
        return
    end if

    ! Step 4: Project to boundary curves if no projection if found and end
    ! curve option is true.
    cpts = 1
    cpoints(:) = 0.0d0
    cparams(:) = 0.0d0
    cdist = 0.0d0

    ! In u-direction at v=0.
    allocate(qw(0:n, 0:3))
    qw = cpw(:, 0, :)
    call project_point_to_curve(pnt, n, p, uk, qw, .true., .false., flag)

    v = vk(q)
    cpoints = points_(1, :)
    cparams = (/ params1d_(1), v /)
    cdist = dproj_(1)
    do i = 1, npts_
        if (dproj_(i) .lt. cdist) then
            cpoints = points_(i, :)
            cparams = (/ params1d_(i), v /)
            cdist = dproj_(i)
        end if
    end do

    ! In u-direction at v=1.
    qw = cpw(:, m, :)
    call project_point_to_curve(pnt, n, p, uk, qw, .true., .false., flag)
    v = vk(m + 1)
    do i = 1, npts_
        if (dproj_(i) .lt. cdist) then
            cpoints = points_(i, :)
            cparams = (/ params1d_(i), v /)
            cdist = dproj_(i)
        end if
    end do

    ! In v-direction at u=0.
    deallocate(qw)
    allocate(qw(0:m, 0:3))
    qw = cpw(0, :, :)
    call project_point_to_curve(pnt, m, q, vk, qw, .true., .false., flag)
    u = uk(p)
    do i = 1, npts_
        if (dproj_(i) .lt. cdist) then
            cpoints = points_(i, :)
            cparams = (/ u, params1d_(i) /)
            cdist = dproj_(i)
        end if
    end do

    ! In v-direction at u=1.
    qw = cpw(n, :, :)
    call project_point_to_curve(pnt, m, q, vk, qw, .true., .false., flag)
    u = uk(n + 1)
    do i = 1, npts_
        if (dproj_(i) .lt. cdist) then
            cpoints = points_(i, :)
            cparams = (/ u, params1d_(i) /)
            cdist = dproj_(i)
        end if
    end do

    ! Set results.
    call reset_results()
    allocate(points_(1, 0:2))
    allocate(params2d_(1, 0:1))
    allocate(dproj_(1))

    npts_ = cpts
    points_(1, :) = cpoints
    params2d_(1, :) = cparams
    dproj_(1) =cdist

    if (npts_ .gt. 0) then
        flag = 1
        return
    end if

    flag = 0
    call set_empty_results()

    ! Internal subroutines for recursive subdivision.
    contains

    subroutine obj(ni, x, fvec, fjac, ldfjac, iflag)
        ! Objective function for point refinement.
        ! Input/Output
        integer, intent(in) :: ni, ldfjac, iflag
        double precision, intent(in) :: x(2)
        double precision, intent(out) :: fvec(2), fjac(2, 2)

        ! Working
        double precision :: r(0:2)
        double precision :: sders(0:4, 0:4, 0:2)
        double precision :: pi(0:2), su(0:2), suu(0:2)
        double precision :: sv(0:2), svv(0:2), suv(0:2)

        ! Evaluate surface point and derivatives.
        call rat_surface_derivs(n, p, uk, m, q, vk, cpw, &
                                x(1), x(2), 4, sders)
        pi = sders(0, 0, :)
        su = sders(1, 0, :)
        suu = sders(2, 0, :)
        sv = sders(0, 1, :)
        svv = sders(0, 2, :)
        suv = sders(1, 1, :)

        r = pi - pnt
        ! Calculate function at x and return in fvec.
        if (iflag .eq. 1) then
            fvec(1) = dot_product(r, su)
            fvec(2) = dot_product(r, sv)
            return
        end if

        ! Calculate the jacobian at x and return in fjac.
        if (iflag .eq. 2) then
            fjac(1, 1) = dot_product(su, su) + dot_product(r, suu)
            fjac(1, 2) = dot_product(su, sv) + dot_product(r, suv)
            fjac(2, 1) = fjac(1, 2)
            fjac(2, 2) = dot_product(sv, sv) + dot_product(r, svv)
            return
        end if
    end subroutine obj

    recursive subroutine subdivide(n, m, cpw, ab)
        ! Recursive subdivsion
        integer, intent(in) :: n, m
        double precision, intent(in) :: cpw(0:n, 0:m, 0:3), ab(0:1, 0:1)

        logical :: flat, candidate
        double precision :: cp(0:n, 0:m, 0:2), w(0:n, 0:m), &
                            qw1(0:n, 0:m, 0:3), qw2(0:n, 0:m, 0:3), &
                            qw3(0:n, 0:m, 0:3), qw4(0:n, 0:m, 0:3), &
                            qw5(0:n, 0:m, 0:3), qw6(0:n, 0:m, 0:3), &
                            ab1(0:1, 0:1), ab2(0:1, 0:1), &
                            ab3(0:1, 0:1), ab4(0:1, 0:1), &
                            ab5(0:1, 0:1), ab6(0:1, 0:1)

        call dehomogenize_array2d(n, m, cpw, cp, w)

         call is_surface_flat(n, m, cp, ftol, flat)

        ! Force at least one subdivision since that seemed to help with
        ! Swept/skewed/tapered surfaces.
        if ((flat) .and. (nsub .gt. 0)) then
            call project(n, m, cp, ab)
        else
            nsub = nsub + 1
            call split_bezier_surface(cpw, n, m, 0.5d0, -1.0d0, &
                                      ab(0, 0), ab(0, 1), &
                                      ab(1, 0), ab(1, 1), &
                                      qw1, qw2, ab1, ab2)
            call split_bezier_surface(qw1, n, m, -1.0d0, 0.5d0, &
                                      ab1(0, 0), ab1(0, 1), &
                                      ab1(1, 0), ab1(1, 1), &
                                      qw3, qw4, ab3, ab4)
            call split_bezier_surface(qw2, n, m, -1.0d0, 0.5d0, &
                                      ab2(0, 0), ab2(0, 1), &
                                      ab2(1, 0), ab2(1, 1), &
                                      qw5, qw6, ab5, ab6)

            candidate = candidate_surface(n, m, qw3)
            if (candidate) then
                call subdivide(n, m, qw3, ab3)
            end if
            candidate = candidate_surface(n, m, qw4)
            if (candidate) then
                call subdivide(n, m, qw4, ab4)
            end if
            candidate = candidate_surface(n, m, qw5)
            if (candidate) then
                call subdivide(n, m, qw5, ab5)
            end if
            candidate = candidate_surface(n, m, qw6)
            if (candidate) then
                call subdivide(n, m, qw6, ab6)
            end if
        end if

    end subroutine subdivide

    subroutine project(n, m, cp, ab)
        ! Project point to a plane.
        integer, intent(in) :: n, m
        double precision, intent(in) :: cp(0:n, 0:m, 0:2), ab(0:1, 0:1)

        double precision :: ui, vi, vudot, vvdot, di, mag
        double precision :: vu(0:2), vv(0:2), vp(0:2), vn(0:2)
        double precision :: t3d(0:2, 0:2), t2d(0:2, 0:1)

        vu = cp(n, 0, :) - cp(0, 0, :)
        vv = cp(0, m, :) - cp(0, 0, :)
        vudot = dot_product(vu, vu)
        vvdot = dot_product(vv, vv)
        if ((vudot .gt. 0.0d0) .and. (vvdot .gt. 0.0d0)) then
            vp = pnt - cp(0, 0, :)
            t3d(0, :) = cp(0, 0, :)
            t3d(1, :) = cp(n, 0, :)
            t3d(2, :) = cp(0, m, :)
            t2d(0, :) = (/ ab(0, 0), ab(1, 0) /)
            t2d(1, :) = (/ ab(0, 1), ab(1, 0) /)
            t2d(2, :) = (/ ab(0, 0), ab(1, 1) /)
            call invert_point_in_triangle(pnt, t3d, t2d, ui, vi)
            if (all_pnts) then
                ! Store result.
                allocate(ps_ptr%proj)
                ps_ptr%proj%u0 = ui
                ps_ptr%proj%v0 = vi
                call list_insert(ps_list, transfer(ps_ptr, list_data))
                nsol = nsol + 1
            else
                vn = cross(vu, vv)
                mag = norm(vn)
                vn = vn / mag
                di = dabs(dot_product(vn, vp))
                if (nsol .eq. 0) then
                    ! Store result.
                    allocate(ps_ptr%proj)
                    ps_ptr%proj%u0 = ui
                    ps_ptr%proj%v0 = vi
                    call list_insert(ps_list, transfer(ps_ptr, list_data))
                    nsol = 1
                    dmin = di
                else
                    if (di .lt. dmin) then
                        ! Retrieve second node and store result.
                        ps_ptr = transfer(list_get(list_next(ps_list)), ps_ptr)
                        ps_ptr%proj%u0 = ui
                        ps_ptr%proj%v0 = vi
                        nsol = 1
                        dmin = di
                    end if
                end if
            end if
        end if

    end subroutine project

    function candidate_surface(n, m, cpw) result(candidate)
        ! Tets for potential projection to surface.
        integer, intent(in) :: n, m
        double precision, intent(in) :: cpw(0:n, 0:m, 0:3)

        logical :: candidate

        double precision :: cp(0:n, 0:m, 0:2), w(0:n, 0:m)

        call dehomogenize_array2d(n, m, cpw, cp, w)
        candidate = point_nearest_bezier_patch(n, m, cp, pnt)

    end function candidate_surface

end subroutine project_point_to_surface

function point_nearest_bezier_curve(n, cp, p) result(is_near)
    !> Determine if the curve is a candidate for projection.
    !> n - Number of control points - 1.
    !> cp - Dehomogenized control points.
    !> p - Point to test.
    !> is_near - True if curve is candidate, False if not.

    !f2py intent(in) n, cp, p, atol
    !f2py intent(out) is_near
    !f2py depend(n) cp

    integer, intent(in) :: n
    double precision, intent(in) :: cp(0:n, 0:2), p(0:2)

    logical :: is_near

    integer :: i
    double precision :: r1, r2, d0, d1, p0(0:2)

    is_near = .true.
    r1 = dot_product(p - cp(0, :), cp(1, :) - cp(0, :))
    r2 = dot_product(cp(n, :) - p, cp(n, :) - cp(n - 1, :))
    if ((dabs(r1) .le. ptol) .or. (dabs(r2) .le. ptol)) then
        return
    end if

    d0 = dot_product(p - cp(0, :), p - cp(0, :))
    d1 = dot_product(p - cp(n, :), p - cp(n, :))
    if (d0 .le. d1) then
        p0 = cp(0, :)
        do i = 1, n
            if (dot_product(cp(i, :) - p0, p0 - p) .le. 0.0d0) then
                return
            end if
        end do
    else
        p0 = cp(n, :)
        do i = 0, n - 1
            if (dot_product(cp(i, :) - p0, p0 - p) .le. 0.0d0) then
                return
            end if
        end do
    end if
    is_near = .false.

end function point_nearest_bezier_curve

function point_nearest_bezier_patch(n, m, cp, p) result(is_near)
    !> Determine if the patch is a candidate for projection.
    !> n - Number of control points - 1 in u-direction.
    !> m - Number of control points - 1 in v-direction.
    !> cp - Dehomogenized control points.
    !> p - Point to test.
    !> is_near - True is patch is candidate, False if not.

    !f2py intent(in) n, m, cp, p
    !f2py intent(out) is_near
    !f2py depend(n, m) cp

    integer, intent(in) :: n, m
    double precision, intent(in) :: cp(0:n, 0:m, 0:2), p(0:2)

    logical :: is_near

    integer :: i, j, i0, j0, indx
    double precision :: row(0:m, 0:2), col(0:n, 0:2), &
                        pc(0:2), dc, corners(4, 3), vc(0:2), &
                        dmin, di, p0(0:2), r, w(0:2), v0(0:2)

    pc = cp(0, 0, :)
    vc = pc - p
    dc = norm(vc)
    corners(1, :) = (/ dc, 0.0d0, 0.0d0 /)

    pc = cp(n, 0, :)
    vc = pc - p
    dc = norm(vc)
    corners(2, :) = (/ dc, dble(n), 0.0d0 /)

    pc = cp(0, m, :)
    vc = pc - p
    dc = norm(vc)
    corners(3, :) = (/ dc, 0.0d0, dble(m) /)

    pc = cp(n, m, :)
    vc = pc - p
    dc = norm(vc)
    corners(4, :) = (/ dc, dble(n), dble(m) /)

    dmin = corners(1, 1)
    indx = 1
    do i = 2, 4
        di = corners(i, 1)
        if (di .lt. dmin) then
            dmin = di
            indx = i
        end if
    end do
    i0 = int(corners(indx, 2))
    j0 = int(corners(indx, 3))
    p0 = cp(i0, j0, :)

    is_near = .false.
    do i = 0, n
        do j = 0, m
            if ((i .eq. i0) .and. (j .eq. j0)) then
                ! continue
            else
                r = dot_product(cp(i, j, :) - p0, p0 - p)
                if (r .le. 0.0d0) then
                    is_near = .true.
                    exit
                end if
            end if
        end do
    end do
    if (is_near .eqv. .false.) then
        return
    end if

    ! Tangent cones.
    is_near = .false.
    do i = 0, n
        v0 = cp(i, 0, :) - p
        w = cp(i, 1, :) - cp(i, 0, :)
        r = dot_product(v0, w)
        if (r .le. 0.0d0) then
            is_near = .true.
            exit
        end if
    end do
    if (is_near .eqv. .false.) then
        return
    end if

    is_near = .false.
    do i = 0, n
        v0 = cp(i, m, :) - p
        w = cp(i, m - 1, :) - cp(i, m, :)
        r = dot_product(v0, w)
        if (r .le. 0.0d0) then
            is_near = .true.
            exit
        end if
    end do
    if (is_near .eqv. .false.) then
        return
    end if

    is_near = .false.
    do j = 0, m
        v0 = cp(0, j, :) - p
        w = cp(1, j, :) - cp(0, j, :)
        r = dot_product(v0, w)
        if (r .le. 0.0d0) then
            is_near = .true.
            exit
        end if
    end do
    if (is_near .eqv. .false.) then
        return
    end if

    is_near = .false.
    do j = 0, m
        v0 = cp(n, j, :) - p
        w = cp(n - 1, j, :) - cp(n, j, :)
        r = dot_product(v0, w)
        if (r .le. 0.0d0) then
            is_near = .true.
            exit
        end if
    end do
    if (is_near .eqv. .false.) then
        return
    end if

    is_near = .true.

end function point_nearest_bezier_patch

end module project


MODULE Owens_T
! Calculates Owen's T-function which is useful in calculating bivariate
! normal probabilities.   Also included is function biv_norm for calculating
! bivariate normal probabilities.

! From the paper:
! Patefield, Mike `Fast and accurate calculation of Owen's T-function',
! J. of Statistical Software, vol. 5, 2000
! http://www.stat.ucla.edu/journals/jss/v05

! Code converted using TO_F90 by Alan Miller
! Date: 2000-06-21  Time: 21:16:36

IMPLICIT NONE
INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(12, 60)

PUBLIC   :: t, alnorm, znorm1, znorm2
PRIVATE  :: tf

CONTAINS

FUNCTION t(h, a) RESULT(fn_val)

!        COMPUTES OWEN'S T-FUNCTION OF H AND A
!        WITH H,A ANY REAL (dp) NUMBERS

REAL (dp), INTENT(IN)  :: h
REAL (dp), INTENT(IN)  :: a
REAL (dp)              :: fn_val

REAL (dp)  :: absa, absh, ah, normh, normah
REAL (dp), PARAMETER  :: zero = 0.0_dp, quart = 0.25_dp, half = 0.5_dp,  &
                         cut = 0.67_dp, one = 1.0_dp

absh=ABS(h)
absa=ABS(a)
ah = absa * absh
IF (absa <= one) THEN
  fn_val = tf(absh, absa, ah)
ELSE
  IF (absh <= cut) THEN
    fn_val = quart - znorm1(absh) * znorm1(ah) - tf(ah, one / absa, absh)
  ELSE
    normh = znorm2(absh)
    normah = znorm2(ah)
    fn_val = half * ( normh + normah ) - normh * normah -  &
             tf(ah, one / absa, absh)
  END IF
END IF
IF (a < zero) fn_val = - fn_val

RETURN
END FUNCTION t

FUNCTION tf(h, a, ah) RESULT(fn_val)

!        COMPUTES OWEN'S T-FUNCTION OF H AND A
!        H >= 0 AND 0 <= A <= 1 ; INPUT AH MUST EQUAL A * H

REAL (dp), INTENT(IN)  :: h
REAL (dp), INTENT(IN)  :: a
REAL (dp), INTENT(IN)  :: ah
REAL (dp)              :: fn_val

REAL (dp)  :: z, zi, x, vi, hs, dhs, as, aj, yi, dj, gj, r, ai, y, normh
INTEGER    :: ihint, iaint, m, j, jj, i, maxii, ii, icode
REAL (dp), PARAMETER  :: rtwopi = 0.15915494309189533577_dp,   &
                         rrtpi = 0.39894228040143267794_dp,  &
                         zero = 0.0_dp, mhalf = -0.5_dp, half = 0.5_dp,  &
                         one = 1.0_dp
REAL (dp), PARAMETER  :: c2(21) = (/ 0.99999999999999987510D+00,  &
       -0.99999999999988796462D+00,  0.99999999998290743652D+00,  &
       -0.99999999896282500134D+00,  0.99999996660459362918D+00,  &
       -0.99999933986272476760D+00,  0.99999125611136965852D+00,  &
       -0.99991777624463387686D+00,  0.99942835555870132569D+00,  &
       -0.99697311720723000295D+00,  0.98751448037275303682D+00,  &
       -0.95915857980572882813D+00,  0.89246305511006708555D+00,  &
       -0.76893425990463999675D+00,  0.58893528468484693250D+00,  &
       -0.38380345160440256652D+00,  0.20317601701045299653D+00,  &
       -0.82813631607004984866D-01,  0.24167984735759576523D-01,  &
       -0.44676566663971825242D-02,  0.39141169402373836468D-03 /)
REAL (dp), PARAMETER  :: pts(13) = (/ 0.35082039676451715489D-02,  &
         0.31279042338030753740D-01,  0.85266826283219451090D-01,  &
         0.16245071730812277011D+00,  0.25851196049125434828D+00,  &
         0.36807553840697533536D+00,  0.48501092905604697475D+00,  &
         0.60277514152618576821D+00,  0.71477884217753226516D+00,  &
         0.81475510988760098605D+00,  0.89711029755948965867D+00,  &
         0.95723808085944261843D+00,  0.99178832974629703586D+00 /)
REAL (dp), PARAMETER  :: wts(13) = (/ 0.18831438115323502887D-01,  &
         0.18567086243977649478D-01,  0.18042093461223385584D-01,  &
         0.17263829606398753364D-01,  0.16243219975989856730D-01,  &
         0.14994592034116704829D-01,  0.13535474469662088392D-01,  &
         0.11886351605820165233D-01,  0.10070377242777431897D-01,  &
         0.81130545742299586629D-02,  0.60419009528470238773D-02,  &
         0.38862217010742057883D-02,  0.16793031084546090448D-02 /)
INTEGER, PARAMETER    :: meth(18) = (/ 1, 1, 1, 1, 1, 1, 1, 1, 2,  &
                                       2, 2, 3, 4, 4, 4, 4, 5, 6 /)
INTEGER, PARAMETER    :: ord(18) = (/  2, 3, 4, 5, 7,10,12,18,10,  &
                                      20,30,20, 4, 7, 8,20,13, 0 /)
REAL (dp), PARAMETER  :: hrange(14) = (/ 0.02_dp, 0.06_dp, 0.09_dp, 0.125_dp, &
                         0.26_dp, 0.4_dp,  0.6_dp, 1.6_dp, 1.7_dp, 2.33_dp,  &
                         2.4_dp,  3.36_dp, 3.4_dp, 4.8_dp /)
REAL (dp), PARAMETER  :: arange(7) = (/ 0.025_dp, 0.09_dp, 0.15_dp, 0.36_dp,  &
                                        0.5_dp,   0.9_dp,  0.99999_dp /)
INTEGER, PARAMETER  :: select(15,8) = RESHAPE(  &
 (/ 1, 1, 2,13,13,13,13,13,13,13,13,16,16,16, 9,  &
    1, 2, 2, 3, 3, 5, 5,14,14,15,15,16,16,16, 9,  &
    2, 2, 3, 3, 3, 5, 5,15,15,15,15,16,16,16,10,  &
    2, 2, 3, 5, 5, 5, 5, 7, 7,16,16,16,16,16,10,  &
    2, 3, 3, 5, 5, 6, 6, 8, 8,17,17,17,12,12,11,  &
    2, 3, 5, 5, 5, 6, 6, 8, 8,17,17,17,12,12,12,  &
    2, 3, 4, 4, 6, 6, 8, 8,17,17,17,17,17,12,12,  &
    2, 3, 4, 4, 6, 6,18,18,18,18,17,17,17,12,12 /), (/ 15, 8 /) )

!  DETERMINE APPROPRIATE METHOD FROM T1...T6

DO  ihint=1,14
  IF (h <= hrange(ihint)) GO TO 20
END DO
ihint=15
20 DO  iaint=1,7
  IF (a <= arange(iaint)) GO TO 40
END DO
iaint=8
40 icode = select(ihint,iaint)
m = ord(icode)
SELECT CASE ( meth(icode) )
  CASE (    1)
    GO TO 100
  CASE (    2)
    GO TO 200
  CASE (    3)
    GO TO 300
  CASE (    4)
    GO TO 400
  CASE (    5)
    GO TO 500
  CASE (    6)
    GO TO 600
END SELECT

!  T1(H, A, M) ; M = 2, 3, 4, 5, 7, 10, 12 OR 18
!  JJ = 2J - 1 ; GJ = EXP(-H*H/2) * (-H*H/2)**J / J!
!  AJ = A**(2J-1) / (2*PI)

100 hs = mhalf * h * h
dhs = EXP(hs)
as = a * a
j = 1
jj = 1
aj = rtwopi * a
fn_val = rtwopi * ATAN(a)
dj = dhs - one
gj = hs * dhs
110 fn_val = fn_val + dj * aj / jj
IF (j >= m) RETURN
j = j + 1
jj = jj + 2
aj = aj * as
dj = gj - dj
gj = gj * hs / j
GO TO 110

!  T2(H, A, M) ; M = 10, 20 OR 30
!  Z = (-1)**(I-1) * ZI ; II = 2I - 1
!  VI = (-1)**(I-1) * A**(2I-1) * EXP[-(A*H)**2/2] / SQRT(2*PI)

200 maxii = m + m + 1
ii = 1
fn_val = zero
hs = h * h
as = -a * a
vi = rrtpi * a * EXP(mhalf * ah * ah)
z = znorm1(ah) / h
y = one / hs
210 fn_val = fn_val + z
IF (ii >= maxii) GO TO 220
z = y * (vi - ii * z)
vi = as * vi
ii = ii + 2
GO TO 210
220 fn_val = fn_val * rrtpi * EXP (mhalf * hs)
RETURN

!  T3(H, A, M) ; M = 20
!  II = 2I - 1
!  VI = A**(2I-1) * EXP[-(A*H)**2/2] / SQRT(2*PI)

300 i = 1
ii = 1
fn_val = zero
hs = h * h
as = a * a
vi = rrtpi * a * EXP(mhalf * ah * ah)
zi = znorm1(ah) / h
y = one / hs
310 fn_val = fn_val + zi * c2(i)
IF (i > m) GO TO 320
zi = y  * (ii * zi - vi)
vi = as * vi
i = i + 1
ii = ii + 2
GO TO 310
320 fn_val = fn_val * rrtpi * EXP(mhalf * hs)
RETURN

!  T4(H, A, M) ; M = 4, 7, 8 OR 20;  II = 2I + 1
!  AI = A * EXP[-H*H*(1+A*A)/2] * (-A*A)**I / (2*PI)

400 maxii = m + m + 1
ii = 1
hs = h * h
as = -a * a
fn_val = zero
ai = rtwopi * a * EXP(mhalf * hs * (one - as))
yi = one
410 fn_val = fn_val + ai * yi
IF (ii >= maxii) RETURN
ii = ii + 2
yi = (one - hs * yi) / ii
ai = ai * as
GO TO 410

!  T5(H, A, M) ; M = 13
!  2M - POINT GAUSSIAN QUADRATURE

500 fn_val = zero
as = a * a
hs = mhalf * h * h
DO  i = 1 , m
  r = one + as * pts(i)
  fn_val = fn_val + wts(i) * EXP(hs * r) / r
END DO
fn_val = a * fn_val
RETURN

!  T6(H, A);  APPROXIMATION FOR A NEAR 1, (A <= 1)

600 normh = znorm2(h)
fn_val = half * normh * (one - normh)
y = one - a
x = ATAN(y / (one + a))
fn_val = fn_val - rtwopi * x * EXP(mhalf * y * h * h / x)

RETURN
END FUNCTION tf

FUNCTION alnorm(x, upper) RESULT(fn_val)

!  Algorithm AS66 Applied Statistics (1973) vol.22, no.3

!  Evaluates the tail area of the standardised normal curve
!  from x to infinity if upper is .true. or
!  from minus infinity to x if upper is .false.

! ELF90-compatible version by Alan Miller
! Latest revision - 29 November 1997

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

! Local variables
REAL (dp), PARAMETER  :: zero = 0.0_dp, one = 1.0_dp, half = 0.5_dp, &
                         con = 1.28_dp
REAL (dp)  :: z, y
LOGICAL    :: up

!*** machine dependent constants
REAL (dp), PARAMETER :: ltone = 7.0_dp, utzero = 18.66_dp

REAL (dp), PARAMETER :: p = 0.398942280444_dp, q = 0.39990348504_dp,   &
                        r = 0.398942280385_dp, a1 = 5.75885480458_dp,  &
                        a2 = 2.62433121679_dp, a3 = 5.92885724438_dp,  &
                        b1 = -29.8213557807_dp, b2 = 48.6959930692_dp, &
                        c1 = -3.8052E-8_dp, c2 = 3.98064794E-4_dp,     &
                        c3 = -0.151679116635_dp, c4 = 4.8385912808_dp, &
                        c5 = 0.742380924027_dp, c6 = 3.99019417011_dp, &
                        d1 = 1.00000615302_dp, d2 = 1.98615381364_dp,  &
                        d3 = 5.29330324926_dp, d4 = -15.1508972451_dp, &
                        d5 = 30.789933034_dp

up = upper
z = x
IF(z >=  zero) GO TO 10
up = .NOT. up
z = -z
10 IF(z <= ltone .OR. up .AND. z <= utzero) GO TO 20
fn_val = zero
GO TO 40
20 y = half*z*z
IF(z > con) GO TO 30

fn_val = half - z*(p-q*y/(y+a1+b1/(y+a2+b2/(y+a3))))
GO TO 40
30 fn_val = r*EXP(-y)/(z+c1+d1/(z+c2+d2/(z+c3+d3/(z+c4+d4/(z+c5+d5/(z+c6))))))
40 IF(.NOT. up) fn_val = one - fn_val

RETURN
END FUNCTION alnorm

FUNCTION znorm1(x) RESULT(fn_val)
! Area under the standard normal curve between 0 and x

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

fn_val = alnorm(x, .FALSE.) - 0.5_dp

RETURN
END FUNCTION znorm1

FUNCTION znorm2(x) RESULT(fn_val)
! Area under the standard normal curve to the right of x

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

fn_val = alnorm(x, .TRUE.)

RETURN
END FUNCTION znorm2

FUNCTION biv_norm(h, xmean, xsd, k, ymean, ysd, rho) RESULT(fn_val)
! Calculate bivariate normal probabilities,
! i.e. Prob(X > h, Y > k) where X, Y have a bivariate normal distribution.

! Reference:
! Baughman, A.L. (1988) `A Fortran function for the bivariate normal integral',
! Computer Methods and Programs in Biomedicine, Vol.27, 169-174.

! Evaluates L(h,k,r) = Prob(X > h, Y > k)
! where X and Y are standardized normal variables and R is their correlation.
! Uses Owen's relationship:
! L(h,k,r) = 1.0 - (PH + PK)/2 - T(h, ah) - T(k, ak)
! where PH = tail area of the standardized normal curve from minus infinity
!            up to h,
!       PK = tail area of the standardized normal curve from minus infinity
!            up to k,
!   T(h,a) = integral from 0 to a of
!            (1/(2.pi)).EXP(-0.5.h^2.(1 + x^2)) / (1 + x^2)
!       ah = (h - r.k) / (h.sqrt(1 - r^2))
!       ak = (k - r.h) / (k.sqrt(1 - r^2))

! Uses the TFUNC of Mike Patefield

! Arguments:

! h      lower limit for X
! xmean  mean of X
! xsd    standard deviation of X

! k      lower limit for Y
! ymean  mean of Y
! ysd    standard deviation of Y

! rho    correlation coefficient

REAL (dp), INTENT(IN)  :: h, xmean, xsd, k, ymean, ysd, rho
REAL (dp)              :: fn_val

! Local variables
REAL (dp)  :: rr, horig, korig, ah, ak, hh, kk, thah, tkak
REAL (dp), PARAMETER  :: zero = 0.0_dp, quart = 0.25_dp, half = 0.5_dp,  &
                         one = 1.0_dp, eight = 8.0_dp

! Check input arguments

IF (ABS(rho) > one) THEN
  WRITE(*, *) '** Error in FUNCTION biv_norm **'
  WRITE(*, '(a, g13.5, a)') ' Argument RHO = ', rho, ' It must be between -1 and 1'
END IF
IF (xsd <= zero) THEN
  WRITE(*, *) '** Error in FUNCTION biv_norm **'
  WRITE(*, '(a, g13.5, a)') ' Argument XSD = ', xsd, ' It must be between > 0'
END IF
IF (ysd <= zero) THEN
  WRITE(*, *) '** Error in FUNCTION biv_norm **'
  WRITE(*, '(a, g13.5, a)') ' Argument YSD = ', ysd, ' It must be between > 0'
END IF

! Standardize h and k

hh = (h - xmean) / xsd
kk = (k - ymean) / ysd

! Calculate probability only for positive hh or kk;
! adjust to the right quadrant later.

horig = hh
korig = kk
hh = ABS(hh)
kk = ABS(kk)

! The relations between L(h,k,r) and PX, the tail area up to X for the
! standard normal curve are equations (22.4) to (22.6) in Johnson, N.L.
! and Kotz, S. `Distributions in Statistics: Continuous Multivariate
! Distributions, Ch. 36, Wiley: New York (1972).

IF (rho == zero) THEN
  fn_val = alnorm(horig, .TRUE.) * alnorm(korig, .TRUE.)
  GO TO 100

ELSE IF (rho == -one) THEN
  fn_val = zero
  IF (horig + korig < zero) fn_val = one - alnorm(horig, .FALSE.) -  &
                                           alnorm(korig, .FALSE.)
  GO TO 100

ELSE IF (rho == one) THEN
  fn_val = alnorm(MAX(horig, korig), .TRUE.)
  GO TO 100

ELSE

! For negative h and positive k, or vice-vera, reverse the sign of rho.
! Reference equation (22.2) of J & K.

  IF ((horig < zero .AND. korig >= zero) .OR.  &
      (horig >= zero .AND. korig < zero) ) THEN
    rr = -rho
    IF(hh == zero .AND. kk == zero) THEN
      fn_val = ASIN(rr) / (eight * ATAN(one)) + quart
      GO TO 100
    ELSE IF (hh == zero .AND. kk /= zero) THEN
      thah = quart
      ak = (hh - kk*rr) / (kk*SQRT(one - rr**2))
      tkak = t(k,ak)
    ELSE IF (hh /= zero .AND. kk == zero) THEN
      ak = (kk - hh*rr) / (hh*SQRT(one - rr**2))
      thah = t(h,ah)
      tkak = quart
    ELSE
      ah = (kk - hh*rr) / (hh*SQRT(one - rr**2))
      thah = t(h,ah)
      ak = (hh - kk*rr) / (kk*SQRT(one - rr**2))
      tkak = t(k,ak)
    END IF

  ELSE
    IF(hh == zero .AND. kk == zero) THEN
      fn_val = ASIN(rho) / (eight * ATAN(one)) + quart
      GO TO 100
    ELSE IF (hh == zero .AND. kk /= zero) THEN
      thah = quart
      ak = (hh - kk*rho) / (kk*SQRT(one - rho**2))
      tkak = t(k,ak)
    ELSE IF (hh /= zero .AND. kk == zero) THEN
      ak = (kk - hh*rho) / (hh*SQRT(one - rho**2))
      thah = t(h,ah)
      tkak = quart
    ELSE
      ah = (kk - hh*rho) / (hh*SQRT(one - rho**2))
      thah = t(h,ah)
      ak = (hh - kk*rho) / (kk*SQRT(one - rho**2))
      tkak = t(k,ak)
    END IF
  END IF
END IF

fn_val = one - half * (alnorm(hh, .FALSE.) + alnorm(kk, .FALSE.))  &
             - thah - tkak

IF (horig < zero .AND. korig >= zero) THEN
  fn_val = - fn_val + alnorm(kk, .TRUE.)
END IF

IF (horig >= zero .AND. korig < zero) THEN
  fn_val = - fn_val + alnorm(hh, .TRUE.)
END IF

IF (horig < zero .AND. korig < zero) THEN
  fn_val = fn_val + alnorm(hh, .FALSE.) + alnorm(kk, .FALSE.) - one
END IF

100 fn_val = MAX(zero, fn_val)
fn_val = MIN(one, fn_val)

RETURN
END FUNCTION biv_norm

END MODULE Owens_T


      subroutine get_azel_sp3(tc, prn, stationXYZ,East,North,Up,
     .  Lat,Long,Ht, azimuth,elev,t9,x9,y9,z9)
      implicit none
      include 'local.inc'
      integer jj, ierr,prn, ihr, t(9),polyorder
      real*8 tc, SatPos(3), toffset, omeg, ghadot,
     . xrec, yrec, zrec,xnew, ynew, znew, tod,
     . azimuth, elev, North(3), East(3), Up(3),stationXYZ(3), range2,
     . Lat,Long,Ht, t9(9), x9(9),y9(9), z9(9), outX,outY,outZ,dy
c    this code requests the azel for a time (tc) and satellite (prn)
c    t,x9,y9,and z9 are vectors of precise Cartesian GLONASS coordinates (time in
c     GPS seconds, xyz in meters
c     stationXYZ is in meters
c     returns azimuth and elev in radians (likely)
c     dy is a sigma from the interpolator
c     t9 is real*8 !!!!!
c
c     KL 19feb04 - need to make changes for multi-day sp3 files.
c     t9 is now relative to sp3 epoch time. which means tc should not be used,
c     but rather tc relative to sp3 epoch time

c     starting value for transmit time
      toffset = 0.07
c     Earth Rotation
      ghadot = 7.2921151467d-5 ! rad/sec, using same one as ICD200
      polyorder = 9
c     do this three times - should converge
      do jj = 1, 3
c       interpolate for X,Y, and Z
        call polint(t9, x9, polyorder, tc-toffset, outX, dy)
        call polint(t9, y9, polyorder, tc-toffset, outY, dy)
        call polint(t9, z9, polyorder, tc-toffset, outZ, dy)
        omeg = -ghadot*toffset
        xnew = outX*dcos(omeg) - outY*dsin(omeg)
        ynew = outX*dsin(omeg) + outY*dcos(omeg)
        znew = outZ
        range2= (xnew - stationXYZ(1))**2 + (ynew
     . - stationXYZ(2))**2 + (znew-stationXYZ(3))**2
c       new time is the geometric range divided by the speed of light
        toffset = dsqrt(range2)/c
      enddo
      SatPos(1) =  xnew
      SatPos(2) =  ynew
      SatPos(3) =  znew
      call azel(azimuth, elev, stationXYZ, East, North, Up, SatPos)
      end


!c----------------------------------------------------------------------c
!c                                                                      c
!c      COMPUTER PROGRAMS IN SEISMOLOGY                                 c
!c      VOLUME III                                                      c
!c                                                                      c
!c      PROGRAM: SLEGN96                                                c
!c                                                                      c
!c      COPYRIGHT 1996, 2010                                            c
!c      R. B. Herrmann                                                  c
!c      Department of Earth and Atmospheric Sciences                    c
!c      Saint Louis University                                          c
!c      221 North Grand Boulevard                                       c
!c      St. Louis, Missouri 63103                                       c
!c      U. S. A.                                                        c
!c                                                                      c
!c----------------------------------------------------------------------c
!c
!c
!c     This program calculates the group velocity and partial
!c     derivatives of Love waves for any plane multi-layered
!c     model.  The propagator-matrix, instead of numerical-
!c     integration method is used, in which the Haskell rather
!c     than Harkrider formalisms are concerned.
!c
!c     Developed by C. Y. Wang and R. B. Herrmann, St. Louis
!c     University, Oct. 10, 1981.  Modified for use in surface
!c     wave inversion, with addition of spherical earth flattening
!c     transformation and numerical calculation of group velocity
!c     partial derivatives by David R. Russell, St. Louis
!c     University, Jan. 1984.
!c
!c     Rewrite of theory to agree more with hspec96 wavenumber
!c     integration code
!c
!c- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!c Revision history:
!c       07 AUG 2002 - make string lengths 120 characters from 80
!c       13 OCT 2006 - verbose output of energy integrals
!c       26 SEP 2008 - fixed undefined LOT in subroutine up
!c       14 JUN 2009 - reformulate in general terms as per book
!c       01 AUG 2010 - change code to agree with book  for
!c                     migration to TI. Also clean up code using
!c                     implicit none
!c       20 SEP 2012 - cleaned up some compiler warnings
!c       25 FEB 2017 - fixed error in subroutine varsv. The
!c           computation of sin (nu z)/nu yielded NaN when nu = 0
!c           The corrected code gives lim  sin(nu z) / nu = z
!c                                         nu->0
!c       29 JUL 2017 - modify insert if depth is in halfspace
!c       22 FEB 2018 - verbose also gives LAGR/(omega^2 I0)
!        21 Apr 2021 -- Modified by Nanqiao Du, Fortran 90 version
!c- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

!===================================
! MODULE : Love wave Model
!===================================
module LoveWaveModel
use,intrinsic         :: iso_c_binding
implicit none

! global variables
!============================================
! model param
integer(c_int)              :: mmax
real(c_double),ALLOCATABLE  :: zd(:),zb(:),zrho(:),za(:),xmu(:)
integer(c_int),ALLOCATABLE  :: iwat(:)

! eigen function
real(c_double),ALLOCATABLE  :: uu(:),tt(:),dcdb(:),dcdh(:),dcdr(:)
real(c_double)              :: uu0(4)

! spherical earth
real(c_double),ALLOCATABLE  :: vtp(:),dtp(:),rtp(:)

! save
real(c_double),ALLOCATABLE  :: exl(:)

! love wave var
real(c_double)              :: cosq,sinq,yl,zl,mu

! sumi
real(c_double)              :: sumi0,sumi1,sumi2,flagr,ale,ugr

! openmp wrapper
!$omp threadprivate(mmax,zd,zb,zrho,za,uu,tt,dcdb,dcdh,dcdr,uu0)
!$omp threadprivate(vtp,dtp,rtp,xmu,exl,iwat)
!$omp threadprivate(cosq,sinq,yl,zl,mu)
!$omp threadprivate(sumi0,sumi1,sumi2,flagr,ale,ugr)

contains
subroutine Alloc_Model(nlayer)
  implicit none
  integer(c_int)        ::nlayer
  mmax = nlayer
  ALLOCATE(zd(mmax),zb(mmax),za(mmax),uu(mmax),tt(mmax))
  ALLOCATE(dcdb(mmax),dcdh(mmax),dcdr(mmax))
  ALLOCATE(iwat(mmax))
  ALLOCATE(xmu(mmax),exl(mmax),zrho(mmax))
end subroutine Alloc_Model

subroutine Dealloc_Model()
  implicit none
  DEALLOCATE(zb,zd,za,uu,tt,dcdb,dcdh,dcdr,zrho)
  DEALLOCATE(iwat,xmu,exl)
end subroutine Dealloc_Model

subroutine bldsph()
  !c-----
  !c       Transform spherical earth to flat earth
  !c
  !c       Schwab, F. A., and L. Knopoff (1972).
  !c            Fast surface wave and free
  !c       mode computations,
  !c            in  Methods in Computational Physics, Volume 11,
  !c       Seismology: Surface Waves and Earth Oscillations,
  !c            B. A. Bolt (ed),
  !c       Academic Press, New York
  !c
  !c       Love Wave Equations  44, 45 , 41 pp 112-113
  !c       Rayleigh Wave Equations 102, 108, 109 pp 142, 144
  !c
  !c     Revised 28 DEC 2007 to use mid-point, assume linear variation in
  !c     slowness instead of using average velocity for the layer
  !c     Use the Biswas (1972:PAGEOPH 96, 61-74, 1972) density mapping
  !c
  !c       This is for Love Waves
  !c
  use,intrinsic                 :: iso_c_binding
  implicit none
  integer(c_int)                :: i
  real(c_double)                :: ar, dr, r0, r1, z0, z1,tmp
  !c-----
  !c       vtp is the factor used to convert
  !c            spherical velocity to flat velocity
  !c       rtp is the factor used to convert
  !c            spherical density  to flat density
  !c       dtp is the factor used to convert
  !c            spherical boundary to flat boundary
  !c-----
  !c-----
  !c       duplicate computations of srwvds(IV)
  !c-----
  ar=6371.0d0
  dr=0.0d0
  r0=ar
  zd(mmax)=1.0
  do i=1,mmax
    dr= dr + zd(i)
    r1=ar-dr
    z0=ar*dlog(ar/r0)
    z1=ar*dlog(ar/r1)
    dtp(i) = ar/r0 !+ ar/r1

    !use layer midpoint
    TMP=(2.0d0 *ar)/(r0+r1)
    vtp(i) = tmp
    rtp(i) = tmp**(-5)

    ! earth flattening transform
    zb(i) = zb(i) * tmp
    zrho(i) = zrho(i) * rtp(i)
    zd(i) = z1 - z0
    r0=r1
  ENDDO
  zd(mmax) = 0.0
  return
end subroutine bldsph

end module LoveWaveModel

!===================================
! MODULE : Love wave Kernel
!===================================
module LoveWaveKernel
use,intrinsic               :: iso_c_binding
implicit none

contains
subroutine shfunc(omega,wvno)
  !c-----
  !c       This routine evaluates the eigenfunctions by calling sub up.
  !c-----
  !implicit double precision (a-h,o-z)
  use,intrinsic   :: iso_c_binding
  use LoveWaveModel,only : mmax,iwat,uu,tt,uu0,exl
  implicit none
  real(c_double)        :: fl,omega,wvno

  ! local
  real(c_double)        :: ext,umax,fact
  integer(c_int)        :: k
  !c-----
  !c       get the eigenfunctions in an extended floating point form
  !c       by propagating from the bottom upward. Note since we move in this
  !c       direction the propagator matrix A(d) is evaluated as A(-d)
  !c-----
  call up(omega,wvno,fl)
  uu0(1)=1.0
  !c-----
  !c       uu0(2)=stress0 is actually the value of period equation.
  !c       uu0(3) is used to print out the period equation value before
  !c       the root is refined.
  !c-----
  uu0(2)=fl
  uu0(3)=0.0
  uu0(4)=0.0
  !c-----
  !c       convert to actual displacement from the extended floating point
  !c       working top to down, where the amplitude should be small
  !c       Also normalize so that the V(0) = 1
  !c-----
  ext=0.0
  umax = uu(1)
  tt(1) = 0.0
  do k=2,mmax
    if(iwat(k).eq.0)then
        ext=ext+exl(k-1)
        fact=0.0
        if(ext.lt.80.0) fact=1./dexp(ext)
        uu(k)=uu(k)*fact
        tt(k)=tt(k)*fact
    else
        uu(k) = 0.0
        tt(k) = 0.0
    endif
    if(abs(uu(k)).gt.abs(umax))then
        umax = uu(k)
    endif
  enddo
  if(uu(1).ne.0.0)then
    umax = uu(1)
  endif
  if(abs(umax).gt.0.0)then
    do k=1,mmax
      if(iwat(k).eq.0)then
          uu(k) = uu(k) / umax
          tt(k) = tt(k) / umax
      endif
    enddo
  endif
  !c-----
  !c       force boundary condition at the free surface
  !c       free surface is stress free
  !c-----
  return
end subroutine shfunc

subroutine varl(m,rb,omega,wvno,xkb,dpth,eexl)
  !c-----
  !c     find variables cosQ,  sinQ, etc.
  !c-----
  !c     To handle the hyperbolic functions correctly for large
  !c     arguments, we use an extended precision procedure,
  !c     keeping in mind that the maximum precision in double
  !c     precision is on the order of 16 decimal places.
  !c
  !c     So  cosq = 0.5 ( exp(+q) + exp(-q))
  !c              = exp(q) * 0.5 * ( 1.0 + exp(-2q) )
  !c     becomes
  !c         cosq = 0.5 * (1.0 + exp(-2q) ) with an exponent q
  !c     In performing matrix multiplication, we multiply the modified
  !c     cosp terms and add the exponents. At the last step
  !c     when it is necessary to obtain a true amplitude,
  !c     we then form exp(p). For normalized amplitudes at any depth,
  !c     we carry an exponent for the numerator and the denominator, and
  !c     scale the resulting ratio by exp(NUMexp - DENexp)
  !c
  !!!c
  !c     HSKA        cosq  sinq
  !c
  !c     When the extended floating point is used, we use the
  !c     largest exponent for each, which is  the following:
  !c
  !c     Let sex = s exponent > 0 for evanescent waves = 0 otherwise
  !c
  !c     Then the modified matrix elements are as follow:
  !c
  !c     Haskell:  cosq -> 0.5 ( 1 + exp(-2q) ) exponent = pex
  !c-----
  !implicit double precision (a-h,o-z)
  use LoveWaveModel,only    : zb,zrho,cosq,sinq,&
                              yl,zl,mu
  implicit none
  integer m
  real(c_double)            ::  rb, xkb, omega, wvno, dpth, eexl,q

  real(c_double)            :: wvnop, wvnom , fac

  !c-----
  !c     define the  horizontal wavenumber for the S-wave
  !c-----
  xkb = omega/zb(m)
  !c-----
  !c     define the vertical wavenumber for the given wvno
  !c-----
  wvnop = wvno + xkb
  wvnom = dabs(wvno - xkb)
  fac = wvnop*wvnom
  !C      WrItE(*,*)'fac:',m,fac
  rb=dsqrt(wvnop*wvnom)
  q = rb*dpth
  mu = zrho(m)*zb(m)*zb(m)
  !c-----
  !c     examine S-wave eigenfunctions
  !c        checking whether c > vs, c = vs, c < vs
  !c-----
  eexl = 0.0
  if(wvno.lt.xkb)then
    sinq=dsin(q)
    yl=sinq/rb
    zl=-rb*sinq
    cosq=dcos(q)
  else if(wvno.eq.xkb)then
    cosq=1.0d+00
    yl=dpth
    zl=0.0d+00
  else if(wvno.gt.xkb)then
    eexl = q
    fac = 0.0d+00
    if(q.lt.18.0d+00)fac = dexp(-2.0d+0*q)
    cosq = ( 1.0d+00 + fac ) * 0.5d+00
    sinq = ( 1.0d+00 - fac ) * 0.5d+00
    yl = sinq/rb
    zl = rb*sinq
  endif

  return
end subroutine varl

subroutine hskl(hl,iwat)
  use LoveWaveModel, only : cosq,yl,zl,mu
  implicit none
  !c-----
  !c      procedure arguments
  !c-----
  real(c_double)          :: hl(2,2)
  integer(c_int)          :: iwat

  if(iwat.eq.0)then
    hl(1,1) = cosq
    hl(1,2) = yl/mu
    hl(2,1) = zl*mu
    hl(2,2) = cosq
  else
    hl(1,1) = 1.0d+00
    hl(1,2) = 0.0d+00
    hl(2,1) = 0.0d+00
    hl(2,2) = 1.0d+00
  endif
  return
end subroutine hskl

subroutine emat(xnub,wvno,el,einvl)
  implicit none
  !c-----
  !c     compute the E and E^-1 matrices
  !c-----
  real(c_double)              :: wvno
  complex(c_double_complex)   :: xnub, el(2,2), einvl(2,2)

  einvl(1,1) =  0.5/wvno
  einvl(1,2) =  0.5/(wvno*xnub)
  einvl(2,1) =  0.5/wvno
  einvl(2,2) = -0.5/(wvno*xnub)
  el(1,1) =  wvno
  el(1,2) =  wvno
  el(2,1) =  wvno*xnub
  el(2,2) = -wvno*xnub
  return
end subroutine emat

subroutine up(omega,wvno,fl)
  use LoveWaveModel, only  : mmax,zb,zd,iwat,uu,tt,xmu,exl
  implicit none
  !c-----
  !c       This routine calculates the elements of Haskell matrix,
  !c       and finds the eigenfunctions by analytic solution.
  !c-----
  !c       History:
  !c
  !c       16 JUN 2009 - generalized the routine so that  the
  !c         nature of the propagator matrices is buried in the
  !c         subroutine hskl
  !c         This will permit simpler extension to TI
  !c-----
  !implicit double precision (a-h,o-z)

  real(c_double)        :: fl,omega,wvno
  real(c_double)        :: a11, a12, a21, a22,rb, xkb, dpth,hl(2,2)
  real(c_double)        :: eexl,amp0,str0,rr,ss,ttlast
  integer(c_int)        :: mmx1,k,k1

  !c
  !c-----
  !c       apply the boundary conditions to the halfspace
  !c-----
  !c-----
  !c     kludge for fluid core
  !c-----
  if(zb(mmax).gt.0.01)then
    dpth = 0.0
    call varl(mmax,rb,omega,wvno,xkb,dpth,eexl)
    if(wvno.lt.xkb)then
        !write(LOT,*) ' imaginary nub derivl'
        !write(LOT,*)'omega,wvno,b(mmax)',omega,wvno,zb(mmax)
    endif
    uu(mmax)=1.0
    tt(mmax)=-xmu(mmax)*rb
  else
    uu(mmax)=1.0
    tt(mmax)=0.0
  endif
  exl(mmax) = 0.0
  mmx1=mmax-1
  ttlast = 0.0
  do k=mmx1,1,-1
    if(iwat(k).eq.0)then
      dpth=zd(k)
      call varl(k,rb,omega,wvno,xkb,dpth,eexl)
      call hskl(hl,iwat(k))
      k1=k+1
      !c We actually use A^-1 since we go from the bottom to top
      a11 = hl(1,1)
      a22 = hl(2,2)
      a12 = - hl(1,2)
      a21 = - hl(2,1)
      !C            WRITE(6,*)'eexl:',eexl
      !C            WRITE(6,*)'hl:',hl

      amp0 = a11 * uu(k1) + a12*(tt(k1))
      str0 = a21 * uu(k1) + a22*(tt(k1))

      !c now normalize and save the normalization
      rr=dabs(amp0)
      ss=dabs(str0)
      if(ss.gt.rr) rr=ss
      if(rr.lt.1.d-30) rr=1.d+00
      exl(k)=dlog(rr)+eexl
      uu(k)=amp0/rr
      tt(k)=str0/rr
      ttlast = tt(k)
    endif
  enddo
  fl=ttlast
end subroutine up

subroutine energy(omega,wvno,&
                Eut,Edut,Ed2ut,Eut0,Ett0,&
                lss,lrr)
  !!c-----
  !!c       This routine calculates the values of integrals I0, I1,
  !!c       and I2 using analytic solutions. It is found
  !!c       that such a formulation is more efficient and practical.
  !!c
  !!c       This is based on a suggestion by David Harkrider in 1980.
  !!c       Given the eigenfunctions, which are properly defined,
  !!c       define the potential coefficients at the bottom and
  !!c       top of each layer. If the V(z) = A exp (nu z) + B exp (-nu z)
  !!c       We want the B at the top of the layer for z=0, and the A at the
  !!c       bottom of the layer, from the relation K=[Kup Kdn]^T
  !!c       = [A B]^T = E^-1 U
  !!c-----
  !!c       History:
  !!c
  !!c       16 JUN 2009 - generalized the routine so that  the
  !!c         nature of the propagator matrices is buried in the
  !!c         This will permit simpler extension to TI
  !!c-----
  !implicit double precision (a-h,o-z)
  use LoveWaveModel, only        :mmax,zd,zb,zrho,xmu,iwat,&
                                  uu,tt,dcdb,dcdh,dcdr,sumi0,&
                                  sumi1,sumi2,flagr,ale,ugr
  implicit none
  complex(c_double_complex)     :: nub,xnub,exqq,f1,f2,f3
  real(c_double)                :: omega,wvno
  COMPLEX(c_double_complex)     :: CDEXP,kmup, km1dn
  complex(c_double_complex)     :: einvl(2,2), el(2,2)
  complex(c_double_complex)     :: f, g
  real(c_double)                :: TN, TL,Eut,Edut,Ed2ut,Eut0,Ett0,upup,dupdup
  real(c_double)                :: DCDBH, DCDBV, DCDRSH,dcr,dcb,fac,&
                                    c2,llflag,dvdz,dfac
  real(c_double)                :: VSHH, VSHV,c,omega2,wvno2,drho,dpth,&
                                    dmu,rb,xkb,eexl
  integer(c_int)                :: k,k1,LSS,lrr

  c=omega/wvno
  omega2=omega*omega
  wvno2=wvno*wvno
  sumi0=0.0d+00
  sumi1=0.0d+00
  sumi2=0.0d+00
  !c-----
  !c RBH beware when nub = 0
  !c-----
  do k=1,mmax
    if(iwat(k).eq.0)then
      TN = zrho(k)*zb(k)*zb(k)
      TL = zrho(k)*zb(k)*zb(k)
      VSHH = zb(k)
      VSHV = zb(k)
      k1=k+1
      drho=zrho(k)
      dpth=zd(k)
      call varl(k,rb,omega,wvno,xkb,dpth,eexl)
      dmu=xmu(k)
      if(rb .lt. 1.0d-10)rb = 1.0d-10

      !c-----
      !c      for safety do not permit rb = 0
      !c-----
      if(k.eq.mmax) then
        upup  =(0.5d+00/rb)*uu(mmax)*uu(mmax)
        dupdup=(0.5d+00*rb)*uu(mmax)*uu(mmax)
      else
        !c-----
        !c               use Einv to get the potential coefficients
        !c               from the U and T
        !c-----
        nub=dcmplx(rb,0.0d+00)
        if(wvno.lt.xkb) nub=dcmplx(0.0d+00,rb)
        xnub=dmu*nub
        call emat(xnub,wvno,el,einvl)
        km1dn = einvl(2,1)*uu(k)  + einvl(2,2)*tt(k)
        kmup  = einvl(1,1)*uu(k1) + einvl(1,2)*tt(k1)

        ! c               get the f function
        f3=nub*dpth
        exqq=0.0d+00
        if(dreal(f3).lt.40.0) exqq=cdexp(-2.d+00*f3)
        f=(1.d+00-exqq)/(2.d+00*nub)

        !c get the g function
        exqq=0.0d+00
        if(dreal(f3).lt.75.0) exqq=cdexp(-f3)
        g=dpth*exqq

        f1 = f*(el(1,1)*el(1,1)*kmup*kmup  &
        + el(1,2)*el(1,2)*km1dn*km1dn)
        f2 = g*(el(1,1)*el(1,2)+el(1,1)*el(1,2))*kmup*km1dn

        !c cast to a real  upup
        upup = real(f1 + f2)

        !c cast to a real dupdup
        dupdup = real(nub*nub*(f1 - f2))
      endif

      sumi0=sumi0+drho*upup
      sumi1=sumi1+TN*upup
      sumi2=sumi2+TL*dupdup
      dcr=-0.5d+00*c*c*c*upup
      dcb=0.5d+00*c*(upup+dupdup/wvno2)
      DCDBH = c*drho*VSHH*upup
      DCDBV = c*drho*VSHV*dupdup/wvno2
      dcdb(k)=DCDBH + DCDBV
      DCDRSH= 0.5*c*(-c*c*upup + VSHH*VSHH*upup + &
      VSHV*VSHV*dupdup/wvno2)
      dcdr(k)=DCDRSH
    else
      dcdb(k)=0.0
      dcdr(k)=0.0
    endif
  enddo
  do k=1,mmax
    if(iwat(k).eq.0)then
      dcdb(k)=dcdb(k)/sumi1
      dcdr(k)=dcdr(k)/sumi1
    else
      dcdb(k)=0.0
      dcdr(k)=0.0
    endif
  enddo
  flagr=omega2*sumi0-wvno2*sumi1-sumi2
  ugr=sumi1/(c*sumi0)
  !print*,ugr
  ale=0.5d+00/sumi1

  !c-----
  !c       define partial with respect to layer thickness
  !c-----
  !c       fac = 0.5d+00*c**3/(omega2*sumi1)
  fac = ale*c/wvno2
  c2 = c*c
  llflag = 0
  do k=1,mmax
    if(iwat(k).eq.0)then
      if(llflag.eq.0)then
        drho = zrho(k)
        dmu  = xmu(k)
        dvdz = 0.0
      else
        drho = zrho(k) - zrho(k-1)
        dmu  = xmu(k) - xmu(k-1)
        dvdz = tt(k)*tt(k)*(1.0/xmu(k) - 1.0/xmu(k-1))
      endif
      dfac = fac * ( uu(k)*uu(k)* &
      (omega2*drho - wvno2*dmu) + dvdz)
      if(dabs(dfac).lt.1.0d-38)then
        dcdh(k) = 0.0
      else
        dcdh(k) = dfac
      endif
        llflag = llflag + 1
    else
        dcdh(k) = 0.0
    endif
  enddo
  !c-----
  !c       compute the eigenfuntions and depth derivatives
  !c       at the source depth
  !c-----
  if(iwat(lss).eq.0)then
    Eut = uu(lss)
    Edut = tt(lss)/xmu(lss)
    Ed2ut = ( - (omega/zb(lss))**2 + wvno2)*Eut
  else
    Eut = 0.0d+00
    Edut = 0.0d+00
    Ed2ut = 0.0d+00
  endif
  if(iwat(lrr).eq.0)then
    Eut0 = uu(lrr)
    Ett0 = tt(lrr)
  else
    Eut0 = 0.0d+00
    Ett0 = 0.0d+00
  endif
  return
end subroutine energy

subroutine splove(om,c,csph,usph,ugr)
  !!c-----
  !!c       Transform spherical earth to flat earth
  !c       and relate the corresponding flat earth dispersion to spherical
  !!c
  !!c       Schwab, F. A., and L. Knopoff (1972). Fast surface wave
  !!c            and free
  !!c       mode computations, in
  !!c            Methods in Computational Physics, Volume 11,
  !!c       Seismology: Surface Waves and Earth Oscillations,
  !!c            B. A. Bolt (ed),
  !!c       Academic Press, New York
  !!c
  !!c       Rayleigh Wave Equations 111, 114 p 144
  !!c
  !!c       Partial with respect to parameter uses the relation
  !!c       For phase velocity, for example,
  !!c
  !!c       dcs/dps = dcs/dpf * dpf/dps, c is phase velocity, p is
  !!c       parameter, and f is flat model
  !!c
  !!c       om      R*8     angular frequency
  !!c       c       R*8     phase velocity
  !!c       mmax    I*4     number of layers
  !!c-----
  use LoveWaveModel, only        : mmax,vtp,dtp,rtp,dcdb,dcdh,dcdr
  real(c_double)                :: om,tm,c,csph,usph
  real(c_double)                :: ugr,a
  INTEGER(c_int)                :: i
  a = 6371.0d0
  tm=sqrt(1.+(3.0*c/(2.*a*om))**2)
  do i=1,mmax
    dcdb(i)=dcdb(i)*  vtp(i)/(tm**3)
    dcdh(i)=dcdh(i)*  dtp(i)/ (tm**3)
    dcdr(i)=dcdr(i)*  rtp(i)/(tm**3)
  enddo
  csph = c / tm
  usph = ugr * tm
  return
  end

subroutine slegn96(thk,vs,rhom,nlayer,&
                  t,cp,cg,disp,stress,dc2db,dc2dh,dc2dr,&
                  iflsph)bind(c,name='slegn96_')
  use LoveWaveModel
  implicit none
  integer(c_int),value,INTENT(IN)   ::nlayer,iflsph
  real(c_float),INTENT(IN)          :: thk(nlayer),vs(nlayer),rhom(nlayer)
  real(c_double),INTENT(IN)         :: t
  real(c_double),INTENT(INOUT)      :: cp,cg
  real(c_double),INTENT(INOUT)      :: disp(nlayer),stress(nlayer),&
                                       dc2db(nlayer),dc2dh(nlayer),&
                                       dc2dr(nlayer)

  ! local variables
  integer(c_int)           :: i,nsph
  real(c_double)           :: c, omega, wvno, gamma, csph, usph,twopi
  real(c_double)           :: Eut, Edut, Eut0, Ett0, Ed2ut
  real(c_double),PARAMETER :: pi = 3.1415926535898

  ! velocity model
  real(c_double)           :: sums
  !real(c_float)            :: sut,sdut,sd2ut,suz,sduz,sd2uz,sale,wvnsrc,sur0

  ! allocate arrays

  ! copy model
  call Alloc_Model(nlayer)
  zb(1:mmax) = vs(1:mmax);
  zrho(1:mmax) = rhom(1:mmax); zd(1:mmax) = thk(1:mmax)

  ! check water layer
  do i=1,mmax
    if(zb(i) == 0.0)then
      iwat(i) = 1
    else
      iwat(i) = 0
    endif
  enddo

  ! earth flattening transformation
  nsph = iflsph
  if(nsph > 0) then
    ALLOCATE(vtp(mmax),dtp(mmax),rtp(mmax))
    call bldsph()
  endif

  ! compute mu
  xmu(1:mmax) = zrho(1:mmax) * zb(1:mmax)**2

  ! main part
  twopi = 2.0 * pi
  omega = twopi/t
  c=cp
  wvno=omega/c
  call shfunc(omega,wvno)
  call energy(omega,wvno,Eut,Edut,Ed2ut,Eut0,Ett0,1,1)

  ! no attenuation
  gamma = 0.0

  ! earth flattening transform for kernel
  if(nsph > 0) then
    call splove(omega,c,csph,usph,ugr)
    wvno = omega/csph
  else
    csph = c
    usph = ugr
  endif

  !check for underflow
  if(dabs(Eut).lt. 1.0d-36)Eut = 0.0d+00
  if(dabs(Edut).lt. 1.0d-36)Edut = 0.0d+00
  if(dabs(Ed2ut).lt. 1.0d-36)Ed2ut = 0.0d+00
  if(dabs(Eut0).lt. 1.0d-36)Eut0 = 0.0d+00
  if(dabs(Ett0).lt. 1.0d-36)Ett0 = 0.0d+00
  if(dabs(ugr).lt.1.0d-36)ugr=0.0d+00
  if(dabs(sumi0).lt.1.0d-36)sumi0=0.0d+00
  if(dabs(sumi1).lt.1.0d-36)sumi1=0.0d+00
  if(dabs(sumi2).lt.1.0d-36)sumi2=0.0d+00
  if(dabs(ale).lt.1.0d-36)ale=0.0d+00
  if(dabs(flagr).lt.1.0d-36)flagr=0.0d+00
  if(dabs(gamma).lt.1.0d-36)gamma=0.0d+00

  ! get the derivatives of the eigenfunctions required
  ! for source excitation from the definition of stress. For
  ! completeness get the second derivative from the first
  ! derivatives and the equation of motion for the medium
  dc2dh(:) = dcdh(:)
  do i=1,mmax-1
    sums = sum(dc2dh(i+1:mmax))
    !print*,sum(dc2dh(i+1:mmax)),-sum(dc2dh(1:i))
    !sums = sums * 0.5
    dcdh(i) = sums
  enddo
  dcdh(mmax) = 0.0

  ! copy to input variables
  disp(:) = uu(:)
  stress(:) = uu(:)
  dc2db(:) = dcdb(:)
  dc2dr(:) = dcdr(:)
  dc2dh(:) = dcdh(:)
  cp = csph
  cg = usph

  call Dealloc_Model()

  if(nsph == 1) then
    DEALLOCATE(vtp,dtp,rtp)
  endif

end subroutine slegn96

subroutine slegnpu(thk,vs,rhom,nlayer,&
                  t,cp,cg,disp,stress,&
                  t1,cp1,t2,cp2,dc2db,dc2dh,dc2dr,&
                  du2db,du2dh,du2dr,iflsph)bind(c,name='slegnpu_')
  use LoveWaveModel
  implicit none
  integer(c_int),value,INTENT(IN) ::nlayer,iflsph
  real(c_float),INTENT(IN)        :: thk(nlayer),vs(nlayer),rhom(nlayer)
  real(c_double),INTENT(IN)       :: t
  real(c_double),INTENT(INOUT)    :: cp,cg
  real(c_double),INTENT(INOUT)    :: disp(nlayer),stress(nlayer),&
                                    dc2db(nlayer),dc2dh(nlayer),dc2dr(nlayer)
  real(c_double),intent(inout)    :: du2db(nlayer),du2dh(nlayer),du2dr(nlayer)
  real(c_double),intent(inout)    :: t1,t2,cp1,cp2 ! period and phasev at slightly differentperiod

  !local
  integer(c_int)              :: i
  integer(c_int)              :: nsph
  real(c_double),PARAMETER    :: pi = atan(1.0) * 4.0
  real(c_double)              :: c, omega, wvno, twopi,sums
  real(c_double)              :: cg1,cg2,uc1
  real(c_double),ALLOCATABLE  :: dc2db1(:),dc2db2(:),&
                                dc2dh1(:),dc2dh2(:),dc2dr1(:),dc2dr2(:)
  real(c_double)              :: ar,tm,tm1
  real(c_double)              :: Eut, Edut, Eut0, Ett0, Ed2ut

  ! copy model
  call Alloc_Model(nlayer)
  zb(1:mmax) = vs(1:mmax)
  zrho(1:mmax) = rhom(1:mmax); zd(1:mmax) = thk(1:mmax)
  ALLOCATE(dc2db1(mmax),dc2db2(mmax),dc2dh1(mmax),&
          dc2dh2(mmax),dc2dr1(mmax),dc2dr2(mmax))

  ! check water layer
  do i=1,mmax
    if(zb(i).gt.0.0)then
      iwat(i) = 0
    else
      iwat(i) = 1
    endif
  enddo

  ! earth flattening transformation
  nsph = iflsph
  if(nsph > 0) then
    ALLOCATE(vtp(mmax),dtp(mmax),rtp(mmax))
    call bldsph()
  endif

  ! compute mu and lambda
  xmu(:) = zrho(:) * zb(:)**2

  ! compute group velocity for t and phase kernel
  twopi = 2.0 * pi
  omega = twopi/t
  c=cp
  wvno=omega/c
  call shfunc(omega,wvno)
  call energy(omega,wvno,Eut,Edut,Ed2ut,Eut0,Ett0,1,1)
  cg = ugr
  dc2db(:) = dcdb(:); stress(:) = tt(:);
  dc2dr(:) = dcdr(:); disp(:) = uu(:)
  dc2dh(:) = dcdh(:);

  ! compute group velocity for t1 and phase kernel
  twopi = 2.0 * pi
  omega = twopi/t1
  c=cp1
  wvno=omega/c
  call shfunc(omega,wvno)
  call energy(omega,wvno,Eut,Edut,Ed2ut,Eut0,Ett0,1,1)
  cg1 = ugr
  dc2db1(:) = dcdb(:)
  dc2dr1(:) = dcdr(:)
  dc2dh1(:) = dcdh(:)

  ! compute group velocity for t2 and phase kernel
  twopi = 2.0 * pi
  omega = twopi/t2
  c=cp2
  wvno=omega/c
  call shfunc(omega,wvno)
  call energy(omega,wvno,Eut,Edut,Ed2ut,Eut0,Ett0,1,1)
  cg2 = ugr
  dc2db2(:) = dcdb(:)
  dc2dr2(:) = dcdr(:)
  dc2dh2(:) = dcdh(:)

  ! compute duf/dm
  uc1 = cg / cp
  du2db = uc1 * (2.0 - uc1) * dcdb - uc1**2 * t * (dc2db2 - dc2db1) / (t2-t1)
  du2dr = uc1 * (2.0 - uc1) * dcdr - uc1**2 * t * (dc2dr2 - dc2dr1) / (t2-t1)
  du2dh = uc1 * (2.0 - uc1) * dcdh - uc1**2 * t * (dc2dh2 - dc2dh1) / (t2-t1)

  ! earth flattening transform for kernel
  if(nsph >0)then
    ar = 6371.0
    omega = twopi / t
    tm = sqrt(1.+(3.0 * cp/(2.*ar*omega))**2)
    tm1 = (1.5/(ar * omega))**2 / tm

    ! convert duf/dm to dus/dm
    du2db = (tm * du2db + cg * cp * dc2db * tm1) * vtp
    du2dr = (tm * du2dr + cg * cp * dc2dr * tm1) * rtp
    du2dh = (tm * du2dh + cg * cp * dc2dh * tm1) * dtp

    ! convert dcf/dm to dcs/dm
    dc2db = dc2db / tm**3 * vtp
    dc2dr = dc2dr / tm**3 * rtp
    dc2dh = dc2dh / tm**3 * dtp

    ! convert cp and cg to spherical one
    cp = cp  / tm
    cg = cg * tm
  endif

  ! change dc/dz,du/dz to dc/dthk,du/dthk
  do i=1,mmax-1
    sums = sum(dc2dh(i+1:mmax))
    dc2dh(i) = sums
    sums = sum(du2dh(i+1:mmax))
    du2dh(i) = sums
  enddo
  dc2dh(mmax) = 0.0
  du2dh(mmax) = 0.0

  call Dealloc_Model()
  DEALLOCATE(dc2db1,dc2db2,dc2dh1,dc2dh2,dc2dr1,dc2dr2)

  if(nsph == 1) then
    DEALLOCATE(vtp,dtp,rtp)
  endif

end subroutine slegnpu

end module LoveWaveKernel


cc ------------ dpmjet3.4 - authors: S.Roesler, R.Engel, J.Ranft -------
cc -------- phojet1.12-40 - authors: S.Roesler, R.Engel, J.Ranft -------
cc                                                      - oct'13 -------
cc ----------- pythia-6.4 - authors: Torbjorn Sjostrand, Lund'10 -------
cc ---------------------------------------------------------------------
cc                                  converted for use with FLUKA -------
cc                                                      - oct'13 -------

C...PYGAMM
C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
C...(Dover, 1965) 6.1.36.

      DOUBLE PRECISION FUNCTION PYGAMM(X)

C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)

C...Local array and data.
      DIMENSION B(8)
      DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0,
     &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/

      NX=INT(X)
      DX=X-NX

      PYGAMM=1D0
      DXP=1D0
      DO 100 I=1,8
        DXP=DXP*DX
        PYGAMM=PYGAMM+B(I)*DXP
  100 CONTINUE
      IF(X.LT.1D0) THEN
        PYGAMM=PYGAMM/X
      ELSE
        DO 110 IX=1,NX-1
          PYGAMM=(X-IX)*PYGAMM
  110   CONTINUE
      ENDIF

      RETURN
      END


      COMPLEX*16 FUNCTION JAA(Q2,P2,M12,M22)
*-------------------------------------------
      IMPLICIT NONE!
*-------------------
      REAL*8 Q2,P2,S,PI,DLOG,DREAL
      COMPLEX*16 M12,M22,LOG,XSPENZ,DCMPLX
      DATA PI/3.14159265358979D0/
*-
      S=-Q2
      IF(DREAL(M12).EQ.0D0) THEN
***  next rows with m_e cancels in sum -> look test_box_me.frm
       JAA=1D0/(P2+M22)*(DCMPLX(0d0,PI)*LOG((P2+M22)**2/S/M22)
***  &    +1D0/(P2+M22)*(DCMPLX(0d0,PI)*LOG(S/M12)
***  & -.5D0*LOG(M12/S)**2
     & -.5D0*LOG(M22/S)**2
     & + LOG((P2+M22)**2/P2/S)*DLOG(P2/S)
     & + LOG(1D0+M22/P2)**2-2D0*XSPENZ(P2/(P2+M22)) )
      ELSE
***  complete expression
       JAA=1D0/(P2+M22)*(DCMPLX(0d0,PI)*LOG((P2+M22)**2/M12/M22)
     & -.5D0*LOG(M12/S)**2
     & -.5D0*LOG(M22/S)**2
     & + LOG((P2+M22)**2/P2/S)*DLOG(DABS(P2/S))
     & + LOG(1D0+M22/P2)**2-2D0*XSPENZ(P2/(P2+M22)) )
      ENDIF
      RETURN
      END

      COMPLEX*16 FUNCTION JAV(Q2,P2,M12,M22,MZ2)
*-----------------------------------------------
      IMPLICIT NONE!
*-------------------
      REAL*8 Q2,P2,S,DREAL
      COMPLEX*16 M12,M22,MZ2
      COMPLEX*16 LOG
*-
      S=-Q2
      IF(DREAL(M12).EQ.0D0) THEN
       JAV=1D0/(P2+M22)*(
***  next raw with m_e cancel in sum -> look test_box_me.frm
***  & -LOG((Q2+MZ2)/MZ2)*LOG(S/M12)
     & -LOG((Q2+MZ2)/MZ2)*LOG((P2+M22)**2/S/M22))
      ELSE
       JAV=1D0/(P2+M22)*(
***  complete expression
     & -LOG((Q2+MZ2)/MZ2)*LOG((P2+M22)**2/M12/M22))
      ENDIF
      RETURN
      END

      COMPLEX*16 FUNCTION JAVSUB(Q2,P2,MT2,MB2,MV2)
*--------------------------------------------------
      IMPLICIT NONE!
*-------------------
      REAL*8 Q2,P2,DREAL,D2
      COMPLEX*16 CZ2,MT2,MB2,MV2,RAT
      COMPLEX*16 LOG,C01,XSPENZ
      DATA D2/1.6449340668482D0/
      DATA CZ2/(0D0,-1D-40)/
*-
      IF(DREAL(MT2).EQ.0D0) THEN
       JAVSUB=-2D0/P2*(LOG((Q2+MV2)/MV2)*LOG(P2/MV2)+XSPENZ(-Q2/MV2))
      ELSE
***    complete expression
       RAT=MV2/(Q2+MV2)
       JAVSUB=1D0/(P2+MT2)*(
     & (Q2+MT2)*C01(-DREAL(MT2),-DREAL(MB2),Q2,CZ2,MT2,MV2)
     & +LOG(RAT)*LOG((P2+MT2)**2/Q2/MT2)
     & -1D0/2*LOG(RAT)**2-XSPENZ(RAT)+D2)
      ENDIF
      RETURN
      END

      COMPLEX*16 FUNCTION JAVLIM(Q2,P2,M12,M22,MV2)
*--------------------------------------------------
* VERSION OF JAV FOR VERY SMALL MASSES M1 AND M2
      IMPLICIT NONE!
*-------------------
      REAL*8 Q2,P2
      COMPLEX*16 M12,M22,MV2
      COMPLEX*16 LOG
*
      JAVLIM=1D0/P2*(-LOG((Q2+MV2)/MV2)*LOG(P2**2/M12/M22))
*
      RETURN
      END