! Implementation of the Bastankhah and Porte Agel gaussian-shaped wind turbine wake
! model (2016) with various farm modeling (TI and wake combination) methods included
! Created by Jared J. Thomas, 2017.
! FLight Optimization and Wind Laboratory (FLOW Lab)
! Brigham Young University

! implementation of the Bastankhah and Porte Agel (BPA) wake model for analysis
subroutine porteagel_analyze(nTurbines, nRotorPoints, nCtPoints, turbineXw, &
                             sorted_x_idx, turbineYw, turbineZ, &
                             rotorDiameter, Ct, wind_speed, &
                             yawDeg, ky, kz, alpha, beta, TI, RotorPointsY, RotorPointsZ, &
                             z_ref, z_0, shear_exp, wake_combination_method, &
                             TI_calculation_method, calc_k_star, opt_exp_fac, print_ti, &
                             wake_model_version, interp_type, &
                             use_ct_curve, ct_curve_wind_speed, ct_curve_ct, sm_smoothing, &
                             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, nRotorPoints, nCtPoints
    integer, intent(in) :: wake_combination_method, TI_calculation_method, &
                        &  wake_model_version, interp_type
    logical, intent(in) :: calc_k_star, print_ti, use_ct_curve
    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) :: Ct
    real(dp), intent(in) :: ky, kz, alpha, beta, TI, wind_speed, z_ref, z_0, shear_exp, opt_exp_fac
    real(dp), dimension(nRotorPoints), intent(in) :: RotorPointsY, RotorPointsZ
    real(dp), dimension(nCtPoints), intent(in) :: ct_curve_wind_speed, ct_curve_ct
    real(dp), intent(in) :: sm_smoothing

    ! local (General)
    real(dp), dimension(nTurbines) :: yaw, TIturbs, Ct_local, ky_local, kz_local
    real(dp) :: x0, deltax0, deltay, theta_c_0, sigmay, sigmaz, wake_offset, k_star
    real(dp) :: x, deltav, deltaz, sigmay_dp, sigmaz_dp, deltax0_dp, deficit_sum
    real(dp) :: tol, discontinuity_point, TI_area_ratio
    real(dp) :: TI_area_ratio_tmp, TI_dst_tmp, TI_ust_tmp, rpts
    real(dp) :: LocalRotorPointY, LocalRotorPointZ, point_velocity, point_z, point_velocity_with_shear
    Integer :: u, d, turb, turbI, p
    real(dp), parameter :: pi = 3.141592653589793_dp

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

    intrinsic sin, 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

    ! set tolerance for location checks
    tol = 0.1_dp

    ! initialize wind turbine velocities to 0.0
    wtVelocity = 0.0_dp

    ! initialize TI of all turbines to free-stream value
    !print *, "start TIturbs: ", TIturbs
    TIturbs = TI

    ! initialize the local wake factors
    ky_local(:) = ky
    kz_local(:) = kz
    Ct_local(:) = Ct

    !print *, 'wake model version: ', wake_model_version

    !print *, "ky_local: ", ky_local
    !print *, "kz_local: ", kz_local
    !print *, "TIturbs init: ", TIturbs

    do, d=1, nTurbines

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

        do, p=1, nRotorPoints

            ! initialize the TI_area_ratio to 0.0 for each turbine
            TI_area_ratio = 0.0_dp

            ! initialize deficit summation term to zero
            deficit_sum = 0.0_dp

            ! scale rotor sample point coordinate by rotor diameter (in rotor hub ref. frame)
            LocalRotorPointY = RotorPointsY(p)*0.5_dp*rotorDiameter(turbI)
            LocalRotorPointZ = RotorPointsZ(p)*0.5_dp*rotorDiameter(turbI)
!             !print *, "rotorDiameter after local rotor points", rotorDiameter
!             !print *, "local rotor points Y,Z: ", LocalRotorPointY, LocalRotorPointZ

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

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

                ! skip this loop if turb = turbI (turbines impact on itself)
                if (turb .eq. turbI) cycle

                ! downstream distance between upstream turbine and point
                x = turbineXw(turbI) - turbineXw(turb) + LocalRotorPointY*sin(yaw(turbI))

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

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

                    !print *, "rotorDiameter before x0 ", rotorDiameter

                    ! determine the onset location of far wake
                    call x0_func(rotorDiameter(turb), yaw(turb), Ct_local(turb), alpha, &
                                & TIturbs(turb), beta, x0)
!                     call x0_func(rotorDiameter(turb), yaw(turb), Ct(turb), alpha, &
!                                 & TI, 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)
                        ky_local(turb) = k_star
                        kz_local(turb) = k_star
                    end if

                    !print *, "ky_local ", ky_local
                    !print *, "deltax0 ", deltax0
                    !print *, "turbineZ ", turbineZ
                    !print *, "rotorDiameter after x0 ", rotorDiameter
                    !print *, "Ct ", Ct
                    !print *, "yaw ", yaw

                    ! determine the initial wake angle at the onset of far wake
                    call theta_c_0_func(yaw(turb), Ct_local(turb), theta_c_0)
                    !print *, "theta_c_0 ", theta_c_0
                    ! horizontal spread
                    call sigmay_func(ky_local(turb), deltax0, rotorDiameter(turb), yaw(turb), sigmay)
                    !print *, "sigmay ", sigmay
                    !print *, "rotorDiameter after sigmay", rotorDiameter
                    ! vertical spread
                    call sigmaz_func(kz_local(turb), deltax0, rotorDiameter(turb), sigmaz)
                    !print *, "sigmaz ", sigmaz
                    !print *, "rotorDiameter after sigmaz ", rotorDiameter
                    ! horizontal cross-wind wake displacement from hub
                    call wake_offset_func(rotorDiameter(turb), theta_c_0, x0, yaw(turb), &
                                         & ky_local(turb), kz_local(turb), Ct_local(turb), sigmay, sigmaz, wake_offset)

                    !print *, "wake_offset ", wake_offset
                    ! cross wind distance from downstream point location to wake center
                    deltay = LocalRotorPointY*cos(yaw(turbI)) + turbineYw(turbI) - (turbineYw(turb) + wake_offset)

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

                    !print *, "dx, dy, dz: ", x, deltay, deltaz
                    !print *, "local y,z : ", LocalRotorPointY, LocalRotorPointZ, turb, turbI, p
                    !print *, deltaz, deltay
                    ! far wake region

                    ! find the final point where the original model is undefined
                    call discontinuity_point_func(x0, rotorDiameter(turb), ky_local(turb), &
                                                 & kz_local(turb), yaw(turb), Ct_local(turb), &
                                                 & discontinuity_point)
                    !print *, "discontinuity point is: ", discontinuity_point
                    if (x > discontinuity_point) then

                        !print *, x

                        ! velocity difference in the wake
                        call deltav_func(deltay, deltaz, Ct_local(turb), yaw(turb), &
                                        & sigmay, sigmaz, rotorDiameter(turb), &
                                        & wake_model_version, kz_local(turb), x, &
                                        & opt_exp_fac, deltav)
                        !print *, "rotorDiameter after far deltav ", rotorDiameter
                    ! near wake region (linearized)
                    else

                        ! determine distance from discontinuity point to far wake onset
                        deltax0_dp = discontinuity_point - x0

                        ! horizontal spread at far wake onset
                        call sigmay_func(ky_local(turb), deltax0_dp, rotorDiameter(turb), yaw(turb), sigmay_dp)

                        ! vertical spread at far wake onset
                        call sigmaz_func(kz_local(turb), deltax0_dp, rotorDiameter(turb), sigmaz_dp)

                       !  print *, "inputs in parent: ", deltay, deltaz, Ct(turb), yaw(turb), sigmay_dp, sigmaz_dp, &
!                                          & rotorDiameter(turb), x, discontinuity_point, sigmay_dp, sigmaz_dp, &
!                                          & wake_model_version, kz_local, x0, &
!                                          & opt_exp_fac

                        ! velocity deficit in the nearwake (linear model)
                        call deltav_near_wake_lin_func(deltay, deltaz, &
                                         & Ct_local(turb), yaw(turb), sigmay_dp, sigmaz_dp, &
                                         & rotorDiameter(turb), x, discontinuity_point, sigmay_dp, sigmaz_dp, &
                                         & wake_model_version, kz_local(turb), x0, &
                                         & opt_exp_fac, deltav)

                        !print *, "rotorDiameter after deltav near ", rotorDiameter
                    end if

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

                    if ((x > 0.0_dp) .and. (TI_calculation_method > 0)) then
                        !print *, "turbI, turb: ", turbI, turb
                        ! calculate TI value at each turbine
!                         print *, "turb, turbI: ", turb, turbI

                        ! save ti_area_ratio and ti_dst to new memory locations to avoid
                        ! aliasing during differentiation
                        TI_area_ratio_tmp = TI_area_ratio
                        TI_dst_tmp = TIturbs(turbI)
                        TI_ust_tmp = TIturbs(turb)

                        call added_ti_func(TI, Ct_local(turb), x, ky_local(turb), rotorDiameter(turb), &
                                           & rotorDiameter(turbI), deltay, turbineZ(turb), &
                                           & turbineZ(turbI), sm_smoothing, TI_ust_tmp, &
                                           & TI_calculation_method, TI_area_ratio_tmp, &
                                           & TI_dst_tmp, TI_area_ratio, TIturbs(turbI))

                        !print *, "rotorDiameter after TI calcs", rotorDiameter
                    end if

!                     !print *, "deficit_sum, turbI, p, turb: ", deficit_sum, turbI, p, turb

                end if

            end do

            ! print *, deficit_sum

            ! find velocity at point p due to the wake of turbine turb
            point_velocity = wind_speed - deficit_sum

            !print *, "point velocity, deficit_sum, turbI, p: ", point_velocity, deficit_sum, turbI, p

            ! put sample point height in global reference frame
            point_z = LocalRotorPointZ + turbineZ(turbI)

            !print *, "point_z, turbI, p: ", point_z, turbI, p
            ! adjust sample point velocity for shear
            call wind_shear_func(point_z, point_velocity, z_ref, z_0, shear_exp, point_velocity_with_shear)
            !print *, "v, vs, x, turb, turbI, p: ", point_velocity, point_velocity_with_shear, x, turb, turbI, p
            ! add sample point velocity to turbine velocity to be averaged later
            wtVelocity(turbI) = wtVelocity(turbI) + point_velocity_with_shear

        end do

        ! final velocity calculation for turbine turbI (average equally across all points)
        rpts = REAL(nRotorPoints, dp)
!         print *, rpts, nRotorPoints, wtVelocity(turbI), wtVelocity(turbI)/rpts, wtVelocity(turbI)/nRotorPoints
!         STOP 1
        wtVelocity(turbI) = wtVelocity(turbI)/rpts
!         print *, wtVelocity(turbI)
        if (use_ct_curve) then
            call interpolation(nCtPoints, interp_type, ct_curve_wind_speed, ct_curve_ct, &
                              & wtVelocity(turbI), Ct_local(turbI), 0.0_dp, 0.0_dp, .false.)
        end if

    end do

   !!  print TIturbs values to a file
!     if (print_ti) then
!         open(unit=2, file="TIturbs_tmp.txt")
!         do, turb=1, nTurbines
!             write(2,*) TIturbs(turb)
!         end do
!         close(2)
!     end if

    !print *, "TIturbs: ", TIturbs
    !print *, wtVelocity

    !! 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 subroutine porteagel_analyze

