! implementation of the Bastankhah and Porte Agel (BPA) wake model for analysis
subroutine porteagel_analyze(nTurbines, turbineXw, sorted_x_idx, turbineYw, turbineZ, &
                             rotorDiameter, Ct, wind_speed, &
                             yawDeg, ky, kz, alpha, beta, TI, wake_combination_method, &
                             TI_calculation_method, calc_k_star, wtVelocity)

    ! independent variables: turbineXw turbineYw turbineZ rotorDiameter
    !                        Ct yawDeg

    ! dependent variables: wtVelocity

    implicit none

    ! define precision to be the standard for a double precision ! on local system
    integer, parameter :: dp = kind(0.d0)

    ! in
    integer, intent(in) :: nTurbines
    integer, intent(in) :: wake_combination_method, TI_calculation_method
    logical, intent(in) :: calc_k_star
    real(dp), dimension(nTurbines), intent(in) :: turbineXw, turbineYw, turbineZ
    integer, dimension(nTurbines), intent(in) :: sorted_x_idx
    real(dp), dimension(nTurbines), intent(in) :: rotorDiameter, yawDeg
    real(dp), dimension(nTurbines), intent(in) :: Ct
    real(dp), intent(in) :: ky, kz, alpha, beta, TI, wind_speed

    ! local (General)
    real(dp), dimension(nTurbines) :: yaw, TIturbs, k_star
    real(dp) :: x0, deltax0, deltay, theta_c_0, sigmay, sigmaz, wake_offset
    real(dp) :: x, deltav, deltaz, sigmay0, sigmaz0, deficit_sum
    real(dp) :: ky_local, kz_local
    Integer :: u, d, turb, turbI
    real(dp), parameter :: pi = 3.141592653589793_dp

    ! model out
    real(dp), dimension(nTurbines), intent(out) :: wtVelocity

    intrinsic cos, atan, max, sqrt, log

    ! bastankhah and porte agel 2016 define yaw to be positive clockwise, this is reversed
    yaw = - yawDeg*pi/180.0_dp

    ! initialize TI of all turbines to free-stream value
    TIturbs = TI

    ! initialize local k values to free-stream values
    ky_local = ky
    kz_local = kz

    do, d=1, nTurbines

        ! get index of downstream turbine
        turbI = sorted_x_idx(d) + 1

        ! initialize deficit summation term to zero
        deficit_sum = 0.0_dp

!         print *, turbineXw(turbI)

        do, u=1, nTurbines ! at turbineX-locations

            ! get index of upstream turbine
            turb = sorted_x_idx(u) + 1

            ! downstream distance between turbines
            x = turbineXw(turbI) - turbineXw(turb)

            ! set this iterations velocity deficit to 0
            deltav = 0.0_dp

            ! check turbine relative locations
            if (x > 0.0_dp) then

                ! determine the onset location of far wake
                call x0_func(rotorDiameter(turb), yaw(turb), Ct(turb), alpha, &
                            & TIturbs(turb), beta, x0)

                ! downstream distance from far wake onset to downstream turbine
                deltax0 = x - x0

                ! calculate wake spreading parameter at each turbine if desired
                if (calc_k_star .eqv. .true.) then
                    call k_star_func(TIturbs(turb), k_star(turb))
                    ky_local = k_star(turb)
                    kz_local = k_star(turb)
                end if

                !print *, "ky, kz"
                !print *, ky
                !print *, ky_local
                !print *, kz
                !print *, kz_local

                ! far wake region
                if (x >= x0) then

                    ! determine the initial wake angle at the onset of far wake
                    call theta_c_0_func(yaw(turb), Ct(turb), theta_c_0)

                    ! horizontal spread
                    call sigmay_func(ky_local, deltax0, rotorDiameter(turb), yaw(turb), sigmay)
                    !print *, "sigmay ", sigmay
                    ! vertical spread
                    call sigmaz_func(kz_local, deltax0, rotorDiameter(turb), sigmaz)
                    !print *, "sigmaz ", sigmaz
                    ! horizontal cross-wind wake displacement from hub
                    call wake_offset_func(rotorDiameter(turb), theta_c_0, x0, yaw(turb), &
                                         & ky_local, kz_local, Ct(turb), sigmay, sigmaz, wake_offset)
                    !print *, "wake_offset ", wake_offset
                    ! cross wind distance from downstream hub location to wake center
                    deltay = turbineYw(turbI) - (turbineYw(turb) + wake_offset)

                    ! cross wind distance from hub height to height of point of interest
                    deltaz = turbineZ(turbI) - turbineZ(turb)

                    ! velocity difference in the wake
                    call deltav_func(deltay, deltaz, Ct(turb), &
                                     & yaw(turb), sigmay, sigmaz, rotorDiameter(turb), deltav)

                    ! linear supposition
                    !deficit_sum = deficit_sum + deltav

                    ! combine deficits according to selected method wake combination method
                    call wake_combination_func(wind_speed, wtVelocity(turb), deltav,         &
                                               wake_combination_method, deficit_sum)

                ! near wake region (linearized)
                else

                    ! determine the initial wake angle at the onset of far wake
                    call theta_c_0_func(yaw(turb), Ct(turb), theta_c_0)

                    ! horizontal spread at point of interest (currently same as x0)
                    call sigmay_func(ky_local, deltax0, rotorDiameter(turb), yaw(turb), sigmay)

                    ! vertical spread at point of interest (currently same as x0)
                    call sigmaz_func(kz_local, deltax0, rotorDiameter(turb), sigmaz)

                    ! horizontal cross-wind wake displacement from hub
                    call wake_offset_func(rotorDiameter(turb), theta_c_0, x0, yaw(turb), &
                                         & ky_local, kz_local, Ct(turb), sigmay, sigmaz, &
                                         & wake_offset)

                    ! distance from downstream hub location to wake center
                    deltay = turbineYw(turbI) - (turbineYw(turb) + wake_offset)

                    ! vertical distance from downstream hub location to wake center
                    deltaz = turbineZ(turbI) - turbineZ(turb)

                    ! horizontal spread at far wake onset
                    call sigmay_func(ky_local, 0.0_dp, rotorDiameter(turb), yaw(turb), sigmay0)

                    ! vertical spread at far wake onset
                    call sigmaz_func(kz_local, 0.0_dp, rotorDiameter(turb), sigmaz0)

                    ! velocity deficit in the nearwake (linear model)
                    call deltav_near_wake_lin_func(deltay, deltaz, &
                                     & Ct(turb), yaw(turb), sigmay0, sigmaz0, &
                                     & rotorDiameter(turb), x, x0, sigmay0, sigmaz0, deltav)

                    ! combine deficits according to selected method wake combination method
                    call wake_combination_func(wind_speed, wtVelocity(turb), deltav,         &
                                               wake_combination_method, deficit_sum)
                end if

                if ((deltax0 > 0.0_dp) .and. (TI_calculation_method > 0)) then

                    ! calculate TI value at each turbine
                    call added_ti_func(TI, Ct, deltax0, k_star(turb), rotorDiameter(turb), &
                                       & rotorDiameter(turbI), deltay, turbineZ(turb), &
                                       & turbineZ(turbI), TIturbs(turb), &
                                       & TI_calculation_method, &
                                       & TIturbs(turbI))
                end if

            end if
        end do

        ! final velocity calculation for turbine turbI
        wtVelocity(turbI) = wind_speed - deficit_sum

    !! make sure turbine inflow velocity is non-negative
!             if (wtVelocity(turbI) .lt. 0.0_dp) then
!                 wtVelocity(turbI) = 0.0_dp
!             end if
    !print *, "fortran"

    end do

end subroutine porteagel_analyze

! implementation of the Bastankhah and Porte Agel (BPA) wake model for visualization
subroutine porteagel_visualize(nTurbines, nSamples, turbineXw, sorted_x_idx, turbineYw, turbineZ, &
                             rotorDiameter, Ct, wind_speed, &
                             yawDeg, ky, kz, alpha, beta, TI, velX, velY, velZ, &
                             wake_combination_method, TI_calculation_method, &
                             calc_k_star, wsArray)

    ! independent variables: turbineXw turbineYw turbineZ rotorDiameter
    !                        Ct yawDeg

    ! dependent variables: wtVelocity

    implicit none

    ! define precision to be the standard for a double precision ! on local system
    integer, parameter :: dp = kind(0.d0)

    ! in
    integer, intent(in) :: nTurbines, nSamples
    real(dp), dimension(nTurbines), intent(in) :: turbineXw, turbineYw, turbineZ
    integer, dimension(nTurbines), intent(in) :: sorted_x_idx
    real(dp), dimension(nTurbines), intent(in) :: rotorDiameter, yawDeg
    real(dp), dimension(nTurbines), intent(in) :: Ct
    real(dp), intent(in) :: ky, kz, alpha, beta, TI, wind_speed
    real(dp), dimension(nSamples), intent(in) :: velX, velY, velZ
    integer, intent(in) :: wake_combination_method, TI_calculation_method
    logical, intent(in) :: calc_k_star

    ! local (General)
    real(dp), dimension(nTurbines) :: yaw
    real(dp) :: x0, deltax0, deltay, theta_c_0, sigmay, sigmaz, wake_offset
    real(dp) :: x, deltav, deltav0m, sigmay0, sigmaz0, deltavs, deltaz
    Integer :: turb, loc
    real(dp), parameter :: pi = 3.141592653589793_dp

    ! model out
    real(dp), dimension(nSamples), intent(out) :: wsArray

    intrinsic cos, atan, max, sqrt, log

    ! bastankhah and porte agel 2016 define yaw to be positive clockwise, this is reversed
    yaw = - yawDeg*pi/180.0_dp

    ! initialize location velocities to free stream
    wsArray = wind_speed

    do, turb=1, nTurbines

         ! determine the onset location of far wake
        call x0_func(rotorDiameter(turb), yaw(turb), Ct(turb), alpha, TI, beta, x0)

        ! determine the initial wake angle at the onset of far wake
        call theta_c_0_func(yaw(turb), Ct(turb), theta_c_0)

        do, loc=1, nSamples ! at turbineX-locations

            ! downstream distance between turbines
            x = velX(loc) - turbineXw(turb)

            ! downstream distance from far wake onset to downstream turbine
            deltax0 = x - x0

            ! far wake region
            if (x >= x0) then

                ! horizontal spread
                call sigmay_func(ky, deltax0, rotorDiameter(turb), yaw(turb), sigmay)

                ! vertical spread
                call sigmaz_func(kz, deltax0, rotorDiameter(turb), sigmaz)

                ! horizontal cross-wind wake displacement from hub
                call wake_offset_func(rotorDiameter(turb), theta_c_0, x0, yaw(turb), &
                                     & ky, kz, Ct(turb), sigmay, sigmaz, wake_offset)

                ! horizontal distance from downstream hub location to wake center
                deltay = velY(loc) - (turbineYw(turb) + wake_offset)

                ! vertical distance from downstream hub location to wake center
                deltaz = velZ(loc) - turbineZ(turb)

                ! velocity difference in the wake
                call deltav_func(deltay, deltaz, wake_offset, wind_speed, Ct(turb), &
                                 & yaw(turb), sigmay, sigmaz, rotorDiameter(turb), deltav)

                ! linear wake superposition (additive)
                wsArray(loc) = wsArray(loc) - deltav

            ! near wake region (linearized)
            else if (x > 0.0_dp) then

                ! horizontal spread at point of interest
                call sigmay_func(ky, deltax0, rotorDiameter(turb), yaw(turb), sigmay)

                ! vertical spread at point of interest
                call sigmaz_func(kz, deltax0, rotorDiameter(turb), sigmaz)

                ! horizontal cross-wind wake displacement from hub
                call wake_offset_func(rotorDiameter(turb), theta_c_0, x0, yaw(turb), &
                                     & ky, kz, Ct(turb), sigmay, sigmaz, wake_offset)

                ! horizontal distance from downstream hub location to wake center
                deltay = velY(loc) - (turbineYw(turb) + wake_offset)

                ! vertical distance from downstream hub location to wake center
                deltaz = velZ(loc) - turbineZ(turb)

                ! horizontal spread at far wake onset
                call sigmay_func(ky, 0.0_dp, rotorDiameter(turb), yaw(turb), sigmay0)

                ! vertical spread at far wake onset
                call sigmaz_func(kz, 0.0_dp, rotorDiameter(turb), sigmaz0)

                ! velocity deficit in the nearwake (linear model)
                call deltav_near_wake_lin_func(deltay, deltaz, wake_offset, wind_speed, &
                                 & Ct(turb), yaw(turb), sigmay, sigmaz, &
                                 & rotorDiameter(turb), x, x0, sigmay0, sigmaz0, deltav)

                ! linear wake superposition (additive)
                wsArray(loc) = wsArray(loc) - deltav

            end if

            ! make sure turbine flow-field velocity is non-negative
            if (wsArray(loc) .lt. 0.0_dp) then
                wsArray(loc) = 0.0_dp
            end if

        end do
    end do

    !print *, "fortran"

end subroutine porteagel_visualize

! calculates the onset of far-wake conditions
subroutine x0_func(rotor_diameter, yaw, Ct, alpha, TI, beta, x0)

    implicit none

    ! define precision to be the standard for a double precision ! on local system
    integer, parameter :: dp = kind(0.d0)

    ! in
    real(dp), intent(in) :: rotor_diameter, yaw, Ct, alpha, TI, beta

    ! out
    real(dp), intent(out) :: x0

    intrinsic cos, sqrt

    ! determine the onset location of far wake
    x0 = rotor_diameter * (cos(yaw) * (1.0_dp + sqrt(1.0_dp - Ct)) / &
                                (sqrt(2.0_dp) * (alpha * TI + beta * &
                                                & (1.0_dp - sqrt(1.0_dp - Ct)))))

end subroutine x0_func

! calculates the wake angle at the onset of far wake conditions
subroutine theta_c_0_func(yaw, Ct, theta_c_0)

    implicit none

    ! define precision to be the standard for a double precision ! on local system
    integer, parameter :: dp = kind(0.d0)

    ! in
    real(dp), intent(in) :: yaw, Ct

    ! out
    real(dp), intent(out) :: theta_c_0

    intrinsic cos, sqrt

    ! determine the initial wake angle at the onset of far wake
    theta_c_0 = 0.3_dp * yaw * (1.0_dp - sqrt(1.0_dp - Ct * cos(yaw))) / cos(yaw)

end subroutine theta_c_0_func

