!-----------------------------------------------------------------------
!
! RAdS Jan12.
! Copyright (C) 2011-2014 by Rodrigo Alvares de Souza.
! Mail: <rsouza01@gmail.com>. Web: "http://www.astro.iag.usp.br/~rsouza/".
! This program may be copied and/or distributed freely. See the
! _ terms and conditions in the files in the doc/ subdirectory.
!
!
! MODULE: cubic_spline_module
!
!> @author
!> Rodrigo Souza
!
! DESCRIPTION:
!> Interpolation related routines
!
!-----------------------------------------------------------------------
module cubic_spline_module
use global_constants
use types

    implicit none

    contains

   !> \brief Evaluates the 3rd order polynomial to interpolate \rho(P)
    !!
    !! \param eos_element
    !! \param pressure_bar
    !! \return
    !!
    double precision function interpolation_pressure_from_eos(parameters, eos_element, rho_bar)
        type(ConfigParameters), intent(in) :: parameters
        type(EquationOfStateValue), pointer, intent(in) :: eos_element
        double precision, intent(in) :: rho_bar

        double precision :: delta_x_bar

        type(InterpolationStepValue), pointer :: isv

        isv => eos_element%PRESSURE_FROM_RHO

        if(parameters%INTERPOLATION_METHOD == IDX_CUBIC_SPLINE) then

            delta_x_bar = rho_bar - isv%x

            interpolation_pressure_from_eos = isv%a + isv%b * delta_x_bar + &
                    isv%c * delta_x_bar**2. +isv%d * delta_x_bar**3.

        else if(parameters%INTERPOLATION_METHOD == IDX_LINEAR) then

            interpolation_pressure_from_eos = isv%a*(rho_bar - eos_element%rho_bar) + isv%b

        end if

        !write (*, *) '(interpolation_pressure_from_eos ) = (', interpolation_pressure_from_eos, ')';

    end function interpolation_pressure_from_eos

   !> \brief Evaluates the 3rd order polynomial to interpolate \rho(P)
    !!
    !! \param eos_element
    !! \param pressure_bar
    !! \return
    !!
    double precision function interpolation_baryonic_density_from_eos(parameters, eos_element, rho_bar)
        type(ConfigParameters), intent(in) :: parameters
        type(EquationOfStateValue), pointer, intent(in) :: eos_element
        double precision, intent(in) :: rho_bar
        double precision :: delta_x_bar

        type(InterpolationStepValue), pointer :: isv

        isv => eos_element%BARYON_DENSITY_FROM_RHO

        if(parameters%INTERPOLATION_METHOD == IDX_CUBIC_SPLINE) then

            delta_x_bar = rho_bar - isv%x

            interpolation_baryonic_density_from_eos = isv%a + isv%b * delta_x_bar + &
                                      isv%c * delta_x_bar**2. +isv%d * delta_x_bar**3.

        else if(parameters%INTERPOLATION_METHOD == IDX_LINEAR) then

            interpolation_baryonic_density_from_eos = isv%a*(rho_bar - eos_element%rho_bar) + isv%b

        end if

        !write (*, *) '(interpolation_pressure_from_eos ) = (', interpolation_pressure_from_eos, ')';

    end function interpolation_baryonic_density_from_eos

    !---------------------------------------------------------------------------
    ! DESCRIPTION:
    !> Evaluates the baryonic number density at a given energy density
    !
    !> Compute \f$ P \f$
    !---------------------------------------------------------------------------
    double precision function barionic_density_from_eos_table(parameters, dimless_rho)
    implicit none
        type(ConfigParameters), intent(in) :: parameters
        double precision, intent(in) :: dimless_rho

        type(EquationOfStateValue), pointer :: eos_value
        double precision :: bar_density_bar

        eos_value => parameters%first_element

        !DEBUG
        !write (*,*) '(dimless_rho, eos_value%rho_bar) = ', '(', &
        !    dimless_rho, ', ', &
        !    eos_value%rho, ' )';

        do while  (associated(eos_value%next_element) .and. .not. (dimless_rho <= eos_value%rho_bar .and. &
            dimless_rho >= eos_value%next_element%rho_bar))

            !write (*,*) '(dimless_rho, eos_value%rho_bar) = ', '(', &
            !    dimless_rho, ', ', &
            !    eos_value%rho_bar, ' )';

            eos_value => eos_value%next_element

        end do

        bar_density_bar = interpolation_baryonic_density_from_eos(parameters, eos_value, dimless_rho)

        barionic_density_from_eos_table = bar_density_bar

    end function barionic_density_from_eos_table

    !---------------------------------------------------------------------------
    ! DESCRIPTION:
    !> Evaluates the pressure P at a given density
    !
    !> Compute \f$ P \f$
    !---------------------------------------------------------------------------
    double precision function pressure_from_eos_table(parameters, dimless_rho)
    implicit none
        type(ConfigParameters), intent(in) :: parameters
        double precision, intent(in) :: dimless_rho

        type(EquationOfStateValue), pointer :: eos_value
        double precision :: pressure_bar

        eos_value => parameters%first_element

        !DEBUG
        !write (*,*) '(dimless_rho, eos_value%rho_bar) = ', '(', &
        !    dimless_rho, ', ', &
        !    eos_value%rho_bar, ' )';

        do while  (.not. (dimless_rho <= eos_value%rho_bar .and. &
            dimless_rho >= eos_value%next_element%rho_bar))

            eos_value => eos_value%next_element

        end do

        pressure_bar = interpolation_pressure_from_eos (parameters, eos_value, dimless_rho)

        pressure_from_eos_table = pressure_bar

    end function pressure_from_eos_table

   !---------------------------------------------------------------------------
    double precision function cs_h(current, next)
    implicit none
    type(InterpolationStepValue), intent(in) :: current, next

        cs_h = next%x - current%x

    end function cs_h

   !---------------------------------------------------------------------------
    double precision function linear_a(x1, y1, x2, y2)
    implicit none
    double precision, intent(in) :: x1, x2, y1, y2;

        linear_a = (y2 - y1)/(x2 - x1);

    end function linear_a

   !---------------------------------------------------------------------------
    double precision function linear_b(x1, y1, x2, y2)
    implicit none
    double precision, intent(in) :: x1, x2, y1, y2;

        linear_b = y1

    end function linear_b

   !---------------------------------------------------------------------------
    double precision function cs_alpha(previous, current, next)
    implicit none
    type(InterpolationStepValue), intent(in) :: previous, current, next
    double precision :: alpha

        if(current%h /= 0. .and. previous%h /= 0.) then
            alpha = (3. / current%h) * (next%a - current%a) - (3. / previous%h) * (current%a - previous%a);
        else
            alpha = 0.
        end if

        !write (*,*) '(alpha) = ', '(', alpha, ')';

        cs_alpha = alpha;

    end function cs_alpha

   !---------------------------------------------------------------------------
    double precision function cs_l(previous, next)
    implicit none
    type(InterpolationStepValue), intent(in) :: previous, next

            cs_l = 2. * (next%x - previous%x) - previous%h * previous%mu;

    end function cs_l

   !---------------------------------------------------------------------------
    double precision function cs_mu(current)
    implicit none
    type(InterpolationStepValue), intent(in) :: current

        if(current%h /= 0.) then
            cs_mu = current%h - current%l;
        else
            cs_mu = 0
        end if

    end function cs_mu

   !---------------------------------------------------------------------------
    double precision function cs_z(previous, current)
    implicit none
    type(InterpolationStepValue), intent(in) :: previous, current

        if(current%h /= 0.) then
            cs_z = (current%alpha - previous%h * previous%z)/current%l;
        else
            cs_z = 0
        end if

    end function cs_z

   !---------------------------------------------------------------------------
    double precision function cs_coeficient_c(current, next)
    implicit none
    type(InterpolationStepValue), intent(in) :: current, next

        if(current%h /= 0.) then
            cs_coeficient_c = current%z - current%mu * next%c;
        else
            cs_coeficient_c = 0;
        end if

    end function cs_coeficient_c

   !---------------------------------------------------------------------------
    double precision function cs_coeficient_b(current, next)
    implicit none
    type(InterpolationStepValue), intent(in) :: current, next

        if(current%h /= .0) then

            cs_coeficient_b = (next%a - current%a) / current%h - &
                current%h * (next%c + 2. * current%c)/3.
        else
            cs_coeficient_b = 0
        end if
    end function cs_coeficient_b

   !---------------------------------------------------------------------------
    double precision function cs_coeficient_d(current, next)
    implicit none
    type(InterpolationStepValue), intent(in) :: current, next

        if(current%h /= 0.) then
            cs_coeficient_d = (next%c - current%c) / (3. * current%h)
        else
            cs_coeficient_d = 0
        end if
    end function cs_coeficient_d

    !---------------------------------------------------------------------------
    ! DESCRIPTION:
    !> Maybe later...
    !---------------------------------------------------------------------------
    subroutine generate_interpolation_values(cl_parameters, parameters)
        implicit none
        type(CommandLineParameters), intent(in) :: cl_parameters
        type(ConfigParameters), intent(in) :: parameters

        if(parameters%INTERPOLATION_METHOD == IDX_CUBIC_SPLINE) then

            call generate_cubic_spline_interpolation_values(cl_parameters, parameters)

        else if(parameters%INTERPOLATION_METHOD == IDX_LINEAR) then

            call generate_linear_interpolation_values(cl_parameters, parameters)

        end if

    end subroutine generate_interpolation_values

    !---------------------------------------------------------------------------
    ! DESCRIPTION:
    !> Maybe later...
    !---------------------------------------------------------------------------
    subroutine generate_cubic_spline_interpolation_values(cl_parameters, parameters)
        implicit none

        type(CommandLineParameters), intent(in) :: cl_parameters
        type(ConfigParameters), intent(in) :: parameters

        Type(EquationOfStateValue), pointer :: eos_element

        !STEP 1 - OK!
        eos_element => parameters%first_element

        do while (associated(eos_element%next_element%next_element))

            eos_element%RHO_FROM_PRESSURE%h = &
                cs_h(eos_element%RHO_FROM_PRESSURE, eos_element%next_element%RHO_FROM_PRESSURE)

            eos_element%PRESSURE_FROM_RHO%h = &
                cs_h(eos_element%PRESSURE_FROM_RHO, eos_element%next_element%PRESSURE_FROM_RHO)

            eos_element%RHO_FROM_BARYON_DENSITY%h = &
                cs_h(eos_element%RHO_FROM_BARYON_DENSITY, eos_element%next_element%RHO_FROM_BARYON_DENSITY)

            eos_element%BARYON_DENSITY_FROM_RHO%h = &
                cs_h(eos_element%BARYON_DENSITY_FROM_RHO, eos_element%next_element%BARYON_DENSITY_FROM_RHO)

            !DEBUG
            !write (*,*) '(j, RHO_FROM_PRESSURE%h, PRESSURE_FROM_RHO%h) = ', '(', &
            !    eos_element%idx_j, ', ', &
            !    eos_element%RHO_FROM_PRESSURE%h, ', ', &
            !    eos_element%PRESSURE_FROM_RHO%h, ')';

            eos_element => eos_element%next_element

        end do

        !STEP 2
        eos_element => parameters%first_element%next_element
        do while (associated(eos_element%next_element%next_element))

            eos_element%RHO_FROM_PRESSURE%alpha = &
                cs_alpha(eos_element%previous_element%RHO_FROM_PRESSURE, &
                    eos_element%RHO_FROM_PRESSURE, &
                    eos_element%next_element%RHO_FROM_PRESSURE)

            eos_element%PRESSURE_FROM_RHO%alpha = &
                cs_alpha(eos_element%previous_element%PRESSURE_FROM_RHO, &
                    eos_element%PRESSURE_FROM_RHO, &
                    eos_element%next_element%PRESSURE_FROM_RHO)

            eos_element%RHO_FROM_BARYON_DENSITY%alpha = &
                cs_alpha(eos_element%previous_element%RHO_FROM_BARYON_DENSITY, &
                    eos_element%RHO_FROM_BARYON_DENSITY, &
                    eos_element%next_element%RHO_FROM_BARYON_DENSITY)

            eos_element%BARYON_DENSITY_FROM_RHO%alpha = &
                cs_alpha(eos_element%previous_element%BARYON_DENSITY_FROM_RHO, &
                    eos_element%BARYON_DENSITY_FROM_RHO, &
                    eos_element%next_element%BARYON_DENSITY_FROM_RHO)

            !DEBUG
            !write (*,*) '(j, R_FROM_P%alpha, P_FROM_R%alpha) = ', '(', &
            !    eos_element%idx_j, ', ', &
            !    eos_element%RHO_FROM_PRESSURE%alpha, ', ', &
            !    eos_element%PRESSURE_FROM_RHO%alpha, ')';

            eos_element => eos_element%next_element

        end do

        !STEP 3
        parameters%first_element%RHO_FROM_PRESSURE%l = 1.
        parameters%first_element%PRESSURE_FROM_RHO%l = 1.

        parameters%first_element%RHO_FROM_PRESSURE%z = 0.
        parameters%first_element%PRESSURE_FROM_RHO%z = 0.

        parameters%first_element%RHO_FROM_PRESSURE%c = 0.
        parameters%first_element%PRESSURE_FROM_RHO%c = 0.

        parameters%first_element%RHO_FROM_BARYON_DENSITY%l = 1.
        parameters%first_element%BARYON_DENSITY_FROM_RHO%l = 1.
        parameters%first_element%RHO_FROM_BARYON_DENSITY%z = 0.
        parameters%first_element%BARYON_DENSITY_FROM_RHO%z = 0.
        parameters%first_element%RHO_FROM_BARYON_DENSITY%c = 0.
        parameters%first_element%BARYON_DENSITY_FROM_RHO%c = 0.

        !STEP 4 - OK
        eos_element => parameters%first_element%next_element

        do while (associated(eos_element%next_element%next_element))

            ! Let's calculate 'l'
            eos_element%RHO_FROM_PRESSURE%l = &
                cs_l(eos_element%previous_element%RHO_FROM_PRESSURE, eos_element%next_element%RHO_FROM_PRESSURE)
            eos_element%PRESSURE_FROM_RHO%l = &
                cs_l(eos_element%previous_element%PRESSURE_FROM_RHO, eos_element%next_element%PRESSURE_FROM_RHO)

            eos_element%RHO_FROM_BARYON_DENSITY%l = &
                cs_l(eos_element%previous_element%RHO_FROM_BARYON_DENSITY, eos_element%next_element%RHO_FROM_BARYON_DENSITY)
            eos_element%BARYON_DENSITY_FROM_RHO%l = &
                cs_l(eos_element%previous_element%BARYON_DENSITY_FROM_RHO, eos_element%next_element%BARYON_DENSITY_FROM_RHO)

            !DEBUG
            !write (*,*) '(j, R_FROM_P%l, P_FROM_R%l) = ', '(', &
            !    eos_element%idx_j, ', ', &
            !    eos_element%RHO_FROM_PRESSURE%l, ', ', &
            !    eos_element%PRESSURE_FROM_RHO%l, ')';

            ! Now calculate 'mu'
            eos_element%RHO_FROM_PRESSURE%mu = cs_mu(eos_element%RHO_FROM_PRESSURE)
            eos_element%PRESSURE_FROM_RHO%mu = cs_mu(eos_element%PRESSURE_FROM_RHO)

            eos_element%RHO_FROM_BARYON_DENSITY%mu = cs_mu(eos_element%RHO_FROM_BARYON_DENSITY)
            eos_element%BARYON_DENSITY_FROM_RHO%mu = cs_mu(eos_element%BARYON_DENSITY_FROM_RHO)

            !DEBUG
            !write (*,*) '(j, R_FROM_P%mu, P_FROM_R%mu) = ', '(', &
            !    eos_element%idx_j, ', ', &
            !    eos_element%RHO_FROM_PRESSURE%mu, ', ', &
            !    eos_element%PRESSURE_FROM_RHO%mu, ')';

            ! And now 'z'
            eos_element%RHO_FROM_PRESSURE%z = &
                cs_z(eos_element%previous_element%RHO_FROM_PRESSURE, eos_element%RHO_FROM_PRESSURE)

            eos_element%PRESSURE_FROM_RHO%z = &
                cs_z(eos_element%previous_element%PRESSURE_FROM_RHO, eos_element%PRESSURE_FROM_RHO)

            eos_element%RHO_FROM_BARYON_DENSITY%z = &
                cs_z(eos_element%previous_element%RHO_FROM_BARYON_DENSITY, eos_element%RHO_FROM_BARYON_DENSITY)

            eos_element%BARYON_DENSITY_FROM_RHO%z = &
                cs_z(eos_element%previous_element%BARYON_DENSITY_FROM_RHO, eos_element%BARYON_DENSITY_FROM_RHO)

            !DEBUG
            !write (*,*) '(j, R_FROM_P%z, P_FROM_R%z) = ', '(', &
            !    eos_element%idx_j, ', ', &
            !    eos_element%RHO_FROM_PRESSURE%z, ', ', &
            !    eos_element%PRESSURE_FROM_RHO%z, ')';

            eos_element => eos_element%next_element

        end do

        !STEP 5 - OK
        eos_element%RHO_FROM_PRESSURE%l = 1.
        eos_element%PRESSURE_FROM_RHO%l = 1.
        eos_element%RHO_FROM_PRESSURE%z = 0.
        eos_element%PRESSURE_FROM_RHO%z = 0.
        eos_element%RHO_FROM_PRESSURE%c = 0.
        eos_element%PRESSURE_FROM_RHO%c = 0.

        eos_element%RHO_FROM_BARYON_DENSITY%l = 1.
        eos_element%BARYON_DENSITY_FROM_RHO%l = 1.
        eos_element%RHO_FROM_BARYON_DENSITY%z = 0.
        eos_element%BARYON_DENSITY_FROM_RHO%z = 0.
        eos_element%RHO_FROM_BARYON_DENSITY%c = 0.
        eos_element%BARYON_DENSITY_FROM_RHO%c = 0.

        !STEP 6 - OK
        eos_element => eos_element%previous_element
        do while (associated(eos_element))

            !Coeficient c
            eos_element%RHO_FROM_PRESSURE%c = &
                cs_coeficient_c(eos_element%RHO_FROM_PRESSURE, eos_element%next_element%RHO_FROM_PRESSURE)
            eos_element%PRESSURE_FROM_RHO%c = &
                cs_coeficient_c(eos_element%PRESSURE_FROM_RHO, eos_element%next_element%PRESSURE_FROM_RHO)

            !Coeficient b
            eos_element%RHO_FROM_PRESSURE%b = &
                cs_coeficient_b(eos_element%RHO_FROM_PRESSURE, eos_element%next_element%RHO_FROM_PRESSURE)
            eos_element%PRESSURE_FROM_RHO%b = &
                cs_coeficient_b(eos_element%PRESSURE_FROM_RHO, eos_element%next_element%PRESSURE_FROM_RHO)

            !Coeficient d
            eos_element%RHO_FROM_PRESSURE%d = &
                cs_coeficient_d(eos_element%RHO_FROM_PRESSURE, eos_element%next_element%RHO_FROM_PRESSURE)
            eos_element%PRESSURE_FROM_RHO%d = &
                cs_coeficient_d(eos_element%PRESSURE_FROM_RHO, eos_element%next_element%PRESSURE_FROM_RHO)

            eos_element%RHO_FROM_BARYON_DENSITY%c = &
                cs_coeficient_c(eos_element%RHO_FROM_BARYON_DENSITY, eos_element%next_element%RHO_FROM_BARYON_DENSITY)
            eos_element%BARYON_DENSITY_FROM_RHO%c = &
                cs_coeficient_c(eos_element%BARYON_DENSITY_FROM_RHO, eos_element%next_element%BARYON_DENSITY_FROM_RHO)

            eos_element%RHO_FROM_BARYON_DENSITY%b = &
                cs_coeficient_b(eos_element%RHO_FROM_BARYON_DENSITY, eos_element%next_element%RHO_FROM_BARYON_DENSITY)
            eos_element%BARYON_DENSITY_FROM_RHO%b = &
                cs_coeficient_b(eos_element%BARYON_DENSITY_FROM_RHO, eos_element%next_element%BARYON_DENSITY_FROM_RHO)

            eos_element%RHO_FROM_BARYON_DENSITY%d = &
                cs_coeficient_d(eos_element%RHO_FROM_BARYON_DENSITY, eos_element%next_element%RHO_FROM_BARYON_DENSITY)
            eos_element%BARYON_DENSITY_FROM_RHO%d = &
                cs_coeficient_d(eos_element%BARYON_DENSITY_FROM_RHO, eos_element%next_element%BARYON_DENSITY_FROM_RHO)

            eos_element => eos_element%previous_element

        end do

    end subroutine generate_cubic_spline_interpolation_values

    !---------------------------------------------------------------------------
    ! DESCRIPTION:
    !> Maybe later...
    !---------------------------------------------------------------------------
    subroutine generate_linear_interpolation_values(cl_parameters, parameters)
        implicit none

        type(CommandLineParameters), intent(in) :: cl_parameters
        type(ConfigParameters), intent(in) :: parameters

        Type(EquationOfStateValue), pointer :: eos_element

        !STEP 1 - OK!
        eos_element => parameters%first_element

        do while (associated(eos_element%next_element%next_element))

            eos_element%RHO_FROM_PRESSURE%a = &
                linear_a(eos_element%pressure_bar, eos_element%rho_bar, &
                    eos_element%next_element%pressure_bar, eos_element%next_element%rho_bar);
            eos_element%RHO_FROM_PRESSURE%b = &
                linear_b(eos_element%pressure_bar, eos_element%rho_bar, &
                    eos_element%next_element%pressure_bar, eos_element%next_element%rho_bar);

            eos_element%PRESSURE_FROM_RHO%a = &
                linear_a(eos_element%rho_bar, eos_element%pressure_bar, &
                    eos_element%next_element%rho_bar, eos_element%next_element%pressure_bar);
            eos_element%PRESSURE_FROM_RHO%b = &
                linear_b(eos_element%rho_bar, eos_element%pressure_bar, &
                    eos_element%next_element%rho_bar, eos_element%next_element%pressure_bar);

            eos_element%RHO_FROM_BARYON_DENSITY%a = &
                linear_a(eos_element%baryonic_number_density_bar, eos_element%rho_bar, &
                    eos_element%next_element%baryonic_number_density_bar, eos_element%next_element%rho_bar);
            eos_element%RHO_FROM_BARYON_DENSITY%b = &
                linear_b(eos_element%baryonic_number_density_bar, eos_element%rho_bar, &
                    eos_element%next_element%baryonic_number_density_bar, eos_element%next_element%rho_bar);

            eos_element%BARYON_DENSITY_FROM_RHO%a = &
                linear_a(eos_element%rho_bar, eos_element%baryonic_number_density_bar, &
                    eos_element%next_element%rho_bar, eos_element%next_element%baryonic_number_density_bar);
            eos_element%BARYON_DENSITY_FROM_RHO%b = &
                linear_b(eos_element%rho_bar, eos_element%baryonic_number_density_bar, &
                    eos_element%next_element%rho_bar, eos_element%next_element%baryonic_number_density_bar);

            eos_element => eos_element%next_element

        end do

    end subroutine generate_linear_interpolation_values

    !> \brief Function that interpolate the energy density from a given pressure
    !!
    !! \param parameters
    !! \param t
    !! \param Y
    !! \param V
    !! \return
    !!
    double precision function energy_density_from_eos(parameters, t, Y, V)
    implicit none
        type(ConfigParameters), intent(in) :: parameters
        double precision, intent(in) :: t
        double precision, intent(in) :: Y(N_DIFF_EQUATIONS)
        double precision, intent(in) :: V(N_VARIABLES)

        !double precision :: BAG_CONSTANT = 9.23D+034

        !< Must find in the table the correct density

        if(Y(IDX_PRESSURE_BAR) < parameters%last_element%pressure_bar) then
            energy_density_from_eos = 0.
        else
            energy_density_from_eos = density_from_eos_table(parameters, Y(IDX_PRESSURE_BAR))
        end if

        !Analytic expressions for DEBUG purposes only.
        !Uncomment if you are testing

        !rho = P/c^2
        !energy_density_from_eos = V(IDX_PRESSURE_BAR)

        !rho = RHO_0
        !energy_density_from_eos = 1

        !MIT BAG MODEL
        !energy_density_from_eos = 3. * V(IDX_PRESSURE_BAR) + 4. * &
        !    BAG_CONSTANT /(parameters%RHO_0 * LIGHT_SPEED(parameters%UNIT_SYSTEM)**2.)

    end function energy_density_from_eos

    !> \brief Evaluates the 3rd order polynomial to interpolate \rho(P)
    !!
    !! \param eos_element
    !! \param pressure_bar
    !! \return
    !!
    double precision function interpolation_rho_from_eos(parameters, eos_element, pressure_bar)
        type(ConfigParameters), intent(in) :: parameters
        type(EquationOfStateValue), pointer, intent(in) :: eos_element
        double precision, intent(in) :: pressure_bar

        double precision :: delta_x_bar

        type(InterpolationStepValue), pointer :: isv

        double precision :: rho_bar = 0.

        isv => eos_element%RHO_FROM_PRESSURE

        if(parameters%INTERPOLATION_METHOD == IDX_CUBIC_SPLINE) then

            delta_x_bar = pressure_bar - isv%x

            rho_bar = isv%a + isv%b * delta_x_bar + &
                                      isv%c * delta_x_bar**2. +isv%d * delta_x_bar**3.

        else if(parameters%INTERPOLATION_METHOD == IDX_LINEAR) then

            rho_bar = isv%a*(pressure_bar - eos_element%pressure_bar) + isv%b

        end if

        interpolation_rho_from_eos = rho_bar

    end function interpolation_rho_from_eos

    !---------------------------------------------------------------------------
    ! DESCRIPTION:
    !> Evaluates the pressure P at a given density
    !
    !> Compute \f$ P \f$
    !---------------------------------------------------------------------------
    double precision function density_from_eos_table(parameters, dimless_pressure)
    implicit none
        type(ConfigParameters), intent(in) :: parameters
        double precision, intent(in) :: dimless_pressure

        double precision :: rho_bar

        type(EquationOfStateValue), pointer :: eos_value

        double precision currentPressure, nextPressure

        !write (*,*) '(dimless_pressure) = (', dimless_pressure, ')'

        if(dimless_pressure <= 0.) then
            rho_bar = 0.
        else

            !Da pra otimizar isso aqui...
            eos_value => parameters%first_element

            currentPressure = parameters%first_element%pressure_bar
            nextPressure = parameters%first_element%next_element%pressure_bar

            do while  (.not. (currentPressure >= dimless_pressure .and. &
                nextPressure < dimless_pressure ))

                !write (*,*) '(currentPressure, nextPressure) = (', currentPressure, ', ', nextPressure, ')'

                if(associated(eos_value%next_element)) then

                    eos_value => eos_value%next_element

                    currentPressure = eos_value%pressure_bar

                    if(associated(eos_value%next_element)) then
                        nextPressure = eos_value%next_element%pressure_bar
                    else
                        nextPressure = 0.
                    end if
                end if

            end do

            rho_bar = interpolation_rho_from_eos (parameters, eos_value, dimless_pressure)

            !write (*,*) '(pressure_bar, rho_bar) = (', dimless_pressure, ', ', rho_bar, ')'
        end if

        density_from_eos_table = rho_bar

    end function density_from_eos_table