! implementation of the Bastankhah and Porte Agel (BPA) wake model for visualization
subroutine porteagel_visualize(nTurbines, nSamples, nRotorPoints, nCtPoints, turbineXw, &
                             sorted_x_idx, turbineYw, turbineZ, &
                             rotorDiameter, Ct, wind_speed, &
                             yawDeg, ky, kz, alpha, beta, TI, RotorPointsY, RotorPointsZ, &
                             z_ref, z_0, shear_exp, velX, velY, velZ, &
                             wake_combination_method, TI_calculation_method, &
                             calc_k_star, opt_exp_fac, wake_model_version, interp_type, &
                             use_ct_curve, ct_curve_wind_speed, ct_curve_ct, sm_smoothing, &
                             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, nRotorPoints, nCtPoints
    integer, intent(in) :: wake_combination_method, TI_calculation_method, &
                        &  wake_model_version, interp_type
    logical, intent(in) :: calc_k_star, use_ct_curve
    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, z_ref, z_0, shear_exp, opt_exp_fac
    real(dp), dimension(nRotorPoints), intent(in) :: RotorPointsY, RotorPointsZ
    real(dp), dimension(nCtPoints), intent(in) :: ct_curve_wind_speed, ct_curve_ct
    real(dp), intent(in) :: sm_smoothing
    real(dp), dimension(nSamples), intent(in) :: velX, velY, velZ

    ! local (General)
    real(dp), dimension(nTurbines) :: yaw, TIturbs, wtVelocity
    real(dp) :: TI_area_ratio, TI_area_ratio_tmp, TI_dst_tmp, TI_ust_tmp
    real(dp) :: x0, deltax0, deltay, theta_c_0, sigmay, sigmaz, wake_offset, discontinuity_point
    real(dp) :: x, deltav, deltaz, sigmay_dp, sigmaz_dp, deltax0_dp, deficit_sum, tol, k_star
    real(dp) :: LocalRotorPointY, LocalRotorPointZ, point_velocity, point_z, point_velocity_with_shear
    real(dp), dimension(nTurbines) :: ky_local, kz_local, Ct_local
    Integer :: u, d, turb, turbI, loc, p
    real(dp), parameter :: pi = 3.141592653589793_dp

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

    intrinsic sin, 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

    ! set tolerance for location checks
    tol = 0.1_dp

    ! initialize location velocities to free stream
    wsArray = wind_speed

    ! initialize wind turbine velocities to 0.0
    wtVelocity = 0.0_dp

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

    ! initialize local wake values to free-stream values
    ky_local(:) = ky
    kz_local(:) = kz
    Ct_local(:) = Ct

    !print *, "entering turbine calculation loops"

    do, d=1, nTurbines

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

        do, p=1, nRotorPoints

            ! initialize the TI_area_ratio to 0.0 for each turbine
            TI_area_ratio = 0.0_dp

            ! initialize deficit summation term to zero
            deficit_sum = 0.0_dp

            ! scale rotor sample point coordinate by rotor diameter (in rotor hub ref. frame)
            LocalRotorPointY = RotorPointsY(p)*0.5_dp*rotorDiameter(turbI)
            LocalRotorPointZ = RotorPointsZ(p)*0.5_dp*rotorDiameter(turbI)

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

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

                ! skip this loop if turb = turbI (turbines impact on itself)
                if (turb .eq. turbI) cycle

                ! downstream distance between turbines, adjust for downstream turbine yaw
                x = turbineXw(turbI) - turbineXw(turb) + LocalRotorPointY*sin(yaw(turbI))

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

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

                    ! determine the onset location of far wake
                    call x0_func(rotorDiameter(turb), yaw(turb), Ct_local(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)
                        ky_local(turb) = k_star
                        kz_local(turb) = k_star
                    end if

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

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

                    ! vertical spread
                    call sigmaz_func(kz_local(turb), 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(turb), kz_local(turb), Ct_local(turb), sigmay, sigmaz, wake_offset)

                    ! cross wind distance from downstream point location to wake center
                    deltay = LocalRotorPointY*cos(yaw(turbI)) + turbineYw(turbI) - (turbineYw(turb) + wake_offset)

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

                    ! find the final point where the original model is undefined
                    call discontinuity_point_func(x0, rotorDiameter(turb), ky_local(turb), &
                                                 & kz_local(turb), yaw(turb), Ct_local(turb), &
                                                 & discontinuity_point)

                    ! far wake region
                    if (x > discontinuity_point) then

                        ! velocity difference in the wake
                        call deltav_func(deltay, deltaz, Ct_local(turb), yaw(turb), &
                                        & sigmay, sigmaz, rotorDiameter(turb), &
                                        & wake_model_version, kz_local(turb), x, &
                                        & opt_exp_fac, deltav)

                    ! near wake region (linearized)
                    else

                        ! determine distance from discontinuity point to far wake onset
                        deltax0_dp = discontinuity_point - x0

                        ! horizontal spread at discontinuity point
                        call sigmay_func(ky_local(turb), deltax0_dp, rotorDiameter(turb), yaw(turb), sigmay_dp)

                        ! vertical spread at discontinuity point
                        call sigmaz_func(kz_local(turb), deltax0_dp, rotorDiameter(turb), sigmaz_dp)

                        ! print *, "inputs in parent: ", deltay, deltaz, Ct(turb), yaw(turb), sigmay_dp, sigmaz_dp, &
!                                          & rotorDiameter(turb), x, discontinuity_point, sigmay_dp, sigmaz_dp, &
!                                          & wake_model_version, kz_local, x0, &
!                                          & opt_exp_fac

                        ! velocity deficit in the nearwake (linear model)
                        call deltav_near_wake_lin_func(deltay, deltaz, &
                                         & Ct_local(turb), yaw(turb), sigmay_dp, sigmaz_dp, &
                                         & rotorDiameter(turb), x, discontinuity_point, sigmay_dp, sigmaz_dp, &
                                         & wake_model_version, kz_local(turb), x0, &
                                         & opt_exp_fac, deltav)

                    end if

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

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

                        ! save ti_area_ratio value to new memory location to avoid aliasing
                        TI_area_ratio_tmp = TI_area_ratio
                        TI_dst_tmp = TIturbs(turbI)
                        TI_ust_tmp = TIturbs(turb)

                        ! calculate TI value at each turbine
                        call added_ti_func(TI, Ct_local(turb), x, ky_local(turb), rotorDiameter(turb), &
                                           & rotorDiameter(turbI), deltay, turbineZ(turb), &
                                           & turbineZ(turbI), sm_smoothing, TI_ust_tmp, &
                                           & TI_calculation_method, TI_area_ratio_tmp, &
                                           & TI_dst_tmp, TI_area_ratio, &
                                           & TIturbs(turbI))
                    end if

                end if

            end do

            ! find velocity at point p due to the wake of turbine turb
            point_velocity = wind_speed - deficit_sum

            ! put sample point height in global reference frame
            point_z = LocalRotorPointZ + turbineZ(turbI)

            ! adjust sample point velocity for shear
            call wind_shear_func(point_z, point_velocity, z_ref, z_0, shear_exp, point_velocity_with_shear)

            ! add sample point velocity to turbine velocity to be averaged later
            wtVelocity(turbI) = wtVelocity(turbI) + point_velocity_with_shear

        end do

        ! final velocity calculation for turbine turbI (average equally across all points)
        wtVelocity(turbI) = wtVelocity(turbI)/nRotorPoints

        if (use_ct_curve) then
            call interpolation(nCtPoints, interp_type, ct_curve_wind_speed, ct_curve_ct, &
                              & wtVelocity(turbI), Ct_local(turbI), 0.0_dp, 0.0_dp, .false.)
        end if

    end do

    do, loc=1, nSamples

        ! set combined velocity deficit to zero for loc
        deficit_sum = 0.0_dp

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

            ! set velocity deficit at loc due to turb to zero
            deltav = 0.0_dp

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

            if (x > 0.0_dp) then

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

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

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

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

                ! vertical spread
                call sigmaz_func(kz_local(turb), 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(turb), kz_local(turb), Ct_local(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)

                ! find the final point where the original model is undefined
                call discontinuity_point_func(x0, rotorDiameter(turb), ky_local(turb), kz_local(turb), yaw(turb), Ct_local(turb), &
                                             & discontinuity_point)
!                 print *, "discontinuity point is: ", discontinuity_point
                ! far wake region
                if (x > discontinuity_point) then

                    ! velocity difference in the wake
                    call deltav_func(deltay, deltaz, Ct_local(turb), yaw(turb),  &
                                    & sigmay, sigmaz, rotorDiameter(turb), &
                                    & wake_model_version, kz_local(turb), x, &
                                    & opt_exp_fac, deltav)

                ! near wake region (linearized)
                else

                    ! determine distance from discontinuity point to far wake onset
                    deltax0_dp = discontinuity_point - x0

                    ! horizontal spread at far wake onset
                    call sigmay_func(ky_local(turb), deltax0_dp, rotorDiameter(turb), yaw(turb), &
                                    & sigmay_dp)

                    ! vertical spread at far wake onset
                    call sigmaz_func(kz_local(turb), deltax0_dp, rotorDiameter(turb), sigmaz_dp)

                    ! velocity deficit in the nearwake (linear model)
                    call deltav_near_wake_lin_func(deltay, deltaz,        &
                                     & Ct_local(turb), yaw(turb), sigmay_dp, sigmaz_dp,           &
                                     & rotorDiameter(turb), x, discontinuity_point, &
                                     & sigmay_dp, sigmaz_dp,    &
                                     & wake_model_version, kz_local(turb), x0, &
                                     & opt_exp_fac, deltav)

                end if

                ! 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

        end do

        ! find velocity at point p due to the wake of turbine turb
        point_velocity = wind_speed - deficit_sum

        ! put sample point height in global reference frame
        point_z = velZ(loc)

        ! adjust sample point velocity for shear
        call wind_shear_func(point_z, point_velocity, z_ref, z_0, shear_exp, point_velocity_with_shear)

        ! final velocity calculation for location loc
        wsArray(loc) = point_velocity_with_shear

    end do

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_ust, version, k, deltax, opt_exp_fac, 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_ust, opt_exp_fac
    real(dp), intent(in) :: k, deltax    ! only for 2014 version
    integer, intent(in) :: version

    ! local
    real(dp) :: beta_2014, epsilon_2014 ! only for 2014 version

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

    ! load intrinsic functions
    intrinsic cos, sqrt, exp

    !print *, "rotor_diameter in deltav entry", rotor_diameter_ust
!     print *, 'wake model version in deltav: ', version

    if (version == 2014) then
        !print *, "in 2014 version"
        beta_2014 = 0.5_dp*(1.0_dp + sqrt(1.0_dp - Ct))/sqrt(1.0_dp - Ct)
        epsilon_2014 = 0.2_dp*sqrt(beta_2014)

       ! print *, "beta = ", beta_2014, "epsilon = ", epsilon_2014
       ! print *, "k, deltax: ", k, deltax
       ! print *, "term: ", Ct                                                   &
!                            / (8.0_dp * (k*deltax/rotor_diameter_ust+epsilon_2014)**2)
        deltav = (                                                                       &
            (1.0_dp - sqrt(1.0_dp - Ct                                                   &
                           / (8.0_dp * ((k*deltax/rotor_diameter_ust)+epsilon_2014)**2)))* &
            exp((-1.0_dp/(2.0_dp*((k*deltax/rotor_diameter_ust) + epsilon_2014)**2))*      &
            ((deltaz/(opt_exp_fac*rotor_diameter_ust))**2 + (deltay/(opt_exp_fac*rotor_diameter_ust))**2))           &
        )
       ! print *, "deltav 2014 = ", deltav
    else if (version == 2016) then
        ! velocity difference in the wake at each sample point
        deltav = (                                                                    &
            (1.0_dp - sqrt(1.0_dp - Ct *                                                         &
                           cos(yaw) / (8.0_dp * sigmay * sigmaz / (rotor_diameter_ust ** 2)))) *     &
            exp(-0.5_dp * (deltay / (opt_exp_fac*sigmay)) ** 2) * exp(-0.5_dp * (deltaz / (opt_exp_fac*sigmaz)) ** 2)&
        )
    else
        print *, "Invalid Bastankhah and Porte Agel model version. Must be 2014 or 2016. ", version, " was given."
        stop 1
    end if

    !print *, "rotor_diameter in deltav exit", rotor_diameter_ust

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_ust, x, &
                                 & discontinuity_point, sigmay0, sigmaz0, version, k, &
                                 & deltax0_dp, opt_exp_fac, 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_ust, opt_exp_fac
    real(dp), intent(in) :: x, discontinuity_point, sigmay0, sigmaz0
    real(dp), intent(in) :: k, deltax0_dp    ! only for 2014 version
    integer, intent(in) :: version

    ! local
    real(dp) :: deltav0m, deltavr
    real(dp) :: beta_2014, epsilon_2014 ! only for 2014 version

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

    ! load intrinsic functions
    intrinsic cos, sqrt, exp

   !  print *, 'wake model version in deltav near wake: ', version
!     print *, "inputs: ", deltay, deltaz, Ct, yaw,  &
!                                  & sigmay, sigmaz, rotor_diameter_ust, x, &
!                                  & discontinuity_point, sigmay0, sigmaz0, version, k, &
!                                  & deltax0_dp, opt_exp_fac
    if (version == 2014) then
        if (yaw > 0.0_dp) then
            print *, "model version 2014 may only be used when yaw=0"
            stop 1
        end if
        beta_2014 = 0.5_dp*(1.0_dp + sqrt(1.0_dp - Ct))/sqrt(1.0_dp - Ct)
        epsilon_2014 = 0.2_dp*sqrt(beta_2014)

        ! magnitude term of gaussian at x0
        deltav0m = (1.0_dp - sqrt(1.0_dp - Ct                                            &
                           / (8.0_dp * (k*deltax0_dp/rotor_diameter_ust+epsilon_2014)**2)))

        ! initialize the gaussian magnitude term at the rotor for the linear interpolation
        deltavr = deltav0m

        ! linearized gaussian magnitude term for near wake
        deltav = (                                                                       &
             (((deltav0m - deltavr)/discontinuity_point) * x + deltavr) *                &
            exp((-1.0_dp/(2.0_dp*(k*deltax0_dp/rotor_diameter_ust + epsilon_2014)**2))*      &
            ((deltaz/(opt_exp_fac*rotor_diameter_ust))**2 + (deltay/(opt_exp_fac*rotor_diameter_ust))**2))           &
        )
    else if (version == 2016) then

        ! magnitude term of gaussian at x0
        deltav0m = (                                         &
                    (1.0_dp - sqrt(1.0_dp - Ct *                          &
                    cos(yaw) / (8.0_dp * sigmay0 * sigmaz0 /              &
                                                (rotor_diameter_ust ** 2)))))
        ! initialize the gaussian magnitude term at the rotor for the linear interpolation
        deltavr = deltav0m

        ! linearized gaussian magnitude term for near wake
        deltav = (((deltav0m - deltavr)/discontinuity_point) * x + deltavr) *       &
            exp(-0.5_dp * (deltay / (opt_exp_fac*sigmay)) ** 2) *                                 &
            exp(-0.5_dp * (deltaz / (opt_exp_fac*sigmaz)) ** 2)
    else
        print *, "Invalid Bastankhah and Porte Agel model version. Must be 2014 or 2016. ", version, " was given."
        stop 1
    end if

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)

    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, OVz2

    ! load intrinsic functions
    intrinsic acos, sqrt

!     print *, turbine_y, turbine_z, rotor_diameter, &
!                             wake_center_y, wake_center_z, wake_diameter, &
!                             wake_overlap

   ! distance between wake center and rotor center
    if ((wake_center_z > (turbine_z + tol)) .or. (wake_center_z < (turbine_z - tol))) then
        OVdYd = sqrt((wake_center_y-turbine_y)**2_dp + (wake_center_z - turbine_z)**2_dp)
    else if (wake_center_y > (turbine_y + tol)) then! potential source of gradient issues, abs() did not cause a problem in FLORIS
        OVdYd = wake_center_y - turbine_y
    else if (turbine_y > (wake_center_y + tol)) then
        OVdYd = turbine_y - wake_center_y
    else
        OVdYd = 0.0_dp
    end if

    !print *, "OVdYd: ", OVdYd
    ! find rotor radius
    OVr = rotor_diameter/2.0_dp
    !print *, "OVr: ", OVr

    ! find wake radius
    OVRR = wake_diameter/2.0_dp
    !print *, "OVRR: ", OVRR

    ! make sure the distance from wake center to turbine hub is positive
    ! OVdYd = abs(OVdYd) !!! commented out since change to 2D distance (y,z) will always be positive

    ! calculate the distance from the wake center to the line perpendicular to the
    ! line between the two circle intersection points
    !if (OVdYd >= 0.0_dp + tol) then ! check case to avoid division by zero
!     print *, "OVdYd ", OVdYd
    ! if (OVdYd >= 0.0_dp + tol) then ! check case to avoid division by zero
!         OVL = (-OVr*OVr+OVRR*OVRR+OVdYd*OVdYd)/(2.0_dp*OVdYd)
! !         print *, "OVdYd, OVL: ", OVdYd, OVL
!     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
!     if (OVz > 0.0_dp + tol) then
!         OVz = sqrt(OVz)
!     else
!         OVz = 0.0_dp
!     end if

    !print *, "OVRR, OVL, OVRR, OVr, OVdYd, OVz ", OVRR, OVL, OVRR, OVr, OVdYd, OVz

    ! if (OVdYd < (OVr+OVRR)) then ! if the rotor overlaps the wake
!         !print *, "OVL: ", OVL
!         if (OVL < OVRR .and. (OVdYd-OVL) < OVr) then
! !         if (OVdYd > 0.0_dp + tol) then
! !         if ((OVdYd > 0.0_dp) .and. (OVdYd > (OVRR - OVr))) then
!             ! print *, "acos(OVL/OVRR), acos((OVdYd-OVL)/OVr), OVRR, OVL, OVr, OVdYd, OVL/OVRR, (OVdYd-OVL)/OVr ", &
! !     & acos(OVL/OVRR), acos((OVdYd-OVL)/OVr), OVRR, OVL, OVr, OVdYd, OVL/OVRR, (OVdYd-OVL)/OVr
!             wake_overlap = OVRR*OVRR*acos(OVL/OVRR) + OVr*OVr*acos((OVdYd-OVL)/OVr) - OVdYd*OVz
!         else if (OVRR > OVr) then
!             wake_overlap = pi*OVr*OVr
!             !print *, "wake ovl: ", wake_overlap
!         else
!             wake_overlap = pi*OVRR*OVRR
!         end if
!     else
!         wake_overlap = 0.0_dp
!     end if

    ! determine if there is overlap
    if (OVdYd < (OVr+OVRR)) then ! if the rotor overlaps the wake zone

        ! check that turbine and wake centers are not perfectly aligned
        if (OVdYd > (0.0_dp + tol)) then

            ! check if the rotor is wholly contained in the wake
            if ((OVdYd + OVr) < OVRR + tol) then
                wake_overlap = pi*OVr*OVr
!                 print *, "1"
            ! check if the wake is wholly contained in the rotor swept area
            else if ((OVdYd + OVRR) < OVr + tol) then
                wake_overlap = pi*OVRR*OVRR
!                 print *, "2"
            else

                ! calculate the distance from the wake center to the chord connecting the lens
                ! cusps
                OVL = (-OVr*OVr+OVRR*OVRR+OVdYd*OVdYd)/(2.0_dp*OVdYd)

                OVz = sqrt(OVRR*OVRR-OVL*OVL)
                OVz2 = sqrt(OVr*OVr-(OVdYd-OVL)*(OVdYd-OVL))

                wake_overlap = OVRR*OVRR*acos(OVL/OVRR) + OVr*OVr*acos((OVdYd-OVL)/OVr) - &
                               & OVL*OVz - (OVdYd-OVL)*OVz2
!                 print *, OVRR, OVr, OVdYd, OVL, OVz, OVz2
!                 print *, "3"
            end if

        ! perfect overlap case where the wake is larger than the rotor
        else if (OVRR > OVr) then
            wake_overlap = pi*OVr*OVr
!             print *, "4"

        ! perfect overlap case where the rotor is larger than the wake
        else
            wake_overlap = pi*OVRR*OVRR
!             print *, "5"
        end if

    ! case with no overlap
    else
        wake_overlap = 0.0_dp
    end if

!     print *, "wake overlap in func: ", wake_overlap/(pi*OVr**2)
!     print *, "wake overlap in func: ", wake_overlap/(pi*OVRR**2)

    if ((wake_overlap/(pi*OVr*OVr) > (1.0_dp + tol)) .or. (wake_overlap/(pi*OVRR*OVRR) > (1.0_dp + tol))) then
        print *, "wake overlap in func: ", wake_overlap/(pi*OVr*OVr)
        print *, "wake overlap in func: ", wake_overlap/(pi*OVRR*OVRR)
        STOP 1
    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
        !print *, "here"

    ! 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, sm_smoothing, TI_ust, &
                        & TI_calculation_method, TI_area_ratio_in, TI_dst_in, TI_area_ratio, 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, sm_smoothing
    real(dp), intent(in) :: TI_ust, TI, TI_area_ratio_in, TI_dst_in
    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, rotor_area_dst, TI_area_ratio_tmp
    real(dp), parameter :: pi = 3.141592653589793_dp

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

    ! intrinsic functions
    intrinsic sqrt

    ! initialize output variables
    TI_area_ratio = TI_area_ratio_in
    TI_dst = TI_dst_in

    ! initialize wake overlap to zero
    wake_overlap = 0.0_dp

    !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

        ! calculate axial induction based on the Ct value
        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_dp)*(TI_ust**0.0325_dp)* &
                    ((x/rotor_diameter_ust)**(-0.32_dp))
        !print *, "TI_added = ", TI_added
        rotor_area_dst = 0.25_dp*pi*rotor_diameter_dst**2_dp
        ! 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_in**2.0_dp + (TI_added*wake_overlap/rotor_area_dst)**2.0_dp)

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

        ! calculate axial induction based on the Ct value
        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_dp)*(TI_ust**0.0325_dp)* &
                    ((x/rotor_diameter_ust)**(-0.32_dp))

        ! 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_dp
        TI_tmp = sqrt(TI**2.0_dp + (TI_added*(wake_overlap/rotor_area_dst))**2.0_dp)

        ! Check if this is the max and use it if it is
        if (TI_tmp > TI_dst_in) then