! calculates the horizontal spread of the wake at a given distance from the onset of far
! wake condition
subroutine sigmay_func(ky, deltax0, rotor_diameter, yaw, sigmay)

    implicit none

    ! define precision to be the standard for a double precision on local system
    integer, parameter :: dp = kind(0.d0)

    ! in
    real(dp), intent(in) :: ky, deltax0, rotor_diameter, yaw

    ! out
    real(dp), intent(out) :: sigmay

    intrinsic cos, sqrt

    ! horizontal spread
    sigmay = rotor_diameter * (ky * deltax0 / rotor_diameter + cos(yaw) / sqrt(8.0_dp))

end subroutine sigmay_func

! calculates the vertical spread of the wake at a given distance from the onset of far
! wake condition
subroutine sigmaz_func(kz, deltax0, rotor_diameter, sigmaz)

    implicit none

    ! define precision to be the standard for a double precision ! on local system
    integer, parameter :: dp = kind(0.d0)

    ! in
    real(dp), intent(in) :: kz, deltax0, rotor_diameter

    ! out
    real(dp), intent(out) :: sigmaz

    ! load necessary intrinsic functions
    intrinsic sqrt

    ! vertical spread
    sigmaz = rotor_diameter * (kz * deltax0 / rotor_diameter + 1.0_dp / sqrt(8.0_dp))

end subroutine sigmaz_func

! calculates the horizontal distance from the wake center to the hub of the turbine making
! the wake
subroutine wake_offset_func(rotor_diameter, theta_c_0, x0, yaw, ky, kz, Ct, sigmay, &
                            & sigmaz, wake_offset)

    implicit none

    ! define precision to be the standard for a double precision ! on local system
    integer, parameter :: dp = kind(0.d0)

    ! in
    real(dp), intent(in) :: rotor_diameter, theta_c_0, x0, yaw, ky, kz, Ct, sigmay
    real(dp), intent(in) :: sigmaz

    ! out
    real(dp), intent(out) :: wake_offset

    intrinsic cos, sqrt, log

    ! horizontal cross-wind wake displacement from hub
    wake_offset = rotor_diameter * (                                           &
                  theta_c_0 * x0 / rotor_diameter +                            &
                  (theta_c_0 / 14.7_dp) * sqrt(cos(yaw) / (ky * kz * Ct)) *    &
                  (2.9_dp + 1.3_dp * sqrt(1.0_dp - Ct) - Ct) *                 &
                  log(                                                         &
                    ((1.6_dp + sqrt(Ct)) *                                     &
                     (1.6_dp * sqrt(8.0_dp * sigmay * sigmaz /                 &
                                    (cos(yaw) * rotor_diameter ** 2))          &
                      - sqrt(Ct))) /                                           &
                    ((1.6_dp - sqrt(Ct)) *                                     &
                     (1.6_dp * sqrt(8.0_dp * sigmay * sigmaz /                 &
                                    (cos(yaw) * rotor_diameter ** 2))          &
                      + sqrt(Ct)))                                             &
                  )                                                            &
    )
end subroutine wake_offset_func

! calculates the velocity difference between hub velocity and free stream for a given wake
! for use in the far wake region
subroutine deltav_func(deltay, deltaz, Ct, yaw, sigmay, sigmaz, rotor_diameter, deltav)

    implicit none

    ! define precision to be the standard for a double precision ! on local system
    integer, parameter :: dp = kind(0.d0)

    ! in
    real(dp), intent(in) :: deltay, deltaz, Ct, yaw, sigmay
    real(dp), intent(in) :: sigmaz, rotor_diameter

    ! out
    real(dp), intent(out) :: deltav

    intrinsic cos, sqrt, exp

    ! velocity difference in the wake
    deltav = (                                                 &
        (1.0_dp - sqrt(1.0_dp - Ct *                                                     &
                       cos(yaw) / (8.0_dp * sigmay * sigmaz / (rotor_diameter ** 2)))) * &
        exp(-0.5_dp * ((deltay) / sigmay) ** 2) * exp(-0.5_dp * ((deltaz) / sigmaz) ** 2)&
    )

end subroutine deltav_func

! calculates the velocity difference between hub velocity and free stream for a given wake
! for use in the near wake region only
subroutine deltav_near_wake_lin_func(deltay, deltaz, Ct, yaw, &
                                 & sigmay, sigmaz, rotor_diameter, x, x0, &
                                 & sigmay0, sigmaz0, deltav)

    implicit none

    ! define precision to be the standard for a double precision ! on local system
    integer, parameter :: dp = kind(0.d0)

    ! in
    real(dp), intent(in) :: deltay, deltaz, Ct, yaw, sigmay
    real(dp), intent(in) :: sigmaz, rotor_diameter, x, x0, sigmay0, sigmaz0

    ! local
    real(dp) :: deltav0m, deltavr

    ! out
    real(dp), intent(out) :: deltav

    intrinsic cos, sqrt, exp

    deltavr = 0.9

    ! magnitude term of gaussian at x0
    deltav0m = (                                         &
                (1.0_dp - sqrt(1.0_dp - Ct *                          &
                cos(yaw) / (8.0_dp * sigmay0 * sigmaz0 /              &
                                            (rotor_diameter ** 2)))))

    ! linearized gaussian magnitude term for near wake
    deltav = (((deltav0m - deltavr)/x0) * x + deltavr) *              &
        exp(-0.5_dp * (deltay / sigmay) ** 2) *                       &
        exp(-0.5_dp * (deltaz / sigmaz) ** 2)

end subroutine deltav_near_wake_lin_func

! calculates the overlap area between a given wake and a rotor area
subroutine overlap_area_func(turbine_y, turbine_z, rotor_diameter, &
                            wake_center_y, wake_center_z, wake_diameter, &
                            wake_overlap)
!   calculate overlap of rotors and wake zones (wake zone location defined by wake
!   center and wake diameter)
!   turbineX,turbineY is x,y-location of center of rotor

    implicit none

    ! define precision to be the standard for a double precision ! on local system
    integer, parameter :: dp = kind(0.d0)

    ! in
    real(dp), intent(in) :: turbine_y, turbine_z, rotor_diameter
    real(dp), intent(in) :: wake_center_y, wake_center_z, wake_diameter

    ! out
    real(dp), intent(out) :: wake_overlap

    ! local
    real(dp), parameter :: pi = 3.141592653589793_dp, tol = 0.000001_dp
    real(dp) :: OVdYd, OVr, OVRR, OVL, OVz

    intrinsic dacos

    OVdYd = wake_center_y-turbine_y        ! distance between wake center and rotor center
    OVr = rotor_diameter/2.0_dp            ! rotor diameter
    OVRR = wake_diameter/2.0_dp            ! wake diameter
    OVdYd = abs(OVdYd)
    if (OVdYd >= 0.0_dp + tol) then
        ! calculate the distance from the wake center to the vertical line between
        ! the two circle intersection points
        OVL = (-OVr*OVr+OVRR*OVRR+OVdYd*OVdYd)/(2.0_dp*OVdYd)
    else
        OVL = 0.0_dp
    end if

    OVz = OVRR*OVRR-OVL*OVL

    ! Finish calculating the distance from the intersection line to the outer edge of the wake
    if (OVz > 0.0_dp + tol) then
        OVz = sqrt(OVz)
    else
        OVz = 0.0_dp
    end if

    if (OVdYd < (OVr+OVRR)) then ! if the rotor overlaps the wake zone

        if (OVL < OVRR .and. (OVdYd-OVL) < OVr) then
            wake_overlap = OVRR*OVRR*dacos(OVL/OVRR) + OVr*OVr*dacos((OVdYd-OVL)/OVr) - OVdYd*OVz
        else if (OVRR > OVr) then
            wake_overlap = pi*OVr*OVr
        else
            wake_overlap = pi*OVRR*OVRR
        end if
    else
        wake_overlap = 0.0_dp
    end if

end subroutine overlap_area_func

! combines wakes using various methods
subroutine wake_combination_func(wind_speed, turb_inflow, deltav,                  &
                                 wake_combination_method, deficit_sum)

    ! combines wakes to calculate velocity at a given turbine
    ! wind_speed                = Free stream velocity
    ! turb_inflow               = Effective velocity as seen by the upstream rotor
    ! deltav                    = Velocity deficit percentage for current turbine pair
    ! wake_combination_method   = Use for selecting which method to use for wake combo
    ! deficit_sum (in)          = Combined deficits prior to including the current deltav
    ! deficit_sum (out)         = Combined deficits after to including the current deltav

    implicit none

    ! define precision to be the standard for a double precision ! on local system
    integer, parameter :: dp = kind(0.d0)

    ! in
    real(dp), intent(in) :: wind_speed, turb_inflow, deltav
    integer, intent(in) :: wake_combination_method

    ! out
    real(dp), intent(inout) :: deficit_sum

    ! intrinsic functions
    intrinsic sqrt

    ! freestream linear superposition (Lissaman 1979)
    if (wake_combination_method == 0) then
        deficit_sum = deficit_sum + wind_speed*deltav

    ! local velocity linear superposition (Niayifar and Porte Agel 2015, 2016)
    else if (wake_combination_method == 1) then
        deficit_sum = deficit_sum + turb_inflow*deltav

    ! sum of squares freestream superposition (Katic et al. 1986)
    else if (wake_combination_method == 2) then
        deficit_sum = sqrt(deficit_sum**2 + (wind_speed*deltav)**2)

    ! sum of squares local velocity superposition (Voutsinas 1990)
    else if (wake_combination_method == 3) then
        deficit_sum = sqrt(deficit_sum**2 + (turb_inflow*deltav)**2)

    ! wake combination method error
    else
        print *, "Invalid wake combination method. Must be one of [0,1,2,3]."
        stop 1
    end if

end subroutine wake_combination_func

! combines wakes using various methods
subroutine added_ti_func(TI, Ct_ust, x, k_star_ust, rotor_diameter_ust, rotor_diameter_dst, &
                        & deltay, wake_height, turbine_height, TI_ust, &
                        & TI_calculation_method, TI_dst)

    implicit none

    ! define precision to be the standard for a double precision ! on local system
    integer, parameter :: dp = kind(0.d0)

    ! in
    real(dp), intent(in) :: Ct_ust, x, k_star_ust, rotor_diameter_ust, rotor_diameter_dst
    real(dp), intent(in) :: deltay, wake_height, turbine_height, TI_ust, TI
    integer, intent(in) :: TI_calculation_method

    ! local
    real(dp) :: axial_induction_ust, beta, epsilon, sigma, wake_diameter, wake_overlap
    real(dp) :: TI_added, TI_tmp, sum_of_squares, rotor_area_dst
    real(dp), parameter :: pi = 3.141592653589793_dp

    ! out
    real(dp), intent(inout) :: TI_dst

    ! intrinsic functions
    intrinsic sqrt
    !print *, "TI_dst in: ", TI_dst
    ! Niayifar and Porte Agel 2015, 2016 (adjusted by Annoni and Thomas for SOWFA match
    ! and optimization)
    if (TI_calculation_method == 1) then
        call ct_to_axial_ind_func(Ct_ust, axial_induction_ust)

        ! calculate BPA spread parameters Bastankhah and Porte Agel 2014
        beta = 0.5_dp*((1.0_dp + sqrt(1.0_dp - Ct_ust))/sqrt(1.0_dp - Ct_ust))
        epsilon = 0.2_dp*sqrt(beta)
        !print *, "epsilon = ", epsilon
        ! calculate wake spread for TI calcs
        sigma = k_star_ust*x + rotor_diameter_ust*epsilon
        wake_diameter = 4.0_dp*sigma
        !print *, "sigma = ", sigma
        ! calculate wake overlap ratio
        call overlap_area_func(deltay, turbine_height, rotor_diameter_dst, &
                            0.0_dp, wake_height, wake_diameter, &
                            wake_overlap)
        !print *, "wake_overlap = ", wake_overlap
        ! Calculate the turbulence added to the inflow of the downstream turbine by the
        ! wake of the upstream turbine
        TI_added = 0.73_dp*(axial_induction_ust**0.8325)*(TI_ust**0.0325)* &
                    ((x/rotor_diameter_ust)**-0.32)
        !print *, "TI_added = ", TI_added
        rotor_area_dst = 0.25_dp*pi*rotor_diameter_dst**2
        ! Calculate the total turbulence intensity at the downstream turbine
        !sum_of_squares = TI_dst**2 + (TI_added*wake_overlap)**2
        ! print *, "sum of squares = ", sum_of_squares
!         TI_dst = sqrt(sum_of_squares)
!         print *, "TI_dst = ", TI_dst
        TI_dst = sqrt(TI_dst**2 + (TI_added*wake_overlap/rotor_area_dst)**2)

    ! Niayifar and Porte Agel 2015, 2016
    else if (TI_calculation_method == 2) then
        call ct_to_axial_ind_func(Ct_ust, axial_induction_ust)

        ! calculate BPA spread parameters Bastankhah and Porte Agel 2014
        beta = 0.5_dp*((1.0_dp + sqrt(1.0_dp - Ct_ust))/sqrt(1.0_dp - Ct_ust))
        epsilon = 0.2_dp*sqrt(beta)

        ! calculate wake spread for TI calcs
        sigma = k_star_ust*x + rotor_diameter_ust*epsilon
        wake_diameter = 4.0_dp*sigma

        ! calculate wake overlap ratio
        call overlap_area_func(deltay, turbine_height, rotor_diameter_dst, &
                            0.0_dp, wake_height, wake_diameter, &
                            wake_overlap)

        ! Calculate the turbulence added to the inflow of the downstream turbine by the
        ! wake of the upstream turbine
        TI_added = 0.73_dp*(axial_induction_ust**0.8325)*(TI_ust**0.0325)* &
                    ((x/rotor_diameter_ust)**-0.32)

        ! Calculate the total turbulence intensity at the downstream turbine based on
        ! current upstream turbine
        rotor_area_dst = 0.25_dp*pi*rotor_diameter_dst**2
        TI_tmp = sqrt(TI**2 + (TI_added*wake_overlap/rotor_area_dst)**2)

        ! Check if this is the max and use it if it is
        if (TI_tmp > TI_dst) then
            TI_dst = TI_tmp
        end if

    ! TODO add other TI calculation methods

    ! wake combination method error

    else
        print *, "Invalid added TI calculation method. Must be one of [1,2,3]."
        stop 1
    end if
    !print *, "TI_dst out: ", TI_dst
end subroutine added_ti_func