end module cubic_spline_module


      SUBROUTINE SCPINT(A,NA,B,NB)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1994-11-11 SCPINT Krogh   Declared all vars.
C>> 1994-10-20 SCPINT Krogh  Changes to use M77CON
C>> 1987-12-09 SCPINT Lawson  Initial code.
c--S replaces "?": ?CPINT
      INTEGER NA, NB, J, NBP1, K
      REAL             A(*),B(*),D1,D2,FAC,ZERO,HALF,TWO
      DATA ZERO,HALF,TWO/ 0.E0,.5E0, 2.E0 /
C
C     INTEGRATION OF FINITE CHEBYSHEV SERIES
C     C.L.LAWSON, JPL, 1973 JULY 18
C
C     (A(I),I=1,2)       SCALE FACTORS .
C     (A(I+2),I=1,NA+1)  COEFS OF CHEBY SERIES .
C     NA                 DEGREE OF CHEBY SERIES .
C     (B(I),I=1,2)       OUTPUT..  SCALE FACTORS .
C     (B(I+2),I=1,NB+1)  OUTPUT..  COEFS DEFINING INTEGRATED
C                                  SERIES .
C     NB                 OUTPUT..  DEGREE OF SERIES
C
      IF (NA .LT. 0) THEN
        CALL IERM1('SCPINT',1,0,'REQUIRE NA .GE. 0','NA',NA,'.')
      ELSE
        B(1)=A(1)
        B(2)=A(2)
        NB=NA+1
        D2=ZERO
        IF (NB .NE. 1) THEN
          D1=ZERO
          FAC=2*NB
          DO 50 J=1,NA
            B(NA+5-J) = (A(NA+4-J)-D2)/FAC
            D2=D1
            D1=A(NA+4-J)
   50       FAC=FAC-TWO
        END IF
        B(4)=A(3)-HALF*D2
        B(3)=ZERO
        NBP1=NB+1
        DO 70 K=1,NBP1
   70     B(K+2)=B(K+2)*B(2)
      END IF
      RETURN
      END