!            print *, "TI_tmp > TI_dst"
           TI_dst = TI_tmp
        end if

    ! Niayifar and Porte Agel 2015, 2016 with smooth max
     else if (TI_calculation_method == 3) then

        ! calculate axial induction based on the Ct value
        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

!         print *, "sigma, k_star_ust, x, rotor_diameter_ust, epsilon ", sigma, k_star_ust, x, rotor_diameter_ust, epsilon

        ! print *, "deltay, turbine_height, rotor_diameter_dst, wake_height, wake_diameter", &
!                 & deltay, turbine_height, rotor_diameter_dst, &
!                             wake_height, wake_diameter

        ! 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_dp)*(TI_ust**0.0325_dp)* &
                    ((x/rotor_diameter_ust)**(-0.32_dp))

        ! 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_dp
        TI_tmp = sqrt(TI**2.0_dp + (TI_added*(wake_overlap/rotor_area_dst))**2.0_dp)

        !print *, "TI, TI_added, wake_overlap, rotor_area_dst: ", TI, TI_added, wake_overlap, rotor_area_dst

        ! Check if this is the max and use it if it is
        !if (TI_tmp > TI_dst) then
        !    TI_dst = TI_tmp
        !end if
!         print *, "before: ", TI_dst, TI_tmp
!         TI_dst_in = TI_dst
        call smooth_max(sm_smoothing, TI_dst_in, TI_tmp, TI_dst)