! combines wakes using various methods
subroutine k_star_func(TI_ust, k_star_ust)

    implicit none

    ! define precision to be the standard for a double precision ! on local system
    integer, parameter :: dp = kind(0.d0)

    ! in
    real(dp), intent(in) :: TI_ust

    ! out
    real(dp), intent(inout) :: k_star_ust

    k_star_ust = 0.3837*TI_ust+0.003678

end subroutine k_star_func

! calculate axial induction from Ct
subroutine ct_to_axial_ind_func(CT, axial_induction)

    implicit none

    ! define precision to be the standard for a double precision ! on local system
    integer, parameter :: dp = kind(0.d0)

    ! in
    real(dp), intent(in) :: CT

    ! out
    real(dp), intent(out) :: axial_induction

    axial_induction = 0.0_dp

    ! execute
    if (CT > 0.96) then  ! Glauert condition
        axial_induction = 0.143_dp + sqrt(0.0203_dp-0.6427_dp*(0.889_dp - CT))
    else
        axial_induction = 0.5_dp*(1.0_dp-sqrt(1.0_dp-CT))
    end if

end subroutine ct_to_axial_ind_func


	SUBROUTINE GCYLML ( mproj, msppj, np, dlat, dlon, polat, polon,
     +			    rotat, sclmcd, swchxy, xl, yl, iret )
C************************************************************************
C* GCYLML								*
C* 									*
C* This subroutine converts a location from latitude/longitude		*
C* coordinates to linear intermediate coordinates for cylindrical	*
C* projections.								*
C*									*
C* SWCHXY is a flag for a -90 degree rotation of the linear coordinates *
C* to develop a transverse projection with the y-axis oriented south to *
C* north.                                                               *
C* 									*
C* GCYLML ( MPROJ, MSPPJ, NP, DLAT, DLON, POLAT, POLON, ROTAT, 		*
C*          SCLMCD, SWCHXY, XL, YL, IRET )				*
C*									*
C* Input parameters:							*
C*	MPROJ		INTEGER		Projection class		*
C*	MSPPJ		INTEGER		Projection type			*
C*	NP		INTEGER		Number of points		*
C* 	DLAT (NP)	REAL		Latitudes			*
C* 	DLON (NP)	REAL		Longitudes			*
C*	POLAT		REAL		Not used			*
C*	POLON		REAL		Central longitude 		*
C*	ROTAT		REAL		Not used			*
C*	SCLMCD		REAL		Scaling for MCD			*
C*	SWCHXY		LOGICAL		Flag to rotate x,y		*
C* 									*
C* Output parameters:							*
C* 	XL (NP)		REAL		X coordinates			*
C* 	YL (NP)		REAL		Y-coordinates			*
C* 	IRET		INTEGER		Return code			*
C**									*
C* Log:									*
C* G. Chatters/RDS	 7/84	GEMPLT Version 3.0			*
C* M. desJardins/GSFC	 7/87	GEMPLT Version 3.1			*
C* M. desJardins/GSFC	 1/88	Fixed CED rounding problem at pole	*
C* M. desJardins/GSFC	 6/88	Added EPS for rounding			*
C* K. Brill/EMC		 3/96	Changes for general rotation		*
C************************************************************************
	INCLUDE		'ERROR.PRM'
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		xl (*), yl (*), dlat (*), dlon (*)
	LOGICAL		swchxy
C*
	PARAMETER	( EPS = .00001 )
C*
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = NORMAL
C
C*	Loop through all points.
C
	hlfpin = -HALFPI - EPS
	hlfpip = HALFPI + EPS

	DO  i = 1, np
C
C*	  Check for missing data.
C
	  IF  ( ( ERMISS ( dlat (i) ) ) .or.
     +		( ERMISS ( dlon (i) ) ) )  THEN
	    xl (i) = RMISSD
	    yl (i) = RMISSD
	  ELSE
	    rlat   = dlat (i) * DTR
	    rlon   = dlon (i) * DTR
	    xl (i) = rlon - polon
	    yl (i) = RMISSD
C
C*	    Compute internal projection angles.
C*	    Special case of cylinder tangent at equator.
C*	    The general case is implemented via coordinate rotation.
C
C*	    Compute Y axis coordinate for given projection type.
C
	    IF ( mproj .eq. MPCEQU )  THEN
C				! Cylindrical equidistant
		IF  ( ( rlat .ge. hlfpin ) .and.
     +		      ( rlat .le. hlfpip ) )  THEN
		    yl (i) = rlat
		END IF
C				! Mercator
	      ELSE IF ( mproj .eq. MPCMER ) THEN
		IF (( rlat .gt. -HALFPI ) .and. ( rlat .lt. HALFPI ))
     +			THEN
		    a      = HALFPI - rlat
		    yl (i) = ALOG ( ( 1.0 + COS ( a ) ) / SIN ( a ) )
		END IF
C				! Modified cylindrical equidistant
	      ELSE IF ( mproj .eq. MPCMCD ) THEN
		IF  ( ( rlat .ge. hlfpin ) .and.
     +		      ( rlat .le. hlfpip ) )  THEN
		    yl (i) = sclmcd * rlat
		END IF
	   END IF
C
C*	   If the y value is missing, set the x value to missing.
C
	   IF  ( ERMISS ( yl (i) ) )  xl (i) = RMISSD
	  END IF
	  IF ( swchxy ) THEN
		xsav = xl (i)
	 	xl (i) = -yl (i)
		yl (i) = xsav
	  END IF
	END DO
	IF ( swchxy ) THEN
	    CALL PRNLNR ( np, yl, ier )
	ELSE
	    CALL PRNLNR ( np, xl, ier )
	END IF
C*
	RETURN
	END


! parameter(nterms=8,pi=3.1415926,twopi=2.*pi,rad=pi/180.)
! parameter(npts=1000)
! common/path/t(npts),x(nterms,npts)

subroutine dist(range,time)
  !parameter(nterms=8,pi=3.1415926,twopi=2.*pi,rad=pi/180.)
  integer, parameter :: nterms=8
  real, parameter :: pi=3.1415926
  real, parameter :: twopi=2.*pi
  real, parameter :: rad=pi/180.

  !parameter(npts=1000)
  integer, parameter :: npts=1000

  common/path/t(npts),x(nterms,npts)
  do i=1,npts
     if(x(3,i).le.0..and.i.gt.1) go to 250
  end do
  ! linear interpolation to get range
250 frac=x(3,i-1)/(x(3,i-1)-x(3,i))
  d1=sqrt(x(2,i-1)**2+x(1,i-1)**2)
  d2=sqrt(x(2,i)**2+x(1,i)**2)
  range=d1+frac*(d2-d1)
  time=t(i)
  return
end subroutine dist


module kernels
implicit none

contains

function kern_prod(k, x, l) result(y)
  external :: k        ! Base kernel
  real(8) :: k
  real(8), intent(in)  :: x(:)  ! Input argument
  real(8), intent(in)  :: l(:)  ! Length scales
  real(8) :: y
  integer :: i
  y = 1d0
  do i = 1, size(x)
    y = y*k(x(i)/l(i))
  end do
end function

function dkern_prod(k, dk, j, x, l) result(y)
  external :: k        ! Base kernel
  real(8) :: k
  external :: dk        ! Base kernel
  real(8) :: dk       ! Derivative of base kernel
  integer, intent(in) :: j      ! Direction to differentiate
  real(8), intent(in)  :: x(:)  ! Input argument
  real(8), intent(in)  :: l(:)  ! Length scales
  real(8) :: y
  integer :: i
  y = 1d0
  do i = 1, size(x)
    if (i == j) then
      y = y*dk(x(i)/l(i))/l(i)  ! Factor for direction to differentiate
    else
      y = y*k(x(i)/l(i))        ! Usual factor
    end if
  end do
end function

end module kernels


      SUBROUTINE iau_CAL2JD ( IY, IM, ID, DJM0, DJM, J )
*+
*  - - - - - - - - - - -
*   i a u _ C A L 2 J D
*  - - - - - - - - - - -
*
*  Gregorian Calendar to Julian Date.
*
*  This routine is part of the International Astronomical Union's
*  SOFA (Standards of Fundamental Astronomy) software collection.
*
*  Status:  support routine.
*
*  Given:
*     IY,IM,ID    i     year, month, day in Gregorian calendar (Note 1)
*
*  Returned:
*     DJM0        d     MJD zero-point: always 2400000.5
*     DJM         d     Modified Julian Date for 0 hrs
*     J           i     status:
*                           0 = OK
*                          -1 = bad year   (Note 3: JD not computed)
*                          -2 = bad month  (JD not computed)
*                          -3 = bad day    (JD computed)
*
*  Notes:
*
*  1) The algorithm used is valid from -4800 March 1, but this
*     implementation rejects dates before -4799 January 1.
*
*  2) The Julian Date is returned in two pieces, in the usual SOFA
*     manner, which is designed to preserve time resolution.  The
*     Julian Date is available as a single number by adding DJM0 and
*     DJM.
*
*  3) In early eras the conversion is from the "Proleptic Gregorian
*     Calendar";  no account is taken of the date(s) of adoption of
*     the Gregorian Calendar, nor is the AD/BC numbering convention
*     observed.
*
*  Reference:
*
*     Explanatory Supplement to the Astronomical Almanac,
*     P. Kenneth Seidelmann (ed), University Science Books (1992),
*     Section 12.92 (p604).
*
*  This revision:  2014 November 7
*
*  SOFA release 2017-04-20
*
*  Copyright (C) 2017 IAU SOFA Board.  See notes at end.
*
*-----------------------------------------------------------------------

      IMPLICIT NONE

      INTEGER IY, IM, ID
      DOUBLE PRECISION DJM0, DJM

      INTEGER J, NDAYS, MY, IYPMY

*  Earliest year allowed (4800BC)
      INTEGER IYMIN
      PARAMETER ( IYMIN = -4799 )

*  Month lengths in days
      INTEGER MTAB(12)
      DATA MTAB / 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 /

* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

*  Preset status.
      J = 0

*  Validate year.
      IF ( IY.LT.IYMIN ) THEN
         J = -1
      ELSE

*     Validate month.
         IF ( IM.GE.1 .AND. IM.LE.12 ) THEN

*        Days in current month.
            NDAYS = MTAB(IM)

*        Allow for leap year.
            IF ( IM .EQ. 2 ) THEN
               IF ( MOD(IY,4) .EQ. 0 ) NDAYS = 29
               IF ( MOD(IY,100).EQ.0 .AND.
     :              MOD(IY,400).NE.0 ) NDAYS = 28
            END IF

*        Validate day.
            IF ( ID.LT.1 .OR. ID.GT.NDAYS ) J = -3

*        Result.
            MY = ( IM - 14 ) / 12
            IYPMY = IY + MY
            DJM0 = 2400000.5D0
            DJM = DBLE( ( 1461 * ( IYPMY + 4800 ) ) / 4
     :                + (  367 * ( IM-2 - 12*MY ) ) / 12
     :                - (    3 * ( ( IYPMY + 4900 ) / 100 ) ) / 4
     :                + ID - 2432076)

*        Bad month
         ELSE
            J = -2
         END IF
      END IF

*  Finished.

*+----------------------------------------------------------------------
*
*  Copyright (C) 2017
*  Standards Of Fundamental Astronomy Board
*  of the International Astronomical Union.
*
*  =====================
*  SOFA Software License
*  =====================
*
*  NOTICE TO USER:
*
*  BY USING THIS SOFTWARE YOU ACCEPT THE FOLLOWING SIX TERMS AND
*  CONDITIONS WHICH APPLY TO ITS USE.
*
*  1. The Software is owned by the IAU SOFA Board ("SOFA").
*
*  2. Permission is granted to anyone to use the SOFA software for any
*     purpose, including commercial applications, free of charge and
*     without payment of royalties, subject to the conditions and
*     restrictions listed below.
*
*  3. You (the user) may copy and distribute SOFA source code to others,
*     and use and adapt its code and algorithms in your own software,
*     on a world-wide, royalty-free basis.  That portion of your
*     distribution that does not consist of intact and unchanged copies
*     of SOFA source code files is a "derived work" that must comply
*     with the following requirements:
*
*     a) Your work shall be marked or carry a statement that it
*        (i) uses routines and computations derived by you from
*        software provided by SOFA under license to you; and
*        (ii) does not itself constitute software provided by and/or
*        endorsed by SOFA.
*
*     b) The source code of your derived work must contain descriptions
*        of how the derived work is based upon, contains and/or differs
*        from the original SOFA software.
*
*     c) The names of all routines in your derived work shall not
*        include the prefix "iau" or "sofa" or trivial modifications
*        thereof such as changes of case.
*
*     d) The origin of the SOFA components of your derived work must
*        not be misrepresented;  you must not claim that you wrote the
*        original software, nor file a patent application for SOFA
*        software or algorithms embedded in the SOFA software.
*
*     e) These requirements must be reproduced intact in any source
*        distribution and shall apply to anyone to whom you have
*        granted a further right to modify the source code of your
*        derived work.
*
*     Note that, as originally distributed, the SOFA software is
*     intended to be a definitive implementation of the IAU standards,
*     and consequently third-party modifications are discouraged.  All
*     variations, no matter how minor, must be explicitly marked as
*     such, as explained above.
*
*  4. You shall not cause the SOFA software to be brought into
*     disrepute, either by misuse, or use for inappropriate tasks, or
*     by inappropriate modification.
*
*  5. The SOFA software is provided "as is" and SOFA makes no warranty
*     as to its use or performance.   SOFA does not and cannot warrant
*     the performance or results which the user may obtain by using the
*     SOFA software.  SOFA makes no warranties, express or implied, as
*     to non-infringement of third party rights, merchantability, or
*     fitness for any particular purpose.  In no event will SOFA be
*     liable to the user for any consequential, incidental, or special
*     damages, including any lost profits or lost savings, even if a
*     SOFA representative has been advised of such damages, or for any
*     claim by any third party.
*
*  6. The provision of any version of the SOFA software under the terms
*     and conditions specified herein does not imply that future
*     versions will also be made available under the same terms and
*     conditions.
*
*  In any published work or commercial product which uses the SOFA
*  software directly, acknowledgement (see www.iausofa.org) is
*  appreciated.
*
*  Correspondence concerning SOFA software should be addressed as
*  follows:
*
*      By email:  sofa@ukho.gov.uk
*      By post:   IAU SOFA Center
*                 HM Nautical Almanac Office
*                 UK Hydrographic Office
*                 Admiralty Way, Taunton
*                 Somerset, TA1 2DN
*                 United Kingdom
*
*-----------------------------------------------------------------------

      END


      SUBROUTINE SCLGNP(N,NN,MMAXT,NUMT,DEG,MODE,EPS0,COEF,
     $                    NNUMT,DDEG,CCOEF,ALPHA,BETA,RWORK,XWORK,
     $                                      FACV,FACE,COESCL,IERR)