!=======================================================================
   Real(8) FUNCTION azl(z, h, ks, lp)
!=======================================================================
!
!   Value of B_(lp+1)/r^lp at r = 0 where lp = l+1
!----------------------------------------------------------------------

      IMPLICIT NONE

      INTEGER, INTENT(in) :: ks, lp
      REAL(8), INTENT(in) :: z, h

      INTEGER(4) :: j
      REAL(8) :: c

      IF (lp < ks) THEN
         azl = 1.d0
         c = z/h
         do j = 1, lp
            azl = (azl*c*(ks - j))/(j*j)
         end do
      ELSE
         azl = 0.d0
      END IF

   END FUNCTION azl


module simulation_mod
  use helpers_mod
  implicit none

  contains

  subroutine compute_tentative_velocity(u, v, f, g, flag, del_t)
    real u(0:imax+1, 0:jmax+1), v(0:imax+1, 0:jmax+1), f(0:imax+1, 0:jmax+1),  &
         g(0:imax+1, 0:jmax+1)
    integer flag(0:imax+1, 0:jmax+1)
    real, intent(in) :: del_t

    integer i, j
    real du2dx, duvdy, duvdx, dv2dy, laplu, laplv

    do i = 1, (imax-1)
      do j = 1, jmax
        ! only if both adjacent cells are fluid cells */
        if (toLogical(iand(flag(i,j), C_F)) .and.                              &
            toLogical(iand(flag(i+1,j), C_F))) then

          du2dx = ((u(i,j)+u(i+1,j))*(u(i,j)+u(i+1,j))+                        &
                  gamma*abs(u(i,j)+u(i+1,j))*(u(i,j)-u(i+1,j))-                &
                  (u(i-1,j)+u(i,j))*(u(i-1,j)+u(i,j))-                         &
                  gamma*abs(u(i-1,j)+u(i,j))*(u(i-1,j)-u(i,j)))                &
                  /(4.0*delx)
          duvdy = ((v(i,j)+v(i+1,j))*(u(i,j)+u(i,j+1))+                        &
                  gamma*abs(v(i,j)+v(i+1,j))*(u(i,j)-u(i,j+1))-                &
                  (v(i,j-1)+v(i+1,j-1))*(u(i,j-1)+u(i,j))-                     &
                  gamma*abs(v(i,j-1)+v(i+1,j-1))*(u(i,j-1)-u(i,j)))            &
                        /(4.0*dely)
          laplu = (u(i+1,j)-2.0*u(i,j)+u(i-1,j))/delx/delx+                    &
                  (u(i,j+1)-2.0*u(i,j)+u(i,j-1))/dely/dely

          f(i,j) = u(i,j) + del_t*(laplu/Re-du2dx-duvdy)
        else
          f(i,j) = u(i,j)
        end if
      end do
    end do

    do i = 1, imax
       do j = 1, (jmax-1)
          ! only if both adjacent cells are fluid cells
          if (toLogical(iand(flag(i,j), C_F)) .and.                            &
              toLogical(iand(flag(i,j+1), C_F))) then

             duvdx = ((u(i,j)+u(i,j+1))*(v(i,j)+v(i+1,j))+                     &
                      gamma*abs(u(i,j)+u(i,j+1))*(v(i,j)-v(i+1,j))-            &
                      (u(i-1,j)+u(i-1,j+1))*(v(i-1,j)+v(i,j))-                 &
                      gamma*abs(u(i-1,j)+u(i-1,j+1))*(v(i-1,j)-v(i,j)))        &
                      /(4.0*delx)
             dv2dy = ((v(i,j)+v(i,j+1))*(v(i,j)+v(i,j+1))+                     &
                      gamma*abs(v(i,j)+v(i,j+1))*(v(i,j)-v(i,j+1))-            &
                      (v(i,j-1)+v(i,j))*(v(i,j-1)+v(i,j))-                     &
                      gamma*abs(v(i,j-1)+v(i,j))*(v(i,j-1)-v(i,j)))            &
                      /(4.0*dely)

          laplv = (v(i+1,j)-2.0*v(i,j)+v(i-1,j))/delx/delx+                    &
                  (v(i,j+1)-2.0*v(i,j)+v(i,j-1))/dely/dely

          g(i,j) = v(i,j)+del_t*(laplv/Re-duvdx-dv2dy)
        else
          g(i,j) = v(i,j)
        end if
      end do
    end do

    f(0, 1:jmax) = u(0, 1:jmax)
    f(imax, 1:jmax) = u(imax, 1:jmax)

    g(1:imax, 0) = v(1:imax, 0)
    g(1:imax, jmax) = v(1:imax, jmax)
  end subroutine compute_tentative_velocity

  subroutine compute_rhs(f, g, rhs, flag, del_t)
    real rhs(0:imax+1, 0:jmax+1)
    real f(0:imax+1, 0:jmax+1), g(0:imax+1, 0:jmax+1)
    integer flag(0:imax+1, 0:jmax+1)
    real, intent(in) :: del_t

    integer :: i, j

    do i = 1, imax
      do j = 1, jmax
        if (toLogical(iand(flag(i,j), C_F))) then
          ! only do fluid and non-surface cells */
          rhs(i,j) = ((f(i,j)-f(i-1,j))/delx + (g(i,j)-g(i,j-1))/dely) / del_t
        end if
      end do
    end do
  end subroutine compute_rhs

  integer function poisson(p, rhs, flag, res, ifluid)
    integer, intent(in) :: ifluid
    real :: res
    real p(0:imax+1, 0:jmax+1), rhs(0:imax+1, 0:jmax+1)
    integer flag(0:imax+1, 0:jmax+1)

    integer :: i, j, iter
    real :: resp, beta_mod, p0 = 0.0

    integer :: eps_E, eps_W, eps_N, eps_S

    integer :: rb

    real :: rdx2 = 1.0/(delx*delx)
    real :: rdy2 = 1.0/(dely*dely)
    real :: beta_2

    beta_2 = -omega/(2.0*(rdx2+rdy2))

    ! Calculate sum of squares
    do i = 1, imax
      do j = 1, jmax
        if (toLogical(iand(flag(i,j), C_F))) p0 = p0 + p(i,j)*p(i,j)
      end do
    end do

    p0 = sqrt(p0/ifluid)
    if (p0 < 0.0001) p0 = 1.0

    ! Red/Black SOR-iteration
    do iter = 0, (itermax-1)
      do rb = 0, 1, 1
        do i = 1,  imax, 1
          do j = 1, jmax, 1
            eps_E = toMask(iand(flag(i+1,j), C_F))
            eps_W = toMask(iand(flag(i-1,j), C_F))
            eps_N = toMask(iand(flag(i,j+1), C_F))
            eps_S = toMask(iand(flag(i,j-1), C_F))

            if (mod((i+j),2) == rb) then
              if (flag(i,j) == (ior(C_F, B_NSEW))) then
                ! five point star for interior fluid cells
                p(i,j) = (1.-omega)*p(i,j) -                                 &
                         beta_2*((p(i+1,j)+p(i-1,j))*rdx2                    &
                                 + (p(i,j+1)+p(i,j-1))*rdy2                  &
                                 - rhs(i,j))
              else if (toLogical(iand(flag(i,j), C_F))) then
                ! modified star near boundary
                beta_mod = -omega/((eps_E+eps_W)*rdx2+(eps_N+eps_S)*rdy2)
                p(i,j) = (1.-omega)*p(i,j) -                                 &
                         beta_mod*((eps_E*p(i+1,j)+eps_W*p(i-1,j))*rdx2      &
                                   + (eps_N*p(i,j+1)+eps_S*p(i,j-1))*rdy2    &
                                   - rhs(i,j))
              end if
            end if
          end do ! end of j
        end do ! end of i
      end do ! end of rb

      !Partial computation of residual
      res = 0.0
      do i = 1, imax
        do j = 1, jmax
          if (toLogical(iand(flag(i,j), C_F))) then
            ! only fluid cells
            eps_E = toMask(iand(flag(i+1,j), C_F))
            eps_W = toMask(iand(flag(i-1,j), C_F))
            eps_N = toMask(iand(flag(i,j+1), C_F))
            eps_S = toMask(iand(flag(i,j-1), C_F))

            resp = ((eps_E*(p(i+1,j) - p(i,j))) -                            &
                    (eps_W*(p(i,j) - p(i-1,j)))) * rdx2  +                   &
                   (((eps_N*(p(i,j+1) - p(i,j))) -                           &
                    (eps_S*(p(i,j)-p(i,j-1)))) * rdy2)  - rhs(i,j)
            res = res + resp*resp
          end if
        end do
      end do

      ! write (*,*) res, ifluid, p0
      res = sqrt((res)/ifluid)/p0

      ! convergence?
      if (res<eps) exit

    end do ! end of iter

    poisson = iter
  end function poisson

  subroutine update_velocity(u, v, f, g, p, flag, del_t)
    real u(0:imax+1, 0:jmax+1), v(0:imax+1, 0:jmax+1), f(0:imax+1, 0:jmax+1),  &
         g(0:imax+1, 0:jmax+1), p(0:imax+1, 0:jmax+1)
    integer flag(0:imax+1, 0:jmax+1)
    real, intent(in) :: del_t

    integer :: i, j

    do i = 1, (imax-1)
      do j = 1, jmax
        ! only if both adjacent cells are fluid cells */
        if (toLogical(iand(flag(i,j), C_F)) .and.                              &
            toLogical(iand(flag(i+1,j), C_F))) then
          u(i,j) = f(i,j)-(p(i+1,j)-p(i,j))*del_t/delx
        end if
      end do
    end do
    do i = 1, imax
      do j = 1, (jmax-1)
        ! only if both adjacent cells are fluid cells
        if (toLogical(iand(flag(i,j), C_F)) .and.                              &
            toLogical(iand(flag(i,j+1), C_F))) then
          v(i,j) = g(i,j)-(p(i,j+1)-p(i,j))*del_t/dely
        end if
      end do
    end do
  end subroutine update_velocity

  real function set_timestep_interval(u, v, del_t)
    integer :: i, j
    real, intent(in) :: del_t
    real u(0:imax+1, 0:jmax+1), v(0:imax+1, 0:jmax+1)
    real :: umax, vmax, deltu, deltv, deltRe, del_tp

    ! del_t satisfying CFL conditions
    if (tau >= 1.0e-10) then
      umax = 1.0e-10
      vmax = 1.0e-10

      do i = 0, (imax+1), 1
        do j = 1, (jmax+1), 1
          umax = max(abs(u(i,j)), umax)
        end do
      end do
      do  i = 1, (imax+1), 1
        do j = 0, (jmax+1), 1
          vmax = max(abs(v(i,j)), vmax)
        end do
      end do

      deltu = delx/umax
      deltv = dely/vmax
      deltRe = 1/(1/(delx*delx)+1/(dely*dely))*Re/2.0

      if (deltu < deltv) then
        del_tp = min(deltu, deltRe)
      else
        del_tp = min(deltv, deltRe)
      end if

      !multiply by safety factor
      set_timestep_interval = tau * (del_tp)
    else
      set_timestep_interval = del_t
    end if
  end function set_timestep_interval
end module simulation_mod


      MODULE MOD_LIPO
      contains
C**********  MODULNAME: LIPO      ******* 24/03/87  21.17.46.******    25 KARTEN
      SUBROUTINE LIPO (F,X,FI,XI,N)
C***  LINEAR INTERPOLATION: FOR GIVEN X, FIND F(X) FROM A TABLE FI(XI)
C ------ INDEXSUCHE DURCH BISECTION ------

      IMPLICIT REAL*8(A-H,O-Z)

      DIMENSION FI(N),XI(N)
      NA=1
      A=XI(1)
      NB=N
      B=XI(N)
      IF((X-A)*(X-B).GT..0) STOP 'ERROR'
    1 IF((NB-NA).EQ.1) GOTO 2
      NH=(NA+NB)/2
      H=XI(NH)
      IF((X-A)*(X-H).GT..0) GOTO 3
      NB=NH
      B=H
      GOTO 1
    3 NA=NH
      A=H
      GOTO 1

    2 P=(X-A)/(B-A)
      F=P*FI(NB)+(1.-P)*FI(NA)
      RETURN
      END SUBROUTINE
      END MODULE


      SUBROUTINE CHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB,
     $                   ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK,
     $                   RWORK, INFO )