!         print *, "after:: ", TI_dst, TI_tmp

    ! Niayifar and Porte Agel 2015, 2016 using max on area TI ratio
    else if (TI_calculation_method == 4) then

        ! calculate axial induction based on the Ct value
        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_dp)*(TI_ust**0.0325_dp)* &
                    ((x/rotor_diameter_ust)**(-0.32_dp))

        ! 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_dp
        TI_area_ratio_tmp = TI_added*(wake_overlap/rotor_area_dst)

        ! Check if this is the max and use it if it is
        if (TI_area_ratio_tmp > TI_area_ratio_in) then
!            print *, "ti_area_ratio_tmp > ti_area_ratio"
           !TI_dst = TI_tmp
           TI_area_ratio = TI_area_ratio_tmp
           TI_dst = sqrt(TI**2.0_dp + (TI_area_ratio)**2.0_dp)

        end if

    ! Niayifar and Porte Agel 2015, 2016 using smooth max on area TI ratio
    else if (TI_calculation_method == 5) then

        ! calculate axial induction based on the Ct value
        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)
        ! only include turbines with area overlap in the softmax
        if (wake_overlap > 0.0_dp) then

            ! 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_dp)*(TI_ust**0.0325_dp)* &
                        ((x/rotor_diameter_ust)**(-0.32_dp))

            rotor_area_dst = 0.25_dp*pi*rotor_diameter_dst**2_dp
            TI_area_ratio_tmp = TI_added*(wake_overlap/rotor_area_dst)
            !TI_tmp = sqrt(TI**2.0_dp + (TI_added*(wake_overlap/rotor_area_dst))**2.0_dp)

            ! Run through the smooth max to get an approximation of the true max TI area ratio
            call smooth_max(sm_smoothing, TI_area_ratio_in, TI_area_ratio_tmp, TI_area_ratio)

            ! Calculate the total turbulence intensity at the downstream turbine based on
            ! the result of the smooth max function
            TI_dst = sqrt(TI**2.0_dp + TI_area_ratio**2.0_dp)

        end if

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

    !print *, "ratio: ", wake_overlap/rotor_area_dst
    !print *, "Dr, Dw: ", rotor_diameter_dst, wake_diameter
    !print *, "Ar, Aol: ", rotor_area_dst, wake_overlap

end subroutine added_ti_func

! compute wake spread parameter based on local turbulence intensity
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(out) :: k_star_ust

    ! calculate wake spread parameter from Niayifar and Porte Agel (2015, 2016)
    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

    ! initialize axial induction to zero
    axial_induction = 0.0_dp

    ! calculate axial induction
    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

! adjust wind speed for wind shear
subroutine wind_shear_func(point_z, u_ref, z_ref, z_0, shear_exp, adjusted_wind_speed)

    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) :: point_z, u_ref, z_ref, z_0, shear_exp

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

    ! initialize adjusted wind speed to zero
    adjusted_wind_speed = 0.0_dp

    ! check that the point of interest is above ground level
    if (point_z >= z_0) then
        ! adjusted wind speed for wind shear if point is above ground
        adjusted_wind_speed = u_ref*((point_z-z_0)/(z_ref-z_0))**shear_exp
    else
        ! if the point of interest is below ground, set the wind speed to 0.0
        adjusted_wind_speed = 0.0_dp
    end if

end subroutine wind_shear_func

! calculate the point where the Bastankhah and Porte Agel wake model becomes undefined
subroutine discontinuity_point_func(x0, rotor_diameter, ky, kz, yaw, Ct, discontinuity_point)

    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) :: x0, rotor_diameter, ky, kz, yaw, Ct

    ! local
    real(dp) :: a, b, c

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

    intrinsic cos, sqrt

    ! for clarity, break out the terms in the equation
    a = ky + kz*cos(yaw)
    b = 4.0_dp * ky * kz * cos(yaw)*(Ct - 1.0_dp)
    c = 2.0_dp * sqrt(8.0_dp) * ky * kz

    ! distance from rotor to the last point where the wake model is undefined
    discontinuity_point = x0 + rotor_diameter * (a - sqrt(a**2 - b))/c

end subroutine discontinuity_point_func

subroutine smooth_max(s, x, y, g)

    ! based on John D. Cook's writings at
    ! (1) https://www.johndcook.com/blog/2010/01/13/soft-maximum/
    ! and
    ! (2) https://www.johndcook.com/blog/2010/01/20/how-to-compute-the-soft-maximum/

    ! s controls the level of smoothing used in the smooth max
    ! x and y are the values to be compared

    ! g is the result

    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) :: s, x, y

    ! local
    real(dp) :: max_val, min_val

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

    intrinsic log, exp, max, min

    ! LogSumExponential Method - used this in the past
    ! g = (x*exp(s*x)+y*exp(s*y))/(exp(s*x)+exp(s*y))

    ! non-overflowing version of Smooth Max function (see ref 2 above)
    max_val = max(x, y)
    min_val = min(x, y)
    g = (log(1.0_dp + exp(s*(min_val - max_val)))+s*max_val)/s

end subroutine smooth_max

subroutine interpolation(nPoints, interp_type, x, y, xval, yval, dy0in, dy1in, usedyin)

    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) :: nPoints, interp_type
    real(dp), dimension(nPoints), intent(in) :: x, y
    real(dp), intent(in) :: xval
    real(dp), intent(in):: dy0in, dy1in
    logical :: usedyin

    ! local
    integer :: idx
    real(dp) :: x0, x1, y0, dy0, y1, dy1

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

!     print *, "in interpolation"

    ! if ((xval < x(1)) .or. (xval > x(nPoints))) then
!         print *, "interpolation point is out of bounds"
! !         STOP 1
!     end if

    if (usedyin .and. (interp_type == 1)) then
        print *, "end point derivatives may not be specified for linear interpolation"
        STOP 1
    end if

    if (xval < x(1)) then
        yval = y(1)
    else if (xval > x(nPoints)) then
        yval = y(nPoints)

    else
        idx = 1

        do while ((xval > x(idx)) .and. (idx <= nPoints))
            idx = idx + 1
        end do

        idx = idx - 1

        x0 = x(idx)
        x1 = x((idx + 1))
        y0 = y(idx)
        y1 = y((idx + 1))

        ! Hermite cubic piecewise spline interpolation
        if (interp_type == 0) then

            ! approximate derivative at left end of interval
            if (idx == 1) then

                if (usedyin) then
                    dy0 = dy0in
                else
                    dy0 = 0.0_dp
                endif

            else
                dy0 = (y(idx+1) - y(idx-1))/(x(idx+1) - x(idx-1))
            end if

            ! approximate derivative at the right end of interval
            if (idx >= nPoints-1) then

                if(usedyin)then
                    dy1 = dy1in
                else
                    dy1 = 0.0_dp
                endif
            else
                dy1 = (y(idx+2) - y(idx))/(x(idx+2) - x(idx))
            end if

            ! call Hermite spline routine
            call Hermite_Spline(xval, x0, x1, y0, dy0, y1, dy1, yval)

        ! linear interpolation
        else if (interp_type == 1) then

            yval = (xval-x0)*(y1-y0)/(x1-x0) + y0

        end if
    end if

!     print *, "yval = ", yval

end subroutine interpolation

subroutine Hermite_Spline(x, x0, x1, y0, dy0, y1, dy1, y)
    !    This function produces the y and dy values for a hermite cubic spline
    !    interpolating between two end points with known slopes
    !
    !    :param x: x position of output y
    !    :param x0: x position of upwind endpoint of spline
    !    :param x1: x position of downwind endpoint of spline
    !    :param y0: y position of upwind endpoint of spline
    !    :param dy0: slope at upwind endpoint of spline
    !    :param y1: y position of downwind endpoint of spline
    !    :param dy1: slope at downwind endpoint of spline
    !
    !    :return: y: y value of spline at location x

    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) :: x, x0, x1, y0, dy0, y1, dy1

    ! out
    real(dp), intent(out) :: y !, dy_dx

    ! local
    real(dp) :: c3, c2, c1, c0

    ! initialize coefficients for parametric cubic spline
    c3 = (2.0_dp*(y1))/(x0**3 - 3.0_dp*x0**2*x1 + 3.0_dp*x0*x1**2 - x1**3) - &
         (2.0_dp*(y0))/(x0**3 - 3.0_dp*x0**2*x1 + 3.0_dp*x0*x1**2 - x1**3) + &
         (dy0)/(x0**2 - 2.0_dp*x0*x1 + x1**2) + &
         (dy1)/(x0**2 - 2.0_dp*x0*x1 + x1**2)

    c2 = (3.0_dp*(y0)*(x0 + x1))/(x0**3 - 3.0_dp*x0**2*x1 + 3.0_dp*x0*x1**2 - x1**3) - &
         ((dy1)*(2.0_dp*x0 + x1))/(x0**2 - 2.0_dp*x0*x1 + x1**2) - ((dy0)*(x0 + &
         2.0_dp*x1))/(x0**2 - 2.0_dp*x0*x1 + x1**2) - (3.0_dp*(y1)*(x0 + x1))/(x0**3 - &
         3.0_dp*x0**2*x1 + 3.0_dp*x0*x1**2 - x1**3)

    c1 = ((dy0)*(x1**2 + 2.0_dp*x0*x1))/(x0**2 - 2.0_dp*x0*x1 + x1**2) + ((dy1)*(x0**2 + &
         2.0_dp*x1*x0))/(x0**2 - 2.0_dp*x0*x1 + x1**2) - (6.0_dp*x0*x1*(y0))/(x0**3 - &
         3.0_dp*x0**2*x1 + 3.0_dp*x0*x1**2 - x1**3) + (6.0_dp*x0*x1*(y1))/(x0**3 - &
         3.0_dp*x0**2*x1 + 3.0_dp*x0*x1**2 - x1**3)

    c0 = ((y0)*(- x1**3 + 3.0_dp*x0*x1**2))/(x0**3 - 3.0_dp*x0**2*x1 + 3.0_dp*x0*x1**2 - &
         x1**3) - ((y1)*(- x0**3 + 3.0_dp*x1*x0**2))/(x0**3 - 3.0_dp*x0**2*x1 + &
         3.0_dp*x0*x1**2 - x1**3) - (x0*x1**2*(dy0))/(x0**2 - 2.0_dp*x0*x1 + x1**2) - &
         (x0**2*x1*(dy1))/(x0**2 - 2.0_dp*x0*x1 + x1**2)