C
C SCLGNP  SCALES THE COEFFICIENTS OF A POLYNOMIAL SYSTEM OF N
C EQUATIONS IN N UNKNOWNS, F(X)=0, WHERE THE JTH TERM OF
C THE ITH EQUATION LOOKS LIKE:
C
C    COEF(I,J) * X(1)**DEG(I,1,J) ... X(N)**DEG(I,N,J)
C
C THE ITH EQUATION IS SCALED BY 10**FACE(I).  THE KTH
C VARIABLE IS SCALED BY 10**FACV(K).  IN OTHER WORDS, X(K) =
C 10**FACV(K) * Y(K), WHERE Y SOLVES THE SCALED EQUATION.
C THE SCALED EQUATION HAS THE SAME FORM AS THE ORIGINAL
C EQUATION, EXCEPT THAT COESCL(I,J) REPLACES COEF(I,J), WHERE
C
C COESCL(I,J)=COEF(I,J)* 10**( FACE(I) + FACV(1)*DEG(I,1,J)+ ...
C                                       +FACV(N)*DEG(I,N,J) )
C
C THE CRITERION FOR GENERATING FACE AND FACV IS THAT OF
C MINIMIZING THE SUM OF SQUARES OF THE EXPONENTS OF THE SCALED
C COEFFICIENTS.  IT TURNS OUT THAT THIS CRITERION REDUCES TO
C SOLVING A SINGLE LINEAR SYSTEM, ALPHA*X = BETA, AS DEFINED
C IN THE CODE BELOW.  FURTHER, THE FORM OF THE POLYNOMIAL
C SYSTEM ALONE DETERMINES THE MATRIX ALPHA.  THUS, IN CASES
C IN WHICH MANY SYSTEMS OF THE SAME FORM, BUT WITH DIFFERENT
C COEFFICIENTS, ARE TO BE SCALED, THE MATRIX ALPHA IS
C UNCHANGED AND MAY BE FACTORED ONLY ONCE (BY  QRFAQF).  WHEN
C SCLGNP  IS CALLED WITH MODE=1,  SCLGNP  DOES NOT RECOMPUTE OR
C REFACTOR THE MATRIX ALPHA.  SEE MEINTJES AND MORGAN "A
C METHODOLOGY FOR SOLVING CHEMICAL EQUILIBRIUM SYSTEMS"
C (GENERAL MOTORS RESEARCH LABORATORIES TECHNICAL REPORT
C GMR-4971).
C
C SUBROUTINES CALLED DIRECTLY:  QRFAQF, QRSLQF.
C SUBROUTINES CALLED INDIRECTLY:  DAXPY, DCOPY, DDOT, DNRM2, DSCAL.
C
C ON INPUT:
C
C N  IS THE NUMBER OF EQUATIONS AND THE NUMBER OF VARIABLES.
C
C NN  IS THE DECLARED DIMENSION OF SEVERAL ARRAY INDICES.
C
C MMAXT  IS AN UPPER BOUND ON THE SET NUMT(I), I=1 TO N.
C
C NUMT(I)  IS THE NUMBER OF TERMS IN THE I-TH EQUATION FOR I=1 TO N.
C
C DEG(I,K,J)  IS THE DEGREE OF THE K-TH VARIABLE IN THE
C   J-TH TERM OF THE I-TH EQUATION FOR I=1 TO N, J=1 TO NUMT(I), AND
C   K=1 TO N.
C
C MODE
C  =1  THIS IS NOT THE FIRST CALL TO  SCLGNP, AND THE FORM OF THE
C      SYSTEM HAS NOT CHANGED.
C  =0  THIS IS THE FIRST CALL TO  SCLGNP.
C
C EPS0  ZERO-EPSILON FOR TERMS (TERMS LESS THAN  EPS0  IN MAGNITUDE
C   ARE TREATED AS ZERO BY THE SCALING ALGORITHM).
C
C COEF(I,J)  IS THE COEFFICIENT OF THE JTH TERM OF THE ITH EQUATION
C   FOR I=1 TO N AND J=1 TO NUMT(N).  (COEF(I,J) MAY BE ZERO.)
C
C NNUMT, DDEG, CCOEF, ALPHA, BETA, RWORK, AND  XWORK  ARE WORKSPACES.
C
C ON OUTPUT:
C
C N, NUMT, DEG, MODE, EPS0, AND  COEF  ARE UNCHANGED.
C
C FACV(I)  IS THE VARIABLE SCALE FACTOR FOR THE I-TH VARIABLE, FOR
C   I=1 TO N.
C
C FACE(I)  IS THE EQUATION SCALE FACTOR FOR THE I-TH EQUATION, FOR
C   I=1 TO N.
C
C COESCL(I,J)  IS THE SCALED VERSION OF COEFFICIENT  COEF(I,J), FOR
C   I=1 TO N, J=1 TO NUMT(I), UNLESS IERR=1.
C
C IERR
C   =0  IF SCALING MATRIX, ALPHA, IS WELL CONDITIONED.
C   =1  OTHERWISE.  IN THIS CASE, ALPHA IS "REPAIRED" AND A
C         SCALING IS COMPUTED.
C
C
C DECLARATION OF INPUT
      INTEGER N,NN,MMAXT,NUMT(NN),DEG(NN,NN+1,MMAXT)
      INTEGER MODE
      DOUBLE PRECISION EPS0,COEF
      DIMENSION COEF(NN,MMAXT)
C
C DECLARATION OF WORKSPACE
      INTEGER NNUMT,DDEG
      DOUBLE PRECISION CCOEF,ALPHA,BETA,RWORK,XWORK
      DIMENSION NNUMT(N),DDEG(N,N+1,MMAXT)
      DIMENSION CCOEF(N,MMAXT),ALPHA(2*N,2*N),BETA(2*N),
     $ RWORK(N*(2*N+1)),XWORK(2*N)
C
C DECLARATION OF OUTPUT
      INTEGER IERR
      DOUBLE PRECISION FACV,FACE,COESCL
      DIMENSION FACV(N),FACE(N),COESCL(N,MMAXT)
C
C DECLARATION OF VARIABLES
      INTEGER I,IDAMAX,IFLAG,INDEX,IRMAX,J,JJ,K,LENR,N2,S
      DOUBLE PRECISION D1MACH,DUM,LMFPN,NTUR,RTOL,SUM
C
      SAVE
C
      IERR=0
      N2=2*N
      LMFPN=D1MACH(2)
      NTUR=D1MACH(4)*N
      LENR=N*(N+1)/2
C
C  DELETE NEAR ZERO TERMS
      DO  60 I=1,N
         JJ=0
         NNUMT(I)=0
         DO 40 J=1,NUMT(I)
             IF(ABS(COEF(I,J)) .GT. EPS0) THEN
                JJ=JJ+1
                NNUMT(I)=NNUMT(I)+1
                  CCOEF(I,JJ)=COEF(I,J)
                  DO 20 K=1,N
                    DDEG(I,K,JJ)=DEG(I,K,J)
  20              CONTINUE
             END IF
  40     CONTINUE
  60  CONTINUE
      DO 90 I=1,N
          DO 80 J=1,NNUMT(I)
              COESCL(I,J)=LOG10(ABS(CCOEF(I,J)))
  80      CONTINUE
  90  CONTINUE
C
C SKIP OVER THE GENERATION AND DECOMPOSITON OF MATRIX ALPHA IF MODE=1
      IF (MODE .EQ. 0) THEN
C
C GENERATE THE MATRIX ALPHA
      DO 110 S=1,N
      DO 110 K=1,N
          ALPHA(S,K)=0
 110  CONTINUE
      DO 200 S=1,N
        ALPHA(S,S)=NNUMT(S)
 200  CONTINUE
      DO 300 S=1,N
        DO 300 I=1,N
          SUM=0
          DO 220 J=1,NNUMT(I)
            SUM=SUM+DDEG(I,S,J)
 220      CONTINUE
          ALPHA(N+S,I)=SUM
 300  CONTINUE
      DO 400 S=1,N
        DO 330 K=1,N
          SUM=0
          DO 320 I=1,N
            DO 310 J=1,NNUMT(I)
              SUM=SUM+DDEG(I,S,J)*DDEG(I,K,J)
 310        CONTINUE
 320      CONTINUE
          ALPHA(N+S,N+K)=SUM
 330    CONTINUE
 400  CONTINUE
      DO 500 S=1,N
        DO 500 K=1,N
          SUM=0
          DO 420 J=1,NNUMT(S)
            SUM=SUM+DDEG(S,K,J)
 420      CONTINUE
          ALPHA(S,N+K)=SUM
 500  CONTINUE
C
C COMPUTE QR FACTORIZATION OF MATRIX ALPHA
      CALL QRFAQF(ALPHA,RWORK,2*N,IFLAG)
C
C REPAIR ILL CONDITIONED SCALING MATRIX
      IRMAX=IDAMAX(LENR,RWORK,1)
      RTOL=RWORK(IRMAX)*NTUR
      INDEX=1
      DO 510 I=N,2,-1
        IF (ABS(RWORK(INDEX)) .LT. RTOL) THEN
          RWORK(INDEX)=LMFPN
          IERR=1
        ENDIF
      INDEX=INDEX+I
 510  CONTINUE
      IF (ABS(RWORK(INDEX)) .LT. RTOL) THEN
        RWORK(INDEX)=LMFPN
        IERR=1
      ENDIF
C
      ENDIF
C
C CONTROL PASSES HERE IF MODE=1
C
C
C GENERATE THE COLUMN BETA
      DO 600 S=1,N
        SUM=0
        DO 550 J=1,NNUMT(S)
          SUM=SUM+COESCL(S,J)
 550    CONTINUE
        BETA(S)=-SUM
 600  CONTINUE
      DO 700 S=1,N
        SUM=0
        DO 620 I=1,N
          DO 610 J=1,NNUMT(I)
            SUM=SUM+COESCL(I,J)*DDEG(I,S,J)
 610      CONTINUE
 620    CONTINUE
        BETA(N+S)=-SUM
 700  CONTINUE
C
C SOLVE THE LINEAR SYSTEM ALPHA * X = BETA
      CALL QRSLQF(ALPHA,RWORK,BETA,XWORK,2*N)
C
C GENERATE FACE, FACV, AND THE MATRIX COESCL
      DO 800 I=1,N
        FACE(I)=BETA(I)
        FACV(I)=BETA(N+I)
 800  CONTINUE
      DO 900 I=1,N
        DO 820 J=1,NUMT(I)
          DUM = ABS(COEF(I,J))
          IF (DUM .EQ. 0.0) THEN
            COESCL(I,J) = 0.0
          ELSE
            SUM = FACE(I) + LOG10( DUM )
            DO 810 K=1,N
              SUM = SUM + FACV(K)*DEG(I,K,J)
 810        CONTINUE
            COESCL(I,J) = SIGN(10.0**(SUM), COEF(I,J))
          ENDIF
 820    CONTINUE
 900  CONTINUE
      RETURN
      END


      SUBROUTINE ORRS(LSTI,LREI,NI,YI,UI,UDI, REI, ITMAXI,
     &                ALPHAR,ALPHAI , OMEGAR,OMEGAI,
     &                UTR,UTI, VTR,VTI, WTR, WTI, CTR, CTI, DELMAX)
      DIMENSION YI(NI), UI(NI), UDI(NI)
      DIMENSION UTR(NI), UTI(NI), VTR(NI), VTI(NI),
     &          WTR(NI), WTI(NI), CTR(NI), CTI(NI)
C---------------------------------------------------------------------
C     Routine for solving the Orr-Sommerfeld equation
C     in the spatial or temporal stability problems.
C
C     Input:
C     ------
C      LSTI    1: spatial  amplification problem
C              2: temporal amplification problem
C      LREI    1: Reynolds number fixed
C              2: Reynolds number variable
C                 [ to obtain specified ai (LSTI=1), or wi (LSTI=2) ]
C      NI      total number of points in profiles
C      YI      normal BL coordinate array
C      UI      mean flow u(y) profile
C      UDI     mean flow du/dy profile
C      REI     Reynolds number
C      ITMAXI  max number of Newton iterations to seek eigenvalue
C      OMEGAR  real  part of temporal frequency (for initial guess)
C      OMEGAI  imag. part of temporal frequency (for initial guess)
C      ALPHAR  real  part of complex wavenumber (for initial guess)
C      ALPHAI  imag. part of complex wavenumber (for initial guess)
C
C     Output:
C     -------
C      OMEGAR  real  part of temporal frequency (if LSTI = 2)
C      OMEGAI  imag. part of temporal frequency (if LSTI = 2)
C      ALPHAR  real  part of complex wavenumber (if LSTI = 1)
C      ALPHAI  imag. part of complex wavenumber (if LSTI = 1)
C      UTR     real  part of perturbation x-velocity profile
C      UTI     imag. part of perturbation x-velocity profile
C      VTR     real  part of perturbation y-velocity profile
C      VTI     imag. part of perturbation y-velocity profile
C      WTR     real  part of perturbation vorticity profile
C      WTI     imag. part of perturbation vorticity profile
C      CTR     real  part of perturbation d(vorticity)/dy profile
C      CTI     imag. part of perturbation d(vorticity)/dy profile
C      DELMAX  max change in (UTR,UTI) in last iteration (~= 0 if converged)
C---------------------------------------------------------------------
C
      INCLUDE 'ORRS.INC'
C
C---- convergence tolerance
      DATA EPS / 1.0E-4 /
C
      IF(NI.GT.NMAX) STOP 'ORRS: Array overflow.'
C
C---- set initial BC flag
      IBC  = 1
C
C---- set du'/dy normalization constant (normally imposed at wall)
      FNORM = (1.0,-1.0)
ccc      FNORM = (1.0, 0.0)
C
C---- set input variables from parameter list
      LST = LSTI
      LRE = LREI
C
      ITMAX = ITMAXI
C
      N = NI
      DO I=1, N
        Y(I) = YI(I)
        U(I) = UI(I)
        UD(I) = UDI(I)
      ENDDO
