! Panel type
module panel_mod

    use helpers_mod
    use linked_list_mod
    use vertex_mod
    use math_mod
    use flow_mod
    use linalg_mod

    implicit none

    integer :: doublet_order
    integer :: source_order
    integer :: eval_count ! Developer counter for optimization purposes
    logical :: debug = .true. ! Developer toggle
    character(len=:),allocatable :: influence_calc_type ! Either 'johnson' or 'epton-magnus'

    type eval_point_geom
        ! Container type for the geometric parameters necessary for calculating a panel's influence on a given field point

        real,dimension(3) :: r ! Point position in global coords
        real,dimension(2) :: r_ls ! Transformed point in panel plane
        real :: h ! Transformed height above panel
        real,dimension(3) :: a, g2, l1, l2, R1, R2, g ! Edge parameters

    end type eval_point_geom

    type dod
        ! Container type for parameters of whether a panel lies in a point's domain of dependence

        logical :: in_dod
        logical,dimension(3) :: verts_in_dod, edges_in_dod

    end type dod

    type panel
        ! A three-sided panel

        integer :: N = 3 ! Number of sides/vertices
        integer :: index ! Index of this panel in the mesh array
        type(vertex_pointer),dimension(:),allocatable :: vertices
        real :: radius
        real,dimension(3) :: normal, conormal ! Normal and conormal vectors
        real,dimension(:,:),allocatable :: midpoints
        real,dimension(3) :: centroid
        real,dimension(3,3) :: A_g_to_l, A_s_to_ls, A_g_to_ls, A_ls_to_g ! Coordinate transformation matrices
        real,dimension(3,3) :: B_mat_ls, C_mat_ls ! Local scaled metric matrices
        real,dimension(:,:),allocatable :: vertices_ls, midpoints_ls ! Location of the vertices and edge midpoints described in local scaled coords
        real,dimension(:,:),allocatable :: t_hat_g, t_hat_l, t_hat_ls ! Edge unit tangents
        real,dimension(:,:),allocatable :: n_hat_g, n_hat_l, n_hat_ls ! Edge unit outward normals
        real,dimension(:,:),allocatable :: nu_hat_ls ! Edge unit outward conormals
        real,dimension(:),allocatable :: l ! Edge lengths
        real :: A ! Surface area
        real,dimension(:,:),allocatable :: S_mu_inv, S_sigma_inv ! Matrix relating doublet/source strengths to doublet/source influence parameters
        integer,dimension(:),allocatable :: vertex_indices ! Indices of this panel's vertices in the mesh vertex array
        logical :: in_wake ! Whether this panel belongs to a wake mesh
        integer,dimension(3) :: abutting_panels ! Indices of panels abutting this one
        integer,dimension(3) :: edges ! Indices of this panel's edges
        integer :: top_parent, bot_parent ! Indices of the top and bottom panels this panel's strength is determined by (for a wake panel w/ constant doublet strength)
        real :: r ! Panel inclination indicator; r=-1 -> superinclined, r=1 -> subinclined
        real,dimension(3) :: tau ! Edge inclination parameter
        integer,dimension(3) :: q ! Edge type indicator; q=1 -> subsonic, q=-1 -> supersonic
        real :: J ! Local scaled transformation Jacobian
        real :: rs ! Product of the inclination indicator and the flow type indicator

        contains

            procedure :: init => panel_init_3
            procedure :: calc_derived_properties =>panel_calc_derived_properties
            procedure :: calc_area => panel_calc_area
            procedure :: calc_normal => panel_calc_normal
            procedure :: calc_centroid => panel_calc_centroid
            procedure :: calc_transforms => panel_calc_transforms
            procedure :: calc_g_to_l_transform => panel_calc_g_to_l_transform
            procedure :: calc_g_to_ls_transform => panel_calc_g_to_ls_transform
            procedure :: calc_edge_vectors => panel_calc_edge_vectors
            procedure :: calc_singularity_matrices => panel_calc_singularity_matrices
            procedure :: get_vertex_loc => panel_get_vertex_loc
            procedure :: get_vertex_index => panel_get_vertex_index
            procedure :: touches_vertex => panel_touches_vertex
            procedure :: point_to_vertex_clone => panel_point_to_vertex_clone
            procedure :: check_dod => panel_check_dod
            procedure :: get_field_point_geometry => panel_get_field_point_geometry
            procedure :: E_i_M_N_K => panel_E_i_M_N_K
            procedure :: F_i_1_1_1 => panel_F_i_1_1_1
            procedure :: calc_F_integrals => panel_calc_F_integrals
            procedure :: calc_H_integrals => panel_calc_H_integrals
            procedure :: calc_integrals => panel_calc_integrals
            procedure :: get_source_potential => panel_get_source_potential
            procedure :: get_source_velocity => panel_get_source_velocity
            procedure :: get_doublet_potential => panel_get_doublet_potential
            procedure :: get_doublet_velocity => panel_get_doublet_velocity
            procedure :: get_velocity_jump => panel_get_velocity_jump

    end type panel