!    print *, 'c3 = ', c3
!    print *, 'c2 = ', c2
!    print *, 'c1 = ', c1
!    print *, 'c0 = ', c0
    ! Solve for y and dy values at the given point
    y = c3*x**3 + c2*x**2 + c1*x + c0
    !dy_dx = c3*3*x**2 + c2*2*x + c1

end subroutine Hermite_Spline

 !    yd, n = _checkIfFloat(yd)
!
!     y1 = (1-pct_offset)*ymax
!     y2 = (1+pct_offset)*ymax
!
!     dy1 = (1-pct_offset)
!     dy2 = (1+pct_offset)
!
!     if (maxmin == 1) then
!         f1 = y1
!         f2 = ymax
!         g1 = 1.0_dp
!         g2 = 0.0_dp
!         if (yd .ge. y2) then
!             idx_constant = False
!         else
!             idx_constant = True
!         end if
!
!         df1 = dy1
!         df2 = 1.0_dp
!
!
!     else if (maxmin == 0) then
!         f1 = ymax
!         f2 = y2
!         g1 = 0.0_dp
!         g2 = 1.0_dp
!         if (yd .ge. y1) then
!             idx_constant = False
!         else
!             idx_constant = True
!         end if
!
!         df1 = 1.0_dp
!         df2 = dy2
!
!     end if
!
!     f = CubicSplineSegment(y1, y2, f1, f2, g1, g2)
!
!     # main region
!     ya = np.copy(yd)
!     if dyd is None:
!         dya_dyd = np.ones_like(yd)
!     else:
!         dya_dyd = np.copy(dyd)
!
!     dya_dymax = np.zeros_like(ya)
!
!     # cubic spline region
!     idx = np.logical_and(yd > y1, yd < y2)
!     ya[idx] = f.eval(yd[idx])
!     dya_dyd[idx] = f.eval_deriv(yd[idx])
!     dya_dymax[idx] = f.eval_deriv_params(yd[idx], dy1, dy2, df1, df2, 0.0, 0.0)
!
!     # constant region
!     ya[idx_constant] = ymax
!     dya_dyd[idx_constant] = 0.0
!     dya_dymax[idx_constant] = 1.0
!
!     if n == 1:
!         ya = ya[0]
!         dya_dyd = dya_dyd[0]
!         dya_dymax = dya_dymax[0]
!
!
!     return ya, dya_dyd, dya_dymax
!
!
! def smooth_max(yd, ymax, pct_offset=0.01, dyd=None):
!     """array max, uses cubic spline to smoothly transition.  derivatives with respect to array and max value.
!     width of transition can be controlled, and chain rules for differentiation"""
!     return _smooth_maxmin(yd, ymax, 'max', pct_offset, dyd)
!
!
! def smooth_min(yd, ymin, pct_offset=0.01, dyd=None):
!     """array min, uses cubic spline to smoothly transition.  derivatives with respect to array and min value.
!     width of transition can be controlled, and chain rules for differentiation"""
!     return _smooth_maxmin(yd, ymin, 'min', pct_offset, dyd)
!


C CONHSRA construida con el programa CONTINUO
C calcula el continuo del HSRA por medio de un ajuste a un polinomio
c de tercer grado.El error maximo es de .125%

	real*4 function conhsra(x)

	implicit real*4 (a-h,o-z)
	real*4 c1(11),c2(11),c3(11),c4(11),c5(11),c6(11),c7(11)
	data c1/-4.906054765549e13,1.684734544039e11,1.507254517567e7
     &       ,-7561.242976546,0.,0.,0.,0.,0.,0.,0./
	data c2/-4.4650822755e14,6.1319780351059e11,-9.350928003805e7
     &       ,0.,0.,0.,0.,0.,0.,0.,0./
	data c3/-1.025961e15,1.3172859e12,-3.873465e8
     &       ,46486.541,-2.049,0.,0.,0.,0.,0.,0./
	data c4/4.861821e15,-2.2589885e12,4.3764376e8
     &       ,-39279.61444,1.34388,0.,0.,0.,0.,0.,0./
c	data c5/4.353082e17,-1.261996e14,5.31125e9,908890.899,43.24361
c     &       7,-2.0462285d-2,1.0018226758d-6,0.,0.,0.,0./
	data c5/1.758394e15,-3.293986e11,1.6782617e7,0.,0.,0.
     &       ,0.,0.,0.,0.,0./
	data c6/1.61455557e16,-6.544209e12,1.0159316e9
     &       ,-70695.58136,1.852022,0.,0.,0.,0.,0.,0./
	data c7/7.97805136e14,-1.16906597e11,5.315222e6
     &       ,-4.57327954,-3.473452d-3,0.,0.,0.,0.,0.,0./

	if(x.lt.3644.15)then
	    conhsra=c1(1)+x*(c1(2)+x*(c1(3)+x*(c1(4)+x*c1(5))))
	else if(x.lt.3750.)then
	    conhsra=c2(1)+x*(c2(2)+x*(c2(3)+x*(c2(4)+x*c2(5))))
	else if(x.lt.6250.)then
	    conhsra=c3(1)+x*(c3(2)+x*(c3(3)+x*(c3(4)+x*c3(5))))
	else if(x.lt.8300.)then
	    conhsra=c4(1)+x*(c4(2)+x*(c4(3)+x*(c4(4)+x*c4(5))))
	else if(x.lt.8850.)then
	    conhsra=c5(1)+x*(c5(2)+x*(c5(3)+x*(c5(4)+x*c5(5))))
	else if(x.lt.10000.)then
	    conhsra=c6(1)+x*(c6(2)+x*(c6(3)+x*(c6(4)+x*c6(5))))
	else
	    conhsra=c7(1)+x*(c7(2)+x*(c7(3)+x*(c7(4)+x*c7(5))))
	end if
	return
	end


      subroutine rbf_eval_b(idim, jdim, r, rb, nwp, rw, wt, wtb)
      implicit none
      include 'dim.h'
      integer idim, jdim, nwp
      real    r  (idim,jdim,NDIM),
     1        rw (NDIM,*),
     2        wt (NDIM,*)
      real    rb (idim,jdim,NDIM),
     1        wtb(NDIM,*)

      integer i, j, k
      real    dx, dy, dx1, dy1, dr1, rbf
      real    dxb, dyb

      do i=1,idim
         do j=1,jdim
            dxb = rb(i,j,1)
            dyb = rb(i,j,2)
            do k=1,nwp
               dx1 = r(i,j,1) - rw(1,k)
               dy1 = r(i,j,2) - rw(2,k)
               dr1 = sqrt(dx1*dx1 + dy1*dy1)
               if(dr1.eq.0.0)then
                  rbf = 0.0
               else
                  rbf = dr1*dr1*log(dr1)
               endif
               wtb(1,k) = wtb(1,k) + dxb * rbf
               wtb(2,k) = wtb(2,k) + dyb * rbf
            enddo
            wtb(1,nwp+1) = wtb(1,nwp+1) + dxb
            wtb(1,nwp+2) = wtb(1,nwp+2) + dxb*r(i,j,1)
            wtb(1,nwp+3) = wtb(1,nwp+3) + dxb*r(i,j,2)
            wtb(2,nwp+1) = wtb(2,nwp+1) + dyb
            wtb(2,nwp+2) = wtb(2,nwp+2) + dyb*r(i,j,1)
            wtb(2,nwp+3) = wtb(2,nwp+3) + dyb*r(i,j,2)
         enddo
      enddo

      return
      end


      SUBROUTINE DERTHE(S,T,P0,DTHEDT,DTHEDS,DTHEDP)
C *********************************************************************
C ******* THIS SUBROUTINE USES THE BRYDEN (1973) POLYNOMIAL
C ******* FOR POTENTIAL TEMPERATURE AS A FUNCTION OF S,T,P
C ******* TO OBTAIN THE PARTIAL DERIVATIVES OF THETA WITH
C ******* RESPECT TO T,S,P. PRESSURE IS IN DBARS.
      IMPLICIT DOUBLE PRECISION (A-Z)
      PARAMETER (A0=-0.36504D-4,A1=-0.83198D-5,A2=+0.54065D-7)
      PARAMETER (A3=-0.40274D-9,B0=-0.17439D-5,B1=+0.29778D-7)
      PARAMETER (D0=+0.41057D-10,C0=-0.89309D-8,C1=+0.31628D-9)
      PARAMETER (C2=-0.21987D-11,E0=+0.16056D-12,E1=-0.50484D-14)
      DS=S-35.0
      P=P0
      PP=P*P
      PPP=PP*P
      TT=T*T
      TTT=TT*T
      PART=1.0+P*(A1+2.*A2*T+3.*A3*TT+DS*B1)
      DTHEDT=PART+PP*(C1+2.*C2*T)+PPP*E1
      DTHEDS=P*(B0+B1*T)+PP*D0
      PART=A0+A1*T+A2*TT+A3*TTT+DS*(B0+B1*T)
      DTHEDP=PART+2.*P*(DS*D0+C0+C1*T+C2*TT)+3.*PP*(E0+E1*T)
C      CHECK=T+PART*P+PP*(DS*D0+C0+C1*T+C2*TT)+PPP*(E0+E1*T)
C      TYPE 100,CHECK
C  100 FORMAT(1H ,' THE CHECK VALUE OF THETA FROM DERTHE IS = ',F9.5)
      RETURN
      END


MODULE scatsource_mod

PRIVATE
PUBLIC :: scatsource

CONTAINS

  !> \author msleigh
  !!
  !! PURPOSE: Sets up source term for current iteration
  !!
  !! STRUCTURE
  !! 1. Add group-to-group scattering (g' -> g where g' < g) to group source

  SUBROUTINE scatsource( &
    & group)

  USE getkinds_mod
  USE setdata_mod

  IMPLICIT NONE

  ! Arguments
  INTEGER(KIND=ik), INTENT(IN) :: group !< Energy group being considered

  ! Counters
  INTEGER(KIND=ik) :: j
  INTEGER(KIND=ik) :: group_primed ! Energy group of incident neutrons
  INTEGER(KIND=ik) :: node

  !----------------------------------------------------------------------------
  ! 1. Add group-to-group scattering (g' -> g where g' < g) to group source
  !----------------------------------------------------------------------------

  IF (group > 1_ik) THEN
    DO node = 1_ik, numnodes
      DO j = 1_ik, numcells
        DO group_primed = 1_ik, group-1_ik
          source_g(j,node) = source_g(j,node) + &
            & (sigma_s(j,group,group_primed) * &
            & scalflux_outer(j,group_primed,node))
        ENDDO
      ENDDO
    ENDDO
  ENDIF

  RETURN
  END SUBROUTINE scatsource

END MODULE scatsource_mod