C
      IRE   = CMPLX( 0.0  , REI  )
      ALPHA = CMPLX(ALPHAR,ALPHAI)
      OMEGA = CMPLX(OMEGAR,OMEGAI)
C
C---- save initial guess for restoration if normalization condition is relocated
      OMINIT = OMEGA
      ALINIT = ALPHA
C
C
C---- set number of righthand sides
      NRHS = 2
      IF(LRE .EQ. 2) NRHS = 3
C
      CALL OS_INIT
C
C---- Newton iteration loop
      DO 100 ITER=1, ITMAX
C
        CALL OS_SETUP
        CALL OS_SOLVE
        CALL OS_UPDATE
C
        CALL OS_BCCHEK
C
CCC        call newpen(1)
CCC        do 66 i=1, n
CCC          utr(i) = real(f1(i))
CCC   66   continue
CCC        call urplot(n,y,utr)
C
        DELMAX = DFMAX
C
        IF(ITMAX.EQ.1) GO TO 101
C
c        IF(LRE.EQ.1) THEN
c         IF(LST.EQ.1)
c     &    WRITE(*,7011) ITER,DFMAX,REAL(ALPHA),IMAG(ALPHA)
c 7011     FORMAT(1X,I2,'  max =', E11.4,'  a =', 2F10.6)
c         IF(LST.EQ.2)
c     &    WRITE(*,7012) ITER,DFMAX,REAL(OMEGA),IMAG(OMEGA)
c 7012     FORMAT(1X,I2,'  max =', E11.4,'  w =', 2F10.6)
c        ELSE
c         IF(LST.EQ.1)
c     &    WRITE(*,7021) ITER,DFMAX,REAL(ALPHA),IMAG(ALPHA),IMAG(IRE)
c 7021    FORMAT(1X,I2,'  max =', E11.4,'  a =', 2F10.6,'  Re =',E11.4)
c         IF(LST.EQ.2)
c     &    WRITE(*,7022) ITER,DFMAX,REAL(OMEGA),IMAG(OMEGA),IMAG(IRE)
c 7022    FORMAT(1X,I2,'  max =', E11.4,'  w =', 2F10.6,'  Re =',E11.4)
c        ENDIF
C
        IF(ISOL.NE.0 .AND. DFMAX .LT. EPS) GO TO 101
  100 CONTINUE
      WRITE(*,*) 'ORRS: Convergence failed.  Continuing ...'
C
  101 CONTINUE
C
C---- save variables for passing back to calling routine
      ALPHAR = REAL(ALPHA)
      ALPHAI = IMAG(ALPHA)
      OMEGAR = REAL(OMEGA)
      OMEGAI = IMAG(OMEGA)
      REI = IMAG(IRE)
C
      DO 200 I=1, N
        UTR(I) =  REAL(F1(I))
        UTI(I) =  IMAG(F1(I))
        VTR(I) =  REAL((0.0,-1.0)*ALPHA*F0(I))
        VTI(I) =  IMAG((0.0,-1.0)*ALPHA*F0(I))
        WTR(I) = -REAL(F2(I))
        WTI(I) = -IMAG(F2(I))
        CTR(I) = -REAL(F3(I))
        CTI(I) = -IMAG(F3(I))
  200 CONTINUE
C
      RETURN
      END ! ORRS

      SUBROUTINE OS_INIT
      INCLUDE 'ORRS.INC'
C
      DO I=1, N
        F0(I) = 0.
        F1(I) = 0.
        F2(I) = 0.
        F3(I) = 0.
      ENDDO
C
      ISOL = 0
C
      RETURN
      END

      SUBROUTINE OS_BCCHEK
      INCLUDE 'ORRS.INC'
      COMPLEX FFACT
C
      FWALL = CABS(F2(1))
      FEDGE = CABS(F2(N))
C
      IF(IBC .EQ. 1  .AND.  FEDGE .GT. 2.0*FWALL) THEN
       WRITE(*,*) 'Switching normalizing condition to edge'
       IBC = 2
       FFACT = FNORM/F2(N)
      ELSE IF(IBC .EQ. 2  .AND.  FWALL .GT. 2.0*FEDGE) THEN
       WRITE(*,*) 'Switching normalizing condition to wall'
       IBC = 1
       FFACT = FNORM/F2(1)
      ELSE
       RETURN
      ENDIF
C
      DO I=1, N
        F0(I) = F0(I)*FFACT
        F1(I) = F1(I)*FFACT
        F2(I) = F2(I)*FFACT
        F3(I) = F3(I)*FFACT
      ENDDO
C
      ISOL = 0
      ITMAX = MIN0( ITMAX + 1 , 20 )
      IF(LST.EQ.1) ALPHA = ALINIT
      IF(LST.EQ.2) OMEGA = OMINIT
C
      RETURN
      END ! OS_BCCHEK

      SUBROUTINE OS_SETUP
      INCLUDE 'ORRS.INC'
C------------------------------------------------------
C     Sets up 4x4 block-tridiagnonal system
C     for Orr-Sommerfeld equation solution.
C
C     The perturbation stream function has the form:
C
C         P(x,y,t;a,w,R,U)  =  p(y) exp[i(ax - wt)]
C
C     The four equations set up are:
C
C         p' = q    2
C         q' = r + a p
C         r' = s                     2
C         s' = iR[(aU-w)r - aU"p] + a p
C
C     p = streamfunction  = F0
C     q = velocity        = F1
C     r = vorticity       = F2
C     s = dr/dy           = F3
C
C------------------------------------------------------
C
C---- zero out A,B,C blocks and righthand sides R
      DO I=1, N
        DO J=1, 4
          DO K=1, 4
            A(J,K,I) = (0.0,0.0)
            B(J,K,I) = (0.0,0.0)
            C(J,K,I) = (0.0,0.0)
          ENDDO
          DO K=1, NRMAX
            R(J,K,I) = (0.0,0.0)
          ENDDO
        ENDDO
      ENDDO
C
      I = 1
C
C---- set 1st wall BC
      R(1,1,I) = F0(I)
      A(1,1,I) = 1.0
C
      IF(IBC.EQ.1) THEN
C
C----- set normalizing condition in lieu of 2nd wall BC (enforced in OS_UPDATE)
       R(2,1,I) = F2(I) - FNORM
       A(2,3,I) = 1.0
C
      ELSE
C
C----- set 2nd wall BC
       R(2,1,I) = F1(I)
       A(2,2,I) = 1.0
C
      ENDIF
C
C---- set interior equations
      DO 50 I=1,N-1
C
        DY = Y(I+1) - Y(I)
        UAV = 0.5*(U(I+1) + U(I))
        UDD = UD(I+1) - UD(I)
C---------------------------------------------------------------
C
        R(1,1,I+1) = F0(I+1) - F0(I) - 0.5*DY*(F1(I+1)+F1(I))
        B(1,1,I+1) = -1.0
        A(1,1,I+1) =  1.0
        B(1,2,I+1) = -0.5*DY
        A(1,2,I+1) = -0.5*DY
C---------------------------------------------------------------
C
        R(2,1,I+1) = F1(I+1) - F1(I)
     &             - 0.5*DY*(   F2(I+1)+F2(I)
     &                         + (F0(I+1)+F0(I))*ALPHA**2 )
        IF(LST.EQ.1)
     &  R(2,2,I+1) = -0.5*DY * (F0(I+1)+F0(I)) * 2.0*ALPHA
        B(2,1,I+1) = -0.5*DY*ALPHA**2
        A(2,1,I+1) = -0.5*DY*ALPHA**2
        B(2,2,I+1) = -1.0
        A(2,2,I+1) =  1.0
        B(2,3,I+1) = -0.5*DY
        A(2,3,I+1) = -0.5*DY
C---------------------------------------------------------------
C
        R(3,1,I) = F2(I+1) - F2(I) - 0.5*DY*(F3(I+1)+F3(I))
        A(3,3,I) = -1.0
        C(3,3,I) =  1.0
        A(3,4,I) = -0.5*DY
        C(3,4,I) = -0.5*DY
C---------------------------------------------------------------
C
        R(4,1,I) = F3(I+1) - F3(I)
     &             - 0.5*DY* (F2(I+1)+F2(I)) * ALPHA**2
     &             - IRE*( (ALPHA*UAV-OMEGA)*0.5*DY*(F2(I+1)+F2(I))
     &                    - ALPHA*UDD*0.5*(F0(I+1)+F0(I)) )
        IF(LST.EQ.1)
     &  R(4,2,I) = - 0.5*DY* (F2(I+1)+F2(I)) * 2.0*ALPHA
     &             - IRE*(        UAV       *0.5*DY*(F2(I+1)+F2(I))
     &                    -       UDD*0.5*(F0(I+1)+F0(I)) )
        IF(LST.EQ.2)
     &  R(4,2,I) = - IRE*( (         -1.0  )*0.5*DY*(F2(I+1)+F2(I)) )
        R(4,3,I) =
     &        -(0.0,1.0)*( (ALPHA*UAV-OMEGA)*0.5*DY*(F2(I+1)+F2(I))
     &                    - ALPHA*UDD*0.5*(F0(I+1)+F0(I)) )
        A(4,1,I) =                      IRE* ALPHA*UDD*0.5
        C(4,1,I) =                      IRE* ALPHA*UDD*0.5
        A(4,3,I) = -0.5*DY*ALPHA**2 - IRE*(ALPHA*UAV-OMEGA)*0.5*DY
        C(4,3,I) = -0.5*DY*ALPHA**2 - IRE*(ALPHA*UAV-OMEGA)*0.5*DY
        A(4,4,I) = -1.0
        C(4,4,I) =  1.0
C---------------------------------------------------------------
C
   50 CONTINUE
C
C---- set asymptotic regularity conditions at outer edge
C
      FACSQ  = ALPHA**2 + IRE*(ALPHA*U(N)-OMEGA)
      FAC    = CSQRT(FACSQ)
      IF(REAL(FACSQ) .LT. 0.0  .AND.  IMAG(FACSQ) .LT. 0.0) THEN
CCC       WRITE(*,*) 'ORRS: Overdamped mode.'
       FAC = -FAC
      ENDIF
      FAC_AL = (2.0*ALPHA + IRE*U(N)) * 0.5/FAC
      FAC_OM = (          - IRE     ) * 0.5/FAC
      FAC_RE = (0.0,1.0)*(ALPHA*U(N)-OMEGA) * 0.5/FAC
C
      IF(IBC.EQ.2) THEN
C
C----- set normalization condition in lieu of asymptotic regularity condition
       R(3,1,N) = F2(N) - FNORM
       A(3,3,N) = 1.0
C
      ELSE
C
       R(3,1,N) = (ALPHA + FAC   )*(F1(N) + F0(N)*ALPHA) + F2(N)
       IF(LST.EQ.1)
     & R(3,2,N) = (1.0   + FAC_AL)*(F1(N) + F0(N)*ALPHA)
     &          + (ALPHA + FAC   )*(        F0(N)      )
       IF(LST.EQ.2)
     & R(3,2,N) = (        FAC_OM)*(F1(N) + F0(N)*ALPHA)
       R(3,3,N) = (        FAC_RE)*(F1(N) + F0(N)*ALPHA)
       A(3,1,N) = (ALPHA + FAC   )*(              ALPHA)
       A(3,2,N) = (ALPHA + FAC   )
       A(3,3,N) = 1.0
C
      ENDIF
C
      R(4,1,N) = F3(N) + F2(N)*FAC
      IF(LST.EQ.1)
     &R(4,2,N) =         F2(N)*FAC_AL
      IF(LST.EQ.2)
     &R(4,2,N) =         F2(N)*FAC_OM
      R(4,3,N) =         F2(N)*FAC_RE
      A(4,3,N) =               FAC
      A(4,4,N) = 1.0
C
      RETURN
      END ! OS_SETUP

      SUBROUTINE OS_SOLVE
      INCLUDE 'ORRS.INC'
      COMPLEX PIVOT, TEMP