*
*  -- LAPACK routine (instrumented to count operations, version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     June 30, 1999
*
*     .. Scalar Arguments ..
      CHARACTER          COMPQ, COMPZ, JOB
      INTEGER            IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, LWORK, N
*     ..
*     .. Array Arguments ..
      REAL               RWORK( * )
      COMPLEX            A( LDA, * ), ALPHA( * ), B( LDB, * ),
     $                   BETA( * ), Q( LDQ, * ), WORK( * ), Z( LDZ, * )
*     ..
*
*     ----------------------- Begin Timing Code ------------------------
*     Common block to return operation count and iteration count
*     ITCNT is initialized to 0, OPS is only incremented
*     OPST is used to accumulate small contributions to OPS
*     to avoid roundoff error
*     .. Common blocks ..
      COMMON             / LATIME / OPS, ITCNT
*     ..
*     .. Scalars in Common ..
      REAL               ITCNT, OPS
*     ..
*     ------------------------ End Timing Code -------------------------
*
*
*  Purpose
*  =======
*
*  CHGEQZ implements a single-shift version of the QZ
*  method for finding the generalized eigenvalues w(i)=ALPHA(i)/BETA(i)
*  of the equation
*
*       det( A - w(i) B ) = 0
*
*  If JOB='S', then the pair (A,B) is simultaneously
*  reduced to Schur form (i.e., A and B are both upper triangular) by
*  applying one unitary tranformation (usually called Q) on the left and
*  another (usually called Z) on the right.  The diagonal elements of
*  A are then ALPHA(1),...,ALPHA(N), and of B are BETA(1),...,BETA(N).
*
*  If JOB='S' and COMPQ and COMPZ are 'V' or 'I', then the unitary
*  transformations used to reduce (A,B) are accumulated into the arrays
*  Q and Z s.t.:
*
*       Q(in) A(in) Z(in)* = Q(out) A(out) Z(out)*
*       Q(in) B(in) Z(in)* = Q(out) B(out) Z(out)*
*
*  Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix
*       Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973),
*       pp. 241--256.
*
*  Arguments
*  =========
*
*  JOB     (input) CHARACTER*1
*          = 'E': compute only ALPHA and BETA.  A and B will not
*                 necessarily be put into generalized Schur form.
*          = 'S': put A and B into generalized Schur form, as well
*                 as computing ALPHA and BETA.
*
*  COMPQ   (input) CHARACTER*1
*          = 'N': do not modify Q.
*          = 'V': multiply the array Q on the right by the conjugate
*                 transpose of the unitary tranformation that is
*                 applied to the left side of A and B to reduce them
*                 to Schur form.
*          = 'I': like COMPQ='V', except that Q will be initialized to
*                 the identity first.
*
*  COMPZ   (input) CHARACTER*1
*          = 'N': do not modify Z.
*          = 'V': multiply the array Z on the right by the unitary
*                 tranformation that is applied to the right side of
*                 A and B to reduce them to Schur form.
*          = 'I': like COMPZ='V', except that Z will be initialized to
*                 the identity first.
*
*  N       (input) INTEGER
*          The order of the matrices A, B, Q, and Z.  N >= 0.
*
*  ILO     (input) INTEGER
*  IHI     (input) INTEGER
*          It is assumed that A is already upper triangular in rows and
*          columns 1:ILO-1 and IHI+1:N.
*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
*
*  A       (input/output) COMPLEX array, dimension (LDA, N)
*          On entry, the N-by-N upper Hessenberg matrix A.  Elements
*          below the subdiagonal must be zero.
*          If JOB='S', then on exit A and B will have been
*             simultaneously reduced to upper triangular form.
*          If JOB='E', then on exit A will have been destroyed.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max( 1, N ).
*
*  B       (input/output) COMPLEX array, dimension (LDB, N)
*          On entry, the N-by-N upper triangular matrix B.  Elements
*          below the diagonal must be zero.
*          If JOB='S', then on exit A and B will have been
*             simultaneously reduced to upper triangular form.
*          If JOB='E', then on exit B will have been destroyed.
*
*  LDB     (input) INTEGER
*          The leading dimension of the array B.  LDB >= max( 1, N ).
*
*  ALPHA   (output) COMPLEX array, dimension (N)
*          The diagonal elements of A when the pair (A,B) has been
*          reduced to Schur form.  ALPHA(i)/BETA(i) i=1,...,N
*          are the generalized eigenvalues.
*
*  BETA    (output) COMPLEX array, dimension (N)
*          The diagonal elements of B when the pair (A,B) has been
*          reduced to Schur form.  ALPHA(i)/BETA(i) i=1,...,N
*          are the generalized eigenvalues.  A and B are normalized
*          so that BETA(1),...,BETA(N) are non-negative real numbers.
*
*  Q       (input/output) COMPLEX array, dimension (LDQ, N)
*          If COMPQ='N', then Q will not be referenced.
*          If COMPQ='V' or 'I', then the conjugate transpose of the
*             unitary transformations which are applied to A and B on
*             the left will be applied to the array Q on the right.
*
*  LDQ     (input) INTEGER
*          The leading dimension of the array Q.  LDQ >= 1.
*          If COMPQ='V' or 'I', then LDQ >= N.
*
*  Z       (input/output) COMPLEX array, dimension (LDZ, N)
*          If COMPZ='N', then Z will not be referenced.
*          If COMPZ='V' or 'I', then the unitary transformations which
*             are applied to A and B on the right will be applied to the
*             array Z on the right.
*
*  LDZ     (input) INTEGER
*          The leading dimension of the array Z.  LDZ >= 1.
*          If COMPZ='V' or 'I', then LDZ >= N.
*
*  WORK    (workspace/output) COMPLEX array, dimension (LWORK)
*          On exit, if INFO >= 0, WORK(1) returns the optimal LWORK.
*
*  LWORK   (input) INTEGER
*          The dimension of the array WORK.  LWORK >= max(1,N).
*
*          If LWORK = -1, then a workspace query is assumed; the routine
*          only calculates the optimal size of the WORK array, returns
*          this value as the first entry of the WORK array, and no error
*          message related to LWORK is issued by XERBLA.
*
*  RWORK   (workspace) REAL array, dimension (N)
*
*  INFO    (output) INTEGER
*          = 0: successful exit
*          < 0: if INFO = -i, the i-th argument had an illegal value
*          = 1,...,N: the QZ iteration did not converge.  (A,B) is not
*                     in Schur form, but ALPHA(i) and BETA(i),
*                     i=INFO+1,...,N should be correct.
*          = N+1,...,2*N: the shift calculation failed.  (A,B) is not
*                     in Schur form, but ALPHA(i) and BETA(i),
*                     i=INFO-N+1,...,N should be correct.
*          > 2*N:     various "impossible" errors.
*
*  Further Details
*  ===============
*
*  We assume that complex ABS works as long as its value is less than
*  overflow.
*
*  =====================================================================
*
*     .. Parameters ..
      COMPLEX            CZERO, CONE
      PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ),
     $                   CONE = ( 1.0E+0, 0.0E+0 ) )
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
      REAL               HALF
      PARAMETER          ( HALF = 0.5E+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            ILAZR2, ILAZRO, ILQ, ILSCHR, ILZ, LQUERY
      INTEGER            ICOMPQ, ICOMPZ, IFIRST, IFRSTM, IITER, ILAST,
     $                   ILASTM, IN, ISCHUR, ISTART, J, JC, JCH, JITER,
     $                   JR, MAXIT, NQ, NZ
      REAL               ABSB, ANORM, ASCALE, ATOL, BNORM, BSCALE, BTOL,
     $                   C, OPST, SAFMIN, TEMP, TEMP2, TEMPR, ULP
      COMPLEX            ABI22, AD11, AD12, AD21, AD22, CTEMP, CTEMP2,
     $                   CTEMP3, ESHIFT, RTDISC, S, SHIFT, SIGNBC, T,
     $                   U12, X
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      REAL               CLANHS, SLAMCH
      EXTERNAL           LSAME, CLANHS, SLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           CLARTG, CLASET, CROT, CSCAL, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, AIMAG, CMPLX, CONJG, MAX, MIN, REAL, SQRT
*     ..
*     .. Statement Functions ..
      REAL               ABS1
*     ..
*     .. Statement Function definitions ..
      ABS1( X ) = ABS( REAL( X ) ) + ABS( AIMAG( X ) )
*     ..
*     .. Executable Statements ..
*     ----------------------- Begin Timing Code ------------------------
      ITCNT = ZERO
*     ------------------------ End Timing Code -------------------------
*
*     Decode JOB, COMPQ, COMPZ
*
      IF( LSAME( JOB, 'E' ) ) THEN
         ILSCHR = .FALSE.
         ISCHUR = 1
      ELSE IF( LSAME( JOB, 'S' ) ) THEN
         ILSCHR = .TRUE.
         ISCHUR = 2
      ELSE
         ISCHUR = 0
      END IF
*
      IF( LSAME( COMPQ, 'N' ) ) THEN
         ILQ = .FALSE.
         ICOMPQ = 1
         NQ = 0
      ELSE IF( LSAME( COMPQ, 'V' ) ) THEN
         ILQ = .TRUE.
         ICOMPQ = 2
         NQ = N
      ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
         ILQ = .TRUE.
         ICOMPQ = 3
         NQ = N
      ELSE
         ICOMPQ = 0
      END IF
*
      IF( LSAME( COMPZ, 'N' ) ) THEN
         ILZ = .FALSE.
         ICOMPZ = 1
         NZ = 0
      ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
         ILZ = .TRUE.
         ICOMPZ = 2
         NZ = N
      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
         ILZ = .TRUE.
         ICOMPZ = 3
         NZ = N
      ELSE
         ICOMPZ = 0
      END IF
*
*     Check Argument Values
*
      INFO = 0
      WORK( 1 ) = MAX( 1, N )
      LQUERY = ( LWORK.EQ.-1 )
      IF( ISCHUR.EQ.0 ) THEN
         INFO = -1
      ELSE IF( ICOMPQ.EQ.0 ) THEN
         INFO = -2
      ELSE IF( ICOMPZ.EQ.0 ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( ILO.LT.1 ) THEN
         INFO = -5
      ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN
         INFO = -6
      ELSE IF( LDA.LT.N ) THEN
         INFO = -8
      ELSE IF( LDB.LT.N ) THEN
         INFO = -10
      ELSE IF( LDQ.LT.1 .OR. ( ILQ .AND. LDQ.LT.N ) ) THEN
         INFO = -14
      ELSE IF( LDZ.LT.1 .OR. ( ILZ .AND. LDZ.LT.N ) ) THEN
         INFO = -16
      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
         INFO = -18
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CHGEQZ', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
*
*     Quick return if possible
*
c     WORK( 1 ) = CMPLX( 1 )
      IF( N.LE.0 ) THEN
         WORK( 1 ) = CMPLX( 1 )
         RETURN
      END IF
*
*     Initialize Q and Z
*
      IF( ICOMPQ.EQ.3 )
     $   CALL CLASET( 'Full', N, N, CZERO, CONE, Q, LDQ )
      IF( ICOMPZ.EQ.3 )
     $   CALL CLASET( 'Full', N, N, CZERO, CONE, Z, LDZ )
*
*     Machine Constants
*
      IN = IHI + 1 - ILO
      SAFMIN = SLAMCH( 'S' )
      ULP = SLAMCH( 'E' )*SLAMCH( 'B' )
      ANORM = CLANHS( 'F', IN, A( ILO, ILO ), LDA, RWORK )
      BNORM = CLANHS( 'F', IN, B( ILO, ILO ), LDB, RWORK )
      ATOL = MAX( SAFMIN, ULP*ANORM )
      BTOL = MAX( SAFMIN, ULP*BNORM )
      ASCALE = ONE / MAX( SAFMIN, ANORM )
      BSCALE = ONE / MAX( SAFMIN, BNORM )
*
*     ---------------------- Begin Timing Code -------------------------
*     Count ops for norms, etc.
      OPST = ZERO
      OPS = OPS + REAL( 4*N**2+12*N-5 )
*     ----------------------- End Timing Code --------------------------
*
*
*
*     Set Eigenvalues IHI+1:N
*
      DO 10 J = IHI + 1, N
         ABSB = ABS( B( J, J ) )
         IF( ABSB.GT.SAFMIN ) THEN
            SIGNBC = CONJG( B( J, J ) / ABSB )
            B( J, J ) = ABSB
            IF( ILSCHR ) THEN
               CALL CSCAL( J-1, SIGNBC, B( 1, J ), 1 )
               CALL CSCAL( J, SIGNBC, A( 1, J ), 1 )
*              ----------------- Begin Timing Code ---------------------
               OPST = OPST + REAL( 12*( J-1 ) )
*              ------------------ End Timing Code ----------------------
            ELSE
               A( J, J ) = A( J, J )*SIGNBC
            END IF
            IF( ILZ )
     $         CALL CSCAL( N, SIGNBC, Z( 1, J ), 1 )
*           ------------------- Begin Timing Code ----------------------
            OPST = OPST + REAL( 6*NZ+13 )
*           -------------------- End Timing Code -----------------------
         ELSE
            B( J, J ) = CZERO
         END IF
         ALPHA( J ) = A( J, J )
         BETA( J ) = B( J, J )
   10 CONTINUE
*
*     If IHI < ILO, skip QZ steps
*
      IF( IHI.LT.ILO )
     $   GO TO 190
*
*     MAIN QZ ITERATION LOOP
*
*     Initialize dynamic indices
*
*     Eigenvalues ILAST+1:N have been found.
*        Column operations modify rows IFRSTM:whatever
*        Row operations modify columns whatever:ILASTM
*
*     If only eigenvalues are being computed, then
*        IFRSTM is the row of the last splitting row above row ILAST;
*        this is always at least ILO.
*     IITER counts iterations since the last eigenvalue was found,
*        to tell when to use an extraordinary shift.
*     MAXIT is the maximum number of QZ sweeps allowed.
*
      ILAST = IHI
      IF( ILSCHR ) THEN
         IFRSTM = 1
         ILASTM = N
      ELSE
         IFRSTM = ILO
         ILASTM = IHI
      END IF
      IITER = 0
      ESHIFT = CZERO
      MAXIT = 30*( IHI-ILO+1 )
*
      DO 170 JITER = 1, MAXIT
*
*        Check for too many iterations.
*
         IF( JITER.GT.MAXIT )
     $      GO TO 180
*
*        Split the matrix if possible.
*
*        Two tests:
*           1: A(j,j-1)=0  or  j=ILO
*           2: B(j,j)=0
*
*        Special case: j=ILAST
*
         IF( ILAST.EQ.ILO ) THEN
            GO TO 60
         ELSE
            IF( ABS1( A( ILAST, ILAST-1 ) ).LE.ATOL ) THEN
               A( ILAST, ILAST-1 ) = CZERO
               GO TO 60
            END IF
         END IF
*
         IF( ABS( B( ILAST, ILAST ) ).LE.BTOL ) THEN
            B( ILAST, ILAST ) = CZERO
            GO TO 50
         END IF
*
*        General case: j<ILAST
*
         DO 40 J = ILAST - 1, ILO, -1
*
*           Test 1: for A(j,j-1)=0 or j=ILO
*
            IF( J.EQ.ILO ) THEN
               ILAZRO = .TRUE.
            ELSE
               IF( ABS1( A( J, J-1 ) ).LE.ATOL ) THEN
                  A( J, J-1 ) = CZERO
                  ILAZRO = .TRUE.
               ELSE
                  ILAZRO = .FALSE.
               END IF
            END IF
*
*           Test 2: for B(j,j)=0
*
            IF( ABS( B( J, J ) ).LT.BTOL ) THEN
               B( J, J ) = CZERO
*
*              Test 1a: Check for 2 consecutive small subdiagonals in A
*
               ILAZR2 = .FALSE.
               IF( .NOT.ILAZRO ) THEN
                  IF( ABS1( A( J, J-1 ) )*( ASCALE*ABS1( A( J+1,
     $                J ) ) ).LE.ABS1( A( J, J ) )*( ASCALE*ATOL ) )
     $                ILAZR2 = .TRUE.
               END IF
*
*              If both tests pass (1 & 2), i.e., the leading diagonal
*              element of B in the block is zero, split a 1x1 block off
*              at the top. (I.e., at the J-th row/column) The leading
*              diagonal element of the remainder can also be zero, so
*              this may have to be done repeatedly.
*
               IF( ILAZRO .OR. ILAZR2 ) THEN
                  DO 20 JCH = J, ILAST - 1
                     CTEMP = A( JCH, JCH )
                     CALL CLARTG( CTEMP, A( JCH+1, JCH ), C, S,
     $                            A( JCH, JCH ) )
                     A( JCH+1, JCH ) = CZERO
                     CALL CROT( ILASTM-JCH, A( JCH, JCH+1 ), LDA,
     $                          A( JCH+1, JCH+1 ), LDA, C, S )
                     CALL CROT( ILASTM-JCH, B( JCH, JCH+1 ), LDB,
     $                          B( JCH+1, JCH+1 ), LDB, C, S )
                     IF( ILQ )
     $                  CALL CROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1,
     $                             C, CONJG( S ) )
                     IF( ILAZR2 )
     $                  A( JCH, JCH-1 ) = A( JCH, JCH-1 )*C
                     ILAZR2 = .FALSE.
*                    --------------- Begin Timing Code -----------------
                     OPST = OPST + REAL( 32+40*( ILASTM-JCH )+20*NQ )
*                    ---------------- End Timing Code ------------------
                     IF( ABS1( B( JCH+1, JCH+1 ) ).GE.BTOL ) THEN
                        IF( JCH+1.GE.ILAST ) THEN
                           GO TO 60
                        ELSE
                           IFIRST = JCH + 1
                           GO TO 70
                        END IF
                     END IF
                     B( JCH+1, JCH+1 ) = CZERO
   20             CONTINUE
                  GO TO 50
               ELSE
*
*                 Only test 2 passed -- chase the zero to B(ILAST,ILAST)
*                 Then process as in the case B(ILAST,ILAST)=0
*
                  DO 30 JCH = J, ILAST - 1
                     CTEMP = B( JCH, JCH+1 )
                     CALL CLARTG( CTEMP, B( JCH+1, JCH+1 ), C, S,
     $                            B( JCH, JCH+1 ) )
                     B( JCH+1, JCH+1 ) = CZERO
                     IF( JCH.LT.ILASTM-1 )
     $                  CALL CROT( ILASTM-JCH-1, B( JCH, JCH+2 ), LDB,
     $                             B( JCH+1, JCH+2 ), LDB, C, S )
                     CALL CROT( ILASTM-JCH+2, A( JCH, JCH-1 ), LDA,
     $                          A( JCH+1, JCH-1 ), LDA, C, S )
                     IF( ILQ )
     $                  CALL CROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1,
     $                             C, CONJG( S ) )
                     CTEMP = A( JCH+1, JCH )
                     CALL CLARTG( CTEMP, A( JCH+1, JCH-1 ), C, S,
     $                            A( JCH+1, JCH ) )
                     A( JCH+1, JCH-1 ) = CZERO
                     CALL CROT( JCH+1-IFRSTM, A( IFRSTM, JCH ), 1,
     $                          A( IFRSTM, JCH-1 ), 1, C, S )
                     CALL CROT( JCH-IFRSTM, B( IFRSTM, JCH ), 1,
     $                          B( IFRSTM, JCH-1 ), 1, C, S )
                     IF( ILZ )
     $                  CALL CROT( N, Z( 1, JCH ), 1, Z( 1, JCH-1 ), 1,
     $                             C, S )
   30             CONTINUE