contains

    subroutine panel_init_3(this, v1, v2, v3, index)
        ! Initializes a 3-panel

        implicit none

        class(panel),intent(inout) :: this
        type(vertex),intent(in),target :: v1, v2, v3
        integer,intent(in) :: index

        ! Set number of sides
        this%N = 3

        ! Allocate vertex array
        allocate(this%vertices(this%N))
        allocate(this%vertex_indices(this%N))

        ! Assign vertex pointers
        this%vertices(1)%ptr => v1
        this%vertices(2)%ptr => v2
        this%vertices(3)%ptr => v3

        ! Store vertex indices
        this%vertex_indices(1) = v1%index
        this%vertex_indices(2) = v2%index
        this%vertex_indices(3) = v3%index

        ! Store the index of the panel
        this%index = index

        ! Initialize a few things
        this%abutting_panels = 0
        this%top_parent = 0
        this%bot_parent = 0

        call this%calc_derived_properties()

    end subroutine panel_init_3

    subroutine panel_calc_derived_properties(this)
        ! Initializes properties based on the location of the vertices.
        ! Should be called when panel geometry is updated.

        implicit none

        class(panel),intent(inout) :: this
        integer :: i

        ! Determine midpoints
        allocate(this%midpoints(this%N,3))
        do i=1,this%N-1
            this%midpoints(i,:) = 0.5*(this%get_vertex_loc(i)+this%get_vertex_loc(i+1))
        end do
        this%midpoints(this%N,:) = 0.5*(this%get_vertex_loc(1)+this%get_vertex_loc(this%N))

        ! Calculate normal vec
        call this%calc_normal()

        ! Calculate area
        call this%calc_area()

        ! Calculate centroid
        call this%calc_centroid()

    end subroutine panel_calc_derived_properties

    subroutine panel_calc_area(this)

        implicit none

        class(panel),intent(inout) :: this
        real,dimension(3) :: d1, d2, d3, d4

        ! 3-sided panel
        if (this%N == 3) then

            ! Get side vectors
            d1 = this%get_vertex_loc(2)-this%get_vertex_loc(1)
            d2 = this%get_vertex_loc(3)-this%get_vertex_loc(2)

            ! Calculate area from cross product
            this%A = 0.5*norm(cross(d1, d2))

            ! Check for zero area
            if (this%A < 1.e-12) then
                write(*,*) "!!! Panel", this%index, "has zero area. Quitting..."
                stop
            end if

        end if

    end subroutine panel_calc_area

    subroutine panel_calc_normal(this)

        implicit none

        class(panel),intent(inout) :: this
        real,dimension(3) :: d1, d2

        ! Get two chord vectors from midpoints
        d1 = this%midpoints(2,:)-this%midpoints(1,:)
        d2 = this%midpoints(3,:)-this%midpoints(2,:)

        ! Find normal
        this%normal = cross(d1, d2)
        this%normal = this%normal/norm(this%normal)

    end subroutine panel_calc_normal

    subroutine panel_calc_centroid(this)

        implicit none

        class(panel),intent(inout) :: this
        real,dimension(3) :: sum
        integer :: i
        real :: x

        ! Get average of corner points
        sum = 0.
        do i=1,this%N
            sum = sum + this%get_vertex_loc(i)
        end do

        ! Set centroid
        this%centroid = sum/this%N

        ! Calculate radius
        this%radius = 0.
        do i=1,this%N

            ! Distance to i-th vertex
            x = dist(this%get_vertex_loc(i), this%centroid)

            ! Check max
            if (x > this%radius) then
                this%radius = x
            end if

        end do

    end subroutine panel_calc_centroid

    subroutine panel_calc_transforms(this, freestream)

        implicit none

        class(panel),intent(inout) :: this
        type(flow),intent(in) :: freestream

        ! Calculate transforms
        call this%calc_g_to_l_transform(freestream)
        call this%calc_g_to_ls_transform(freestream)

        ! Calculate properties dependent on the transforms
        call this%calc_edge_vectors(freestream)
        call this%calc_singularity_matrices()

    end subroutine panel_calc_transforms

    subroutine panel_calc_g_to_l_transform(this, freestream)

        implicit none

        class(panel),intent(inout) :: this
        type(flow),intent(in) :: freestream

        ! Calculate local eta axis
        this%A_g_to_l(2,:) = cross(this%normal, freestream%c_hat_g)

        ! If the normal and freestream are aligned, then we have to pick a different vector.
        ! We pick the first edge, as we already know this is perpendicular to the normal, so
        ! orthogonality is automatically satisfied.
        if (norm(this%A_g_to_l(2,:)) < 1e-12) then
            this%A_g_to_l(2,:) = this%get_vertex_loc(2)-this%get_vertex_loc(1)
        end if

        ! Normalize
        this%A_g_to_l(2,:) = this%A_g_to_l(2,:)/norm(this%A_g_to_l(2,:))

        ! Calculate local xi axis
        this%A_g_to_l(1,:) = cross(this%A_g_to_l(2,:), this%normal)
        this%A_g_to_l(1,:) = this%A_g_to_l(1,:)/norm(this%A_g_to_l(1,:))

        ! Store local zeta axis
        this%A_g_to_l(3,:) = this%normal

    end subroutine panel_calc_g_to_l_transform

    subroutine panel_calc_g_to_ls_transform(this, freestream)
        ! Calculates the necessary transformations to move from global to local, scaled coordinates (Eq. (E.0.1) in Epton and Magnus)

        implicit none

        class(panel),intent(inout) :: this
        type(flow),intent(in) :: freestream

        real,dimension(3) :: u0, v0
        real :: x, y
        integer :: i

        ! Get in-panel basis vectors
        u0 = this%A_g_to_l(1,:)
        v0 = this%A_g_to_l(2,:)

        ! Calculate compressible parameters
        this%conormal = matmul(freestream%B_mat_g, this%normal)
        x = inner(this%normal, this%conormal)

        ! Check for Mach-inclined panels
        if (freestream%supersonic .and. abs(x) < 1e-12) then
            write(*,*) "!!! Mach-inclined panels are not allowed in supersonic flow. Panel", &
                       this%index, "is Mach-inclined. Quitting..."
            stop
        end if

        ! Calculate panel inclination indicator (E&M Eq. (E.3.16b))
        this%r = sign(x) ! r=-1 -> superinclined, r=1 -> subinclined
        this%rs = this%r*freestream%s

        ! Calculate transformation
        y = 1./sqrt(abs(x))
        this%A_g_to_ls(1,:) = y*matmul(freestream%C_mat_g, u0)
        this%A_g_to_ls(2,:) = this%rs/freestream%B*matmul(freestream%C_mat_g, v0)
        this%A_g_to_ls(3,:) = freestream%B*y*this%normal

        ! Calculate inverse
        if (freestream%M_inf == 0.) then
            this%A_ls_to_g = transpose(this%A_g_to_ls)
        else
            call matinv(3, this%A_g_to_ls, this%A_ls_to_g)
        end if

        ! Calculate Jacobian
        this%J = det3(this%A_g_to_ls)

        ! Transform vertex and midpoint coords to ls
        allocate(this%vertices_ls(this%N,2))
        allocate(this%midpoints_ls(this%N,2))
        do i=1,this%N

            ! Vertices
            this%vertices_ls(i,:) = matmul(this%A_g_to_l(1:2,:), this%get_vertex_loc(i)-this%centroid)

            ! Midpoints
            this%midpoints_ls(i,:) = matmul(this%A_g_to_l(1:2,:), this%midpoints(i,:)-this%centroid)

        end do

        ! Calculate local scaled metric matrices
        this%B_mat_ls = 0.
        this%B_mat_ls(1,1) = freestream%B**2*this%rs
        this%B_mat_ls(2,2) = freestream%B**2
        this%B_mat_ls(3,3) = freestream%B**2*this%r

        this%C_mat_ls = 0.
        this%C_mat_ls(1,1) = this%r
        this%C_mat_ls(2,2) = freestream%s
        this%C_mat_ls(3,3) = this%rs

        ! Check calculation (E&M Eq. (E.2.19))
        if (any(abs(this%B_mat_ls - matmul(this%A_g_to_ls, matmul(freestream%B_mat_g, transpose(this%A_g_to_ls)))) > 1e-12)) then
            write(*,*) "!!! Calculation of local scaled coordinate transform failed. Quitting..."
        end if

    end subroutine panel_calc_g_to_ls_transform

    subroutine panel_calc_edge_vectors(this, freestream)

        implicit none

        class(panel),intent(inout) :: this
        type(flow),intent(in) :: freestream

        real,dimension(3) :: d
        real,dimension(2) :: e
        integer :: i

        ! Allocate memory
        allocate(this%l(this%N))
        allocate(this%t_hat_g(this%N,3))
        allocate(this%t_hat_l(this%N,2))
        allocate(this%t_hat_ls(this%N,2))
        allocate(this%n_hat_g(this%N,3))
        allocate(this%n_hat_l(this%N,2))
        allocate(this%n_hat_ls(this%N,2))
        allocate(this%nu_hat_ls(this%N,2))

        ! Loop through edges
        do i=1,this%N

            ! Calculate edge vector based on index
            d = this%get_vertex_loc(mod(i, this%N)+1)-this%get_vertex_loc(i)

            ! Calculate edge length (unscaled)
            this%l(i) = norm(d)

            ! Calculate tangent in global and local coords
            this%t_hat_g(i,:) = d/this%l(i)
            this%t_hat_l(i,:) = matmul(this%A_g_to_l(1:2,:), this%t_hat_g(i,:))

            ! Calculate tangent in local scaled coords
            e = matmul(this%A_g_to_ls(1:2,:), d)
            this%t_hat_ls(i,:) = e/sqrt(abs(this%rs*e(1)**2 + e(2)**2))

            ! Calculate edge outward normal
            this%n_hat_g(i,:) = cross(this%t_hat_g(i,:), this%normal)
            this%n_hat_l(i,1) = this%t_hat_l(i,2)
            this%n_hat_l(i,2) = -this%t_hat_l(i,1)

            ! Calculate edge normal in local scaled coords
            this%n_hat_ls(i,1) = this%t_hat_ls(i,2)
            this%n_hat_ls(i,2) = -this%t_hat_ls(i,1)

            ! Calculate edge conormal
            this%nu_hat_ls(i,1) = this%rs*this%n_hat_ls(i,1)
            this%nu_hat_ls(i,2) = this%n_hat_ls(i,2)

            ! Calculate the edge type parameter (E&M Eq. (J.3.28) or Eq. (J.7.51))
            this%tau(i) = sqrt(abs(freestream%C_g_inner(this%t_hat_g(i,:), this%t_hat_g(i,:))))

            ! Calculate edge type indicator (E&M Eq. (J.6.48) and Ehlers Eq. (E14))
            this%q(i) = nint(this%r*this%t_hat_ls(i,1)**2 + freestream%s*this%t_hat_ls(i,2)**2)

        end do

    end subroutine panel_calc_edge_vectors

    subroutine panel_calc_singularity_matrices(this)
        ! Calculates the matrices which relate the singularity strengths to the singularity parameters

        implicit none

        class(panel),intent(inout) :: this

        real,dimension(:,:),allocatable :: S_mu, S_sigma

        ! Determine influence of vertex doublet strengths on integral parameters
        if (.not. doublet_order .eq. 0) then

            ! Linear distribution
            if (doublet_order .eq. 1) then

                ! Allocate influence matrices
                allocate(S_mu(3,3))
                allocate(this%S_mu_inv(3,3))

                ! Set values
                S_mu(:,1) = 1.
                S_mu(:,2) = this%vertices_ls(:,1)
                S_mu(:,3) = this%vertices_ls(:,2)

                ! Invert
                call matinv(3, S_mu, this%S_mu_inv)

            else if (doublet_order .eq. 2) then

                ! Allocate influence matrix
                allocate(S_mu(6,6))
                allocate(this%S_mu_inv(6,6))

                ! Set values
                S_mu(:,1) = 1.

                S_mu(1:3,2) = this%vertices_ls(:,1)
                S_mu(1:3,3) = this%vertices_ls(:,2)
                S_mu(1:3,4) = this%vertices_ls(:,1)**2
                S_mu(1:3,5) = this%vertices_ls(:,1)*this%vertices_ls(:,2)
                S_mu(1:3,6) = this%vertices_ls(:,2)**2

                S_mu(4:6,2) = this%midpoints_ls(:,1)
                S_mu(4:6,3) = this%midpoints_ls(:,2)
                S_mu(4:6,4) = this%midpoints_ls(:,1)**2
                S_mu(4:6,5) = this%midpoints_ls(:,1)*this%midpoints_ls(:,2)
                S_mu(4:6,6) = this%midpoints_ls(:,2)**2

                ! Invert
                call matinv(6, S_mu, this%S_mu_inv)

            end if

            deallocate(S_mu)

        end if

        ! Determine influence of vertex source strengths on integral parameters
        ! Linear distribution
        if (source_order .eq. 1) then

            ! Allocate influence matrices
            allocate(S_sigma(3,3))
            allocate(this%S_sigma_inv(3,3))

            ! Set values
            S_sigma(:,1) = 1.
            S_sigma(:,2) = this%vertices_ls(:,1)
            S_sigma(:,3) = this%vertices_ls(:,2)

            ! Invert
            call matinv(3, S_sigma, this%S_sigma_inv)

            deallocate(S_sigma)

        else if (source_order .eq. 2) then

            ! Allocate influence matrix
            allocate(S_sigma(6,6))
            allocate(this%S_sigma_inv(6,6))

            ! Set values
            S_sigma(:,1) = 1.

            S_sigma(1:3,2) = this%vertices_ls(:,1)
            S_sigma(1:3,3) = this%vertices_ls(:,2)
            S_sigma(1:3,4) = this%vertices_ls(:,1)**2
            S_sigma(1:3,5) = this%vertices_ls(:,1)*this%vertices_ls(:,2)
            S_sigma(1:3,6) = this%vertices_ls(:,2)**2

            S_sigma(4:6,2) = this%midpoints_ls(:,1)
            S_sigma(4:6,3) = this%midpoints_ls(:,2)
            S_sigma(4:6,4) = this%midpoints_ls(:,1)**2
            S_sigma(4:6,5) = this%midpoints_ls(:,1)*this%midpoints_ls(:,2)
            S_sigma(4:6,6) = this%midpoints_ls(:,2)**2

            ! Invert
            call matinv(6, S_sigma, this%S_sigma_inv)

            deallocate(S_sigma)

        end if

    end subroutine panel_calc_singularity_matrices

    function panel_get_vertex_loc(this, i) result(loc)

        implicit none

        class(panel),intent(in) :: this
        integer,intent(in) :: i
        real,dimension(3) :: loc

        loc = this%vertices(i)%ptr%loc

    end function panel_get_vertex_loc

    function panel_get_vertex_index(this, i) result(index)

        implicit none

        class(panel),intent(in) :: this
        integer,intent(in) :: i
        integer :: index

        index = this%vertices(i)%ptr%index

    end function panel_get_vertex_index

    function panel_touches_vertex(this, i) result(touches)

        implicit none

        class(panel),intent(in) :: this
        integer,intent(in) :: i
        logical :: touches
        integer :: j

        touches = .false.

        ! Loop through vertices
        do j=1,this%N

            ! Check index
            if (this%vertex_indices(j) == i) then
                touches = .true.
                return
            end if

        end do

    end function panel_touches_vertex

    subroutine panel_point_to_vertex_clone(this, clone)
        ! Updates the panel to point to this new vertex (assumed to be clone of a current vertex)

        implicit none

        class(panel),intent(inout) :: this
        type(vertex),intent(in),target :: clone
        integer :: i

        ! Loop through vertices
        do i=1,this%N

            ! Check which vertex this will replace
            if (dist(this%get_vertex_loc(i), clone%loc) < 1e-12) then

                ! Update pointer
                this%vertices(i)%ptr => clone

                ! Update index
                this%vertex_indices(i) = clone%index

                return

            end if

        end do

    end subroutine panel_point_to_vertex_clone

    function panel_check_dod(this, eval_point, freestream, panel_mirrored, mirror_plane) result(dod_info)
        ! Determines how (if) this panel lies within the domain of dependence of the evaluation point

        implicit none

        class(panel),intent(inout) :: this
        real,dimension(3),intent(in) :: eval_point
        type(flow),intent(in) :: freestream
        logical,intent(in),optional :: panel_mirrored
        integer,intent(in),optional :: mirror_plane

        type(dod) :: dod_info

        real,dimension(3) :: d, point, a, b, R_star
        integer :: i, N_verts_in_dod, N_edges_in_dod, i_next
        real :: C_theta, x, y, dQ_dDp2, s_star
        logical :: totally_out, totally_in, centroid_in, radius_smaller, mirrored, in_panel

        ! Set default mirroring
        if (present(panel_mirrored)) then
            mirrored = panel_mirrored
        else
            mirrored = .false.
        end if

        ! First check the flow is supersonic (check_dod is always called)
        if (freestream%supersonic) then

            ! Fast check based on centroid and radius (Epton & Magnus p. J.3-1)

            ! First, check if the centroid is in the dod
            if (mirrored) then
                point = mirror_about_plane(this%centroid, mirror_plane)
            else
                point = this%centroid
            end if
            centroid_in = freestream%point_in_dod(point, eval_point)

            ! Determine the eval point geometry relative to the compressibility axis
            d = point-eval_point
            x = inner(d, freestream%c_hat_g)
            y = sqrt(norm(d)**2-x**2)

            ! Calculate the distance from the eval point to the Mach cone (E&M Eq. (J.3.26))
            if (y >= freestream%B*x) then
                dQ_dDp2 = (x+freestream%B*y)**2/(1.+freestream%B**2)
            else
                dQ_dDp2 = inner(d, d)
            end if

            ! Check the minimum distance relative to the radius
            if (dQ_dDp2 >= this%radius**2) then
                radius_smaller = .true.
            else
                radius_smaller = .false.
            end if

            ! Determine condition
            totally_out = .not. centroid_in .and. radius_smaller
            totally_in = centroid_in .and. radius_smaller

            ! Set parameters
            if (totally_out) then

                dod_info%in_dod = .false.
                dod_info%verts_in_dod = .false.
                dod_info%edges_in_dod = .false.

            else if (totally_in) then

                dod_info%in_dod = .true.
                dod_info%verts_in_dod = .true.
                dod_info%edges_in_dod = .true.

            ! If it is not guaranteed to be totally out or in, then check all the vertices and edges
            else

                ! Initialize
                dod_info%in_dod = .false.

                ! Check each of the vertices
                N_verts_in_dod = 0
                do i=1,this%N

                    ! Get point
                    if (mirrored) then
                        point = mirror_about_plane(this%get_vertex_loc(i), mirror_plane)
                    else
                        point = this%get_vertex_loc(i)
                    end if

                    ! Check
                    dod_info%verts_in_dod(i) = freestream%point_in_dod(point, eval_point)

                    ! Update number of vertices
                    if (dod_info%verts_in_dod(i)) then
                        N_verts_in_dod = N_verts_in_dod + 1
                        dod_info%in_dod = .true.
                    end if

                end do

                ! Check edges
                do i=1,this%N

                    i_next = mod(i, this%N)+1

                    ! If both vertices are in, then the edge is in (you gotta love convex subspaces)
                    if (dod_info%verts_in_dod(i) .and. dod_info%verts_in_dod(i_next)) then
                        dod_info%edges_in_dod(i) = .true.

                    ! If both aren't in, then the intersection will depend on the edge type
                    else if (this%q(i) == 1) then ! Subsonic

                        ! If both vertices are out, then the edge is out
                        if (.not. dod_info%verts_in_dod(i) .and. .not. dod_info%verts_in_dod(i_next)) then
                            dod_info%edges_in_dod(i) = .false.

                        ! If one endpoint is in, then the edge is in
                        else if (dod_info%verts_in_dod(i) .or. dod_info%verts_in_dod(i_next)) then
                            dod_info%edges_in_dod(i) = .true.

                        end if

                    else ! Supersonic

                        ! If both are out, calculate the point of closest approach
                        if (.not. dod_info%verts_in_dod(i) .and. .not. dod_info%verts_in_dod(i_next)) then

                            ! Get vector describing edge
                            d = this%get_vertex_loc(i_next) - this%get_vertex_loc(i)

                            ! Calculate nondimensional location of the point of closest approach (E&M Eq. (J.3.39))
                            a = cross(freestream%c_hat_g, d)
                            b = cross(freestream%c_hat_g, this%get_vertex_loc(i_next)-eval_point)
                            s_star = inner(a, b)/abs(inner(a, a))

                            ! Check if the point of closest approach is in the edge and in the DoD
                            R_star = this%get_vertex_loc(i_next)-s_star*d
                            if (s_star > 0. .and. s_star < 1. .and. freestream%point_in_dod(R_star, eval_point)) then

                                dod_info%in_dod = .true.
                                dod_info%edges_in_dod(i) = .true.

                            else

                                ! If not, this edge is not in the DoD
                                dod_info%edges_in_dod(i) = .false.

                            end if

                        ! If only one is in, then the edge is in
                        else
                            dod_info%edges_in_dod(i) = .true.

                        end if

                    end if

                end do

                ! If a supersonic panel has no edges or vertices in the DoD, check if the DoD is encompassed by the panel
                if (this%r == -1) then
                    if (.not. any(dod_info%verts_in_dod) .and. .not. any(dod_info%edges_in_dod)) then

                        ! Get the projection of the evaluation point onto the panel in the direction of c_hat
                        s_star = inner(this%get_vertex_loc(1)-eval_point, this%normal)/inner(freestream%c_hat_g, this%normal)
                        R_star = eval_point + freestream%c_hat_g*s_star

                        ! See if the projected point is in the panel
                        in_panel = .true.
                        do i=1,this%N

                            ! Get edge displacement
                            x = inner(R_star, this%n_hat_g(:,i))

                            ! Check sign (should be negative if interior to the panel)
                            if (x >= 0.) then
                                in_panel = .false.
                                exit ! Don't need to check any more
                            end if

                        end do

                        ! Store information
                        if (in_panel) then
                            dod_info%in_dod = .true.
                        else
                            dod_info%in_dod = .false.
                        end if

                    end if

                end if

            end if

        else

            ! Subsonic flow. DoD is everywhere. Life is easy.
            dod_info%in_dod = .true.
            dod_info%verts_in_dod = .true.
            dod_info%edges_in_dod = .true.

        end if

    end function panel_check_dod

    function panel_get_field_point_geometry(this, eval_point, freestream) result(geom)
        ! Calculates the geometric parameters necessary for calculating the influence of the panel at the given evaluation point

        implicit none

        class(panel),intent(in) :: this
        real,dimension(3),intent(in) :: eval_point
        type(flow),intent(in) :: freestream
        type(eval_point_geom) :: geom

        real,dimension(2) :: d
        real,dimension(3) :: r_ls, d3, x
        integer :: i

        ! Store point
        geom%r = eval_point

        ! Transform to local scaled coordinates
        r_ls = matmul(this%A_g_to_ls, geom%r-this%centroid)
        geom%r_ls = r_ls(1:2)
        geom%h = r_ls(3) ! Equivalent to E&M Eq. (J.7.41)

        ! Calculate intermediate quantities
        do i=1,this%N

            ! Projected point displacement from start vertex
            d = this%vertices_ls(i,:)-geom%r_ls

            ! Perpendicular distance in plane from evaluation point to edge E&M Eq. (J.6.46) and (J.7.53)
            geom%a(i) = inner2(d, this%n_hat_ls(i,:))

            ! Integration length on edge to start vertex (E&M Eq. (J.6.47))
            geom%l1(i) = this%rs*d(1)*this%t_hat_ls(i,1) + d(2)*this%t_hat_ls(i,2)

            ! Projected point displacement from end vertex
            d = this%vertices_ls(mod(i, this%N)+1,:)-geom%r_ls

            ! Integration length on edge to end vertex
            geom%l2(i) = this%rs*d(1)*this%t_hat_ls(i,1) + d(2)*this%t_hat_ls(i,2)

            ! Distance from evaluation point to start vertex E&M Eq. (J.8.8)
            ! The distance should be zero in the case of a negative squared distance, as the flow is supersonic and the point lies outside the DoD
            d3 = geom%r-this%get_vertex_loc(i)
            if (freestream%C_g_inner(d3, d3) > 0.) then
                geom%R1(i) = sqrt(freestream%C_g_inner(d3, d3))
            else
                geom%R1(i) = 0.
            end if

            ! Calculate square of the perpendicular distance to edge
            x = cross(d3, this%t_hat_g(i,:))
            geom%g2(i) = (freestream%B/this%tau(i))**2*freestream%B_g_inner(x, x) ! E&M Eq. (J.8.23) or (J.7.70)

            ! Calculate the perpendicular distance to edge
            if (geom%g2(i) >= 0.) then
                geom%g(i) = sqrt(geom%g2(i))
            else
                geom%g(i) = 0.
            end if

        end do

        ! Distance from evaluation point to end vertices
        geom%R2 = cshift(geom%R1, 1)

    end function panel_get_field_point_geometry

    function panel_E_i_M_N_K(this, geom, i, M, N, K, dod_info, freestream) result(E)
        ! Calculates E_i(M,N,K)

        implicit none

        class(panel),intent(in) :: this
        type(eval_point_geom),intent(in) :: geom
        integer,intent(in) :: i, M, N, K
        type(dod),intent(in) :: dod_info
        type(flow),intent(in) :: freestream

        real :: E

        real :: E1, E2
        integer :: i_next

        i_next = mod(i, this%N) + 1

        ! Evaluate at start vertex
        if (dod_info%verts_in_dod(i)) then
            E1 = ((this%vertices_ls(i,1)-geom%r_ls(1))**(M-1)*(this%vertices_ls(i,2)-geom%r_ls(2))**(N-1))/geom%R1(i)**K
        else
            E1 = 0.
        end if

        ! Evaluate at end vertex
        if (dod_info%verts_in_dod(i_next)) then
            E2 = ((this%vertices_ls(i_next,1)-geom%r_ls(1))**(M-1)*(this%vertices_ls(i_next,2)-geom%r_ls(2))**(N-1))/geom%R2(i)**K
        else
            E2 = 0.
        end if

        ! Calculate difference
        E = E2-E1

    end function panel_E_i_M_N_K

    function panel_F_i_1_1_1(this, geom, i, dod_info, freestream) result(F)
        ! Calculates F_i(1,1,1)

        implicit none

        class(panel) :: this
        type(eval_point_geom),intent(in) :: geom
        integer,intent(in) :: i
        type(dod),intent(in) :: dod_info
        type(flow),intent(in) :: freestream

        real :: F, F1, F2
        integer :: i_next

        i_next = mod(i, this%N) + 1

        ! Check DoD
        if (dod_info%edges_in_dod(i)) then

            ! Supersonic edge
            if (this%q(i) == -1) then

                ! Neither endpoint in DoD (Ehlers Eq. (E22))
                if (geom%R1(i) == 0. .and. geom%R2(i) == 0.) then
                    F = pi

                ! At least one endpoint in the DoD (Ehlers Eq. (E22))
                else

                    ! Calculate preliminary quantities
                    F1 = geom%l1(i)*geom%R2(i) - geom%l2(i)*geom%R1(i)
                    F2 = geom%R1(i)*geom%R2(i) + geom%l1(i)*geom%l2(i)

                    ! Calculate F
                    F = -atan2(F1, F2)

                end if

            ! Subsonic edge (all edges in subsonic flow because the definition of a subsonic edge is one that lies inside its own DoD)
            else

                ! Within edge (Johnson Eq. (D.60))
                if (sign(geom%l1(i)) /= sign(geom%l2(i))) then
                    F = log(((geom%R1(i)-geom%l1(i))*(geom%R2(i)+geom%l2(i)))/geom%g2(i))

                ! Above or below edge; this is a unified form of Johnson Eq. (D.60) and should be equivalent to Ehlers Eq. (E.22)
                else
                    F = sign(geom%l1(i))*log((geom%R2(i) + abs(geom%l2(i))) / (geom%R1(i) + abs(geom%l1(i))))

                end if
            end if
        end if

    end function panel_F_i_1_1_1

    function panel_calc_F_integrals(this, geom, proc_H, MXK, MXQ, NHK, dod_info, freestream) result (F)
        ! Calculates the F integrals necessary

        implicit none

        class(panel),intent(in) :: this
        type(eval_point_geom),intent(in) :: geom
        integer,intent(in) :: proc_H, MXK, MXQ, NHK
        type(dod),intent(in) :: dod_info
        type(flow),intent(in) :: freestream
        real,dimension(:,:,:,:),allocatable :: F

        real :: E1, E2, v_xi, v_eta, dF
        real,dimension(3) :: d
        real,dimension(this%N) :: min_dist_to_edge
        integer :: i, MXFK, NFK, k, m, n, i_next

        ! Determine which F integrals are needed
        NFK = 16
        if (proc_H .eq. 1) then
            MXFK = MXK - 2
        else
            MXFK = NHK+MXK-2
        end if

        ! Allocate integral storage
        allocate(F(this%N,1:MXQ,1:MXQ,1:MXFK+NFK), source=0.)

        ! Calculate minimum distance to perimeter of S
        do i=1,this%N

            ! Check this edge is in the DoD
            if (dod_info%edges_in_dod(i)) then

                i_next = mod(i, this%N) + 1

                ! Within edge, the minimum distance is the perpendicular distance
                if (sign(geom%l1(i)) /= sign(geom%l2(i))) then
                    min_dist_to_edge(i) = geom%g(i)

                ! Otherwise, it is the minimum of the distances to the corners
                else
                    if (dod_info%verts_in_dod(i) .and. dod_info%verts_in_dod(i_next)) then
                        min_dist_to_edge(i) = min(geom%R1(i), geom%R2(i))
                    else if (dod_info%verts_in_dod(i)) then
                        min_dist_to_edge(i) = geom%R1(i)
                    else if (dod_info%verts_in_dod(i_next)) then
                        min_dist_to_edge(i) = geom%R2(i)

                    ! If neither is in the DoD, we again go back to the perpendicular distance
                    else
                        min_dist_to_edge(i) = geom%g(i)
                    end if
                end if

            ! Otherwise, set the minimum distance arbitrarily high
            else
                min_dist_to_edge(i) = 100000.
            end if

        end do
        dF = minval(min_dist_to_edge)

        ! Check for point on perimeter
        if (abs(dF) < 1e-12) then
            write(*,*) "Detected control point on perimeter of panel. Quitting..."
            stop
        end if

        ! Loop through edges
        do i=1,this%N

            if (dod_info%edges_in_dod(i)) then

                ! Store edge derivs
                v_xi = this%n_hat_ls(i,1)
                v_eta = this%n_hat_ls(i,2)

                ! Calculate F(1,1,1)
                F(i,1,1,1) = this%F_i_1_1_1(geom, i, dod_info, freestream)

                ! Procedure 4: not close to perimeter
                if (geom%g(i) >= 0.01*dF) then

                    ! Calculate F(1,1,K) integrals
                    do k=3,MXFK,2

                        ! Get necessary E
                        E1 = this%E_i_M_N_K(geom, i, 2, 1, k-2, dod_info, freestream)
                        E2 = this%E_i_M_N_K(geom, i, 1, 2, k-2, dod_info, freestream)

                        ! Calculate F
                        F(i,1,1,k) = 1./(geom%g2(i)*(k-2))*((k-3)*F(i,1,1,k-2)-v_eta*E1+v_xi*E2)
                    end do

                ! Procedure 5: close to perimeter
                else

                    ! Initialize
                    F(i,1,1,MXFK+NFK) = 0.

                    ! Calculate other F(1,1,K) integrals
                    do k=MXFK+NFK,5,2

                        ! Get necessary E
                        E1 = this%E_i_M_N_K(geom, i, 2, 1, k-2, dod_info, freestream)
                        E2 = this%E_i_M_N_K(geom, i, 1, 2, k-2, dod_info, freestream)

                        ! Calculate F
                        F(i,1,1,k-2) = 1./(k-3)*(geom%g2(i)*(k-2)*F(i,1,1,k)+v_eta*E1-v_xi*E2)

                    end do
                end if

                ! Calculate other F integrals (same for both procedures)
                if (abs(v_eta) <= abs(v_xi)) then ! Case a

                    ! Calculate F(1,N,1) integrals (Johnson Eq. (D.62))
                    do n=2,MXQ

                        ! Get E
                        E1 = this%E_i_M_N_K(geom, i, 1, n-1, -1, dod_info, freestream)

                        if (n .eq. 2) then
                            F(i,1,N,1) = 1./(n-1)*((2*n-3)*geom%a(i)*v_eta*F(i,1,n-1,1) + v_xi*E1)
                        else
                            F(i,1,N,1) = 1./(n-1)*((2*n-3)*geom%a(i)*v_eta*F(i,1,n-1,1) &
                                         - (n-2)*(geom%a(i)**2+v_xi**2*geom%h**2)*F(i,1,n-2,1) &
                                         + v_xi*E1)
                        end if
                    end do

                    ! Calculate F(M,N,1) inegrals (Johnsons Eq. (D.63))
                    do m=2,MXQ
                        do n=1,MXQ-m+1
                            F(i,m,n,1) = -v_eta/v_xi*F(i,m-1,n+1,1) + geom%a(i)/v_xi*F(i,m-1,n,1)
                        end do
                    end do

                else ! Case b

                    ! Calculate F(M,1,1) integrals (Johnson Eq. (D.64))
                    do m=2,MXQ

                        ! Get E
                        E1 = this%E_i_M_N_K(geom, i, m-1, 1, -1, dod_info, freestream)

                        if (m .eq. 2) then
                            F(i,m,1,1) = 1./(m-1)*((2*m-3)*geom%a(i)*v_xi*F(i,m-1,1,1) - v_eta*E1)
                        else
                            F(i,m,1,1) = 1./(m-1)*((2*m-3)*geom%a(i)*v_xi*F(i,m-1,1,1) &
                                         - (m-2)*(geom%a(i)**2+v_eta**2*geom%h**2)*F(i,m-2,1,1) &
                                         - v_eta*E1)
                        end if
                    end do

                    ! Calculate F(M,N,1) integrals (Johnson Eq. (D.65))
                    do n=2,MXQ
                        do m=1,MXQ-n+1
                            F(i,m,n,1) = -v_xi/v_eta*F(i,m+1,n-1,1)+geom%a(i)/v_eta*F(i,m,n-1,1)
                        end do
                    end do

                end if

                ! Calculate F(1,2,K) integrals (Johnson Eq. (D.66))
                do k=3,MXK-2,2
                    F(i,1,2,k) = v_eta*geom%a(i)*F(i,1,1,k)-v_xi/(k-2)*this%E_i_M_N_K(geom, i, 1, 1, k-2, dod_info, freestream)
                end do

                ! Calculate F(1,N,K) integrals (Johnson Eq. (D.67))
                do n=3,MXQ
                    do k=3,MXK-2,2
                        F(i,1,n,k) = 2.*geom%a(i)*v_eta*F(i,1,n-1,k) &
                                     - (geom%a(i)**2+v_xi**2*geom%h**2)*F(i,1,n-2,k) &
                                     + v_xi**2*F(i,1,n-2,k-2)
                    end do
                end do
            end if
        end do

        if (debug .and. any(isnan(F))) then
            write(*,*)
            write(*,*) "NaN found in F"
        end if

    end function panel_calc_F_integrals

    function panel_calc_H_integrals(this, geom, proc_H, MXK, MXQ, NHK, dod_info, freestream, F) result(H)
        ! Calculates the necessary H integrals

        implicit none

        class(panel),intent(in) :: this
        type(eval_point_geom),intent(in) :: geom
        integer,intent(in) :: proc_H, MXK, MXQ, NHK
        type(dod),intent(in) :: dod_info
        type(flow),intent(in) :: freestream
        real,dimension(:,:,:,:),allocatable,intent(in) :: F
        real,dimension(:,:,:),allocatable :: H

        real :: S, C, nu, c1, c2, F1, F2
        integer :: i, m, n, k
        real,dimension(:),allocatable :: v_xi, v_eta

        ! Get edge normal derivatives
        allocate(v_xi(this%N), source=this%n_hat_ls(:,1))
        allocate(v_eta(this%N), source=this%n_hat_ls(:,2))

        ! Allocate integral storage
        allocate(H(1:MXQ,1:MXQ,1:MXK+NHK), source=0.)

        ! Procedure 1: not close to panel plane
        if (proc_H == 1) then

            ! Calculate H(1,1,1) (Johnson Eq. (D.41))
            do i=1,this%N

                if (dod_info%edges_in_dod(i)) then

                    ! Supersonic edge
                    if (this%q(i) == -1) then

                        ! Check for neither endpoint in
                        if (.not. dod_info%verts_in_dod(i) .and. .not. dod_info%verts_in_dod(mod(i, this%N)+1)) then

                            ! Add influence of this edge
                            H(1,1,1) = H(1,1,1) - abs(geom%h)*sign(v_xi(i))*pi ! Adapted from Ehlers Eq. (E18) to match the form of Johnson Eq. (D.41)

                        ! At least one in
                        else

                            ! Calculate intermediate quantities Ehlers Eq. (E19) and (E20)
                            F1 = (geom%l1(i)*geom%R2(i)-geom%l2(i)*geom%R1(i))/geom%g2(i)
                            F2 = (geom%R1(i)*geom%R2(i)+geom%l1(i)*geom%l2(i))/geom%g2(i)

                            ! Add to surface integral; adapted from Ehlers Eq. (E18) to match the form of Johnson Eq. (D.41)
                            H(1,1,1) = H(1,1,1) - geom%h*atan2(geom%h*geom%a(i)*F1, geom%R1(i)*geom%R2(i)+geom%h**2*F2)

                        end if

                    ! Subsonic edge
                    else

                        ! Calculate intermediate quantities (Johnson Eq. (D.41))
                        c1 = geom%g2(i)+abs(geom%h)*geom%R1(i)
                        c2 = geom%g2(i)+abs(geom%h)*geom%R2(i)

                        ! Add surface integral
                        S = geom%a(i)*(geom%l2(i)*c1 - geom%l1(i)*c2)
                        C = c1*c2 + geom%a(i)**2*geom%l1(i)*geom%l2(i)
                        H(1,1,1) = H(1,1,1) - atan2(S, C)

                    end if

                end if

            end do

            ! Add line integrals (rs factor added to match Ehlers Eq. (E9))
            H(1,1,1) = abs(geom%h)*H(1,1,1) + this%rs*sum(geom%a*F(:,1,1,1))

            ! Calculate H(1,1,K) integrals (Johnson Eq. (D.42) altered to match Ehlers Eq. (E9))
            do k=3,MXK,2
                if (this%rs == 1.) then
                    H(1,1,k) = 1./((k-2)*geom%h**2)*((k-4)*H(1,1,k-2) + sum(geom%a*F(:,1,1,k-2)))
                else
                    H(1,1,k) = 1./((k-2)*geom%h**2)*(-k*H(1,1,k-2) - sum(geom%a*F(:,1,1,k-2)))
                end if
            end do

        ! Procedures 2 and 3: close to panel plane
        else if (proc_H == 2 .or. proc_H == 3) then

            ! Initialize
            H(1,1,NHK+MXK) = 0.

            ! Calculate H(1,1,K) integrals (Johnson Eq. (D.50) altered to match Ehlers Eq. (E9))
            do k=NHK+MXK,3,-2
                H(1,1,k-2) = 1./(k-4)*(geom%h**2*(k-2)*H(1,1,k) - this%rs*sum(geom%a*F(:,1,1,k-2)))
            end do

        end if

        ! Step 3
        ! Calculate H(2,N,1) integrals (Johnson Eq. (D.43) altered to match Ehlers Eq. (E7))
        do n=1,MXQ-1
            H(2,n,1) = 1./(this%rs*n+1)*(this%rs*geom%h**2*sum(v_xi*F(:,1,n,1)) + sum(geom%a*F(:,2,n,1)))
        end do

        ! Step 4
        ! Calculate H(1,N,1) integrals (Johnson Eq. (D.44) altered to match Ehlers Eq. (E8))
        do n=2,MXQ
            if (n .eq. 2) then
                H(2,n,1) = this%rs/n*(geom%h**2*sum(v_eta*F(:,1,n-1,1)) &
                           + sum(geom%a*F(:,1,n,1)))
            else
                H(2,n,1) = this%rs/n*(-geom%h**2*(n-2)*H(1,n-2,1) &
                           + geom%h**2*sum(v_eta*F(:,1,n-1,1)) &
                           + sum(geom%a*F(:,1,n,1)))
            end if
        end do

        ! Step 5
        ! Calculate H(M,N,1) integrals (Johnson Eq. (D.45) altered to match Ehlers Eq. (E7))
        do m=3,MXQ
            do n=1,MXQ-m+1
                if (m .eq. 2) then
                    H(m,n,1) = 1./(m+n-1)*(this%rs*geom%h**2*sum(v_xi*F(:,m-1,n,1)) &
                               + sum(geom%a*F(:,m,n,1)))
                else
                    H(m,n,1) = 1./(m+n-1)*(-geom%h**2*(m-2)*H(m-2,n,1) &
                               + this%rs*geom%h**2*sum(v_xi*F(:,m-1,n,1)) &
                               + sum(geom%a*F(:,m,n,1)))
                end if
            end do
        end do

        ! Step 6
        ! Calculate H(1,N,K) integrals (Johnson Eq. (D.46) altered to match Ehlers Eq. (E6))
        do n=2,MXQ
            do k=3,MXK,2
                if (n .eq. 2) then
                    H(1,n,k) = -this%rs/(k-2)*sum(v_eta*F(:,1,n-1,k-2))
                else
                    H(1,n,k) = this%rs/(k-2)*((n-2)*H(1,n-2,k-2) &
                               -sum(v_eta*F(:,1,n-1,k-2)))
                end if
            end do
        end do

        ! Step 7
        ! Calculate H(2,N,K) integrals (Johnson Eq. (D.47); already matches Ehlers Eq. (E5))
        do n=1,MXQ-1
            do k=3,MXK,2
                H(2,n,k) = -1./(k-2)*sum(v_xi*F(:,1,n,k-2))
            end do
        end do

        ! Step 8
        ! Calculate remaining H(M,N,K) integrals (Johnson Eq. (D.48) altered to match Ehlers Eq. (E4))
        do k=3,MXK,2
            do n=1,MXQ-m+1
                do m=3,MXQ
                    H(m,n,k) = this%rs*(-H(M-2,N+2,k)-geom%h**2*H(m-2,n,k))+H(m-2,n,k-2)
                end do
            end do
        end do

        ! Convert H* to H in case of Procedure 3
        if (proc_H .eq. 3) then
            do m=1,MXQ
                do n=1,MXQ
                    do k=1,MXK+NHK,2

                        ! Get factorial dingas
                        nu = nu_M_N_K(m, n, k)

                        ! Convert H* to H
                        ! If nu or h is zero, this can just be skipped.
                        if (abs(geom%h) > 1e-12 .and. abs(nu) > 1e-12) then
                            H(m,n,k) = H(m,n,k) + 2.*pi*nu*abs(geom%h)**(m+n-k)
                        end if
                    end do
                end do
            end do
        end if

        ! Clean up
        deallocate(v_xi)
        deallocate(v_eta)

        if (debug .and. any(isnan(H))) then
            write(*,*)
            write(*,*) "NaN found in H"
        end if

    end function panel_calc_H_integrals

    function nu_M_N_K(M, N, K) result(nu)
        ! Calculates nu(M,N,K) based on Eq. (D.51) in Johnson 1980

        implicit none

        integer,intent(in) :: M, N, K
        real :: nu

        integer :: mm, nn, kk, i

        ! Check for even M or N
        if (mod(M, 2) .eq. 0 .or. mod(N, 2) .eq. 0) then
            nu = 0
        else

            ! Initialize
            mm = 1
            nn = 1
            kk = 1

            ! Run factorials (ish. not sure what you'd call these...)
            if (.not. M .eq. 1) then
                do i=1,M-2,2
                    mm = mm*i
                end do
            end if

            if (.not. N .eq. 1) then
                do i=1,N-2,2
                    nn = nn*i
                end do
            end if

            do i=K-2,K-M-N,2
                kk = kk*i
            end do

            ! Calculate nu
            nu = mm*nn/kk

        end if

    end function nu_M_N_K

    subroutine panel_calc_integrals(this, geom, influence_type, singularity_type, dod_info, freestream, H, F)
        ! Calculates the H and F integrals necessary for the given influence

        implicit none

        class(panel),intent(in) :: this
        type(eval_point_geom),intent(in) :: geom
        character(len=*),intent(in) :: influence_type, singularity_type
        type(dod),intent(in) :: dod_info
        type(flow),intent(in) :: freestream
        real,dimension(:,:,:,:),allocatable,intent(out) :: F
        real,dimension(:,:,:),allocatable,intent(out) :: H

        real :: dH
        real,dimension(3) :: d
        real,dimension(this%N) :: min_dist_to_edge
        integer :: MXQ, MXK, NHK, proc_H, i

        ! Determine which H integrals are needed based on distribution and type of influence
        if (singularity_type .eq. "source") then
            if (influence_type .eq. "potential") then
                if (source_order .eq. 0) then
                    MXQ = 1
                    MXK = 1
                end if
            else if (influence_type .eq. "velocity") then
                if (source_order .eq. 0) then
                    MXQ = 1
                    MXK = 3
                end if
            end if
        else if (singularity_type .eq. "doublet") then
            if (influence_type .eq. "potential") then
                if (doublet_order .eq. 1) then
                    MXQ = 2
                    MXK = 3
                end if
            else if (influence_type .eq. "velocity") then
                if (doublet_order .eq. 1) then
                    MXQ = 1
                    MXK = 3
                end if
            end if
        end if

        ! Determine which procedure needs to be used
        if (abs(geom%h) > 1e-12) then ! The nonzero h check seems to be more reliable than that proposed by Johnson
            proc_H = 1 ! Not near plane of panel
            NHK = 0

        else

            ! Check if the projected point falls inside the panel
            ! Outside panel (Procedure 2)
            if (all(geom%a < 0.)) then
                proc_H = 2

            ! Inside panel (Procedure 3)
            else
                proc_H = 3

            end if
            NHK = 16
        end if

        ! Calculate F integrals
        F = this%calc_F_integrals(geom, proc_H, MXK, MXQ, NHK, dod_info, freestream)

        ! Calculate H integrals
        H = this%calc_H_integrals(geom, proc_H, MXK, MXQ, NHK, dod_info, freestream, F)

    end subroutine panel_calc_integrals

    function panel_get_source_potential(this, eval_point, freestream, dod_info, vertex_indices, panel_mirrored) result(phi)

        implicit none

        class(panel),intent(in) :: this
        real,dimension(3),intent(in) :: eval_point
        type(flow),intent(in) :: freestream
        type(dod),intent(in) :: dod_info
        integer,dimension(:),allocatable,intent(out) :: vertex_indices
        logical,intent(in) :: panel_mirrored
        real,dimension(:),allocatable :: phi

        type(eval_point_geom) :: geom
        real,dimension(:,:,:),allocatable :: H
        real,dimension(:,:,:,:),allocatable :: F
        real :: b

        ! Allocate velocity
        if (source_order == 0) then
            allocate(phi(1), source=0.)
        end if

        ! In dod
        if (dod_info%in_dod) then

            ! Calculate geometric parameters
            geom = this%get_field_point_geometry(eval_point, freestream)

            if (influence_calc_type == 'johnson') then

                ! Get integrals
                call this%calc_integrals(geom, "potential", "source", dod_info, freestream, H, F)

                if (source_order == 0) then

                    ! Compute induced potential
                    phi = -freestream%K_inv*H(1,1,1)

                end if

                ! Clean up
                deallocate(H)
                deallocate(F)

            end if
        end if

    end function panel_get_source_potential

    function panel_get_source_velocity(this, eval_point, freestream, dod_info, vertex_indices, panel_mirrored) result(v)

        implicit none

        class(panel),intent(in) :: this
        real,dimension(3),intent(in) :: eval_point
        type(flow),intent(in) :: freestream
        type(dod),intent(in) :: dod_info
        integer,dimension(:),allocatable,intent(out) :: vertex_indices
        logical,intent(in) :: panel_mirrored
        real,dimension(:,:),allocatable :: v

        type(eval_point_geom) :: geom
        real,dimension(:,:,:),allocatable :: H
        real,dimension(:,:,:,:),allocatable :: F

        ! Allocate velocity
        if (source_order == 0) then
            allocate(v(1,3), source=0.)
        end if

        ! In dod
        if (dod_info%in_dod) then

            ! Calculate geometric parameters
            geom = this%get_field_point_geometry(eval_point, freestream)

            if (influence_calc_type == 'johnson') then

                ! Get integrals
                call this%calc_integrals(geom, "velocity", "source", dod_info, freestream, H, F)

                if (source_order == 0) then

                    ! Calculate velocity
                    v(1,1) = freestream%K_inv*sum(this%n_hat_ls(:,1)*F(:,1,1,1))
                    v(1,2) = freestream%K_inv*sum(this%n_hat_ls(:,2)*F(:,1,1,1))
                    v(1,3) = freestream%K_inv*geom%h*H(1,1,3)

                end if

                ! Clean up
                deallocate(H)
                deallocate(F)

            end if
        end if

    end function panel_get_source_velocity

    function panel_get_doublet_potential(this, eval_point, freestream, dod_info, vertex_indices, panel_mirrored) result(phi)

        implicit none

        class(panel),intent(in) :: this
        real,dimension(3),intent(in) :: eval_point
        type(flow),intent(in) :: freestream
        type(dod),intent(in) :: dod_info
        integer,dimension(:),allocatable,intent(out) :: vertex_indices
        logical,intent(in) :: panel_mirrored
        real,dimension(:),allocatable :: phi

        type(eval_point_geom) :: geom
        real,dimension(:,:,:),allocatable :: H
        real,dimension(:,:,:,:),allocatable :: F
        integer,dimension(:),allocatable :: H_shape
        integer :: i, j, k
        real :: a
        real,dimension(2) :: a_bar, x

        ! Specify influencing vertices (also sets zero default influence)
        if (doublet_order == 1) then
            if (this%in_wake) then

                ! Wake panels are influenced by two sets of vertices
                allocate(vertex_indices(6))
                vertex_indices(1) = this%vertices(1)%ptr%top_parent
                vertex_indices(2) = this%vertices(2)%ptr%top_parent
                vertex_indices(3) = this%vertices(3)%ptr%top_parent
                vertex_indices(4) = this%vertices(1)%ptr%bot_parent
                vertex_indices(5) = this%vertices(2)%ptr%bot_parent
                vertex_indices(6) = this%vertices(3)%ptr%bot_parent

                ! Set default influence
                allocate(phi(6), source=0.)

            else

                ! Body panels are influenced by only one set of vertices
                allocate(vertex_indices, source=this%vertex_indices)

                ! Set default influence
                allocate(phi(3), source=0.)

            end if
        end if

        ! Check DoD
        if (dod_info%in_dod) then

            ! Calculate geometric parameters
            geom = this%get_field_point_geometry(eval_point, freestream)

            if (influence_calc_type == 'johnson') then

                ! Get integrals
                call this%calc_integrals(geom, "potential", "doublet", dod_info, freestream, H, F)

                ! Calculate influence
                if (doublet_order == 1) then

                    ! Compute induced potential (Johnson Eq. (D.30); Ehlers Eq. (5.17))
                    phi(1) = geom%h*H(1,1,3)
                    phi(2) = geom%h*H(1,1,3)*geom%r_ls(1) + geom%h*H(2,1,3)
                    phi(3) = geom%h*H(1,1,3)*geom%r_ls(2) + geom%h*H(1,2,3)

                    ! Convert to vertex influences (Davis Eq. (4.41))
                    phi(1:3) = freestream%K_inv*matmul(phi(1:3), this%S_mu_inv)

                    ! Wake bottom influence is opposite the top influence
                    if (this%in_wake) then
                        phi(4:6) = -phi(1:3)
                    end if

                end if

                ! Clean up
                deallocate(H)
                deallocate(F)

            end if
        end if

    end function panel_get_doublet_potential

    function panel_get_doublet_velocity(this, eval_point, freestream, dod_info, vertex_indices, panel_mirrored) result(v)

        implicit none

        class(panel),intent(in) :: this
        real,dimension(3),intent(in) :: eval_point
        type(flow),intent(in) :: freestream
        type(dod),intent(in) :: dod_info
        integer,dimension(:),allocatable,intent(out) :: vertex_indices
        logical,intent(in) :: panel_mirrored
        real,dimension(:,:),allocatable :: v

        type(eval_point_geom) :: geom
        real,dimension(:,:,:),allocatable :: H
        real,dimension(:,:,:,:),allocatable :: F

        ! Allocate velocity and vertices
        if (doublet_order .eq. 1) then
            if (this%in_wake) then

                ! Wake panels are influenced by two sets of vertices
                allocate(vertex_indices(6))
                vertex_indices(1) = this%vertices(1)%ptr%top_parent
                vertex_indices(2) = this%vertices(2)%ptr%top_parent
                vertex_indices(3) = this%vertices(3)%ptr%top_parent
                vertex_indices(4) = this%vertices(1)%ptr%bot_parent
                vertex_indices(5) = this%vertices(2)%ptr%bot_parent
                vertex_indices(6) = this%vertices(3)%ptr%bot_parent

                ! Set default influence
                allocate(v(6,3), source=0.)

            else

                ! Body panels are influenced by only one set of vertices
                allocate(vertex_indices, source=this%vertex_indices)

                ! Set default influence
                allocate(v(3,3), source=0.)

            end if
        end if

        ! Check DoD
        if (dod_info%in_dod) then

            ! Calculate geometric parameters
            geom = this%get_field_point_geometry(eval_point, freestream)

            if (influence_calc_type == 'johnson') then

                ! Get integrals
                call this%calc_integrals(geom, "velocity", "doublet", dod_info, freestream, H, F)

                if (doublet_order .eq. 1) then

                    ! Specify influencing vertices
                    allocate(vertex_indices(3), source=this%vertex_indices)

                    ! Calculate velocity
                    allocate(v(3,3), source=0.)

                end if

                ! Clean up
                deallocate(H)
                deallocate(F)

            end if
        end if

    end function panel_get_doublet_velocity

    function panel_get_velocity_jump(this, mu, sigma, mirrored, mirror_plane) result(dv)
        ! Calculates the jump in perturbation velocity across this panel in global coordinates

        implicit none

        class(panel),intent(in) :: this
        real,dimension(:),allocatable,intent(in) :: mu, sigma
        logical,intent(in) :: mirrored
        integer,intent(in) :: mirror_plane
        real,dimension(3) :: dv

        real,dimension(3) :: mu_verts, mu_params
        integer :: i
        real :: s

        ! Set up array of doublet strengths to calculate doublet parameters
        if (mirrored) then
            do i=1,this%N
                mu_verts(i) = mu(this%vertex_indices(i)+size(mu)/2)
            end do
        else
            do i=1,this%N
                mu_verts(i) = mu(this%vertex_indices(i))
            end do
        end if

        ! Calculate doublet parameters (derivatives)
        mu_params = matmul(this%S_mu_inv, mu_verts)

        ! Calculate tangential velocity jump in panel coordinates E&M Eq. (N.1.11b)
        dv(1) = mu_params(2)
        dv(2) = mu_params(3)
        dv(3) = 0.

        ! Transform to global coordinates
        dv = matmul(transpose(this%A_g_to_ls), dv)

        ! Get source strength
        if (mirrored) then
            s = sigma(this%index+size(sigma)/2)
        else
            s = sigma(this%index)
        end if

        ! Add normal velocity jump in global coords E&M Eq. (N.1.11b)
        dv = dv + s*this%normal/inner(this%conormal, this%normal)

        ! Mirror if necessary
        if (mirrored) then
            dv = mirror_about_plane(dv, mirror_plane)
        end if

    end function panel_get_velocity_jump

end module panel_mod


C$Procedure      VPRJPI ( Vector projection onto plane, inverted )

      SUBROUTINE VPRJPI ( VIN, PROJPL, INVPL, VOUT, FOUND )

C$ Abstract
C
C     Find the vector in a specified plane that maps to a specified
C     vector in another plane under orthogonal projection.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     PLANES
C
C$ Keywords
C
C     GEOMETRY
C     MATH
C     PLANE
C     VECTOR
C
C$ Declarations

      INTEGER               UBPL
      PARAMETER           ( UBPL   =    4 )

      DOUBLE PRECISION      VIN    (    3 )
      DOUBLE PRECISION      PROJPL ( UBPL )
      DOUBLE PRECISION      INVPL  ( UBPL )
      DOUBLE PRECISION      VOUT   (    3 )
      LOGICAL               FOUND

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     VIN        I   The projected vector.
C     PROJPL     I   Plane containing VIN.
C     INVPL      I   Plane containing inverse image of VIN.
C     VOUT       O   Inverse projection of VIN.
C     FOUND      O   Flag indicating whether VOUT could be calculated.
C
C$ Detailed_Input
C
C     VIN,
C     PROJPL,
C     INVPL          are, respectively, a 3-vector, a SPICELIB plane
C                    containing the vector, and a SPICELIB plane
C                    containing the inverse image of the vector under
C                    orthogonal projection onto PROJPL.
C
C$ Detailed_Output
C
C     VOUT           is the inverse orthogonal projection of VIN.  This
C                    is the vector lying in the plane INVPL whose
C                    orthogonal projection onto the plane PROJPL is
C                    VIN.  VOUT is valid only when FOUND (defined below)
C                    is .TRUE.  Otherwise, VOUT is undefined.
C
C     FOUND          indicates whether the inverse orthogonal projection
C                    of VIN could be computed.  FOUND is .TRUE. if so,
C                    .FALSE. otherwise.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)  If the geometric planes defined by PROJPL and INVPL are
C         orthogonal, or nearly so, the inverse orthogonal projection
C         of VIN may be undefined or have magnitude too large to
C         represent with double precision numbers.  In either such
C         case, FOUND will be set to .FALSE.
C
C     2)  Even when FOUND is .TRUE., VOUT may be a vector of extremely
C         large magnitude, perhaps so large that it is impractical to
C         compute with it.  It's up to you to make sure that this
C         situation does not occur in your application of this routine.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     Projecting a vector orthogonally onto a plane can be thought of
C     as finding the closest vector in the plane to the original vector.
C     This `closest vector' always exists; it may be coincident with the
C     original vector.  Inverting an orthogonal projection means finding
C     the vector in a specified plane whose orthogonal projection onto
C     a second specified plane is a specified vector.  The vector whose
C     projection is the specified vector is the inverse projection of
C     the specified vector, also called the `inverse image under
C     orthogonal projection' of the specified vector.  This routine
C     finds the inverse orthogonal projection of a vector onto a plane.
C
C     Related routines are VPRJP, which projects a vector onto a plane
C     orthogonally, and VPROJ, which projects a vector onto another
C     vector orthogonally.
C
C$ Examples
C
C     1)   Suppose
C
C             VIN    =  ( 0.0, 1.0, 0.0 ),
C
C          and that PROJPL has normal vector
C
C             PROJN  =  ( 0.0, 0.0, 1.0 ).
C
C          Also, let's suppose that INVPL has normal vector and constant
C
C             INVN   =  ( 0.0, 2.0, 2.0 )
C             INVC   =    4.0.
C
C          Then VIN lies on the y-axis in the x-y plane, and we want to
C          find the vector VOUT lying in INVPL such that the orthogonal
C          projection of VOUT the x-y plane is VIN.  Let the notation
C          < a, b > indicate the inner product of vectors a and b.
C          Since every point X in INVPL satisfies the equation
C
C             <  X,  (0.0, 2.0, 2.0)  >  =  4.0,
C
C          we can verify by inspection that the vector
C
C             ( 0.0, 1.0, 1.0 )
C
C          is in INVPL and differs from VIN by a multiple of PROJN.  So
C
C             ( 0.0, 1.0, 1.0 )
C
C          must be VOUT.
C
C          To find this result using SPICELIB, we can create the
C          SPICELIB planes PROJPL and INVPL using the code fragment
C
C             CALL NVP2PL  ( PROJN,  VIN,   PROJPL )
C             CALL NVC2PL  ( INVN,   INVC,  INVPL  )
C
C          and then perform the inverse projection using the call
C
C             CALL VPRJPI ( VIN, PROJPL, INVPL, VOUT )
C
C          VPRJPI will return the value
C
C             VOUT = ( 0.0, 1.0, 1.0 )
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     [1] `Calculus and Analytic Geometry', Thomas and Finney.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C
C$ Version
C
C-    SPICELIB Version 2.0.0, 17-FEB-2004 (NJB)
C
C        Computation of LIMIT was re-structured to avoid
C        run-time underflow warnings on some platforms.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 01-NOV-1990 (NJB)
C
C-&

C$ Index_Entries
C
C     vector projection onto plane inverted
C
C-&

C$ Revisions
C
C-    SPICELIB Version 2.0.0, 17-FEB-2004 (NJB)
C
C        Computation of LIMIT was re-structured to avoid
C        run-time underflow warnings on some platforms.
C        In the revised code, BOUND/DPMAX() is never
C        scaled by a number having absolute value < 1.
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      DPMAX
      DOUBLE PRECISION      VDOT

      LOGICAL               RETURN

C
C     Local parameters
C

C
C     BOUND is used to bound the magnitudes of the numbers that we
C     try to take the reciprocal of, since we can't necessarily invert
C     any non-zero number.  We won't try to invert any numbers with
C     magnitude less than
C
C        BOUND / DPMAX().
C
C     BOUND is chosen somewhat arbitrarily....
C
      DOUBLE PRECISION      BOUND
      PARAMETER           ( BOUND = 10.D0 )

C
C     Local variables
C
      DOUBLE PRECISION      DENOM
      DOUBLE PRECISION      INVC
      DOUBLE PRECISION      INVN  ( 3 )
      DOUBLE PRECISION      LIMIT
      DOUBLE PRECISION      MULT
      DOUBLE PRECISION      NUMER
      DOUBLE PRECISION      PROJC
      DOUBLE PRECISION      PROJN ( 3 )

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      ELSE
         CALL CHKIN ( 'VPRJPI' )
      END IF

C
C     Unpack the planes.
C
      CALL PL2NVC ( PROJPL, PROJN, PROJC )
      CALL PL2NVC ( INVPL,  INVN,  INVC  )

C
C     We'll first discuss the computation of VOUT in the nominal case,
C     and then deal with the exceptional cases.
C
C     When PROJPL and INVPL are not orthogonal to each other, the
C     inverse projection of VIN will differ from VIN by a multiple of
C     PROJN, the unit normal vector to PROJPL.  We find this multiple
C     by using the fact that the inverse projection VOUT satisfies the
C     plane equation for the inverse projection plane INVPL.
C
C        We have
C
C           VOUT = VIN  +  MULT * PROJN;                           (1)
C
C        since VOUT satisfies
C
C           < VOUT, INVN >  =  INVC
C
C        we must have
C
C           <  VIN  +  MULT * PROJN,  INVN  > = INVC
C
C        which in turn implies
C
C
C                     INVC  -  < VIN, INVN >
C           MULT  =  ------------------------.                     (2)
C                        < PROJN, INVN >
C
C        Having MULT, we can compute VOUT according to equation (1).
C
C     Now, if the denominator in the above expression for MULT is zero
C     or just too small, performing the division would cause a
C     divide-by-zero error or an overflow of MULT.  In either case, we
C     will avoid carrying out the division, and we'll set FOUND to
C     .FALSE.
C

C
C     Compute the numerator and denominator of the right side of (2).
C
      NUMER  =  INVC - VDOT ( VIN,   INVN )
      DENOM  =         VDOT ( PROJN, INVN )

C
C     If the magnitude of the denominator is greater than the absolute
C     value of
C
C                    BOUND
C        LIMIT  =  --------- * NUMER,
C                   DPMAX()
C
C     we can safely divide the numerator by the denominator, and the
C     magnitude of the result will be no greater than
C
C         DPMAX()
C        --------- .
C          BOUND
C
C     Note that we have ruled out the case where NUMER and DENOM are
C     both zero by insisting on strict inequality in the comparison of
C     DENOM and LIMIT.
C
C     We never set LIMIT smaller than BOUND/DPMAX(), since
C     the computation using NUMER causes underflow to be signaled
C     on some systems.
C
      IF ( ABS(NUMER) .LT. 1.D0 ) THEN
         LIMIT  =           BOUND / DPMAX()
      ELSE
         LIMIT  =  ABS (  ( BOUND / DPMAX() ) * NUMER  )
      END IF

      IF (  ABS (DENOM) .GT. LIMIT  ) THEN
C
C        We can find VOUT after all.
C
         MULT = NUMER / DENOM

         CALL VLCOM ( 1.0D0, VIN, MULT, PROJN, VOUT )

         FOUND = .TRUE.

      ELSE
C
C        No dice.
C
         FOUND = .FALSE.

      END IF

      CALL CHKOUT ( 'VPRJPI' )
      RETURN
      END


program gau3d
    use math
    implicit none
    integer :: i
    double precision :: v(10000, 3)

    do i = 1, 10000
        v(i, :) = maxwell(temperature=10.d0*e, mass=me, dim=3)
    end do

    open(66, file='out3.dat', status='unknown')
    do i = 1, 10000
        write(66, *) mag(v(i, :))
    end do
end program gau3d


      SUBROUTINE MB03YT( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL,
     $                   CSR, SNR )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute the periodic Schur factorization of a real 2-by-2
C     matrix pair (A,B) where B is upper triangular. This routine
C     computes orthogonal (rotation) matrices given by CSL, SNL and CSR,
C     SNR such that
C
C     1) if the pair (A,B) has two real eigenvalues, then
C
C        [ a11 a12 ] := [  CSL  SNL ] [ a11 a12 ] [  CSR -SNR ]
C        [  0  a22 ]    [ -SNL  CSL ] [ a21 a22 ] [  SNR  CSR ]
C
C        [ b11 b12 ] := [  CSR  SNR ] [ b11 b12 ] [  CSL -SNL ]
C        [  0  b22 ]    [ -SNR  CSR ] [  0  b22 ] [  SNL  CSL ],
C
C     2) if the pair (A,B) has a pair of complex conjugate eigenvalues,
C        then
C
C        [ a11 a12 ] := [  CSL  SNL ] [ a11 a12 ] [  CSR -SNR ]
C        [ a21 a22 ]    [ -SNL  CSL ] [ a21 a22 ] [  SNR  CSR ]
C
C        [ b11  0  ] := [  CSR  SNR ] [ b11 b12 ] [  CSL -SNL ]
C        [  0  b22 ]    [ -SNR  CSR ] [  0  b22 ] [  SNL  CSL ].
C
C     This is a modified version of the LAPACK routine DLAGV2 for
C     computing the real, generalized Schur decomposition of a
C     two-by-two matrix pencil.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,2)
C             On entry, the leading 2-by-2 part of this array must
C             contain the matrix A.
C             On exit, the leading 2-by-2 part of this array contains
C             the matrix A of the pair in periodic Schur form.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= 2.
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,2)
C             On entry, the leading 2-by-2 part of this array must
C             contain the upper triangular matrix B.
C             On exit, the leading 2-by-2 part of this array contains
C             the matrix B of the pair in periodic Schur form.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= 2.
C
C     ALPHAR  (output) DOUBLE PRECISION array, dimension (2)
C     ALPHAI  (output) DOUBLE PRECISION array, dimension (2)
C     BETA    (output) DOUBLE PRECISION array, dimension (2)
C             (ALPHAR(k)+i*ALPHAI(k))*BETA(k) are the eigenvalues of the
C             pair (A,B), k=1,2, i = sqrt(-1). ALPHAI(1) >= 0.
C
C     CSL     (output) DOUBLE PRECISION
C             The cosine of the first rotation matrix.
C
C     SNL     (output) DOUBLE PRECISION
C             The sine of the first rotation matrix.
C
C     CSR     (output) DOUBLE PRECISION
C             The cosine of the second rotation matrix.
C
C     SNR     (output) DOUBLE PRECISION
C             The sine of the second rotation matrix.
C
C     REFERENCES
C
C     [1] Van Loan, C.
C         Generalized Singular Values with Algorithms and Applications.
C         Ph. D. Thesis, University of Michigan, 1973.
C
C     CONTRIBUTORS
C
C     D. Kressner, Technical Univ. Berlin, Germany, and
C     P. Benner, Technical Univ. Chemnitz, Germany, December 2003.
C
C     REVISIONS
C
C     V. Sima, June 2008 (SLICOT version of the HAPACK routine DLAPV2).
C     V. Sima, July 2008, May 2009.
C
C     KEYWORDS
C
C     Eigenvalue, periodic Schur form
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      INTEGER           LDA, LDB
      DOUBLE PRECISION  CSL, CSR, SNL, SNR
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), ALPHAI(2), ALPHAR(2), B(LDB,*),
     $                  BETA(2)
C     .. Local Scalars ..
      DOUBLE PRECISION  ANORM, BNORM, H1, H2, H3, QQ, R, RR, SAFMIN,
     $                  SCALE1, SCALE2, T, ULP, WI, WR1, WR2
C     .. External Functions ..
      DOUBLE PRECISION  DLAMCH, DLAPY2
      EXTERNAL          DLAMCH, DLAPY2
C     .. External Subroutines ..
      EXTERNAL          DLAG2, DLARTG, DLASV2, DROT
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, MAX
C
C     .. Executable Statements ..
C
      SAFMIN = DLAMCH( 'S' )
      ULP    = DLAMCH( 'P' )
C
C     Scale A.
C
      ANORM = MAX( ABS( A(1,1) ) + ABS( A(2,1) ),
     $             ABS( A(1,2) ) + ABS( A(2,2) ), SAFMIN )
      A(1,1) = A(1,1) / ANORM
      A(1,2) = A(1,2) / ANORM
      A(2,1) = A(2,1) / ANORM
      A(2,2) = A(2,2) / ANORM
C
C     Scale B.
C
      BNORM = MAX( ABS( B(1,1) ), ABS( B(1,2) ) + ABS( B(2,2) ), SAFMIN)
      B(1,1) = B(1,1) / BNORM
      B(1,2) = B(1,2) / BNORM
      B(2,2) = B(2,2) / BNORM
C
C     Check if A can be deflated.
C
      IF ( ABS( A(2,1) ).LE.ULP ) THEN
         CSL = ONE
         SNL = ZERO
         CSR = ONE
         SNR = ZERO
         WI  = ZERO
         A(2,1) = ZERO
         B(2,1) = ZERO
C
C     Check if B is singular.
C
      ELSE IF ( ABS( B(1,1) ).LE.ULP ) THEN
         CALL DLARTG( A(2,2), A(2,1), CSR, SNR, T )
         SNR = -SNR
         CALL DROT( 2, A(1,1), 1, A(1,2), 1, CSR, SNR )
         CALL DROT( 2, B(1,1), LDB, B(2,1), LDB, CSR, SNR )
         CSL = ONE
         SNL = ZERO
         WI  = ZERO
         A(2,1) = ZERO
         B(1,1) = ZERO
         B(2,1) = ZERO
      ELSE IF( ABS( B(2,2) ).LE.ULP ) THEN
         CALL DLARTG( A(1,1), A(2,1), CSL, SNL, R )
         CSR = ONE
         SNR = ZERO
         WI  = ZERO
         CALL DROT( 2, A(1,1), LDA, A(2,1), LDA, CSL, SNL )
         CALL DROT( 2, B(1,1), 1, B(1,2), 1, CSL, SNL )
         A(2,1) = ZERO
         B(2,1) = ZERO
         B(2,2) = ZERO
      ELSE
C
C        B is nonsingular, first compute the eigenvalues of A / adj(B).
C
         R = B(1,1)
         B(1,1) = B(2,2)
         B(2,2) = R
         B(1,2) = -B(1,2)
         CALL DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, WR2,
     $               WI )
C
         IF( WI.EQ.ZERO ) THEN
C
C           Two real eigenvalues, compute s*A-w*B.
C
            H1 = SCALE1*A(1,1) - WR1*B(1,1)
            H2 = SCALE1*A(1,2) - WR1*B(1,2)
            H3 = SCALE1*A(2,2) - WR1*B(2,2)
C
            RR = DLAPY2( H1, H2 )
            QQ = DLAPY2( SCALE1*A(2,1), H3 )
C
            IF ( RR.GT.QQ ) THEN
C
C              Find right rotation matrix to zero 1,1 element of
C              (sA - wB).
C
               CALL DLARTG( H2, H1, CSR, SNR, T )
C
            ELSE
C
C              Find right rotation matrix to zero 2,1 element of
C              (sA - wB).
C
               CALL DLARTG( H3, SCALE1*A(2,1), CSR, SNR, T )
C
            END IF
C
            SNR = -SNR
            CALL DROT( 2, A(1,1), 1, A(1,2), 1, CSR, SNR )
            CALL DROT( 2, B(1,1), 1, B(1,2), 1, CSR, SNR )
C
C           Compute inf norms of A and B.
C
            H1 = MAX( ABS( A(1,1) ) + ABS( A(1,2) ),
     $                ABS( A(2,1) ) + ABS( A(2,2) ) )
            H2 = MAX( ABS( B(1,1) ) + ABS( B(1,2) ),
     $                ABS( B(2,1) ) + ABS( B(2,2) ) )
C
            IF( ( SCALE1*H1 ).GE.ABS( WR1 )*H2 ) THEN
C
C              Find left rotation matrix Q to zero out B(2,1).
C
               CALL DLARTG( B(1,1), B(2,1), CSL, SNL, R )
C
            ELSE
C
C              Find left rotation matrix Q to zero out A(2,1).
C
               CALL DLARTG( A(1,1), A(2,1), CSL, SNL, R )
C
            END IF
C
            CALL DROT( 2, A(1,1), LDA, A(2,1), LDA, CSL, SNL )
            CALL DROT( 2, B(1,1), LDB, B(2,1), LDB, CSL, SNL )
C
            A(2,1) = ZERO
            B(2,1) = ZERO
C
C           Re-adjoint B.
C
            R = B(1,1)
            B(1,1) = B(2,2)
            B(2,2) = R
            B(1,2) = -B(1,2)
C
         ELSE
C
C           A pair of complex conjugate eigenvalues:
C           first compute the SVD of the matrix adj(B).
C
            R = B(1,1)
            B(1,1) = B(2,2)
            B(2,2) = R
            B(1,2) = -B(1,2)
            CALL DLASV2( B(1,1), B(1,2), B(2,2), R, T, SNL, CSL,
     $                   SNR, CSR )
C
C           Form (A,B) := Q(A,adj(B))Z' where Q is left rotation matrix
C           and Z is right rotation matrix computed from DLASV2.
C
            CALL DROT( 2, A(1,1), LDA, A(2,1), LDA, CSL, SNL )
            CALL DROT( 2, B(1,1), LDB, B(2,1), LDB, CSR, SNR )
            CALL DROT( 2, A(1,1), 1, A(1,2), 1, CSR, SNR )
            CALL DROT( 2, B(1,1), 1, B(1,2), 1, CSL, SNL )
C
            B(2,1) = ZERO
            B(1,2) = ZERO
         END IF
C
      END IF
C
C     Unscaling
C
      R = B(1,1)
      T = B(2,2)
      A(1,1) = ANORM*A(1,1)
      A(2,1) = ANORM*A(2,1)
      A(1,2) = ANORM*A(1,2)
      A(2,2) = ANORM*A(2,2)
      B(1,1) = BNORM*B(1,1)
      B(2,1) = BNORM*B(2,1)
      B(1,2) = BNORM*B(1,2)
      B(2,2) = BNORM*B(2,2)
C
      IF( WI.EQ.ZERO ) THEN
         ALPHAR(1) = A(1,1)
         ALPHAR(2) = A(2,2)
         ALPHAI(1) = ZERO
         ALPHAI(2) = ZERO
         BETA(1) = B(1,1)
         BETA(2) = B(2,2)
      ELSE
         WR1 = ANORM*WR1
         WI  = ANORM*WI
         IF ( ABS( WR1 ).GT.ONE .OR. WI.GT.ONE ) THEN
            WR1 = WR1*R
            WI = WI*R
            R = ONE
         END IF
         IF ( ABS( WR1 ).GT.ONE .OR. ABS( WI ).GT.ONE ) THEN
            WR1 = WR1*T
            WI = WI*T
            T = ONE
         END IF
         ALPHAR(1) = ( WR1 / SCALE1 )*R*T
         ALPHAI(1) = ABS( ( WI  / SCALE1 )*R*T )
         ALPHAR(2) =  ALPHAR(1)
         ALPHAI(2) = -ALPHAI(1)
         BETA(1) = BNORM
         BETA(2) = BNORM
      END IF
      RETURN
C *** Last line of MB03YT ***
      END


! ader_weno.f90
! author: sunder

!-----------------------------------------------------------------------
! Main module containing all the necessary data structures.
!-----------------------------------------------------------------------

module ader_weno
    use constants, only : m_pi
    implicit none
    public

    ! ---------------------------------------------------------------------------------------------------------
    ! Input parameters - This part can be modified by the user
    ! ---------------------------------------------------------------------------------------------------------

    integer, parameter  :: nVar   = 1          ! Number of variables in the PDE system
    integer             :: N                   ! Degree of approximation
    integer             :: IMAX                ! Number of cells in the x-direction
    double precision    :: tend                ! End time of the simulation
    double precision    :: xL                  ! Left end of the domain
    double precision    :: xR                  ! Right end of the domain
    integer             :: bL                  ! Boundary condition on left  : 0-I, 1-T, 2-R, 3-P
    integer             :: bR                  ! Boundary condition on right : 0-I, 1-T, 2-R, 3-P
    double precision, parameter :: CFL = 0.9d0 ! CFL constant (should be less than 1.0)
    integer             :: ICType              ! Initial condition function.
                                               ! Optional -> Can be set in the initial field file as well in case desired test case does not exist

    ! Supported boundary conditions: I-inflow, T-transmissive, R-reflective, P-periodic

    ! ---------------------------------------------------------------------------------------------------------
    ! Do not change anything below
    ! ---------------------------------------------------------------------------------------------------------

    ! Basic stuff

    double precision :: dx                           ! Size of each cell in the domain (assumed constant)
    double precision :: dt                           ! Time step size
    double precision :: time                         ! Current time in the simulation
    integer          :: timestep                     ! Current time step number
    integer          :: nDOF                         ! Number of degrees of freedom in each cell
    integer          :: nStencils                    ! Number of stencils for WENO reconstruction
    integer          :: nGhostCells                  ! Number of ghost cells on each side of the domain to apply boundary conditions

    ! Arrays holding the solution, grid, rhs and fluxes

    double precision, allocatable  :: x(:)           ! Mesh - contains the cell center values
    double precision, allocatable  :: uh(:,:)        ! Solution vector (nVar, nCells+2*nGhostCells) -> also contains ghost values
    double precision, allocatable  :: duh(:,:)       ! RHS for updating the solution
    double precision, allocatable  :: qbnd(:,:,:)    ! Conserved variable on cell boundaries
    double precision, allocatable  :: Fbnd(:,:,:)    ! Conserved fluxes on cell boundaries
    double precision, allocatable  :: F(:,:)         ! Upwind flux at each face

    ! Basis functions

    double precision, allocatable  :: xGP(:), wGP(:)   ! Legendre-Gauss quadrature points in interval [0,1]
    double precision, allocatable  :: phiL(:), phiR(:) ! Basis function values on the left and side of unit cell

    ! WENO related data

    double precision, parameter   :: lambda_s  = 1.0d0   ! Weight for the sided stencils
    double precision, parameter   :: lambda    = 100.0d0 ! Weight for the centered stencils
    double precision, allocatable :: lin_wt(:)           ! Normalized linear weights of each stencil
    double precision, parameter   :: small_num = 1.0d-12 ! Small number (to avoid division by zero)
    double precision, allocatable :: OS_M(:,:)           ! Oscillation indicator matrix
    double precision, allocatable :: iML(:,:), iMCL(:,:) ! Inverse coefficient matrix for left and center left stencil
    double precision, allocatable :: iMR(:,:), iMCR(:,:) ! Inverse coefficient matrix for right and center right stencil

    ! ADER related data
    double precision, allocatable :: Kxi(:,:)            ! Element stiffness matrix
    double precision, allocatable :: K1(:,:), iK1(:,:)   ! F1 - Ktau and its inverse
    double precision, allocatable :: F0(:)               ! Time flux matrices

    ! Important info and parameters concerning the governing PDE system

    type tEquations
        double precision :: a ! Advection speed of the wave
    end type tEquations

    type(tEquations)   :: EQN

end module ader_weno


    ! module to test double integration
    module test

    use numerics_type, only : i4b, wp
    integer (i4b), parameter :: dim_num=2
    real(wp), dimension(dim_num) :: a,b
    integer (i4b), dimension(dim_num) :: sub_num
    integer (i4b) :: it_max, eval_num, ind, i
    real(wp) :: tol, result

    real(wp), parameter :: lf=333550._wp, ttr=273.15_wp, cw=4200._wp, &
                gamma_liq=0.072_wp, DEcrit=0.2_wp, alphar=2.5_wp, alphai=2.5_wp, &
                pi=4.0_wp*atan(1.0_wp), cr=pi/6.0_wp*1000.0_wp, dr=3.0_wp, ar=836.0_wp, &
                br=0.8_wp, ci=0.04_wp, di=2.0_wp, ai=8.97_wp, bi=0.42_wp
    real(wp) :: phi, T, f, nr1, qr, ni, qi, n0r, lambda0r, n0i, lambda0i, &
        mrthresh, mrupper, miupper, vx, vy

    contains

    subroutine calculate_parameters(n,q,c,d,alpha, n0, lambda)
        use numerics_type, only : wp
        implicit none
        real(wp), intent(in) :: n,q,c,d,alpha
        real(wp), intent(inout) :: n0, lambda

        lambda=((c*gamma(1._wp+d+alpha)/gamma(1._wp+alpha))*N/q)**(1.0_wp/d)
        n0=n*lambda**(1.0_wp+alpha) / gamma(1.0_wp+alpha)

    end subroutine calculate_parameters

    function collisions_precip_mass(dim_num, x)
        use numerics_type, only : wp, i4b
        implicit none
        integer(i4b), intent(in) :: dim_num
        real(wp), dimension(dim_num), intent(in) :: x
        real(wp) :: collisions_precip_mass
        real(wp) :: diamr, diami, mr, mi

        mr=x(1)
        mi=x(2)
        diamr=(mr/cr)**(1.0_wp/dr)
        diami=(mi/ci)**(1.0_wp/di)

        collisions_precip_mass=pi/4.0_wp*(diamr+diami)**2* &
            abs(ar*diamr**br-ai*diami**bi)*n0r*diamr**alphar* &
            exp(-lambda0r*diamr)*n0i*diami**alphai*exp(-lambda0i*diami)* &
            (diamr**(1.0_wp-dr)) / (cr*dr)*(diami**(1.0_wp-di)) / (ci*di)
    end function collisions_precip_mass

    function dintegral(x,y)
        use numerics_type, only : wp
        implicit none
        real(wp), intent(in) :: x
        real(wp), dimension(:), intent(in) :: y
        real(wp), dimension(size(y)) :: dintegral
        real(wp) :: diamr, mr, vr
        real(wp), dimension(size(y)) :: mi, diami, delv, vi, k0, de, nfrag, nfrag_freeze1, &
            nfrag_freeze2

        mr=x
        mi=y
        diamr=(mr/cr)**(1.0_wp/dr)
        diami=(mi/ci)**(1.0_wp/di)
        ! fall-speeds
        vr=ar*diamr**br
        vi=ai*diami**bi
        delv=abs(vr-vi)
        !delv=max((vx+vy)/8.0,abs(vx-vy))
        ! last bit is to convert to integral over m
        dintegral=pi/4.0_wp*(diamr+diami)**2* &
            delv*n0r*diamr**alphar* &
            exp(-lambda0r*diamr)*n0i*diami**alphai*exp(-lambda0i*diami)* &
            (diamr**(1.0_wp-dr)) / (cr*dr)*(diami**(1.0_wp-di)) / (ci*di)

        ! cke from equation 6
        k0=0.5_wp*(mr*mi/(mr+mi))*(vr-vi)**2
        ! de parameter
        de=k0/(gamma_liq*pi*diamr**2)
        ! number of fragments in spalsh
        nfrag=3.0_wp*max(de-decrit, 0.0_wp)
        ! number of fragments in splash that freeze due to mode 1
        nfrag_freeze1=nfrag*f
        ! number of fragments in splash that freeze due to mode 2
        nfrag_freeze2=nfrag*(1.0_wp-f)*phi

        dintegral=dintegral*nfrag_freeze2

    end function dintegral

    function limit1(x)
        use numerics_type, only : wp
        implicit none
        real(wp), intent(in) :: x
        real(wp) :: limit1
        limit1=x
    end function limit1
!
    function limit2(x)
        use numerics_type, only : wp
        implicit none
        real(wp), intent(in) :: x
        real(wp) :: limit2
        limit2=miupper
    end function limit2

    end module test

	!> @mainpage
	!>@author
	!>Paul J. Connolly, The University of Manchester
	!>@copyright 2019
	!>@brief
	!>A collection of numerical routines for use in models
	!>that can be distributed and modified

	!>@author
	!>Paul J. Connolly, The University of Manchester
	!>@brief
	!>main programme for testing

    program main
        use numerics_type
        use numerics, only : dvode, dfsid1, zeroin,fmin, vode_integrate, &
                tridiagonal, erfinv, invgammainc, quad2d_qgaus, &
                quad2d_romb, gammainc_scal, gammainc
        use random, only : random_normal
        use hypergeo, only : hygfx
        use test, only : phi, ni, qi, nr1, qr, ttr, vx,vy, lf, &
            miupper, mrupper, mrthresh, ar, ai, br, bi, cr, ci, dr, di, &
            n0i, n0r, lambda0r, lambda0i, alphar, alphai, cw, f,&
            limit1, limit2, dintegral, calculate_parameters
        implicit none
        real(wp) :: machep
        real(wp) :: ax,bx,tol,f1,f2,func,h0,err

        real(wp), dimension(3) :: atol, y,rtol
        real(wp) :: t,tout
        real(wp), dimension(67) :: rwork
        integer(i4b), dimension(33) :: iwork
        integer(i4b) :: neq, itol, itask,istate,iopt,lrw,liw,mf, &
                                    iout,i3,i4
        real(wp), allocatable,dimension(:) :: rpar
        integer(i4b), allocatable,dimension(:) :: ipar

        real(wp), dimension(1) :: ystart
        real(wp) :: x1,x2,eps,h1,hmin,ff1,aa,bb!, f
        real(wp), dimension(10000001) :: b,x,r
        real(wp), dimension(10000000) :: a,c
        integer(i4b), allocatable, dimension(:) :: seed
        integer(i4b) :: l
        real(wp) :: rr
        real(wp) :: ss, p

        external func
        external func2
        external fex
        external jex

        machep=epsilon(tol)

        tol=1.e-8_wp
        ax=2._wp
        bx=6._wp
        f1=zeroin(ax,bx,func,tol) ! see zbrent
        print *,f1

        h0=1.e-3_wp
        f2=f1
        f1=dfsid1(func,f2,h0,tol,err) ! see dfridr
        print *,f1

        f1=fmin(ax,bx,func,tol) ! see brent
        print *,f1,ax,bx

        call xsetf(0)

        neq = 3
        y(1) = 1.0e0_wp
        y(2) = 0.0e0_wp
        y(3) = 0.0e0_wp
        t = 0.0e0_wp
        tout = 0.4e0_wp
        itol = 2
        rtol = 1.e-4_wp
        atol(1) = 1.e-8_wp
        atol(2) = 1.e-14_wp
        atol(3) = 1.e-6_wp
        itask = 1
        istate = 1
        iopt = 0
        lrw = 67
        liw = 33
        mf = 21

        do iout = 1,12
            call dvode(fex,neq,y,t,tout,itol,rtol,atol,itask,istate, &
                    iopt,rwork,lrw,iwork,liw,jex,mf,rpar,ipar)
            write(6,20)t,y(1),y(2),y(3)
        20  format(' at t =',e12.4,'   y =',3e14.6)

            if (istate .lt. 0) then
                write(6,90) istate
            90  format(///' error halt: istate =',i3)
                stop
            endif

            tout = tout*10._wp
        enddo
        write(6,60) iwork(11),iwork(12),iwork(13),iwork(19), &
                iwork(20),iwork(21),iwork(22)
    60  format(/' no. steps =',i4,'   no. f-s =',i4, &
           '   no. j-s =',i4,'   no. lu-s =',i4/ &
           '  no. nonlinear iterations =',i4/ &
           '  no. nonlinear convergence failures =',i4/ &
           '  no. error test failures =',i4/)

        ! now test integration by vode_integrate
        ystart(1)=0._wp
        x1=0._wp
        x2=pi/2._wp
        eps=1.e-4_wp
        h1=0.01_wp
        hmin=0.0_wp
        call vode_integrate(ystart,x1,x2,eps,h1,hmin,func2)
        print *,ystart

        ! tridiagonal solver
        a=1._wp
        b=2._wp
        c=1._wp
        r=1._wp
        call tridiagonal(a,b,c,r,x)

        ! inverse erf
        call erfinv(0.5_wp,f)
        print *,f,erf(f)

        ! hypergeometric function
        aa=1._wp
        bb=4._wp+2._wp*2.5_wp+0.25_wp
        call hygfx(aa, bb, real(1,sp)+2.5_wp+1.0_wp,0.5_wp,ff1)
        print *,ff1

        ! random number
		call random_seed(size=l)
		allocate(seed(1:l))
		seed(:)=2
		call random_seed(put=seed)

        do l=1,10
            rr=random_normal()
            print *,rr
        enddo

        ! now test double integration - mode 2 fragmentation
        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        ! Some inputs for model                                                   !
        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        phi=0.5_wp
        T=265._wp
        f=-cw*(t-ttr)/lf ! fraction frozen at the end of stage 1 of freezing
        nr1=2.e3_wp
        qr=2.e-5_wp
        ni=.001e3_wp
        qi=0.1e-3_wp
        mrthresh = cr*150.e-6_wp**dr
        mrupper=cr*1.e-3_wp**dr
        miupper=ci*5.e-3_wp**di
        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        ! Calculate some things prior                                             !
        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        call calculate_parameters(nr1,qr,cr,dr,alphar, n0r, lambda0r)
        call calculate_parameters(ni,qi,ci,di,alphai, n0i, lambda0i)
        vx=ar*gamma(br+alphar+1.0_wp)/gamma(alphar+1.0_wp)/lambda0r**(br)
        vy=ai*gamma(bi+alphai+1.0_wp)/gamma(alphai+1.0_wp)/lambda0i**(bi)

        p=0.9999_wp
        p=invgammainc(p,alphar+1.0_wp)
!         p=14.938751954612494_wp
!         print *,p,gammainc(alphar+1.0,p), alphar
        mrupper=cr*(p/lambda0r)**dr
        miupper=ci*(p/lambda0i)**di
        mrupper=min(mrupper,miupper)
        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

        x1=mrthresh
        x2=mrupper

    !     print *,n0r,lambda0r,n0i,lambda0i, &
    !         n0r*gamma(1.+alphar)/lambda0r**(1.+alphar), &
    !         cr*n0r*gamma(1.+alphar+dr)/lambda0r**(1.+alphar+dr), &
    !         n0i*gamma(1.+alphai)/lambda0i**(1.+alphai), &
    !         ci*n0i*gamma(1.+alphai+di)/lambda0i**(1.+alphai+di)
        ss=0._wp
    !     print *,cr*(p/lambda0r)**dr,ci*(p/lambda0i)**di,mrthresh
        if(mrupper.gt.mrthresh) then
            call quad2d_romb(dintegral,limit1,limit2,x1,x2,ss)
        endif

        print *,'Double Integral solution is: ', ss, miupper,gammainc(2.0_wp,0.99_wp)
        ss=0._wp
        if(mrupper.gt.mrthresh) then
            call quad2d_qgaus(dintegral,limit1,limit2,x1,x2,ss)
        endif

        print *,'Double Integral solution 2 is: ', ss

    end program main

    function func(x)
        use numerics_type
        use numerics
        implicit none
        real(wp) :: func
        real(wp), intent(in) :: x

        func=cos(x)
    end function func

    subroutine fex (neq, t, y, ydot, rpar, ipar)
        use numerics_type
        real(wp) :: rpar, t
        real(wp), dimension(neq) :: y,ydot
        ydot(1) = -.04e0_wp*y(1) + 1.e4_wp*y(2)*y(3)
        ydot(3) = 3.e7_wp*y(2)*y(2)
        ydot(2) = -ydot(1) - ydot(3)
        return
    end subroutine fex

    subroutine func2 (t, y, ydot)
        use numerics_type
        implicit none
        real(wp), intent(in) :: t
        real(wp), dimension(:), intent(in) :: y
        real(wp), dimension(:), intent(inout) :: ydot
        ydot(1) = cos(t)
    end subroutine func2

    subroutine jex (neq, t, y, ml, mu, pd, nrpd, rpar, ipar)
        use numerics_type
        real(wp) :: rpar, t
        real(wp), dimension(neq) :: y
        real(wp), dimension(nrpd,neq) :: pd
        pd(1,1) = -.04e0_wp
        pd(1,2) = 1.e4_wp*y(3)
        pd(1,3) = 1.e4_wp*y(2)
        pd(2,1) = .04e0_wp
        pd(2,3) = -pd(1,3)
        pd(3,2) = 6.e7_wp*y(2)
        pd(2,2) = -pd(1,2) - pd(3,2)
        return
    end subroutine jex