c====================================================================================
c
c  Synthetic Seismogram code for complete synthetics using spectral technique
c    for Moment Tensor and Point Force sources in flat layered media
c
c    Funded by Treaty Verification Program, Lawrence Livermore National Lab
c
c    George Randall, Dept. of Geological Sciences, University of South Carolina
c           ger@tigger.seis.scarolina.edu
c    Steve Taylor, Los Alamos National Lab
c           taylor@beta.lanl.gov
c
c        based on
c       "Seismic Wave Propagation in Stratified Media" B.L.N. Kennett,
c        Cambridge University Press, 1983
c
c    Many useful discussions with and testing by
c    Chuck Ammon, Harley Benz, and Bill Walter
c    are gratefully acknowledged.
c
c
c====================================================================================
c
c  Version 1.0   February  1  1993
c
c     tsynth.f takes output spectrum from kennett.f and computes
c     synthetic seismograms
      integer  MXSRC, MXDEP, MAXNR, MAXF
      parameter ( MXSRC=6, MXDEP=50, MAXNR=50, MAXF=8192 )
      character*30 sacu0,sacw0,sactn,sacu0f,sacw0f,sactnf
      character*10 rngstr,depstr,mech(MXSRC),fmech(3)
      complex u0(MAXF),w0(MAXF),tn(MAXF),utot,wtot,tntot,ws
      complex u0f(MAXF),w0f(MAXF),tnf(MAXF),utotf,wtotf,tntotf,wsf
      real u0tf(MAXF),w0tf(MAXF),tntf(MAXF)
      real u0t(MAXF),w0t(MAXF),tnt(MAXF)
      real fmin,fmax,delf,fny,pi,dt,r,vred,tdly,tred,f,azis
      real tlp,fr,up,wp,tp,d,scale
      integer nft,ifmin,ifmax,nfppts,ir,is,i,iff,nfpts,nerr
      integer inunit,iounit,nr,ii,isl,nsrc,id,ndep,iid,iargc,nargc
      integer lds,lrs
      real twopi,rchk,dchk,dummy
      logical pntfrc,displ,veloc,stepstf,impstf
      complex cmplx,cexp
      intrinsic cos,cmplx,cexp
      real rr(maxnr),dd(mxdep)
c
      inunit=5
      iounit=6
      displ = .false.
      veloc = .true.
      stepstf = .true.
      impstf = .false.
c
      nargc = iargc()
      if ( nargc .gt. 0 ) then
	 call chkopts(nargc,displ,veloc,stepstf,impstf)
      endif
      if ( displ ) write(iounit,*) 'Displacement Seismograms'
      if ( veloc ) write(iounit,*) 'Velocity Seismograms'
      if ( stepstf ) write(iounit,*) 'Step Source Time Function'
      if ( impstf ) write(iounit,*) 'Impulse Source Time Function'
c
      open( unit = 7, file = 'mspec' , form = 'unformatted')
      read(7) fmin, fmax, delf, nfppts, fny, nfpts,nr,nsrc,ndep, azis
c
      if ( nr .gt. MAXNR ) then
	 write(iounit,*) "Too many ranges, ", nr, " , max is ", MAXNR
	 stop
      endif
      read(7) (rr(i),i=1,nr)
      if ( ndep .gt. MXDEP ) then
	 write(iounit,*) "Too many depths, ", ndep, " , max is ", MXDEP
	 stop
      endif
      read(7) (dd(i),i=1,ndep)
c
      inquire( file= 'fspec' , exist = pntfrc )
      if ( pntfrc ) then
	open( unit = 8, file = 'fspec' , form = 'unformatted')
	read(8) fmin, fmax, delf, nfppts, fny, nfpts,nr,ndep, azis
	read(8) (rr(i),i=1,nr)
        read(8) (dd(i),i=1,ndep)
      endif
c
      pi = 4.0*atan(1.0)
      twopi = 2.0*pi
      nft =  2 * ( nfpts - 1 )
      if ( nft .gt. MAXF ) then
	 write(iounit,*) "Too many Frequencies ", nft, " , max is ", MAXF
	 stop
      endif
      dt = 1. / ( 2 * fny )
      ifmin = fmin / delf
      ifmax = fmax / delf
      nfppts = ifmax - ifmin + 1
c
      write(iounit,*) 'enter reducing velocity, tdly: '
      read(inunit,*)  vred, tdly
      write(iounit,*) 'Time will be reduced by  T - distance/',vred,' - ',tdly
c
      mech(1) = '_mzz '
      mech(2) = '_mxy '
      mech(3) = '_mxz '
      mech(4) = '_mxx '
      mech(5) = '_myz '
      mech(6) = '_myy '
      if ( nsrc .eq. 1 ) mech(1) = '_mij '
c
      fmech(1) = '_fz '
      fmech(2) = '_fx '
      fmech(3) = '_fy '
c
      do 30 ii = 1,nr
      r = rr(ii)
      tred = r / vred + tdly
      ir = r
c
c     check to see if r is fraction of a km
c     note that this is not fool proof
c
      rchk = float(ir) - r
      if(rchk .eq. 0.) then
       write(rngstr,'(i4.4)') ir
       lrs = 4
      elseif (10. .le. r .and. r .lt. 100.) then
       write(rngstr,'(f4.1)') r
       lrs = 4
      elseif (r .ge. 100.) then
       write(rngstr,'(f5.1)') r
       lrs = 5
      endif
c
      do 30 id = 1, ndep
      d = dd(id)
      iid = d
c
c     check to see if d is fraction of a km
c     note that this is not fool proof
c
      dchk = float(iid) - d
      if(dchk .eq. 0.) then
       write(depstr,'(i4.4)') iid
       lds = 4
      elseif (0. .le. d .and. d .lt. 10.) then
       write(depstr,'(f3.1)') d
       lds = 3
      elseif (10. .le. d .and. d .lt. 100.) then
       write(depstr,'(f4.1)') d
       lds = 4
      elseif (d .ge. 100.) then
       write(depstr,'(f5.1)') d
       lds = 5
      endif
c
      do 1 is = 1, nsrc
c
      do 5 i = 1, nft
         u0(i) = (0.,0.)
         w0(i) = (0.,0.)
         tn(i) = (0.,0.)
         if ( pntfrc .and. (is .ge. 1) .and. (is .le. 3) ) then
           u0f(i) = (0.,0.)
           w0f(i) = (0.,0.)
           tnf(i) = (0.,0.)
         endif
5      continue
c
c
      do 10 i = ifmin, ifmax
         read(7) utot, wtot, tntot
         iff = i-ifmin+1
         u0(iff) = utot
         w0(iff) = wtot
         tn(iff) = tntot
         if ( pntfrc .and. (is .ge. 1) .and. (is .le. 3) ) then
           read(8) utotf, wtotf, tntotf
           u0f(iff) = utotf
           w0f(iff) = wtotf
           tnf(iff) = tntotf
         endif
10    continue
      up = tred * 2*3.14159*delf
      wp = tred * 2*3.14159*delf
      tp = tred * 2*3.14159*delf
      f=fmin
      do 15 i = 1,nfpts
         tlp=1.0
         u0(i) = u0(i) * cexp( cmplx(0., (i-1)*up) ) * tlp
         w0(i) = w0(i) * cexp( cmplx(0., (i-1)*wp) ) * tlp
         tn(i) = tn(i) * cexp( cmplx(0., (i-1)*tp) ) * tlp
         if ( pntfrc .and. (is .ge. 1) .and. (is .le. 3) ) then
           u0f(i) = u0f(i) * cexp( cmplx(0., (i-1)*up) ) * tlp
           w0f(i) = w0f(i) * cexp( cmplx(0., (i-1)*wp) ) * tlp
           tnf(i) = tnf(i) * cexp( cmplx(0., (i-1)*tp) ) * tlp
         endif
         f=f+delf
15    continue
c
c
c Displacement Spectrum has a factor of omeaga**2 from integration of k*dk
c   the Kennett integration is over slowenss p*dp and leaves
c   the remaining factor of omega**2 and and source time spectrum
c   to be included here,
c   Mij moment sources have omega**2 but Fk force sources only omega
c   because the point force source has 1/omega to include
c   Step Source Time Function  is 1/(-i*omega)
c   Impulse Source Time Function is 1
c Velocity spectrum has a factor of (i*omega) * omega**2 [d/dt displ]
c
c
      do 20 i = 1,nfpts
         fr = (i-1)*delf
         if ( displ .and. stepstf ) then
      	    ws = (0.,1.)*fr*twopi
      	    wsf = (0.,1.)
	 endif
         if ( displ .and. impstf ) then
      	    ws = -1.*fr*twopi*fr*twopi
      	    wsf = -1.*fr*twopi
	 endif
         if ( veloc .and. stepstf ) then
      	    ws = -1.*fr*twopi*fr*twopi
      	    wsf = -1.*fr*twopi
	 endif
         if ( veloc .and. impstf ) then
      	    ws = (0.,-1.)*fr*twopi*fr*twopi*fr*twopi
      	    wsf = (0.,-1.)*fr*twopi*fr*twopi
	 endif
         u0(i) = ws * u0(i)
         w0(i) = ws * w0(i)
         tn(i) = ws * tn(i)
         if ( i .gt. 1 .and. i .lt. nfpts ) then
            iff = nft - i + 2
            u0(iff) = conjg( u0(i) )
            w0(iff) = conjg( w0(i) )
            tn(iff) = conjg( tn(i) )
            if ( pntfrc .and. (is .ge. 1) .and. (is .le. 3) ) then
	      u0f(i) = wsf * u0f(i)
              u0f(iff) = conjg( u0f(i) )
	      w0f(i) = wsf * w0f(i)
              w0f(iff) = conjg( w0f(i) )
	      tnf(i) = wsf * tnf(i)
              tnf(iff) = conjg( tnf(i) )
            endif
         endif
20    continue
      call fft(u0,nft,1)
      call fft(w0,nft,1)
      call fft(tn,nft,1)
        if ( pntfrc .and. (is .ge. 1) .and. (is .le. 3) ) then
        call fft(u0f,nft,1)
        call fft(w0f,nft,1)
        call fft(tnf,nft,1)
        endif
      scale = 1 / ( nft * dt * 4 * pi )
      do 40 i = 1,nft
        u0t(i) = real( u0(i) ) * scale
        w0t(i) = real( w0(i) ) * scale
        tnt(i) = real( tn(i) ) * scale
        if ( pntfrc .and. (is .ge. 1) .and. (is .le. 3) ) then
          u0tf(i) = real( u0f(i) ) * scale
          w0tf(i) = real( w0f(i) ) * scale
          tntf(i) = real( tnf(i) ) * scale
        endif
40    continue
c
      isl = is
      sacu0 = 'z_' // rngstr(1:lrs) // "_" // depstr(1:lds) // mech(isl)(1:4)
      sacw0 = 'r_' // rngstr(1:lrs) // "_" // depstr(1:lds) // mech(isl)(1:4)
      sactn = 't_' // rngstr(1:lrs) // "_" // depstr(1:lds) // mech(isl)(1:4)
      if ( pntfrc .and. (is .ge. 1) .and. (is .le. 3) ) then
        sacu0f = 'z_' // rngstr(1:lrs) // "_"  // depstr(1:lds) // fmech(is)(1:3)
        sacw0f = 'r_' // rngstr(1:lrs) // "_"  // depstr(1:lds) // fmech(is)(1:3)
        sactnf = 't_' // rngstr(1:lrs) // "_"  // depstr(1:lds) // fmech(is)(1:3)
      endif