*
*                 ---------------- Begin Timing Code -------------------
                  OPST = OPST + REAL( 64+40*( ILASTM+1-IFRSTM )+20*
     $                   ( NQ+NZ ) )*REAL( ILAST-J )
*                 ----------------- End Timing Code --------------------
*
                  GO TO 50
               END IF
            ELSE IF( ILAZRO ) THEN
*
*              Only test 1 passed -- work on J:ILAST
*
               IFIRST = J
               GO TO 70
            END IF
*
*           Neither test passed -- try next J
*
   40    CONTINUE
*
*        (Drop-through is "impossible")
*
         INFO = 2*N + 1
         GO TO 210
*
*        B(ILAST,ILAST)=0 -- clear A(ILAST,ILAST-1) to split off a
*        1x1 block.
*
   50    CONTINUE
         CTEMP = A( ILAST, ILAST )
         CALL CLARTG( CTEMP, A( ILAST, ILAST-1 ), C, S,
     $                A( ILAST, ILAST ) )
         A( ILAST, ILAST-1 ) = CZERO
         CALL CROT( ILAST-IFRSTM, A( IFRSTM, ILAST ), 1,
     $              A( IFRSTM, ILAST-1 ), 1, C, S )
         CALL CROT( ILAST-IFRSTM, B( IFRSTM, ILAST ), 1,
     $              B( IFRSTM, ILAST-1 ), 1, C, S )
         IF( ILZ )
     $      CALL CROT( N, Z( 1, ILAST ), 1, Z( 1, ILAST-1 ), 1, C, S )
*        --------------------- Begin Timing Code -----------------------
         OPST = OPST + REAL( 32+40*( ILAST-IFRSTM )+20*NZ )
*        ---------------------- End Timing Code ------------------------
*
*        A(ILAST,ILAST-1)=0 -- Standardize B, set ALPHA and BETA
*
   60    CONTINUE
         ABSB = ABS( B( ILAST, ILAST ) )
         IF( ABSB.GT.SAFMIN ) THEN
            SIGNBC = CONJG( B( ILAST, ILAST ) / ABSB )
            B( ILAST, ILAST ) = ABSB
            IF( ILSCHR ) THEN
               CALL CSCAL( ILAST-IFRSTM, SIGNBC, B( IFRSTM, ILAST ), 1 )
               CALL CSCAL( ILAST+1-IFRSTM, SIGNBC, A( IFRSTM, ILAST ),
     $                     1 )
*              ----------------- Begin Timing Code ---------------------
               OPST = OPST + REAL( 12*( ILAST-IFRSTM ) )
*              ------------------ End Timing Code ----------------------
            ELSE
               A( ILAST, ILAST ) = A( ILAST, ILAST )*SIGNBC
            END IF
            IF( ILZ )
     $         CALL CSCAL( N, SIGNBC, Z( 1, ILAST ), 1 )
*           ------------------- Begin Timing Code ----------------------
            OPST = OPST + REAL( 6*NZ+13 )
*           -------------------- End Timing Code -----------------------
         ELSE
            B( ILAST, ILAST ) = CZERO
         END IF
         ALPHA( ILAST ) = A( ILAST, ILAST )
         BETA( ILAST ) = B( ILAST, ILAST )
*
*        Go to next block -- exit if finished.
*
         ILAST = ILAST - 1
         IF( ILAST.LT.ILO )
     $      GO TO 190
*
*        Reset counters
*
         IITER = 0
         ESHIFT = CZERO
         IF( .NOT.ILSCHR ) THEN
            ILASTM = ILAST
            IF( IFRSTM.GT.ILAST )
     $         IFRSTM = ILO
         END IF
         GO TO 160
*
*        QZ step
*
*        This iteration only involves rows/columns IFIRST:ILAST.  We
*        assume IFIRST < ILAST, and that the diagonal of B is non-zero.
*
   70    CONTINUE
         IITER = IITER + 1
         IF( .NOT.ILSCHR ) THEN
            IFRSTM = IFIRST
         END IF
*
*        Compute the Shift.
*
*        At this point, IFIRST < ILAST, and the diagonal elements of
*        B(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in
*        magnitude)
*
         IF( ( IITER / 10 )*10.NE.IITER ) THEN
*
*           The Wilkinson shift (AEP p.512), i.e., the eigenvalue of
*           the bottom-right 2x2 block of A inv(B) which is nearest to
*           the bottom-right element.
*
*           We factor B as U*D, where U has unit diagonals, and
*           compute (A*inv(D))*inv(U).
*
            U12 = ( BSCALE*B( ILAST-1, ILAST ) ) /
     $            ( BSCALE*B( ILAST, ILAST ) )
            AD11 = ( ASCALE*A( ILAST-1, ILAST-1 ) ) /
     $             ( BSCALE*B( ILAST-1, ILAST-1 ) )
            AD21 = ( ASCALE*A( ILAST, ILAST-1 ) ) /
     $             ( BSCALE*B( ILAST-1, ILAST-1 ) )
            AD12 = ( ASCALE*A( ILAST-1, ILAST ) ) /
     $             ( BSCALE*B( ILAST, ILAST ) )
            AD22 = ( ASCALE*A( ILAST, ILAST ) ) /
     $             ( BSCALE*B( ILAST, ILAST ) )
            ABI22 = AD22 - U12*AD21
*
            T = HALF*( AD11+ABI22 )
            RTDISC = SQRT( T**2+AD12*AD21-AD11*AD22 )
            TEMP = REAL( T-ABI22 )*REAL( RTDISC ) +
     $             AIMAG( T-ABI22 )*AIMAG( RTDISC )
            IF( TEMP.LE.ZERO ) THEN
               SHIFT = T + RTDISC
            ELSE
               SHIFT = T - RTDISC
            END IF
*
*           ------------------- Begin Timing Code ----------------------
            OPST = OPST + REAL( 116 )
*           -------------------- End Timing Code -----------------------
*
         ELSE
*
*           Exceptional shift.  Chosen for no particularly good reason.
*
            ESHIFT = ESHIFT + CONJG( ( ASCALE*A( ILAST-1, ILAST ) ) /
     $               ( BSCALE*B( ILAST-1, ILAST-1 ) ) )
            SHIFT = ESHIFT
*
*           ------------------- Begin Timing Code ----------------------
            OPST = OPST + REAL( 15 )
*           -------------------- End Timing Code -----------------------
*
         END IF
*
*        Now check for two consecutive small subdiagonals.
*
         DO 80 J = ILAST - 1, IFIRST + 1, -1
            ISTART = J
            CTEMP = ASCALE*A( J, J ) - SHIFT*( BSCALE*B( J, J ) )
            TEMP = ABS1( CTEMP )
            TEMP2 = ASCALE*ABS1( A( J+1, J ) )
            TEMPR = MAX( TEMP, TEMP2 )
            IF( TEMPR.LT.ONE .AND. TEMPR.NE.ZERO ) THEN
               TEMP = TEMP / TEMPR
               TEMP2 = TEMP2 / TEMPR
            END IF
            IF( ABS1( A( J, J-1 ) )*TEMP2.LE.TEMP*ATOL )
     $         GO TO 90
   80    CONTINUE
*
         ISTART = IFIRST
         CTEMP = ASCALE*A( IFIRST, IFIRST ) -
     $           SHIFT*( BSCALE*B( IFIRST, IFIRST ) )
*
*        --------------------- Begin Timing Code -----------------------
         OPST = OPST - REAL( 6 )
*        ---------------------- End Timing Code ------------------------
*
   90    CONTINUE
*
*        Do an implicit-shift QZ sweep.
*
*        Initial Q
*
         CTEMP2 = ASCALE*A( ISTART+1, ISTART )
*
*        --------------------- Begin Timing Code -----------------------
         OPST = OPST + REAL( 2+( ILAST-ISTART )*18 )
*        ---------------------- End Timing Code ------------------------
*
         CALL CLARTG( CTEMP, CTEMP2, C, S, CTEMP3 )
*
*        Sweep
*
         DO 150 J = ISTART, ILAST - 1
            IF( J.GT.ISTART ) THEN
               CTEMP = A( J, J-1 )
               CALL CLARTG( CTEMP, A( J+1, J-1 ), C, S, A( J, J-1 ) )
               A( J+1, J-1 ) = CZERO
            END IF
*
            DO 100 JC = J, ILASTM
               CTEMP = C*A( J, JC ) + S*A( J+1, JC )
               A( J+1, JC ) = -CONJG( S )*A( J, JC ) + C*A( J+1, JC )
               A( J, JC ) = CTEMP
               CTEMP2 = C*B( J, JC ) + S*B( J+1, JC )
               B( J+1, JC ) = -CONJG( S )*B( J, JC ) + C*B( J+1, JC )
               B( J, JC ) = CTEMP2
  100       CONTINUE
            IF( ILQ ) THEN
               DO 110 JR = 1, N
                  CTEMP = C*Q( JR, J ) + CONJG( S )*Q( JR, J+1 )
                  Q( JR, J+1 ) = -S*Q( JR, J ) + C*Q( JR, J+1 )
                  Q( JR, J ) = CTEMP
  110          CONTINUE
            END IF
*
            CTEMP = B( J+1, J+1 )
            CALL CLARTG( CTEMP, B( J+1, J ), C, S, B( J+1, J+1 ) )
            B( J+1, J ) = CZERO