C---------------------------------------------------
C     4x4 complex tridiagonal block solver.
C     Customized for Orr-Sommerfeld equation system,
C     with certain entries assumed to be zero.
C     (Gives large CPU speedup).
C
C      Assumed initial structure for a block row:
C
C         p q r s   p q r s   p q r s
C        |* * # 0| |* * 0 0| |0 0 0 0|  <--  p' = q    2
C        |* * * 0| |* * * 0| |0 0 0 0|  <--  q' = r + a p
C        |# # # 0| |* * * *| |0 0 * *|  <--  r' = s                     2
C        |# # # 0| |* * * *| |* 0 * *|  <--  s' = iR[(au-w)r - au"p] + a p
C
C         B block   A block   C block
C
C        *  assumed nonzero in initial system
C        #  assumed zero in initial system, becoming nonzero due to fill-in
C        0  assumed zero always
C---------------------------------------------------
C
CCC** Backward sweep: Elimination of upper block diagonal (C's).
      DO 1 I=N, 1, -1
C
        IP = I+1
C
C------ don't eliminate Cn block because it doesn't exist
        IF(I.EQ.N) GO TO 12
C
C------ eliminate Ci block, thus modifying Ai and Ri blocks
        DO 111 L=1, 3
          K = 3
          A(K,L,I) = A(K,L,I)
     &             - C(K,3,I)*B(3,L,IP)
     &             - C(K,4,I)*B(4,L,IP)
          K = 4
          A(K,L,I) = A(K,L,I)
     &             - C(K,1,I)*B(1,L,IP)
     &             - C(K,3,I)*B(3,L,IP)
     &             - C(K,4,I)*B(4,L,IP)
  111   CONTINUE
        DO 112 L=1, NRHS
          K = 3
          R(K,L,I) = R(K,L,I)
     &             - C(K,3,I)*R(3,L,IP)
     &             - C(K,4,I)*R(4,L,IP)
          K = 4
          R(K,L,I) = R(K,L,I)
     &             - C(K,1,I)*R(1,L,IP)
     &             - C(K,3,I)*R(3,L,IP)
     &             - C(K,4,I)*R(4,L,IP)
  112   CONTINUE
C
C                                                              -1
CCC---- multiply Bi block and righthand side Ri vectors by (Ai)
C       using Gaussian elimination.
C
   12   CONTINUE
C
        DO 13 KPIV=4, 2, -1
C
          KM1 = KPIV-1
C
          PIVOT = 1.0/A(KPIV,KPIV,I)
C
C-------- normalize pivot row
          DO 132 L=1, KM1
            A(KPIV,L,I) = A(KPIV,L,I)*PIVOT
  132     CONTINUE
C
          B(KPIV,1,I) = B(KPIV,1,I)*PIVOT
          B(KPIV,2,I) = B(KPIV,2,I)*PIVOT
          B(KPIV,3,I) = B(KPIV,3,I)*PIVOT
C
          DO 134 L=1, NRHS
            R(KPIV,L,I) = R(KPIV,L,I)*PIVOT
  134     CONTINUE
C
C-------- eliminate upper off-diagonal element in Ai block
          K = KM1
            TEMP = A(K,KPIV,I)
            DO 1351 L=KM1, 1, -1
              A(K,L,I) = A(K,L,I) - TEMP*A(KPIV,L,I)
 1351       CONTINUE
            B(K,1,I) = B(K,1,I) - TEMP*B(KPIV,1,I)
            B(K,2,I) = B(K,2,I) - TEMP*B(KPIV,2,I)
            B(K,3,I) = B(K,3,I) - TEMP*B(KPIV,3,I)
            DO 1352 L=1, NRHS
              R(K,L,I) = R(K,L,I) - TEMP*R(KPIV,L,I)
 1352       CONTINUE
C
   13   CONTINUE
C
C
C------ solve for first row
        PIVOT = 1.0/A(1,1,I)
        B(1,1,I) = B(1,1,I)*PIVOT
        B(1,2,I) = B(1,2,I)*PIVOT
        B(1,3,I) = B(1,3,I)*PIVOT
        DO 14 L=1, NRHS
          R(1,L,I) = R(1,L,I)*PIVOT
   14   CONTINUE
C
C------ back substitute (eliminate everything below diagonal in Ai block)
        DO 15 L=1, 3
          B(2,L,I) = B(2,L,I) - A(2,1,I)*B(1,L,I)
          B(3,L,I) = B(3,L,I) - A(3,1,I)*B(1,L,I)
     &                        - A(3,2,I)*B(2,L,I)
          B(4,L,I) = B(4,L,I) - A(4,1,I)*B(1,L,I)
     &                        - A(4,2,I)*B(2,L,I)
     &                        - A(4,3,I)*B(3,L,I)
   15   CONTINUE
C
        DO 16 L=1, NRHS
          R(2,L,I) = R(2,L,I) - A(2,1,I)*R(1,L,I)
          R(3,L,I) = R(3,L,I) - A(3,1,I)*R(1,L,I)
     &                        - A(3,2,I)*R(2,L,I)
          R(4,L,I) = R(4,L,I) - A(4,1,I)*R(1,L,I)
     &                        - A(4,2,I)*R(2,L,I)
     &                        - A(4,3,I)*R(3,L,I)
  16    CONTINUE
C
    1 CONTINUE
C
CCC** Forward sweep: Back substitution using lower block diagonal (Bi's).
      DO 2 I=2, N
        IM = I-1
        DO 21 L=1, NRHS
          DO 211 K=1, 4
            R(K,L,I) = R(K,L,I)
     &        - (  R(1,L,IM)*B(K,1,I)
     &           + R(2,L,IM)*B(K,2,I)
     &           + R(3,L,IM)*B(K,3,I) )
  211     CONTINUE
   21   CONTINUE
    2 CONTINUE
C
      RETURN
      END ! OS_SOLVE

      SUBROUTINE OS_UPDATE
      INCLUDE 'ORRS.INC'
      COMPLEX DF0,DF1,DF2,DF3
      COMPLEX DAW
      COMPLEX RES, RES_AL, RES_OM, RES_RE, RES_F0, RES_F1, RES_F2,
     &             RES_AW
C
      IF(ISOL.EQ.0) THEN
C
C----- no mode solution yet -- don't try to converge on eigenvalue
       DAW = (0.0,0.0)
       DRE = 0.0
C
      ELSE
C
C----- drive eigenvalue (alpha or omega) to satisfy dropped BC at wall or edge
       IF(IBC.EQ.1) THEN
C
C------ wall BC was dropped -- enforce it here
        I = 1
        DAW = (F1(I) - R(2,1,I)) / R(2,2,I)
        DRE = 0.0
C
       ELSE
C
C------ edge BC was dropped -- enforce it here
        RES    = (ALPHA + FAC   )*(F1(N) + F0(N)*ALPHA) + F2(N)
        RES_AL = (1.0   + FAC_AL)*(F1(N) + F0(N)*ALPHA)
     &         + (ALPHA + FAC   )*(        F0(N)      )
        RES_OM = (        FAC_OM)*(F1(N) + F0(N)*ALPHA)
        RES_RE = (        FAC_RE)*(F1(N) + F0(N)*ALPHA)
        RES_F0 = (ALPHA + FAC   )*(              ALPHA)
        RES_F1 = (ALPHA + FAC   )
        RES_F2 = 1.0
C
        IF(LST.EQ.1) RES_AW = RES_AL
        IF(LST.EQ.2) RES_AW = RES_OM
C
        DAW =-(RES   -RES_F0*R(1,1,N)-RES_F1*R(2,1,N)-RES_F2*R(3,1,N))
     &      / (RES_AW-RES_F0*R(1,2,N)-RES_F1*R(2,2,N)-RES_F2*R(3,2,N))
C
       ENDIF
C
      ENDIF
C
C---- set either alpha or omega change (spatial or temporal problem)
      IF(LST.EQ.1) THEN
       DALPHA = DAW
       DOMEGA = (0.0,0.0)
      ELSE
       DALPHA = (0.0,0.0)
       DOMEGA = DAW
      ENDIF
C
C
      RLX = 1.0
C
      DALF = REAL(DALPHA)/ABS(ALPHA)
      IF(RLX*DALF .LT. -.1) RLX = -.1/DALF
      IF(RLX*DALF .GT. 0.1) RLX = 0.1/DALF
C
      DALF = IMAG(DALPHA)/ABS(ALPHA)
      IF(RLX*DALF .LT. -.1) RLX = -.1/DALF
      IF(RLX*DALF .GT. 0.1) RLX = 0.1/DALF
C
      DOMF = REAL(DOMEGA)/ABS(OMEGA)
      IF(RLX*DOMF .LT. -.1) RLX = -.1/DOMF
      IF(RLX*DOMF .GT. 0.1) RLX = 0.1/DOMF
C
      DOMF = IMAG(DOMEGA)/ABS(OMEGA)
      IF(RLX*DOMF .LT. -.1) RLX = -.1/DOMF
      IF(RLX*DOMF .GT. 0.1) RLX = 0.1/DOMF
C
C      DREF = DRE / IMAG(IRE)
C      IF(RLX*DREF .LT. -.2) RLX = -.2/DREF
C      IF(RLX*DREF .GT. 0.3) RLX = 0.3/DREF
CC
C
C==== see if normalizing condition position needs to be changed
C
cC---- predicted wall and edge f" values at next iteration level
c      FWALL = CABS(F2(1) - R(3,1,1) - DAW*R(3,2,1) - DRE*R(3,3,1))
c      FEDGE = CABS(F2(N) - R(3,1,N) - DAW*R(3,2,N) - DRE*R(3,3,N))
cC
cC---- set flag to normalize whatever is bigger by factor of 2
cC
c      IF(IBC .EQ. 1  .AND.  FEDGE .GT. 2.0*FWALL) THEN
cC
c       WRITE(*,*) 'Switching normalizing condition to edge'
c       IBC = 2
c       ITMAX = MIN0( ITMAX+1 , 20 )
c       IF(LST.EQ.1) ALPHA = ALINIT
c       IF(LST.EQ.2) OMEGA = OMINIT
c       RETURN
cC
c      ELSE IF(IBC .EQ. 2  .AND.  FWALL .GT. 2.0*FEDGE) THEN
cC
c       WRITE(*,*) 'Switching normalizing condition to wall'
c       IBC = 1
c       ITMAX = MIN0( ITMAX+1 , 20 )
c       IF(LST.EQ.1) ALPHA = ALINIT
c       IF(LST.EQ.2) OMEGA = OMINIT
c       RETURN
cC
c      ENDIF
C
C
      DFMAX = 0.0
      DFRMS = 0.0
C
C---- perform Newton update on modes
      DO 50 I=1, N
        DF0 = -R(1,1,I) - DAW*R(1,2,I) - DRE*R(1,3,I)
        DF1 = -R(2,1,I) - DAW*R(2,2,I) - DRE*R(2,3,I)
        DF2 = -R(3,1,I) - DAW*R(3,2,I) - DRE*R(3,3,I)
        DF3 = -R(4,1,I) - DAW*R(4,2,I) - DRE*R(4,3,I)
C
        F0(I) = F0(I) + RLX*DF0
        F1(I) = F1(I) + RLX*DF1
        F2(I) = F2(I) + RLX*DF2
        F3(I) = F3(I) + RLX*DF3
C
        D0SQ = (REAL(DF0)**2 + IMAG(DF0)**2)
        D1SQ = (REAL(DF1)**2 + IMAG(DF1)**2)
        D2SQ = (REAL(DF2)**2 + IMAG(DF2)**2)
        D3SQ = (REAL(DF3)**2 + IMAG(DF3)**2)
C
C       IF(D0SQ .GT. DFMAX) THEN
C        KVMAX = 0
C        IVMAX = I
C        DFMAX = D0SQ
C       ENDIF
C
C       IF(D1SQ .GT. DFMAX) THEN
C        KVMAX = 1
C        IVMAX = I
C        DFMAX = D1SQ
C       ENDIF
C
C       IF(D2SQ .GT. DFMAX) THEN
C        KVMAX = 2
C        IVMAX = I
C        DFMAX = D2SQ
C       ENDIF
C
C       IF(D3SQ .GT. DFMAX) THEN
C        KVMAX = 3
C        IVMAX = I
C        DFMAX = D3SQ
C       ENDIF
C
        DFMAX = MAX( DFMAX , D0SQ , D1SQ , D2SQ , D3SQ )
        DFRMS =      DFRMS + D0SQ + D1SQ + D2SQ + D3SQ
   50 CONTINUE
C
      DFMAX = SQRT( DFMAX )
      DFRMS = SQRT( DFRMS / (4.0*FLOAT(N)) )
C
C---- perform Newton update on eigenvalues
      ALPHA = ALPHA + RLX*DALPHA
      OMEGA = OMEGA + RLX*DOMEGA
      IRE   = IRE   + RLX*CMPLX(0.0,DRE)
C
C---- modes are now available
      ISOL = 1
C
      RETURN
      END ! OS_UPDATE


      SUBROUTINE UNIVEC(VEC)
C
C  UNIVEC TRANSFORMS ANY VECTOR INTO A UNIT VECTOR IN SAME DIRECTION
C
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION VEC(3)
      VECMAG=DSQRT(VEC(1)**2+VEC(2)**2+VEC(3)**2)
      DO 1 I=1,3
    1 VEC(I)=VEC(I)/VECMAG
      RETURN
      END


!***********************************************************************
!                                                                      *
      SUBROUTINE DPBDT(J)
!-----------------------------------------------
!                                                                      *
!   This subroutine computes H times the derivative, with respect to   *
!   the internal grid, of the large and small components of the wave   *
!   function with index  J .  These  are tabulated, respectively, in   *
!   arrays  TA  and  TB  in  COMMON  block  /TATB/ .                   *
!                                                                      *
!   A  thirteen-point  Lagrange formaula is used for the calculation   *
!   of derivatives.                                                    *
!                                                                      *
!   Written by Farid F Parpia, at Oxford   Last updated: 06 Oct 1992   *
!                                                                      *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  10:47:21   2/14/04
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE GRID_C
      USE LIC13_C
      USE TATB_C, ONLY: TA, TB
      USE WAVE_C
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: J
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: I, K, IROW, LOC
      REAL(DOUBLE) :: A1, A2, A3, A4, A5, A6, HDPBDT, HDQBDT, AIK
!-----------------------------------------------
!

!     Replace the equivalence statement
      A1=A(7,1)
      A2=A(7,2)
      A3=A(7,3)
      A4=A(7,4)
      A5=A(7,5)
      A6=A(7,6)
!
!   Compute derivative in three separate regions
!
!   First, points 1 to 6
!
      DO I = 1,6
         HDPBDT = 0.D0
         HDQBDT = 0.D0
!cjb replace loop by SUM
!        DO 1 K = 1,13
!            AIK = A(I,K)
!            HDPBDT = HDPBDT+AIK*PF(K,J)
!            HDQBDT = HDQBDT+AIK*QF(K,J)
!    1    CONTINUE
         HDPBDT = SUM(A(I   ,:)*PF(:13,J))
         HDQBDT = SUM(A(I   ,:)*QF(:13,J))
!cjb
         TA(I) = HDPBDT
         TB(I) = HDQBDT
      END DO

!   Next, points 7 to N-6
!
!   Special treatment for this region because of the symmetry of
!   the differentiation formula
!
      DO I = 7, N - 6
         TA(I) = A1*(PF(I - 6,J) - PF(I + 6,J)) + A2*(PF(I - 5,J) - PF(I + 5,J)&
            ) + A3*(PF(I - 4,J) - PF(I + 4,J)) + A4*(PF(I - 3,J) - PF(I + 3,J))&
             + A5*(PF(I - 2,J) - PF(I + 2,J)) + A6*(PF(I - 1,J) - PF(I + 1,J))
         TB(I) = A1*(QF(I - 6,J) - QF(I + 6,J)) + A2*(QF(I - 5,J) - QF(I + 5,J)&
            ) + A3*(QF(I - 4,J) - QF(I + 4,J)) + A4*(QF(I - 3,J) - QF(I + 3,J))&
             + A5*(QF(I - 2,J) - QF(I + 2,J)) + A6*(QF(I - 1,J) - QF(I + 1,J))
      END DO
!
!   Last, points N-5 to N
!
      DO I = N - 5, N
         IROW = I - N + 13
          HDPBDT = SUM(A(IROW,:)*PF(N-12:N,J))
          HDQBDT = SUM(A(IROW,:)*QF(N-12:N,J))
!- git 1/12/07 code below from the new libraries
!         HDPBDT = 0.D0
!        HDQBDT = 0.D0
!        DO K = 1, 13
!           AIK = A(IROW,K)
!           LOC = N - 13 + K
!           HDPBDT = HDPBDT + AIK*PF(LOC,J)
!           HDQBDT = HDQBDT + AIK*QF(LOC,J)
!        END DO
!- git 1/12/07
         TA(I) = HDPBDT
         TB(I) = HDQBDT
      END DO
      RETURN
      END SUBROUTINE DPBDT


SUBROUTINE DGTSVX_F95(DL, D, DU, B, X, DLF, DF, DUF, DU2, &
                           IPIV, FACT, TRANS, FERR, BERR, RCOND, INFO)
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS ..
   USE LA_PRECISION, ONLY: WP => DP
   USE LA_AUXMOD, ONLY: LSAME, ERINFO
   USE F77_LAPACK, ONLY: GTSVX_F77 => LA_GTSVX
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. SCALAR ARGUMENTS ..
   CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS, FACT
   INTEGER, INTENT(OUT), OPTIONAL :: INFO
   REAL(WP), INTENT(OUT), OPTIONAL :: RCOND
!  .. ARRAY ARGUMENTS ..
   REAL(WP), INTENT(IN) :: DL(:), D(:), DU(:), B(:,:)
   INTEGER, INTENT(INOUT), OPTIONAL, TARGET :: IPIV(:)
   REAL(WP), INTENT(INOUT), OPTIONAL, TARGET :: DLF(:), DF(:), DUF(:), DU2(:)
   REAL(WP), INTENT(OUT), OPTIONAL, TARGET :: FERR(:), BERR(:)
   REAL(WP), INTENT(OUT) :: X(:,:)
!----------------------------------------------------------------------
!
! Purpose
! =======
!
!     LA_GTSVX computes the solution to a real or complex linear system
! of equations of the form A*X = B, A^T*X = B or A^H*X = B, where A is a
! square tridiagonal matrix and X and B are rectangular matrices or
! vectors.
!     LA_GTSVX can also optionally estimate the condition number of A and
! compute error bounds.
!
! =========
!
!       SUBROUTINE LA_GTSVX( DL, D, DU, B, X, DLF=dlf, DF=df, DUF=duf, &
!               DU2=du2, IPIV=ipiv, FACT=fact, TRANS=trans, FERR=ferr, &
!               BERR=berr, RCOND=rcond, INFO=info )
!           <type>(<wp>), INTENT(IN) :: DL(:), D(:), DU(:), <rhs>
!           <type>(<wp>), INTENT(OUT) :: <sol>
!           <type>(<wp>), INTENT(INOUT), OPTIONAL :: DLF(:), DF(:), &
!                                                   DUF(:), DU2(:)
!           INTEGER, INTENT(INOUT), OPTIONAL :: IPIV(:)
!           CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: FACT, TRANS
!           REAL(<wp>), INTENT(OUT), OPTIONAL :: <err>
!           REAL(<wp>), INTENT(OUT), OPTIONAL :: RCOND
!           INTEGER, INTENT(OUT), OPTIONAL :: INFO
!       where
!           <type> ::= REAL | COMPLEX
!           <wp>   ::= KIND(1.0) | KIND(1.0D0)
!           <rhs>  ::= B(:,:) | B(:)
!           <sol>  ::= X(:,:) | X(:)
!           <err>  ::= FERR(:), BERR(:) | FERR, BERR
!
! Arguments
! =========
!
! DL     (input) REAL or COMPLEX array, shape (:) with size(DL) = n-1.
!        The subdiagonal of A.
! D      (input) REAL or COMPLEX array, shape (:) with size(D) = n.
!        The diagonal of A.
! DU     (input) REAL or COMPLEX array, shape (:) with size(DU) = n-1.
!        The superdiagonal of A.
! B      (input/output) REAL or COMPLEX array, shape (:,:) with
!        size(B,1) = n or shape (:) with size(B) = n.
!        The matrix B.
! X      (output) REAL or COMPLEX array, shape (:,:) with size(X,1) = n
!        and size(X,2) = size(B,2), or shape (:) with size(X) = n.
!        The solution matrix X .
! DLF    Optional (input or output) REAL or COMPLEX array, shape (:) with
!        size(DLF)= n-1.
!        If FACT = 'F' then DLF is an input argument that contains the
!        multipliers that define the matrix L from the LU factorization
!        of A.
!        If FACT = 'N' then DLF is an output argument that contains the
!        multipliers that define the matrix L from the LU factorization
!        of A.
! DF     Optional (input or output) REAL or COMPLEX array, shape (:) with
!        size(DF)= n.
!        If FACT = 'F' then DF is an input argument that contains the
!        diagonal of the matrix U .
!        If FACT = 'N' then DF is an output argument that contains the
!        diagonal of the matrix U .
! DUF    Optional (input or output) REAL or COMPLEX array, shape (:) with
!        size(DUF) = n-1.
!        If FACT = 'F' then DUF is an input argument that contains the
!        first superdiagonal of U.
!        If FACT = 'N' then DUF is an output argument that contains the
!        first superdiagonal of U.
! DU2    Optional (input or output) REAL or COMPLEX array, shape (:) with
!        size(DU2) = n-2.
!        If FACT = 'F', then DU2 is an input argument that contains the
!        second superdiagonal of U.
!        If FACT = 'N', then DU2 is an output argument that contains the
!        second superdiagonal of U.
! IPIV   Optional (input or output) INTEGER array, shape (:) with
!        size(IPIV) = n.
!        If FACT = 'F' then IPIV is an input argument that contains the
!        pivot indices from the LU factorization of A.
!        If FACT = 'N', then IPIV is an output argument that contains the
!        pivot indices from the LU factorization of A; row i of the
!        matrix was interchanged with row IPIV(i). IPIV(i) will always
!        be either i or i+1; IPIV(i) = i indicates a row interchange was
!        not required.
! FACT   Optional (input) CHARACTER(LEN=1).
!        Specifies whether the factored form of A is supplied on entry.
!            = 'N': The matrix will be copied to DLF, DF and DUF and
! 	          factored.
!            = 'F': DLF, DF, DUF, DU2 and IPIV contain the factored form
! 	          of A.
!        Default value: 'N'.
! TRANS  Optional (input) CHARACTER(LEN=1).
!        Specifies the form of the system of equations:
!            = 'N': A*X = B (No transpose)
!            = 'T': A^T*X = B (Transpose)
!            = 'C': A^H*X = B (Conjugate transpose)
!        Default value: 'N'.
! FERR   Optional (output) REAL array of shape (:), with size(FERR) =
!        size(X,2), or REAL scalar.
!        The estimated forward error bound for each solution vector X(j)
!        (the j-th column of the solution matrix X). If XTRUE is the true
!        solution corresponding to X(j) , FERR(j) is an estimated upper
!        bound for the magnitude of the largest element in (X(j)-XTRUE)
!        divided by the magnitude of the largest element in X(j). The
!        estimate is as reliable as the estimate for RCOND and is almost
!        always a slight overestimate of the true error.
! BERR   Optional (output) REAL array of shape (:), with size(BERR) =
!        size(X,2), or REAL scalar.
!        The componentwise relative backward error of each solution
!        vector X(j) (i.e.,the smallest relative change in any element of
!        A or B that makes X(j) an exact solution).
! RCOND  Optional (output) REAL.
!        The estimate of the reciprocal condition number of the matrix A.
!        If RCOND is less than the machine precision, the matrix is
!        singular to working precision. This condition is indicated by
!        a return code of INFO > 0.
! INFO   Optional (output) INTEGER
!        = 0: successful exit.
!        < 0: if INFO = -i, the i-th argument had an illegal value.
!        > 0: if INFO = i, and i is
!           <= n: U(i,i) = 0. The factorization has not been completed
! 	        unless i = n. The factor U is singular, so the solution
! 		could not be computed.
!           = n+1: U is nonsingular, but RCOND is less than machine
! 	        precision, meaning that the matrix is singular to
! 		working precision. Nevertheless, the solution and
!                 error bounds are computed because the computed solution
! 		can be more accurate than the value of RCOND would
! 		suggest.
!        If INFO is not present and an error occurs, then the program is
!        terminated with an error message.
!----------------------------------------------------------------------
!  .. PARAMETERS ..
   CHARACTER(LEN=8), PARAMETER :: SRNAME = 'LA_GTSVX'
!  .. LOCAL SCALARS ..
   CHARACTER(LEN=1) :: LFACT, LTRANS
   INTEGER :: LINFO, NRHS, N, ISTAT, ISTAT1, SIPIV, SDLF, SDF, SDUF, SDU2, &
              SFERR, SBERR
   REAL(WP) :: LRCOND
!  .. LOCAL POINTERS ..
   INTEGER, POINTER :: IWORK(:), LPIV(:)
   REAL(WP),  POINTER :: LFERR(:), LBERR(:)
   REAL(WP),  POINTER :: WORK(:), LDLF(:), LDF(:), LDUF(:), LDU2(:)
!  .. INTRINSIC FUNCTIONS ..
   INTRINSIC PRESENT, SIZE
!  .. EXECUTABLE STATEMENTS ..
   LINFO = 0; ISTAT = 0
   N = SIZE(D); NRHS = SIZE(B,2)
   IF( PRESENT(RCOND) ) RCOND = 1.0_WP
   IF( PRESENT(FACT) )THEN; LFACT = FACT; ELSE; LFACT='N'; END IF
   IF( PRESENT(IPIV) )THEN; SIPIV = SIZE(IPIV); ELSE; SIPIV = N; END IF
   IF( PRESENT(DLF) )THEN; SDLF = SIZE(DLF); ELSE; SDLF = N-1; END IF
   IF( PRESENT(DF) )THEN; SDF = SIZE(DF); ELSE; SDF = N; END IF
   IF( PRESENT(DUF) )THEN; SDUF = SIZE(DUF); ELSE; SDUF = N-1; END IF
   IF( PRESENT(DU2) )THEN; SDU2 = SIZE(DU2); ELSE; SDU2 = N-2; END IF
   IF( PRESENT(FERR) )THEN; SFERR = SIZE(FERR); ELSE; SFERR = NRHS; END IF
   IF( PRESENT(BERR) )THEN; SBERR = SIZE(BERR); ELSE; SBERR = NRHS; END IF
   IF(PRESENT(TRANS))THEN; LTRANS = TRANS; ELSE; LTRANS='N'; END IF
!  PRINT *, LINFO, ISTAT, N, NRHS, LFACT, SIPIV, SDLF, SDF, SDUF, SDU2, SFERR, SBERR, LTRANS
!  .. TEST THE ARGUMENTS
   IF( SIZE( DL ) /= N-1 .AND. N/=0 ) THEN; LINFO = -1
   ELSE IF( N < 0 ) THEN; LINFO = -2
   ELSE IF( SIZE( DU ) /= N-1 .AND. N/=0) THEN; LINFO = -3
   ELSE IF( SIZE(B, 1) /= N .OR. NRHS < 0 )THEN; LINFO = -4
   ELSE IF( SIZE(X, 1) /= N .OR. SIZE(X, 2) /= NRHS )THEN; LINFO = -5
   ELSE IF( SDLF /= N-1 .AND. N/=0) THEN; LINFO = -6
   ELSE IF( SDF /= N ) THEN; LINFO = -7
   ELSE IF( SDUF /= N-1 .AND. N/=0 ) THEN; LINFO = -8
   ELSE IF( SDU2 /= N-2 .AND. N>1 ) THEN; LINFO = -9
   ELSE IF( SIPIV /= N )THEN; LINFO = -10
   ELSE IF( SFERR /= NRHS )THEN; LINFO = -13
   ELSE IF( SBERR /= NRHS )THEN; LINFO = -14
   ELSE IF( ( .NOT. ( LSAME(LFACT,'F') .OR. LSAME(LFACT,'N') ) ) .OR. &
       ( LSAME(LFACT,'F') .AND. .NOT.( PRESENT(DF) .AND. PRESENT(IPIV) ) ) )THEN
      LINFO = -11
   ELSE IF( .NOT.( LSAME(LTRANS,'N') .OR.  LSAME(LTRANS,'T') .OR. &
                  LSAME(LTRANS,'C') ) )THEN; LINFO = -12
   ELSE IF ( N > 0 )THEN
      IF( .NOT.PRESENT(DF) ) THEN
         ALLOCATE( LDLF(N-1),LDF(N),LDUF(N-1),LDU2(N-2), STAT=ISTAT )
      ELSE; LDLF => DLF; LDF => DF; LDUF => DUF; LDU2 => DU2; END IF
      IF( ISTAT == 0 )THEN
         IF( .NOT.PRESENT(IPIV) )THEN; ALLOCATE( LPIV(N), STAT=ISTAT )
         ELSE; LPIV => IPIV; END IF
      END IF
      IF( ISTAT == 0 )THEN
         IF( .NOT.PRESENT(FERR) )THEN; ALLOCATE( LFERR(NRHS), STAT=ISTAT )
         ELSE; LFERR => FERR; END IF
      END IF
      IF( ISTAT == 0 )THEN
         IF( .NOT.PRESENT(BERR) )THEN; ALLOCATE( LBERR(NRHS), STAT=ISTAT )
         ELSE; LBERR => BERR; END IF
      END IF
      IF( ISTAT == 0 ) ALLOCATE( WORK(3*N), IWORK(N), STAT=ISTAT )
      IF( ISTAT == 0 )THEN
         CALL GTSVX_F77( LFACT, LTRANS, N, NRHS, DL, D, DU, LDLF, LDF, LDUF, &
                         LDU2, LPIV, B, N, X, N, LRCOND, LFERR, LBERR, &
                         WORK, IWORK, LINFO )
      ELSE; LINFO = -100; END IF
      IF( .NOT.PRESENT(DLF) ) DEALLOCATE( LDLF, LDF, LDUF, LDU2, STAT=ISTAT1 )
      IF( .NOT.PRESENT(IPIV) ) DEALLOCATE( LPIV, STAT=ISTAT1 )
      IF( .NOT.PRESENT(FERR) ) DEALLOCATE( LFERR, STAT=ISTAT1 )
      IF( .NOT.PRESENT(BERR) ) DEALLOCATE( LBERR, STAT=ISTAT1 )
      IF( PRESENT(RCOND) ) RCOND=LRCOND
      DEALLOCATE( WORK, IWORK, STAT=ISTAT1 )
   END IF
   CALL ERINFO( LINFO, SRNAME, INFO, ISTAT )
END SUBROUTINE DGTSVX_F95


      INTEGER N,m
      PARAMETER(N=4,m=20000)     ! N = Number od differential equation, m = Number of divisions between x1 and x2
      INTEGER:: i
      ! complex::al,be

      REAL h,x,y(N),dydx(N),yout(N)
      EXTERNAL derivs
	  open(10,file='e:\1\Rabi_Model_Psi.txt') ! Output program results --- for in sigma basis is easier
	  !open(20,file='e:\1\c.txt')

      x1=0.0           ! x1 = t1
	  x2=30            ! x2 = t2
      ! initial conditons
      y(1)=1/sqrt(2.)            ! real part of c1(t):= y(1) + iy(2)
      y(2)=0                      ! complex part of c1(t):= y(1) + iy(2)
      y(3)=1/sqrt(2.)             ! real part of c2(t):= y(3) + iy(4)
      y(4)=0                      ! complex part of c2(t):= y(3) + iy(4)

      ! calculate in sigma(x) base
	  x=x1
	  h=(x2-x1)/m      ! Number of divisions
      do i=0,m-1
	       x=x1+i*h
           call derivs(x,y,dydx)
           call rk4(y,dydx,N,x,h,yout,derivs)
           x=x1+i*h
           if (mod(i,1)==0) then
	          A=y(1)*y(1)+y(2)*y(2)       ! |c1(t)|^2
              B=y(3)*y(3)+y(4)*y(4)       ! |c2(t)|^2
              rho_a_2_11 = A * A
              rho_a_2_22 = B * B
              tr_r_2  = rho_a_2_11 + rho_a_2_22 ! trace (rho_a) ^ 2
              U = A * A
              O = B * B
              S= -((B*LOG(B)/LOG(2.))+(A*LOG(A)/LOG(2.)))   ! Von Neumann entropy
              G= 2*(1-U-O)                ! G = L (Linear entropy)
              C = SQRT(G) !Concurence
!	         et=y(1)*2*(y(3)+y(2)*y(4))
      	     write(10,'(22(f10.4,2x))')x,y(1),y(2),y(3),y(4),tr_r_2,S,G  ! Computational values to create in the file a.txt
           end if
	     do j=1,n
	        y(j)=yout(j) !/sqrt((r11+r22))
	     end do
	  end do

      END

      SUBROUTINE derivs(x,y,dydx)
      REAL x,y(*),dydx(*)
	  REAL la

      ! ------------------- State --------------------

      ! psi(t) = c1(t)|+x,n> + c2(t)|-x,n+1>

      ! --------------- initial values ---------------

	  wa=1 ! atomic frequency
	  wp=0.6 ! field frequency
	  g=0.006 ! coupling strength; g =< (0.5)wp
      n=1  ! number of photons

      ! ----------------- Equations ------------------

      la = g / (wp + ( wa * exp((-2) * ( g / ((wp+wa) * (wp+wa)))))) ! la = lambda

      x = 4 * la * la

      Rr= 2 * (la * wp + g)

      !Rr=la*wp+g-wa*la*exp(-2*la*la)/(n+1)*aalgu(n,1,x)    ! Rr= R[ar]

      G0n = exp(-2 * la * la) * algu(n,x)

      alpha = wp * la * la + 2 * la * g

      beta =0.5 * wa * G0n

      gamma = Rr

      A = wp * n + alpha + beta

      B = gamma * sqrt(n+1.)

      C = (wp * (n + 1)) + alpha - beta !!!!!! I changed "n" to "n+1" in this file !!!!!!

      ! ----------- Differential equations -----------

      dydx(1)= A*y(2)+B*y(4)
      dydx(2)=-A*y(1)-B*y(3)
      dydx(3)= C*y(4)+B*y(2)
      dydx(4)=-C*y(3)-B*y(1)

      return

	  end

      ! ------------ Runge-Kutta Function ------------

      SUBROUTINE rk4(y,dydx,n,x,h,yout,derivs)
      INTEGER n,NMAX
      REAL h,x,dydx(n),y(n),yout(n)
      EXTERNAL derivs
      PARAMETER (NMAX=50)
      INTEGER i
      REAL h6,hh,xh,dym(NMAX),dyt(NMAX),yt(NMAX)
      hh=h*0.5
      h6=h/6.
	  x=0
      xh=x+hh
      do 11 i=1,n
        yt(i)=y(i)+hh*dydx(i)
11    continue
      call derivs(xh,yt,dyt)
      do 12 i=1,n
        yt(i)=y(i)+hh*dyt(i)
12    continue
      call derivs(xh,yt,dym)
      do 13 i=1,n
        yt(i)=y(i)+h*dym(i)
        dym(i)=dyt(i)+dym(i)
13    continue
      call derivs(x+h,yt,dyt)
      do 14 i=1,n
        yout(i)=y(i)+h6*(dydx(i)+dyt(i)+2.*dym(i))

14    continue
      return
      END

      ! ------- Laguerre polynomial Function -------

       function algu (n,x)
       al0=1
       al1=1-x
       if (n==0) then
          algu=al0
	 return
       else if (n==1) then
	     algu=al1
	 return
       end if
       alk=al1
       alkm=al0
       do k=2,n
          alk1=((2*k-1.-x)*alk-(k-1)*alkm)/k
          alkm=alk
          alk=alk1
       end do
       algu=alk1
       return
       end

      ! -- Associate Laguerre polynomial Function --

       function aalgu (n,k,x)
       al0=1
       al1=1+k-x
       if (n==0) then
           aalgu=al0
	 return
       else if (n==1) then
	      aalgu=al1
	 return
       end if
       alk=al1
       alkm=al0
       do i=2,n
           alk1=(k+2*i-1.-x)/i*alk-(k-1+i)/i*alkm
           alkm=alk
           alk=alk1
       end do
       aalgu=alk1
       return
       end


      subroutine imtqlv(n, d, e, e2, w, ind, ierr, rv1)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  double
!...Translated by Pacific-Sierra Research 77to90  4.3E  21:52:17  11/14/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      use pythag_I
      implicit none
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      integer , intent(in) :: n
      integer , intent(out) :: ierr
      integer , intent(inout) :: ind(n)
      real(double) , intent(in) :: d(n)
      real(double) , intent(in) :: e(n)
      real(double) , intent(inout) :: e2(n)
      real(double) , intent(inout) :: w(n)
      real(double) , intent(inout) :: rv1(n)
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      integer :: i, j, k, l, m, ii, mml, tag
      real(double) :: b, c, f, g, p, r, s, tst1, tst2
!-----------------------------------------------
!
!
!     this subroutine is a variant of  imtql1  which is a translation of
!     algol procedure imtql1, num. math. 12, 377-383(1968) by martin and
!     wilkinson, as modified in num. math. 15, 450(1970) by dubrulle.
!     handbook for auto. comp., vol.ii-linear algebra, 241-248(1971).
!
!     this subroutine finds the eigenvalues of a symmetric tridiagonal
!     matrix by the implicit ql method and associates with them
!     their corresponding submatrix indices.
!
!     on input
!
!        n is the order of the matrix.
!
!        d contains the diagonal elements of the input matrix.
!
!        e contains the subdiagonal elements of the input matrix
!          in its last n-1 positions.  e(1) is arbitrary.
!
!        e2 contains the squares of the corresponding elements of e.
!          e2(1) is arbitrary.
!
!     on output
!
!        d and e are unaltered.
!
!        elements of e2, corresponding to elements of e regarded
!          as negligible, have been replaced by zero causing the
!          matrix to split into a direct sum of submatrices.
!          e2(1) is also set to zero.
!
!        w contains the eigenvalues in ascending order.  if an
!          error exit is made, the eigenvalues are correct and
!          ordered for indices 1,2,...ierr-1, but may not be
!          the smallest eigenvalues.
!
!        ind contains the submatrix indices associated with the
!          corresponding eigenvalues in w -- 1 for eigenvalues
!          belonging to the first submatrix from the top,
!          2 for those belonging to the second submatrix, etc..
!
!        ierr is set to
!          zero       for normal return,
!          j          if the j-th eigenvalue has not been
!                     determined after 30 iterations.
!
!        rv1 is a temporary storage array.
!
!     calls pythag for  dsqrt(a*a + b*b) .
!
!     questions and comments should be directed to burton s. garbow,
!     mathematics and computer science div, argonne national laboratory
!
!     this version dated august 1983.
!
!     ------------------------------------------------------------------
!
      ierr = 0
      k = 0
      tag = 0
!
      do i = 1, n
         w(i) = d(i)
         if (i == 1) cycle
         rv1(i-1) = e(i)
      end do
!
      e2(1) = 0.0D0
      rv1(n) = 0.0D0
!
      do l = 1, n
         j = 0
!     .......... look for small sub-diagonal element ..........
  105    continue
         do m = l, n
            if (m == n) exit
            tst1 = dabs(w(m)) + dabs(w(m+1))
            tst2 = tst1 + dabs(rv1(m))
            if (tst2 == tst1) exit
!     .......... guard against underflowed element of e2 ..........
            if (e2(m+1) == 0.0D0) go to 125
         end do
!
         if (m <= k) go to 130
         if (m /= n) e2(m+1) = 0.0D0
  125    continue
         k = m
         tag = tag + 1
  130    continue
         p = w(l)
         if (m == l) go to 215
         if (j == 30) go to 1000
         j = j + 1
!     .......... form shift ..........
         g = (w(l+1)-p)/(2.0D0*rv1(l))
         r = pythag(g,1.0D0)
         g = w(m) - p + rv1(l)/(g + dsign(r,g))
         s = 1.0D0
         c = 1.0D0
         p = 0.0D0
         mml = m - l
!     .......... for i=m-1 step -1 until l do -- ..........
         do ii = 1, mml
            i = m - ii
            f = s*rv1(i)
            b = c*rv1(i)
            r = pythag(f,g)
            rv1(i+1) = r
            if (r == 0.0D0) go to 210
            s = f/r
            c = g/r
            g = w(i+1) - p
            r = (w(i)-g)*s + 2.0D0*c*b
            p = s*r
            w(i+1) = g + p
            g = c*r - b
         end do
!
         w(l) = w(l) - p
         rv1(l) = g
         rv1(m) = 0.0D0
         go to 105
!     .......... recover from underflow ..........
  210    continue
         w(i+1) = w(i+1) - p
         rv1(m) = 0.0D0
         go to 105
!     .......... order eigenvalues ..........
  215    continue
         if (l /= 1) then
!     .......... for i=l step -1 until 2 do -- ..........
            do ii = 2, l
               i = l + 2 - ii
               if (p >= w(i-1)) go to 270
               w(i) = w(i-1)
               ind(i) = ind(i-1)
            end do
         endif
!
         i = 1
  270    continue
         w(i) = p
         ind(i) = tag
      end do
!
      go to 1001
!     .......... set error -- no convergence to an
!                eigenvalue after 30 iterations ..........
 1000 continue
      ierr = l
 1001 continue
      return
      end subroutine imtqlv


module feval
  use bdf
  use bl_types
  implicit none
  integer, parameter :: neq = 1
contains
  subroutine f(neq, npt, y, t, ydot, upar)
    integer,    intent(in)    :: neq, npt
    real(dp_t), intent(in)    :: y(neq,npt), t(npt)
    real(dp_t), intent(  out) :: ydot(neq,npt)
    real(dp_t), intent(inout), optional :: upar(:,:)
  end subroutine f
  subroutine J(neq, npt, y, t, pd, upar)
    integer,    intent(in)    :: neq, npt
    real(dp_t), intent(in)    :: y(neq,npt), t(npt)
    real(dp_t), intent(  out) :: pd(neq,neq,npt)
    real(dp_t), intent(inout), optional :: upar(:,:)
  end subroutine J
end module feval

program test
  use bdf
  use feval

  double precision, parameter :: tol = 1.d-12
  integer,          parameter :: NPT = 1

  type(bdf_ts)  :: ts
  double precision :: rtol(neq), atol(neq)
  double precision :: v(0:6)

  rtol = 1
  atol = 1

  call bdf_ts_build(ts, neq, 1, rtol, atol, max_order=6)

  print *, "====> order 1"
  ts%k = 1
  call random_number(ts%h(:,NPT))
  call bdf_update(ts)
  print *, 'l', ts%l(0:1,NPT)
  call assert(all(ts%l(0:1,NPT) == [ 1.d0, 1.d0 ]), "error in l")

  ts%h = 1
  call bdf_update(ts)
  print *, 'tq', ts%tq
  call assert(all(abs(ts%tq(:,NPT) - [ 1.d0, 0.5d0, 0.2222222222222d0, 2.0d0 ]) < tol), "error in tq")

  print *, "====> order 2"
  ts%k = 2
  call random_number(ts%h(:,NPT))
  call bdf_update(ts)
  print *, 'l', ts%l(0:2,NPT)
  call assert(all(abs(ts%l(0:2,NPT) - [ 1.d0, 1.5d0, 0.5d0 ]) < tol), "error in l")

  ts%h = 1
  call bdf_update(ts)
  print *, 'tq', ts%tq
  call assert(all(abs(ts%tq(:,NPT) - [ 1.0d0, 0.222222222222222d0, 0.13636363636363638d0, 6.0d0 ]) < tol), "error in tq")

  print *, "====> order 3"
  ts%k = 3
  ts%h = 1
  call bdf_update(ts)
  print *, 'l', ts%l(0:3,NPT)
  v(0:3) = [ 1.d0, 1.8333333333333d0, 1.d0, 0.1666666666666d0 ]
  call assert(all(abs(ts%l(0:3,NPT) - v(0:3)) < tol), "error in l")

  ts%h(1,NPT) = 4
  call bdf_update(ts)
  print *, 'l', ts%l(0:3,NPT)
  v(0:3) = [ 1.d0, 1.8333333333333d0, 0.96d0, 0.12666666666666d0 ]
  call assert(all(abs(ts%l(0:3,NPT) - v(0:3)) < tol), "error in l")

  ts%h = 1
  call bdf_update(ts)
  print *, 'tq', ts%tq
  call assert(all(abs(ts%tq(:,NPT) - [ 1.3333333333333d0, 0.13636363636363638d0, 9.6d-2, 24.0d0 ]) < tol), "error in tq")

  call bdf_ts_destroy(ts)

contains

  subroutine assert(cond, message)
    logical, intent(in) :: cond
    character(*), intent(in) :: message

    if (.not. cond) then
       print *, "ASSERTION FAILED: ", message
       call abort()
    end if
  end subroutine assert

end program test


      program computation of function using do statement
      write(*,1)
1      format(3x,'x',11x,'f(x)')
      do x=0,1
      fx=sqrt(X)*cos(2*X+5.0)
      write(*,20)x,f(x)
!50      continue
      end do
20      format(1x,f3.1,9x,f6.4)
      stop
      end