c
       call newhdr
       call setnhv('NPTS',nft,nerr)
       call setlhv('LEVEN',.true.,nerr)
       call setfhv('B',tred,nerr)
       call setfhv('O',0.,nerr)
       call setfhv('DELTA',dt,nerr)
       call setfhv('DIST',r,nerr)
       call setfhv('EVDP',d,nerr)
       call setfhv('USER1',tred,nerr)
       call setfhv('USER2',vred,nerr)
       call setfhv('USER3',tdly,nerr)
       call setfhv('USER4',azis,nerr)
       call wsac0(sacu0,dummy,u0t,nerr)
       call wsac0(sacw0,dummy,w0t,nerr)
       call wsac0(sactn,dummy,tnt,nerr)
       if ( pntfrc .and. (is .ge. 1) .and. (is .le. 3) ) then
	  call wsac0(sacu0f,dummy,u0tf,nerr)
	  call wsac0(sacw0f,dummy,w0tf,nerr)
	  call wsac0(sactnf,dummy,tntf,nerr)
       endif
c
c
1     continue
30    continue
c
      close(7)
      if ( pntfrc ) close(8)
c
      stop
      end
c
      subroutine chkopts(nargc,displ,veloc,stepstf,impstf)
      integer nargc,icmd
      logical displ,veloc,stepstf,impstf
      character*70 cmdlin
      do 10  icmd = 1,nargc
	 call getarg( icmd, cmdlin )
	 if ( cmdlin(1:2) .eq. "-v" ) then
	   veloc = .true.
	   displ = .false.
	 else if ( cmdlin(1:2) .eq. "-d" ) then
	   veloc = .false.
	   displ = .true.
	 else if ( cmdlin(1:2) .eq. "-s" ) then
	   stepstf = .true.
	   impstf = .false.
	 else if ( cmdlin(1:2) .eq. "-i" ) then
	   stepstf = .false.
	   impstf = .true.
	 else if ( cmdlin(1:2) .eq. "-h" ) then
	   write(*,*) 'Valid Command Line Arguments:'
	   write(*,*) '-d  (Generate Displacement Seismograms)'
	   write(*,*) '-v  (Generate Velocity Seismograms)'
	   write(*,*) '-s  (Step Source Time Function)'
	   write(*,*) '-i  (Impulse Source Time Function)'
	   write(*,*) '-h  (Print This Help Message)'
	   write(*,*) 'Default with no Command Line Arguments is Velocity and Step.'
	   stop
	 else
	   write(*,*) 'Illegal Command Line Argument',cmdlin
	   write(*,*) 'Valid Command Line Arguments:'
	   write(*,*) '-d  (Generate Displacement Seismograms)'
	   write(*,*) '-v  (Generate Velocity Seismograms)'
	   write(*,*) '-s  (Step Source Time Function)'
	   write(*,*) '-i  (Impulse Source Time Function)'
	   write(*,*) '-h  (Print This Help Message)'
	   write(*,*) 'Default with no Command Line Arguments is Velocity and Step.'
	   stop
	 endif
10    continue
      return
      end


!*************************************************************************
      SUBROUTINE Light_Tahoe(latit)
!***********************************************************************!
!
!     This routine calculates the light extinction coefficient for the
!     Lake Tahoe, development of the Tahoe light model of Swift (2000)
!
!    scatter = scattering contribution of sediments (clay)
!    a_cdom  = absortion of colored dissolved organic matter
!    a_star  = absortivity coefficient of chlorophyll-material
!    b_star  = scattering coefficient of chlorophyll-material
!    gamma   = constant on equation SD
!    SD      = Secchi Depth
!    mu_zero = cosinus dependence
!    Kd      = diffuse irradiance attenuation coeffient
!    PAR     = Photosynthetically Active Radiation
!***********************************************************************!
      USE DLMWQ_VARIABLES
      USE DLMWQ_SERVICES
		IMPLICIT NONE
      SAVE

		INTEGER(4), PARAMETER:: size = 7
		INTEGER(4):: i,j,j_counter,k,l,month
!IF		INTEGER(4):: jday
		INTEGER(4):: exits

		REAL(8):: Kd
		REAL(8):: A_1(maxns),B_1(maxns),C_1(maxns),BSed_1(maxns)
		REAL(8):: A_mean, B_mean, C_mean, Depth_mean,Bsed_mean,Depth_S
		REAL(8):: Chloro_mean,Parts_mean(size),Volumetric
		REAL(8):: Organic_mean,Total_mean
      REAL(8):: Kd_mean
		REAL(8):: b_sed(maxns)
		REAL(8):: Scatter(size)
		REAL(8):: SD_prima
		REAL(8):: SD_measured(size)
		REAL(8):: POP_mean,PON_mean
		REAL(8):: Vol_mean
      REAL(8):: Nitrate_mean
      REAL(8):: Ammonia_mean
      REAL(8):: THP_mean
		REAL(8):: Total, Organic
		REAL(8):: Dec, radian, tau, elevation, mu_zero, latit
		REAL(8), PARAMETER :: pi=3.1415926535897932384626433832795d0
		REAL(8), PARAMETER :: arfac  = 1.0d+6,volfac = 1000.0d0
		REAL(8):: Ch_abs,Ch_sca,Wa_abs,Wa_sca,CDOMab,Pa_sca,Pa_sc1,Pa_sc2, Pa_sc3,Pa_sc4,Pa_sc5,Pa_sc6
!
!		New Set of Parameters (06/09/2002)
!
		REAL(8),PARAMETER:: 		gamma    = 8.7000D0   			! # 1	! constant, Gamma
		REAL(8),PARAMETER:: 		a_water  = 0.0120D0				! # 5	! /m, Absroption Pure Water
		REAL(8),PARAMETER:: 		a_cdom   = 0.0380D0				! # 2	! /m, Absorption CDOM
		REAL(8),PARAMETER:: 		a_star   = 0.0250D0				! # 4	! m2/mg, Absroption Chla !low value = up the line, high = low the line
		REAL(8),PARAMETER:: 		b_water  = 0.0027D0				! # 5	! /m, Scattering Pure Water
		REAL(8),PARAMETER:: 		b_star   = 0.1050D0				! # 6 ! m2/mg^0.62, Sacttering Chla

		Scatter(1)  = 4.287D-12			! # 7-13 ! m2/particle, Particle Scattering Coefficients
		Scatter(2)  = 3.015D-11       ! m2/particle
		Scatter(3)  = 9.939D-11       ! m2/particle,
		Scatter(4)  = 3.757D-10       ! m2/particle,
		Scatter(5)  = 1.459D-09       ! m2/particle,
		Scatter(6)  = 5.831D-09       ! m2/particle,
		Scatter(7)  = 0.0d0           ! m2/particle,
4004  CONTINUE
!
!    Factor (Ino/Total) particles
!
		fraction  = 0.0D0
		Organic   = 0.0D0
		Total     = 0.0D0

		DO i = 1,size
			Total   = Total   + cf(ns,i)
		ENDDO ! i
		DO i = 1,nchl
			 Organic = Organic + DBLE(phyto_part_fac(i)*wqual(ns,i))
		ENDDO ! i

!
		fraction = Total /(Total+ Organic)
		IF (fraction.ge.1.0D0) fraction = 1.0D0
		IF (fraction.lt.0.0D0) fraction = 0.0D0
!
!
!    Inicialize  variables
!
!
! Solar angle
!
		radian	 = 2.0D0 * pi/360.0D0									! Degrees to radians factor
		jday      = jday - int(jday/1000)*1000							! Jday (XXX) this omitted the year like 1999002
		Dec       = 23.45D0 * dsin((284+jday)*2.0D0*pi/365.0D0)	! Solar Declination
		tau       = DBLE(360.0D0*12.0D0/24.0D0)						! Hour. Fix to midday
		elevation = dsin(dsin(radian*latit)*dsin(radian*dec)	&	! Solar Elevation
		  		  + dcos(radian*latit)*dcos(radian*dec)*dcos(radian*tau))
!gbs	mu_zero   = dcos(dasin(dcos(elevation)/1.33D0))				! Angle mu
		mu_zero   = dcos(dasin(dsin(elevation)/1.33D0))				! Angle mu
		exits=0
!xxxxxxxxxxxxxx LOOP Starts from here xxxxxxxxxxxxxxxxxxxxxxxx
5		CONTINUE

		Total_mean    = 0.0d0
		Organic_mean  = 0.0d0
		fraction_mean = 0.0d0
		DO i = 1,ns
			A_1(i)    = 0.0D0
			B_1(i)    = 0.0D0
			b_sed(i)  = 0.0D0
			BSed_1(i) = 0.0D0
			Kd        = 0.0D0
			DO j = 1,nchl
				A_1(i)    = DBLE(A_1(i)   + DBLE(a_star*wqual(i,j)))
				B_1(i)    = DBLE(B_1(i)   + DBLE(b_star*wqual(i,j)**0.62D0))
			ENDDO ! j

			DO j = 1,7
				b_sed(i)  = DBLE(b_sed(i) +DBLE(DBLE(fraction*Scatter(j)*cf(i,j))))
			ENDDO  !j
			BSed_1(i) = b_sed(i)
			A_1(i)    = DBLE(A_1(i) + a_water + a_cdom)
			B_1(i)    = DBLE(B_1(i) + b_water + b_sed(i))
			C_1(i)    = DBLE(A_1(i) + B_1(i))
			Kd = (A_1(i)/mu_zero) * DSQRT(1.0D0+(0.425D0*mu_zero-0.19D0)* DBLE(B_1(i)/A_1(i)))
			et1(i) = 1.00*Kd
		ENDDO ! i