*
            DO 120 JR = IFRSTM, MIN( J+2, ILAST )
               CTEMP = C*A( JR, J+1 ) + S*A( JR, J )
               A( JR, J ) = -CONJG( S )*A( JR, J+1 ) + C*A( JR, J )
               A( JR, J+1 ) = CTEMP
  120       CONTINUE
            DO 130 JR = IFRSTM, J
               CTEMP = C*B( JR, J+1 ) + S*B( JR, J )
               B( JR, J ) = -CONJG( S )*B( JR, J+1 ) + C*B( JR, J )
               B( JR, J+1 ) = CTEMP
  130       CONTINUE
            IF( ILZ ) THEN
               DO 140 JR = 1, N
                  CTEMP = C*Z( JR, J+1 ) + S*Z( JR, J )
                  Z( JR, J ) = -CONJG( S )*Z( JR, J+1 ) + C*Z( JR, J )
                  Z( JR, J+1 ) = CTEMP
  140          CONTINUE
            END IF
  150    CONTINUE
*
*        --------------------- Begin Timing Code -----------------------
         OPST = OPST + ( REAL( ILAST-ISTART )*
     $          REAL( 120+64+40*( ILASTM-IFRSTM )+20*( NQ+NZ ) )-20 )
*        ---------------------- End Timing Code ------------------------
*
  160    CONTINUE
*
*        --------------------- Begin Timing Code -----------------------
*        End of iteration -- add in "small" contributions.
         OPS = OPS + OPST
         OPST = ZERO
*        ---------------------- End Timing Code ------------------------
*
*
  170 CONTINUE
*
*     Drop-through = non-convergence
*
  180 CONTINUE
      INFO = ILAST
*
*     ---------------------- Begin Timing Code -------------------------
      OPS = OPS + OPST
      OPST = ZERO
*     ----------------------- End Timing Code --------------------------
*
      GO TO 210
*
*     Successful completion of all QZ steps
*
  190 CONTINUE
*
*     Set Eigenvalues 1:ILO-1
*
      DO 200 J = 1, ILO - 1
         ABSB = ABS( B( J, J ) )
         IF( ABSB.GT.SAFMIN ) THEN
            SIGNBC = CONJG( B( J, J ) / ABSB )
            B( J, J ) = ABSB
            IF( ILSCHR ) THEN
               CALL CSCAL( J-1, SIGNBC, B( 1, J ), 1 )
               CALL CSCAL( J, SIGNBC, A( 1, J ), 1 )
*              ----------------- Begin Timing Code ---------------------
               OPST = OPST + REAL( 12*( J-1 ) )
*              ------------------ End Timing Code ----------------------
            ELSE
               A( J, J ) = A( J, J )*SIGNBC
            END IF
            IF( ILZ )
     $         CALL CSCAL( N, SIGNBC, Z( 1, J ), 1 )
*           ------------------- Begin Timing Code ----------------------
            OPST = OPST + REAL( 6*NZ+13 )
*           -------------------- End Timing Code -----------------------
         ELSE
            B( J, J ) = CZERO
         END IF
         ALPHA( J ) = A( J, J )
         BETA( J ) = B( J, J )
  200 CONTINUE
*
*     Normal Termination
*
      INFO = 0
*
*     Exit (other than argument error) -- return optimal workspace size
*
  210 CONTINUE
*
*     ---------------------- Begin Timing Code -------------------------
      OPS = OPS + OPST
      OPST = ZERO
      ITCNT = JITER
*     ----------------------- End Timing Code --------------------------
*
      WORK( 1 ) = CMPLX( N )
      RETURN
*
*     End of CHGEQZ
*
      END


!##############################################################################
! PROGRAM StochasticGrowth
!
! ## A growth model with TFP shocks
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
include "prog09_03m.f90"

program StochasticGrowth

    use globals
    use toolbox

    implicit none

    ! start timer
    call tic()

    ! calculate the shock process
    call discretize_AR(rho, 0d0, sigma_eps, eta, pi)

    ! initialize grid and policy function
    call grid_Cons_Equi(k, k_l, k_u)
    do is = 1, NS
        c(:, is) = exp(eta(is))*k(:)**alpha/2
    enddo

    ! iterate until policy function converges
    do iter = 1, itermax

        ! interpolate coefficients
        do is = 1, NS
            call spline_interp(c(:, is), coeff_c(:, is))
        enddo

        ! calculate decisions for every gridpoint and shock level
        do ik = 0, NK
            do is = 1, NS

                ! set starting value and communicate resource level
                x_in = c(ik, is)
                k_com = k(ik)
                is_com = is

                ! find the optimal consumption level
                call fzero(x_in, foc, check)
                if(check)write(*,*)'ERROR IN ROOTFINDING PROCESS'

                ! get optimal consumption and value function
                c_new(ik, is) = x_in

            enddo
        enddo

        ! get convergence level
        con_lev = maxval(abs(c_new(:, :) - c(:, :))/max(abs(c(:, :)), 1d-10))
        write(*,'(i5,2x,f20.7)')iter, con_lev

        ! check for convergence
        if(con_lev < sig)then
            call output()
        endif

        c = c_new
    enddo

    write(*,*)'No Convergence'
    call output

contains

    ! For creating output plots
    subroutine output()

        use toolbox

        implicit none
        integer, parameter :: nplot = 1000
        real*8 :: kplot(0:nplot), cplot(0:nplot)
        integer, parameter :: n_err = 10000
        real*8 :: err, c_err, err_temp

        ! end timer
        call toc()

        ! simulate a series of shocks
        call simulate_AR(pi, is_t)

        ! calculate the time path of consumption and capital numerically
        eta_t(0) = eta(is_t(0))
        k_t(0) = k0
        c_t(0) = spline_eval(k_t(0), coeff_c(:, is_t(0)), k_l, k_u)
        do it = 1, TT
            eta_t(it) = eta(is_t(it))
            k_t(it) = (1d0-delta)*k_t(it-1) + exp(eta_t(it-1))*k_t(it-1)**alpha - c_t(it-1)
            c_t(it) = spline_eval(k_t(it), coeff_c(:, is_t(it)), k_l, k_u)
        enddo

        ! calculate plot data for value and policy function
        do is = 1, NS
            do ik = 0, nplot
                kplot(ik) = k_l + (k_u-k_l)*dble(ik)/dble(nplot)
                cplot(ik) = spline_eval(kplot(ik), coeff_c(:, is), k_l, k_u)
            enddo
            call plot(kplot, cplot)
        enddo
        call execplot(xlabel='Current level of capital k_t', ylabel='Policy Function c(k_t)')

        ! plot time series data
        call plot((/(dble(it),it=0,TT)/), exp(eta_t))
        call execplot(xlabel='Time t', ylabel='Technology level exp(eta_t)')

        call plot((/(dble(it),it=0,TT)/), c_t)
        call execplot(xlabel='Time t', ylabel='Consumption c_t')

        call plot((/(dble(it),it=0,TT)/), k_t)
        call execplot(xlabel='Time t', ylabel='Capital k_t')

        ! calculate euler equation error
        err = 0d0
        do ik = 0, n_err
            k_com = k_l + (k_u-k_l)*dble(ik)/dble(n_err)
            do is = 1, NS
                is_com = is
                c_err = spline_eval(k_com, coeff_c(:, is), k_l, k_u)
                err_temp = abs(foc(c_err)/c_err)
                if(err_temp > err)err = err_temp
            enddo
        enddo
        write(*,'(a, es15.7)')'Euler equation error:',err

        ! quit program
        stop

    end subroutine

end program


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine calcsurf(n1,n2,n3,cotet,surf)
!
!     calculates the surface of a tetrahedral face consisting
!     of nodes n1,n2 and n3
!
      implicit none
!
      integer n1,n2,n3
!
      real*8 cotet(3,*),s(3),surf
!
      s(1)=(cotet(2,n2)-cotet(2,n1))*(cotet(3,n3)-cotet(3,n1))-
     &     (cotet(3,n2)-cotet(3,n1))*(cotet(2,n3)-cotet(2,n1))
      s(2)=(cotet(3,n2)-cotet(3,n1))*(cotet(1,n3)-cotet(1,n1))-
     &     (cotet(1,n2)-cotet(1,n1))*(cotet(3,n3)-cotet(3,n1))
      s(3)=(cotet(1,n2)-cotet(1,n1))*(cotet(2,n3)-cotet(2,n1))-
     &     (cotet(2,n2)-cotet(2,n1))*(cotet(1,n3)-cotet(1,n1))
      surf=dsqrt(s(1)*s(1)+s(2)*s(2)+s(3)*s(3))/2.d0
!
      return
      end


FUNCTION t_quantile(p, ndf, normdev) RESULT(fn_val)

!  Calculates the two-tail quantiles of Student's t-distribution.
!  The user must supply a function `normdev' to return quantiles of the
!  the normal distribution, such as Applied Statistics algorithm AS 241.

!  Translation from Algol by Alan Miller, CSIRO Division of Mathematics
!  & Statistics, Clayton, Victoria 3169, Australia of:

!  Algorithm 396: Student's t-quantiles by G.W. Hill
!  Comm. A.C.M., vol.13(10), 619-620, October 1970

!  N.B. The number of degrees of freedom is not necessarily an integer

!  Arguments:
!  P       double precision    Area under both tails
!  ndf     double precision    Number of degrees of freedom
!  normal  double precision    External function to return quantiles
!                              of the standard normal curve
!  ier     integer             Error indicator = 0 for normal exit
!                                              = 1 if ndf < 1

!  ELF90-compatible version by Alan Miller
!  Latest revision - 7 August 1997

IMPLICIT NONE
INTEGER, PARAMETER    :: dp = SELECTED_REAL_KIND(12, 60)
REAL (dp), INTENT(IN) :: p, ndf
REAL (dp)             :: fn_val

INTERFACE
  FUNCTION normdev(p) RESULT(x)
    IMPLICIT NONE
    INTEGER, PARAMETER    :: dp = SELECTED_REAL_KIND(12, 60)
    REAL (dp), INTENT(IN) :: p
    REAL (dp)             :: x
  END FUNCTION normdev
END INTERFACE

!     Local variables

REAL (dp)            :: a, b, c, d, prob, x, y
REAL (dp), PARAMETER :: half_pi = 1.5707963267949D0, eps = 1.d-12, one = 1.d0

IF (ndf < one .OR. p > one .OR. p <= 0.d0) THEN
  WRITE(*, *) 'Error in t_quantile: ndf < 1 or p not between 0 and 1'
  RETURN
END IF

IF ( ABS(ndf - 2.d0) < eps ) THEN
  fn_val = SQRT(2.d0 / ( p * (2.d0 - p) ) - 2.d0)
  RETURN

ELSE IF (ndf < one+eps) THEN
  prob = p * half_pi
  fn_val = COS(prob) / SIN(prob)
  RETURN

ELSE
  a = one / (ndf - 0.5D0)
  b = 48.d0 / a**2
  c = ((20700.d0 * a / b - 98.d0) * a - 16.d0) * a + 96.36D0
  d = ((94.5D0 / (b + c) - 3.d0) / b + one) * SQRT(a * half_pi)* ndf
  x = d * p
  y = x ** (2.d0 / ndf)

  IF (y > 0.05D0 + a) THEN

!     Asymptotic inverse expansion about normal

    x = normdev(0.5 * p)
    y = x**2
    IF (ndf < 5.d0) c = c + 0.3D0 * (ndf - 4.5D0) * (x + 0.6D0)
    c = (((0.05D0 * d * x - 5.d0) * x - 7.d0) * x - 2.d0) * x + b+ c
    y = (((((0.4D0*y + 6.3D0) * y + 36.d0) * y + 94.5D0) / c - y  &
         - 3.d0) / b + one) * x
    y = a * y**2
    IF (y > 0.002D0) THEN
      y = EXP(y) - one
    ELSE
      y = 0.5D0 * y**2 + y
    END IF
  ELSE

    y = ((one / (((ndf + 6.d0) / (ndf * y) - 0.089D0 * d -  &
        0.822D0) * (ndf + 2.d0) * 3.d0) + 0.5D0 / (ndf + 4.d0))  &
        * y - one) * (ndf + one) / (ndf + 2.d0) + one / y
  END IF
END IF
fn_val = SQRT(ndf * y)

RETURN
END FUNCTION t_quantile


c
c Module 496 in TOMS
c Based upon the LZ-algorithm
c (see L.C. Kaufman, ACM TOMS 1 (1975) pp. 271-281)
c
      SUBROUTINE DLZHES(N, A, NA, B, NB, X, NX, WANTX)
C THIS SUBROUTINE REDUCES THE COMPLEX MATRIX A TO UPPER
C HESSENBERG FORM AND REDUCES THE COMPLEX MATRIX B TO
C TRIANGULAR FORM
C INPUT PARAMETERS..
C N   THE ORDER OF THE A AND B MATRICES
C A   A COMPLEX MATRIX
C NA  THE ROW DIMENSION OF THE A MATRIX
C B   A COMPLEX MATRIX
C NB  THE ROW DIMENSION OF THE B MATRIX
C NX  THE ROW DIMENSION OF THE X MATRIX
C WANTX A LOGICAL VARIABLE WHICH IS SET TO .TRUE. IF
C       THE EIGENVECTORS ARE WANTED. OTHERWISE IT SHOULD
C     BE SET TO .FALSE.
C OUTPUT PARAMETERS..
C A  ON OUTPUT A IS AN UPPER HESSENBERG MATRIX, THE
C    ORIGINAL MATRIX HAS BEEN DESTROYED
C B  AN UPPER TRIANGULAR MATRIX, THE ORIGINAL MATRIX
C    HAS BEEN DESTROYED
C X  CONTAINS THE TRANSFORMATIONS NEEDED TO COMPUTE
C    THE EIGENVECTORS OF THE ORIGINAL SYSTEM
      implicit none
!
      LOGICAL WANTX
!
      integer k,nm1,nm2,jm2,jp1,ip1,imj,j,ii,im1,i,nx,nb,na,n
!
      REAL*8 C, D
!
      COMPLEX*16 Y, W, Z, A(NA,N), B(NB,N), X(NX,N)
!
      NM1 = N - 1
C REDUCE B TO TRIANGULAR FORM USING ELEMENTARY
C TRANSFORMATIONS
      DO 80 I=1,NM1
        D = 0.D0
        IP1 = I + 1
        DO 10 K=IP1,N
          Y = B(K,I)
          C = DABS(DREAL(Y)) + DABS(DIMAG(Y))
          IF (C.LE.D) GO TO 10
          D = C
          II = K
   10   CONTINUE
        IF (D.EQ.0.D0) GO TO 80
        Y = B(I,I)
        IF (D.LE.DABS(DREAL(Y))+DABS(DIMAG(Y))) GO TO 40
C MUST INTERCHANGE
        DO 20 J=1,N
          Y = A(I,J)
          A(I,J) = A(II,J)
          A(II,J) = Y
   20   CONTINUE
        DO 30 J=I,N
          Y = B(I,J)
          B(I,J) = B(II,J)
          B(II,J) = Y
   30   CONTINUE
   40   DO 70 J=IP1,N
          Y = B(J,I)/B(I,I)
          IF (DREAL(Y).EQ.0.D0 .AND. DIMAG(Y).EQ.0.D0) GO TO 70
          DO 50 K=1,N
            A(J,K) = A(J,K) - Y*A(I,K)
   50     CONTINUE
          DO 60 K=IP1,N
            B(J,K) = B(J,K) - Y*B(I,K)
   60     CONTINUE
   70   CONTINUE
        B(IP1,I) = (0.D0,0.D0)
   80 CONTINUE
C INITIALIZE X
      IF (.NOT.WANTX) GO TO 110
      DO 100 I=1,N
        DO 90 J=1,N
          X(I,J) = (0.D0,0.D0)
   90   CONTINUE
        X(I,I) = (1.D0,0.D0)
  100 CONTINUE
C REDUCE A TO UPPER HESSENBERG FORM
  110 NM2 = N - 2
      IF (NM2.LT.1) GO TO 270
      DO 260 J=1,NM2
        JM2 = NM1 - J
        JP1 = J + 1
        DO 250 II=1,JM2
          I = N + 1 - II
          IM1 = I - 1
          IMJ = I - J
          W = A(I,J)
          Z = A(IM1,J)
          IF (DABS(DREAL(W))+DABS(DIMAG(W)).LE.DABS(DREAL(Z))
     *     +DABS(DIMAG(Z))) GO TO 140
C MUST INTERCHANGE ROWS
          DO 120 K=J,N
            Y = A(I,K)
            A(I,K) = A(IM1,K)
            A(IM1,K) = Y
  120     CONTINUE
          DO 130 K=IM1,N
            Y = B(I,K)
            B(I,K) = B(IM1,K)
            B(IM1,K) = Y
  130     CONTINUE
  140     Z = A(I,J)
          IF (DREAL(Z).EQ.0.D0 .AND. DIMAG(Z).EQ.0.D0) GO TO 170
          Y = Z/A(IM1,J)
          DO 150 K=JP1,N
            A(I,K) = A(I,K) - Y*A(IM1,K)
  150     CONTINUE
          DO 160 K=IM1,N
            B(I,K) = B(I,K) - Y*B(IM1,K)
  160     CONTINUE
C TRANSFORMATION FROM THE RIGHT
  170     W = B(I,IM1)
          Z = B(I,I)
          IF (DABS(DREAL(W))+DABS(DIMAG(W)).LE.DABS(DREAL(Z))
     *     +DABS(DIMAG(Z))) GO TO 210
C MUST INTERCHANGE COLUMNS
          DO 180 K=1,I
            Y = B(K,I)
            B(K,I) = B(K,IM1)
            B(K,IM1) = Y
  180     CONTINUE
          DO 190 K=1,N
            Y = A(K,I)
            A(K,I) = A(K,IM1)
            A(K,IM1) = Y
  190     CONTINUE
          IF (.NOT.WANTX) GO TO 210
          DO 200 K=IMJ,N
            Y = X(K,I)
            X(K,I) = X(K,IM1)
            X(K,IM1) = Y
  200     CONTINUE
  210     Z = B(I,IM1)
          IF (DREAL(Z).EQ.0.D0 .AND. DIMAG(Z).EQ.0.D0) GO TO 250
          Y = Z/B(I,I)
          DO 220 K=1,IM1
            B(K,IM1) = B(K,IM1) - Y*B(K,I)
  220     CONTINUE
          B(I,IM1) = (0.D0,0.D0)
          DO 230 K=1,N
            A(K,IM1) = A(K,IM1) - Y*A(K,I)
  230     CONTINUE
          IF (.NOT.WANTX) GO TO 250
          DO 240 K=IMJ,N
            X(K,IM1) = X(K,IM1) - Y*X(K,I)
  240     CONTINUE
  250   CONTINUE
        A(JP1+1,J) = (0.D0,0.D0)
  260 CONTINUE
  270 RETURN
      END
      SUBROUTINE DLZIT(N, A, NA, B, NB, X, NX, WANTX, ITER, EIGA,
     * EIGB)
C THIS SUBROUTINE SOLVES THE GENERALIZED EIGENVALUE PROBLEM
C              A X  = LAMBDA B X
C WHERE A IS A COMPLEX UPPER HESSENBERG MATRIX OF
C ORDER N AND B IS A COMPLEX UPPER TRIANGULAR MATRIX OF ORDER N
C INPUT PARAMETERS
C N      ORDER OF A AND B
C A      AN N X N UPPER HESSENBERG COMPLEX MATRIX
C NA     THE ROW DIMENSION OF THE A MATRIX
C B      AN N X N UPPER TRIANGULAR COMPLEX MATRIX
C NB     THE ROW DIMENSION OF THE B MATRIX
C X      CONTAINS TRANSFORMATIONS TO OBTAIN EIGENVECTORS OF
C        ORIGINAL SYSTEM. IF EIGENVECTORS ARE REQUESTED AND QZHES
C        IS NOT CALLED, X SHOULD BE SET TO THE IDENTITY MATRIX
C NX     THE ROW DIMENSION OF THE X MATRIX
C WANTX  LOGICAL VARIABLE WHICH SHOULD BE SET TO .TRUE.
C        IF EIGENVECTORS ARE WANTED. OTHERWISE IT
C        SHOULD BE SET TO .FALSE.
C OUTPUT PARAMETERS
C X      THE ITH COLUMN CONTAINS THE ITH EIGENVECTOR
C        IF EIGENVECTORS ARE REQUESTED
C ITER   AN INTEGER ARRAY OF LENGTH N WHOSE ITH ENTRY
C        CONTAINS THE NUMBER OF ITERATIONS NEEDED TO FIND
C        THE ITH EIGENVALUE. FOR ANY I IF ITER(I) =-1 THEN
C        AFTER 30 ITERATIONS THERE HAS NOT BEEN A SUFFICIENT
C        DECREASE IN THE LAST SUBDIAGONAL ELEMENT OF A
C        TO CONTINUE ITERATING.
C EIGA   A COMPLEX ARRAY OF LENGTH N CONTAINING THE DIAGONAL OF A
C EIGB   A COMPLEX ARRAY OF LENGTH N CONTAINING THE DIAGONAL OF B
C THE ITH EIGENVALUE CAN BE FOUND BY DIVIDING EIGA(I) BY
C EIGB(I). WATCH OUT FOR EIGB(I) BEING ZERO
      COMPLEX*16 A(NA,N), B(NB,N), EIGA(N), EIGB(N)
      COMPLEX*16 S, W, Y, Z, CDSQRT
      COMPLEX*16 X(NX,N)
      INTEGER ITER(N)
      COMPLEX*16 ANNM1, ALFM, BETM, D, SL, DEN, NUM, ANM1M1
      REAL*8 EPSA, EPSB, SS, R, ANORM, BNORM, ANI, BNI, C
      REAL*8 D0, D1, D2, E0, E1
      LOGICAL WANTX
      NN = N
C COMPUTE THE MACHINE PRECISION TIMES THE NORM OF A AND B
      ANORM = 0.D0
      BNORM = 0.D0
      DO 30 I=1,N
        ANI = 0.D0
        IF (I.EQ.1) GO TO 10
        Y = A(I,I-1)
        ANI = ANI + DABS(DREAL(Y)) + DABS(DIMAG(Y))
   10   BNI = 0.D0
        DO 20 J=I,N
          ANI = ANI + DABS(DREAL(A(I,J))) + DABS(DIMAG(A(I,J)))
          BNI = BNI + DABS(DREAL(B(I,J))) + DABS(DIMAG(B(I,J)))
   20   CONTINUE
        IF (ANI.GT.ANORM) ANORM = ANI
        IF (BNI.GT.BNORM) BNORM = BNI
   30 CONTINUE
      IF (ANORM.EQ.0.D0) ANORM = 1.D0
      IF (BNORM.EQ.0.D0) BNORM = 1.D0
      EPSB = BNORM
      EPSA = ANORM
   40 EPSA = EPSA/2.D0
      EPSB = EPSB/2.D0
      C = ANORM + EPSA
      IF (C.GT.ANORM) GO TO 40
      IF (N.LE.1) GO TO 320
   50 ITS = 0
      NM1 = NN - 1
C CHECK FOR NEGLIGIBLE SUBDIAGONAL ELEMENTS
   60 D2 = DABS(DREAL(A(NN,NN))) + DABS(DIMAG(A(NN,NN)))
      DO 70 LB=2,NN
        L = NN + 2 - LB
        SS = D2
        Y = A(L-1,L-1)
        D2 = DABS(DREAL(Y)) + DABS(DIMAG(Y))
        SS = SS + D2
        Y = A(L,L-1)
        R = SS + DABS(DREAL(Y)) + DABS(DIMAG(Y))
        IF (R.EQ.SS) GO TO 80
   70 CONTINUE
      L = 1
   80 IF (L.EQ.NN) GO TO 320
      IF (ITS.LT.30) GO TO 90
      ITER(NN) = -1
      IF (DABS(DREAL(A(NN,NM1)))+DABS(DIMAG(A(NN,NM1))).GT.0.8D0*
     * DABS(DREAL(ANNM1))+DABS(DIMAG(ANNM1))) RETURN
   90 IF (ITS.EQ.10 .OR. ITS.EQ.20) GO TO 110
C COMPUTE SHIFT AS EIGENVALUE OF LOWER 2 BY 2
      ANNM1 = A(NN,NM1)
      ANM1M1 = A(NM1,NM1)
      S = A(NN,NN)*B(NM1,NM1) - ANNM1*B(NM1,NN)
      W = ANNM1*B(NN,NN)*(A(NM1,NN)*B(NM1,NM1)-B(NM1,NN)*ANM1M1)
      Y = (ANM1M1*B(NN,NN)-S)/2.
      Z = CDSQRT(Y*Y+W)
      IF (DREAL(Z).EQ.0.D0 .AND. DIMAG(Z).EQ.0.D0) GO TO 100
      D0 = DREAL(Y/Z)
      IF (D0.LT.0.D0) Z = -Z
  100 DEN = (Y+Z)*B(NM1,NM1)*B(NN,NN)
      IF (DREAL(DEN).EQ.0.D0 .AND. DIMAG(DEN).EQ.0.D0) DEN =
     * CMPLX(EPSA,0.D0)
      NUM = (Y+Z)*S - W
      GO TO 120
C AD-HOC SHIFT
  110 Y = A(NM1,NN-2)
      NUM = CMPLX(DABS(DREAL(ANNM1))+DABS(DIMAG(ANNM1)),DABS(DREAL(Y))
     * +DABS(DIMAG(Y)))
      DEN = (1.D0,0.D0)
C CHECK FOR 2 CONSECUTIVE SMALL SUBDIAGONAL ELEMENTS
  120 IF (NN.EQ.L+1) GO TO 140
      D2 = DABS(DREAL(A(NM1,NM1))) + DABS(DIMAG(A(NM1,NM1)))
      E1 = DABS(DREAL(ANNM1)) + DABS(DIMAG(ANNM1))
      D1 = DABS(DREAL(A(NN,NN))) + DABS(DIMAG(A(NN,NN)))
      NL = NN - (L+1)
      DO 130 MB=1,NL
        M = NN - MB
        E0 = E1
        Y = A(M,M-1)
        E1 = DABS(DREAL(Y)) + DABS(DIMAG(Y))
        D0 = D1
        D1 = D2
        Y = A(M-1,M-1)
        D2 = DABS(DREAL(Y)) + DABS(DIMAG(Y))
        Y = A(M,M)*DEN - B(M,M)*NUM
        D0 = (D0+D1+D2)*(DABS(DREAL(Y))+DABS(DIMAG(Y)))
        E0 = E0*E1*(DABS(DREAL(DEN))+DABS(DIMAG(DEN))) + D0
        IF (E0.EQ.D0) GO TO 150
  130 CONTINUE
  140 M = L
  150 CONTINUE
      ITS = ITS + 1
      W = A(M,M)*DEN - B(M,M)*NUM
      Z = A(M+1,M)*DEN
      D1 = DABS(DREAL(Z)) + DABS(DIMAG(Z))
      D2 = DABS(DREAL(W)) + DABS(DIMAG(W))
C FIND L AND M AND SET A=LAM AND B=LBM
C     NP1 = N + 1
      LOR1 = L
      NNORN = NN
      IF (.NOT.WANTX) GO TO 160
      LOR1 = 1
      NNORN = N
  160 DO 310 I=M,NM1
        J = I + 1
C FIND ROW TRANSFORMATIONS TO RESTORE A TO
C UPPER HESSENBERG FORM. APPLY TRANSFORMATIONS
C TO A AND B
        IF (I.EQ.M) GO TO 170
        W = A(I,I-1)
        Z = A(J,I-1)
        D1 = DABS(DREAL(Z)) + DABS(DIMAG(Z))
        D2 = DABS(DREAL(W)) + DABS(DIMAG(W))
        IF (D1.EQ.0.D0) GO TO 60
  170   IF (D2.GT.D1) GO TO 190
C MUST INTERCHANGE ROWS
        DO 180 K=I,NNORN
          Y = A(I,K)
          A(I,K) = A(J,K)
          A(J,K) = Y
          Y = B(I,K)
          B(I,K) = B(J,K)
          B(J,K) = Y
  180   CONTINUE
        IF (I.GT.M) A(I,I-1) = A(J,I-1)
        IF (D2.EQ.0.D0) GO TO 220
C THE SCALING OF W AND Z IS DESIGNED TO AVOID A DIVISION BY ZERO
C WHEN THE DENOMINATOR IS SMALL
        Y = CMPLX(DREAL(W)/D1,DIMAG(W)/D1)/CMPLX(DREAL(Z)/D1,DIMAG(Z)/
     *   D1)
        GO TO 200
  190   Y = CMPLX(DREAL(Z)/D2,DIMAG(Z)/D2)/CMPLX(DREAL(W)/D2,DIMAG(W)/
     *   D2)
  200   DO 210 K=I,NNORN
          A(J,K) = A(J,K) - Y*A(I,K)
          B(J,K) = B(J,K) - Y*B(I,K)
  210   CONTINUE
  220   IF (I.GT.M) A(J,I-1) = (0.D0,0.D0)
C PERFORM TRANSFORMATIONS FROM RIGHT TO RESTORE B TO
C   TRIANGLULAR FORM
C APPLY TRANSFORMATIONS TO A
        Z = B(J,I)
        W = B(J,J)
        D2 = DABS(DREAL(W)) + DABS(DIMAG(W))
        D1 = DABS(DREAL(Z)) + DABS(DIMAG(Z))
        IF (D1.EQ.0.D0) GO TO 60
        IF (D2.GT.D1) GO TO 270
C MUST INTERCHANGE COLUMNS
        DO 230 K=LOR1,J
          Y = A(K,J)
          A(K,J) = A(K,I)
          A(K,I) = Y
          Y = B(K,J)
          B(K,J) = B(K,I)
          B(K,I) = Y
  230   CONTINUE
        IF (I.EQ.NM1) GO TO 240
        Y = A(J+1,J)
        A(J+1,J) = A(J+1,I)
        A(J+1,I) = Y
  240   IF (.NOT.WANTX) GO TO 260
        DO 250 K=1,N
          Y = X(K,J)
          X(K,J) = X(K,I)
          X(K,I) = Y
  250   CONTINUE
  260   IF (D2.EQ.0.D0) GO TO 310
        Z = CMPLX(DREAL(W)/D1,DIMAG(W)/D1)/CMPLX(DREAL(Z)/D1,DIMAG(Z)/
     *   D1)
        GO TO 280
  270   Z = CMPLX(DREAL(Z)/D2,DIMAG(Z)/D2)/CMPLX(DREAL(W)/D2,DIMAG(W)/
     *   D2)
  280   DO 290 K=LOR1,J
          A(K,I) = A(K,I) - Z*A(K,J)
          B(K,I) = B(K,I) - Z*B(K,J)
  290   CONTINUE
        B(J,I) = (0.D0,0.D0)
        IF (I.LT.NM1) A(I+2,I) = A(I+2,I) - Z*A(I+2,J)
        IF (.NOT.WANTX) GO TO 310
        DO 300 K=1,N
          X(K,I) = X(K,I) - Z*X(K,J)
  300   CONTINUE
  310 CONTINUE
      GO TO 60
  320 CONTINUE
      EIGA(NN) = A(NN,NN)
      EIGB(NN) = B(NN,NN)
      IF (NN.EQ.1) GO TO 330
      ITER(NN) = ITS
      NN = NM1
      IF (NN.GT.1) GO TO 50
      ITER(1) = 0
      GO TO 320
C FIND EIGENVECTORS USING B FOR INTERMEDIATE STORAGE
  330 IF (.NOT.WANTX) RETURN
      M = N
  340 CONTINUE
      ALFM = A(M,M)
      BETM = B(M,M)
      B(M,M) = (1.D0,0.D0)
      L = M - 1
      IF (L.EQ.0) GO TO 370
  350 CONTINUE
      L1 = L + 1
      SL = (0.D0,0.D0)
      DO 360 J=L1,M
        SL = SL + (BETM*A(L,J)-ALFM*B(L,J))*B(J,M)
  360 CONTINUE
      Y = BETM*A(L,L) - ALFM*B(L,L)
      IF (DREAL(Y).EQ.0.D0 .AND. DIMAG(Y).EQ.0.D0) Y =
     * CMPLX((EPSA+EPSB)/2.D0,0.D0)
      B(L,M) = -SL/Y
      L = L - 1
  370 IF (L.GT.0) GO TO 350
      M = M - 1
      IF (M.GT.0) GO TO 340
C TRANSFORM TO ORIGINAL COORDINATE SYSTEM
      M = N
  380 CONTINUE
      DO 400 I=1,N
        S = (0.D0,0.D0)
        DO 390 J=1,M
          S = S + X(I,J)*B(J,M)
  390   CONTINUE
        X(I,M) = S
  400 CONTINUE
      M = M - 1
      IF (M.GT.0) GO TO 380
C NORMALIZE SO THAT LARGEST COMPONENT = 1.
      M = N
  410 CONTINUE
      SS = 0.D0
      DO 420 I=1,N
        R = DABS(DREAL(X(I,M))) + DABS(DIMAG(X(I,M)))
        IF (R.LT.SS) GO TO 420
        SS = R
        D = X(I,M)
  420 CONTINUE
      IF (SS.EQ.0.D0) GO TO 440
      DO 430 I=1,N
        X(I,M) = X(I,M)/D
  430 CONTINUE
  440 M = M - 1
      IF (M.GT.0) GO TO 410
      RETURN
      END


      subroutine finitemtcorr(rescaling)
      implicit none
      double precision rescaling,tn
      double complex ftn
      include 'constants.f'
      include 'masses.f'

      tn = 4d0*(mt/hmass)**2
      if (tn .lt. (1d0)) then
         ftn = 0.5d0*(dlog((1d0+dsqrt(1d0-tn))
     &        /(1d0-dsqrt(1d0-tn)))-im*pi)**2
      else
         ftn = -2d0*(dasin(1.0d0/dsqrt(tn)))**2
      endif
      rescaling=cdabs((3d0*tn/4d0)*(2d0+(tn-1d0)*ftn))**2

      return
      end


! cooling_Casiana.f90 $Id: ecbdecb02d740e1d7dcdb7b1c7574c0aaa25ab19 $
!***********************************************************************
FUNCTION cooling_Casiana (self, temp)
  implicit none
  class(cooling_t):: self
  real(kind=dp) cooling_Casiana, temp, qq
  real(kind=dp), parameter:: &
    TEm=1e1, &
    TE0=1e3, &
    TE1=10964.781e0, &
    TE2=19952.632e0, &
    TE3=29512.078e0, &
    TE4=39810.708e0, &
    TE5=69183.121e0, &
    TE6=125892.51e0, &
    TE7=251188.7e0, &
    TE8=501187.01e0, &
    TE9=891250.55e0, &
    TE10=1.412537e6, &
    TE11=2.511887e6, &
    TE12=6.309576e6, &
    TE13=1.e7, &
    TE14=1.5848925e7, &
    TE15=1.e9, &

    Cm=2.,   &
    C0=2.596,   &
    C1=3.846, &
    C2=-0.1764, &
    C3=1.00001, &
    C4=1.6666, &
    C5=1.15384, &
    C6=0.1, &
    C7= -3.933, &
    C8= 0.72, &
    C9= -0.65,  &
    C10= 0.4, &
    C11= -1.25, &
    C12= 0., &
    C13= -0.4,  &
    C14= 0.43333, &

    Hm=4.98282e-05*4e-28, &
    H0=3.2473989e-34, &
    H2=5.739e-22, &
    H3=3.1620277e-27, &
    H4=2.7123742e-30, &
    H5=8.2298862e-28, &
    H6=1.9497e-22, &
    H7=1.1749e+0*4e-28, &
    H8=3.5155e-27, &
    H9=4.982757e-19, &
    H10=1.7379e-25, &
    H11=6.309e-15, &
    H12=1.99525e-22, &
    H13=1.2589e-20, &
    H14=1.2589e-26

  real(kind=8), parameter:: &
    H1=2.894d-39

    if      (temp .le. T_MC) then
      qq = 0.
    else if (temp .le. TE0) then
      qq = Hm*temp**Cm
    else if (temp .le. TE1) then
      qq = H0*temp**C0
    else if (temp .le. TE2) then
      qq = H1*temp**C1
    else if (temp .le. TE3) then
      qq = H2*temp**C2
    else if (temp .le. TE4) then
      qq = H3*temp**C3
    else if (temp .le. TE5) then
      qq = H4*temp**C4
    else if (temp .le. TE6) then
      qq = H5*temp**C5
    else if (temp .le. TE7) then
      qq = H6*temp**C6
    else if (temp .le. TE8) then
      qq = (H7*temp**C7)*2.5e27
    else if (temp .le. TE9) then
      qq = H8*temp**C8
    else if (temp .le. TE10) then
      qq = H9*temp**C9
    else if (temp .le. TE11) then
      qq = H10*temp**C10
    else if (temp .le. TE12) then
      qq = H11*temp**C11
    else if (temp .le. TE13) then
      qq = H12*temp**C12
    else if (temp .le. TE14) then
      qq = H13*temp**C13
    else
      qq = H14*temp**C14
    end if
    cooling_Casiana=qq
END FUNCTION


      DOUBLE PRECISION FUNCTION PHO_DORFVP(X,N,Ak,Ag,D)
      IMPLICIT NONE
      DOUBLE PRECISION Ag , Ak , D , dx , N , X
      SAVE

      dx = SQRT(X)
      PHO_DORFVP = N*X**Ak*(1.+Ag*dx)*(1.-X)**D

      END FUNCTION


C   ***************************************************************
C   * Storm Relative Helicity (SRH) is a measure of the           *
C   * streamwise vorticity within the inflow environment of a     *
C   * convective storm. It is calculated by multiplying the       *
C   * storm-relative inflow velocity vector (Vh-C) by the         *
C   * streamwise vorticity (Zh) and integrating this quantity     *
C   * over the inflow depth (lowest 1-3 km layers above ground    *
C   * level). It describes the extent to which corkscrew-like     *
C   * motion occurs (similar to the spiraling motion of an        *
C   * American football). SRH corresponds to the transfer of      *
C   * vorticity from the environment to an air parcel in          *
C   * convective motion and is used to predict the potential      *
C   * for tornadic development (cyclonic updraft rotation) in     *
C   * right-moving supercells.                                    *
C   *                                                             *
C   * There is no clear threshold value for SRH when forecasting  *
C   * supercells, since the formation of supercells appears to be *
C   * related more strongly to the deeper layer vertical shear.   *
C   * Larger values of 0-3-km SRH (greater than 250 m**2/s**2)    *
C   * and 0-1-km SRH (greater than 100 m**2/s**2), suggest an     *
C   * increased threat of tornadoes with supercells. For SRH,     *
C   * larger values are generally better, but there are no clear  *
C   * "boundaries" between non-tornadic and significant tornadic  *
C   * supercells.                                                 *
C   *                                                             *
C   * SRH < 100 (lowest 1 km): cutoff value                       *
C   * SRH = 150-299: supercells possible with weak tornadoes      *
C   * SRH = 300-499: very favorable to supercell development and  *
C   *                strong tornadoes                             *
C   * SRH > 450    : violent tornadoes                            *
C   ***************************************************************
C NCLFORTSTART
      subroutine dcalrelhl(u, v, ght, ter, top, sreh, miy, mjx, mkzh)
      implicit none
      integer miy, mjx, mkzh
      double precision u(miy,mjx,mkzh), v(miy,mjx,mkzh),
     &                 ght(miy,mjx,mkzh),top,ter(miy,mjx),
     &                 sreh(miy,mjx)
C NCLEND
C
C This helicity code was provided by Dr. Craig Mattocks, and
C verified by Cindy Bruyere to produce results equivalent to
C those generated by RIP4. (The code came from RIP4?)
C
      double precision pi, dtr, dpr
      double precision dh, sdh, su, sv, ua, va, asp, adr, bsp, bdr
      double precision cu, cv, x, sum
      integer i, j, k, k10, k3, ktop
      parameter (pi=3.14159265d0, dtr=pi/180.d0, dpr=180.d0/pi)

      do 15 j = 1, mjx-1
	do 15 i = 1, miy-1
	  sdh = 0.d0
	  su = 0.d0
	  sv = 0.d0
	  k3 = 0
	  k10 = 0
	  ktop = 0
	  do 6 k = mkzh, 2, -1
	    if (((ght(i,j,k) - ter(i,j)) .gt. 10000.d0) .and.
     &             (k10 .eq. 0)) then
	      k10 = k
	      go to 8
	    endif
	    if (((ght(i,j,k) - ter(i,j)) .gt. top) .and.
     &           (ktop .eq. 0)) ktop = k
	    if (((ght(i,j,k) - ter(i,j)) .gt. 3000.d0) .and.
     &           (k3 .eq. 0)) k3 = k
    6     continue
    8     continue
	  if (k10 .eq. 0) k10=2
	  do k = k3, k10, -1
	    dh = ght(i,j,k-1) - ght(i,j,k)
	    sdh = sdh + dh
	    su = su + 0.5d0*dh*(u(i,j,k-1)+u(i,j,k))
	    sv = sv + 0.5d0*dh*(v(i,j,k-1)+v(i,j,k))
	  enddo
	  ua = su / sdh
	  va = sv / sdh
	  asp = sqrt(ua*ua + va*va)
	  if (ua .eq. 0.d0 .and. va .eq. 0.d0) then
	    adr = 0.d0
	  else
	    adr = dpr * (pi + atan2(ua,va))
	  endif
	  bsp = 0.75d0 * asp
	  bdr = adr + 30.d0
	  if (bdr .gt. 360.d0) bdr = bdr-360.d0
	  cu = -bsp * sin(bdr*dtr)
	  cv = -bsp * cos(bdr*dtr)
          sum = 0.d0
          do 12 k = mkzh-1, ktop, -1
            x = ((u(i,j,k)-cu) * (v(i,j,k)-v(i,j,k+1))) -
     &          ((v(i,j,k)-cv) * (u(i,j,k)-u(i,j,k+1)))
            sum = sum + x
   12     continue
          sreh(i,j) = -sum
   15 continue
      end