!
!   Estimate Secchi depth. Use Iterative Process
!
      j_counter = 1
		DO 5000 i = ns,1,-1
			A_mean       = 0.0D0
			B_mean       = 0.0D0
			Bsed_mean    = 0.0D0
			C_mean       = 0.0D0
			Chloro_mean  = 0.0D0
			Depth_mean   = 0.0D0
			Kd_mean      = 0.0D0
			POP_mean     = 0.0D0
			PON_mean     = 0.0D0
			SD_prima     = 0.0D0
			Depth_S      = 0.0D0
			Nitrate_mean = 0.0D0
			Ammonia_mean = 0.0D0
			THP_mean     = 0.0D0
			Vol_mean     = 0.0D0
			Total_mean	  = 0.0D0
			Organic_mean = 0.0d0
			fraction_mean = 0.0d0

			DO l = 1,7
				Parts_mean(l) = 0.0D0
			ENDDO

			DO j = ns,ns - j_counter,-1
				IF(j-1.eq.0.or.ns-j_counter.eq.0) THEN
					Volumetric   = vol(1)*volfac
					Depth_S      = depth(1)
					POP_mean     = POP_mean     + wqual(1,17)*Volumetric
					PON_mean     = PON_mean     + wqual(1,23)*Volumetric
					Nitrate_mean = Nitrate_mean + wqual(1,21)*Volumetric
					Ammonia_mean = Ammonia_mean + wqual(1,22)*Volumetric
					THP_mean     = THP_mean     + wqual(1,16)*Volumetric
					DO k = 1,nchl
						Chloro_mean = Chloro_mean  + wqual(1,k)*Volumetric
					ENDDO    ! k
					DO k = 1,7
						Parts_mean(k) = Parts_mean(k) + cf(1,k)*Volumetric
					ENDDO    ! k
					A_mean =     A_mean     + A_1(1)*depth_S   !
					B_mean =     B_mean     + B_1(1)*depth_S   !
					Bsed_mean  = Bsed_mean  + BSed_1(1)*depth_S
					Depth_mean = Depth_mean + Depth_S
					Vol_mean   = Vol_mean   + Volumetric
					GOTO 3456
				ENDIF
				Volumetric   = vol(j)*volfac
				Depth_S      = depth(j)-depth(j-1)
				POP_mean     = POP_mean     + wqual(j,17)*Volumetric
				PON_mean     = PON_mean     + wqual(j,23)*Volumetric
				Nitrate_mean = Nitrate_mean + wqual(j,21)*Volumetric
				Ammonia_mean = Ammonia_mean + wqual(j,22)*Volumetric
				THP_mean     = THP_mean     + wqual(j,16)*Volumetric
				DO k = 1,nchl
					Chloro_mean = Chloro_mean  + wqual(j,k)*Volumetric
				ENDDO    ! k
				DO k = 1,7
					Parts_mean(k) = Parts_mean(k) + cf(j,k)*Volumetric
				ENDDO    ! k
				A_mean     = A_mean     + A_1(j)   *depth_S !Unit of Length
				B_mean     = B_mean     + B_1(j)   *depth_S !Unit of Length
				Bsed_mean  = Bsed_mean  + BSed_1(j)*depth_S !Unit of Length
				Depth_mean = Depth_mean + Depth_S
				Vol_mean   = Vol_mean   + Volumetric
			ENDDO  ! j

 3456		CONTINUE

			A_mean      = DBLE(A_mean/Depth_mean)
			B_mean      = DBLE(B_mean/Depth_mean)
			Bsed_mean   = DBLE(Bsed_mean/Depth_mean)
			C_mean      = A_mean + B_mean
			Kd_mean     = A_mean * (DSQRT(1+(0.425*mu_zero-0.19D0)*		&
							  DBLE(DBLE(B_mean/A_mean))/mu_zero))

			SD_prima    = DBLE(gamma/DBLE(C_mean + Kd_mean))
			Chloro_mean = DBLE(Chloro_mean/Vol_mean)

			DO k = 1,7
				Parts_mean(k)  = DBLE(Parts_mean(k)/Vol_mean)
			ENDDO       ! k
			Nitrate_mean = DBLE(Nitrate_mean/Vol_mean)
			Ammonia_mean = DBLE(Ammonia_mean/Vol_mean)
			THP_mean     = DBLE(THP_mean/Vol_mean)
			POP_mean     = DBLE(POP_mean/Vol_mean)
			PON_mean     = DBLE(PON_mean/Vol_mean)

			IF(SD_prima.gt.(depth(ns)-depth(i))) THEN
				SD = Depth_mean
				j_counter = j_counter + 1
!				WRITE(*,fmt='(3f10.3)')SD_prima,(depth(ns)-depth(i))
			ELSE
				SD           = SD_prima
				A_Tahoe      = A_mean
				B_Tahoe      = B_mean
				Kd_Tahoe     = Kd_mean
				Bsed_Tahoe   = Bsed_mean
				Chloro_Tahoe = Chloro_mean
				DO k = 1,7
					Parts_Tahoe(k)  = Parts_mean(k)
				ENDDO
				POP_Tahoe     = POP_mean
				PON_Tahoe     = PON_mean
				Nitrate_Tahoe = Nitrate_mean
				Ammonia_Tahoe = Ammonia_mean
				THP_Tahoe     = THP_mean
				DO k = 1,7
					Total_mean   = Total_mean   + Parts_mean(k)
				ENDDO ! k
				Organic_mean = Organic_mean + DBLE(phyto_part_fac(1)*Chloro_mean)
				fraction_mean = Total_mean /(Total_mean+ Organic_mean)
		      IF (fraction_mean.ge.1.0D0) fraction_mean = 1.0D0        !gbs
      		IF (fraction_mean.lt.0.0D0) fraction_mean = 0.0D0	     !gbs
!gbs   Becuase the repeation takes place for some values and it never converge
!gbs   the value has changed. ELSE GOTO 5 repeats and never converge.
!gbs	    IF(DABS(fraction-fraction_mean).gt.0.01) THEN
!gbs       WRITE(*,fmt='(2f10.3)')fraction-fraction_mean,SD
  				IF(DABS(fraction-fraction_mean).gt.0.01) THEN
					fraction = fraction_mean
					exits=exits+1
					IF(exits.gt.5) GOTO 4900
					GOTO 5
				ELSEIF (DABS(fraction-fraction_mean).LE.0.01) THEN
				   GOTO 4900
				ENDIF
				GOTO 4900
			ENDIF
5000	ENDDO  ! i
4900  CONTINUE

!
! Contribution from each source
!
      Ch_abs = 0.0d0
      Ch_sca = 0.0d0
      Wa_abs = 0.0d0
      Wa_sca = 0.0d0
      CDOMab = 0.0d0
      Pa_sca = 0.0d0
      Pa_sc1 = 0.0d0
      Pa_sc2 = 0.0d0
      Pa_sc3 = 0.0d0
      Pa_sc4 = 0.0d0
      Pa_sc5 = 0.0d0
      Pa_sc6 = 0.0d0
		DO k = ns-1, i,-1
			DO j = 1,nchl
				Ch_abs    = Ch_abs   + DBLE(a_star*wqual(k,j))*(depth(k+1)-depth(k))
				Ch_sca    = Ch_sca   + DBLE(b_star*wqual(k,j)**0.62D0)*(depth(k+1)-depth(k))
			ENDDO ! j

			DO j = 1,7
				   Pa_sca = Pa_sca +DBLE(Scatter(j)*cf(k,j))*(depth(k+1)-depth(k))
				 IF (J.EQ.1) THEN
				   Pa_sc1 = Pa_sc1 +DBLE(Scatter(j)*cf(k,j))*(depth(k+1)-depth(k))
				 ELSEIF (J.EQ.2) THEN
				   Pa_sc2 = Pa_sc2 +DBLE(Scatter(j)*cf(k,j))*(depth(k+1)-depth(k))
				 ELSEIF (J.EQ.3) THEN
				   Pa_sc3 = Pa_sc3 +DBLE(Scatter(j)*cf(k,j))*(depth(k+1)-depth(k))
				 ELSEIF (J.EQ.4) THEN
				   Pa_sc4 = Pa_sc4 +DBLE(Scatter(j)*cf(k,j))*(depth(k+1)-depth(k))
				 ELSEIF (J.EQ.5) THEN
				   Pa_sc5 = Pa_sc5 +DBLE(Scatter(j)*cf(k,j))*(depth(k+1)-depth(k))
				 ELSEIF (J.EQ.6) THEN
				   Pa_sc6 = Pa_sc6 +DBLE(Scatter(j)*cf(k,j))*(depth(k+1)-depth(k))
				 ENDIF
			ENDDO  !j
			Wa_abs    =  Wa_abs + a_water*(depth(k+1)-depth(k))
			Wa_sca    =  Wa_sca + b_water*(depth(k+1)-depth(k))
			CDOMab    =  CDOMab + a_cdom*(depth(k+1)-depth(k))
    ENDDO ! k

      IF(ISNAN(SD).or.SD<=10.0d0)SD=10.0d0
      WRITE (99,5005)JDAY,ICLOCK,SD, depth(NS)-DEPTH(I),Ch_abs,Ch_sca,Wa_abs,  &
      Wa_sca,CDOMab,Pa_sca,Pa_sc1,Pa_sc2, Pa_sc3,Pa_sc4,Pa_sc5,Pa_sc6
5005  FORMAT(2I8, 2F10.3, 12F10.6)
		RETURN
		END SUBROUTINE Light_Tahoe


subroutine lmn_bouwal(a,e,gpvel,visac,denac,delta,&
                      wmatr,tract)

!-----------------------------------------------------------------------
!****f* Nstinc/lmn_bouwal
! NAME
!    lmn_bouwal
! DESCRIPTION
!    This routine computes the surface traction for the NS equations at
!    a given integration point of a boundary IBOUN received by argument
!    due to the use of a turbulent wall law. The algorithm is:
!    - Compute the tangential velocity u at the integration point x.
!      In fact, u is not necessarily tangential at x. For example:
!      -> u    -> u
!      o---x---o---x---o
!                      |\ u
!                      |
!    - Given the distance to the wall y, compute (U*) (friction velocity)
!    - Compute y+=(y)(U*)/(nu)
!      if(y+>5) then
!        t=-(rho)*(U*)^2*(u/|u|)
!      else
!        u+=y+ => U*^2=u*nu/y so that
!        t=-mu*u/y
!      end if
! USES
!    vecnor
!    frivel
! USED BY
!    lmn_bouope
!***
!-----------------------------------------------------------------------
   use typre
   use Mod_Element
   use Mod_LowMach
   implicit none
   type(LowMachProblem) :: a
   class(FiniteElement)  :: e
   real(rp) :: gpvel(e%ndime),visac,denac,delta
   real(rp) :: wmatr(a%ndofn,e%mnode,a%ndofn,e%mnode),tract(e%ndime)

   integer(ip)                :: jlins
   integer(ip)                :: ldime,idime,ldimb

   real(rp)                   :: vikin,velfr,yplus    ! nu, U*, y+, y
   real(rp)                   :: tveno,tvelo(e%ndime),ovelo(e%ndime)             ! |u|, u
   real(rp)                   :: trano,xmuit,tcoef,dtrac
   integer(ip)                :: inodb,jnodb,jdime,kdime,inode,jnode
   real(rp)                   :: relax

   jlins = 1
   if(delta<zelmn) return

   !normal velocity, projection of a over b: a_b = (a . b) b
   ovelo = dot_product(e%baloc(:,e%ndime),gpvel)*e%baloc(:,e%ndime)

   tvelo = gpvel - ovelo
   call vecnor(tvelo,e%ndime,tveno,2)                       ! |u|
   vikin=visac/denac                                      ! nu
   if(tveno<=zelmn) then
      velfr=0.0_rp
      tract=0.0_rp
      return
   else
      call frivel(delta,tveno,vikin,velfr)                  ! U*
   end if

   ! Compute prescribed traction
   if(jlins==0) then                                       ! RHS

       yplus=delta*velfr/vikin
       if(yplus<5.0_rp) then
          tract = -denac*vikin*tvelo/delta                  ! t=-mu*u/y
       else
          tract = -denac*velfr*velfr*tvelo/tveno            ! t=-rho*U*^2*(u/|u|)
       end if

   else if(jlins==1) then                                  ! Assembly (the sign changes on the left)

      yplus=delta*velfr/vikin
      if(yplus<5.0_rp) then
         trano=denac*vikin/delta                              ! t=-mu*u/y
      else
         trano=denac*velfr*velfr/tveno                        ! t=-rho*U*^2*(u/|u|)
      end if
      do inodb=1,e%pnodb
         inode = e%lboel(inodb)
         do idime=1,e%ndime
            do jnodb=1,e%pnodb
               jnode = e%lboel(jnodb)
               xmuit=e%shapb(inodb,e%igaub)*e%shapb(jnodb,e%igaub)
               do jdime=1,e%ndime
                  do ldimb=1,e%ndime-1
                     wmatr(idime,inode,jdime,jnode) = &
                        wmatr(idime,inode,jdime,jnode) + &
                         xmuit*e%baloc(idime,ldimb)*e%baloc(jdime,ldimb)*trano
                  end do
               end do
            end do
         end do
      end do

   elseif(jlins==2) then                                   ! Newton on the traction

   else
      call runend('lmn_bouwal: jlins not defined')
   end if

end subroutine lmn_bouwal