!------------------------------------------------------------------------------!
!> Numerical utilities related to equilibrium variables.
!------------------------------------------------------------------------------!
module eq_utilities
#include <PB3D_macros.h>
    use str_utilities
    use output_ops
    use messages
    use num_vars, only: pi, dp, max_str_ln, max_deriv
    use grid_vars, only: grid_type
    use eq_vars, only: eq_1_type, eq_2_type
#if ldebug
    use num_utilities, only: check_deriv
#endif

    implicit none
    private
    public calc_inv_met, calc_g, transf_deriv, calc_F_derivs, do_eq, eq_info, &
        &print_info_eq, calc_memory_eq
#if ldebug
    public debug_calc_inv_met_ind
#endif

    ! global variables
#if ldebug
    !> \ldebug
    logical :: debug_calc_inv_met_ind = .false.                                 !< plot debug information for calc_inv_met_ind()
#endif

    ! interfaces

    !> \public  Transforms  derivatives  of  the  equilibrium  quantities  in  E
    !! coordinates to derivatives in the F coordinates.
    !!
    !! \return ierr
    interface calc_F_derivs
        !> \public
        module procedure calc_F_derivs_1
        !> \public
        module procedure calc_F_derivs_2
    end interface

    !> \public Calculate
    !!      \f$D_1^{m_1} D_2^{m_2} D_3^{m_3} X\f$
    !! from
    !!      \f$D_1^{i_1} D_2^{i_2} D_3^{i_3} X\f$
    !! and
    !!      \f$D_1^{j_1} D_2^{j_2} D_3^{j_3} Y\f$
    !! where \f$XY=1\f$ and \f$i,j = 0\ldots m\f$, according to \cite Weyens3D.
    !!
    !!
    !! \f$D_1^{m_1} D_2^{m_2} D_3^{m_3} \f$ is defined as
    !!      \f$\left(\frac{\partial}{\partial u^1}\right)^{m_1}
    !!      \left(\frac{\partial}{\partial u^2}\right)^{m_2}
    !!      \left(\frac{\partial}{\partial u^3}\right)^{m_3} \f$
    !!
    !! \note It is assumed that the lower order derivatives have been calculated
    !! already. If not, the results will be incorrect.
    !!
    !! \return ierr
    interface calc_inv_met
        !> \public
        module procedure calc_inv_met_ind
        !> \public
        module procedure calc_inv_met_arr
        !> \public
        module procedure calc_inv_met_ind_0D
        !> \public
        module procedure calc_inv_met_arr_0D
    end interface

    !> \public Calculates derivatives in a  coordinate system B from derivatives
    !! in  a coordinates  system  A,  making use  of  the transformation  matrix
    !! \f$\overline{\text{T}}_\text{B}^\text{A}\f$.
    !!
    !! The routine works by exchanging the  derivatives in the coordinates B for
    !! derivatives in coordinates A using the formula
    !!  \f[\mathbf{D}_\text{B}^m X = \overline{\text{T}}_\text{B}^\text{A}
    !!      \mathbf{D}^1_\text{A} \left(\mathbf{D}^{m-1}_\text{B} X\right) , \f]
    !! where \f$\mathbf{D}^m\f$  is a tensor  of rank \f$m\f$ that  contains all
    !! the derivatives of total rank \f$m\f$. For example,
    !!  \f[\mathbf{D}^1 = \vec{D} =
    !!      \left(\begin{array}{c}\frac{\partial}{\partial u^1} \\
    !!      \frac{\partial}{\partial u^2} \\ \frac{\partial}{\partial u^3}
    !!      \end{array}\right)  \f]
    !!
    !! This  is done  for the  derivatives in  each of  the coordinates  B until
    !! degree 0 is reached.
    !!
    !! Furthermore, each of these degrees of derivatives in coordinates B can be
    !! be derived optionally  in the original coordinate system  A, which yields
    !! the formula:
    !!  \f[ \mathbf{D}^p_\text{A} \left(\mathbf{D}^m_\text{B} X \right) =
    !!      \sum_q \left(\begin{array}{c}p\\q\end{array}\right)
    !!      \mathbf{D}^q_\text{A}
    !!      \left(\overline{\text{T}}_\text{B}^\text{A}\right)
    !!      \left(\mathbf{D}^{p-q}_\text{A} \mathbf{D}^1_\text{A}\right)
    !!      \left( \mathbf{D}^{m-1}_\text{B} X \right)\f]
    !!
    !! This way, ultimately the desired derivatives  in the coordinates B can be
    !! obtained  recursively from  the lower  orders  in the  coordinates B  and
    !! higher orders in the coordinates A.
    !!
    !! For example:
    !!  - For order \f$M\f$, the formula can be used with \f$p=0\f$.
    !!  -   For   this,   it    is   necessary   that   \f$\mathbf{D}^1_\text{A}
    !!  \mathbf{D}^{m-1}_\text{B} X\f$ be precalculated, which can be done using
    !!  the formula with \f$p=1\f$ and \f$m=M-1\f$.
    !!  -   For   this,   it    is   necessary   that   \f$\mathbf{D}^1_\text{A}
    !!  \mathbf{D}^{M-1}_\text{B}     X\f$      and     \f$\mathbf{D}^2_\text{A}
    !!  \mathbf{D}^{M-1}_\text{B} X\f$ are precalculated, which can be done with
    !!  \f$p=1\f$ and \f$m=M-1\f$ as well as \f$p=2\f$ and \f$m=M-1\f$.
    !!  - etc.
    !!
    !! \see \cite Weyens3D for more detailed information.
    !!
    !! \return ierr
    interface transf_deriv
        !> \public
        module procedure transf_deriv_3_ind
        !> \public
        module procedure transf_deriv_3_arr
        !> \public
        module procedure transf_deriv_3_arr_2D
        !> \public
        module procedure transf_deriv_1_ind
    end interface

contains
    !> \private individual matrix version
    integer function calc_inv_met_ind(X,Y,deriv) result(ierr)
        use num_utilities, only: calc_inv, calc_mult, c, conv_mat
#if ldebug
        use num_vars, only: n_procs
#endif

        character(*), parameter :: rout_name = 'calc_inv_met_ind'

        ! input / output
        real(dp), intent(inout) :: X(1:,1:,1:,1:,0:,0:,0:)                      !< X
        real(dp), intent(in) :: Y(1:,1:,1:,1:,0:,0:,0:)                         !< Y
        integer, intent(in) :: deriv(:)                                         !< derivatives

        ! local variables
        integer :: r, t, z                                                      ! counters for derivatives
        integer :: m1, m2, m3                                                   ! alias for deriv(i)
        integer :: dims(3)                                                      ! dimensions of coordinates
        real(dp) :: bin_fac(3)                                                  ! binomial factor for norm., pol. and tor. sum
        real(dp), allocatable :: dum1(:,:,:,:)                                  ! dummy variable representing metric matrix for some derivatives
        real(dp), allocatable :: dum2(:,:,:,:)                                  ! dummy variable representing metric matrix for some derivatives
        integer :: nn                                                           ! size of matrices
        character(len=max_str_ln) :: err_msg                                    ! error message
#if ldebug
        real(dp), allocatable :: XY(:,:,:,:)                                    ! to check if XY is indeed unity
#endif

        ! initialize ierr
        ierr = 0

        ! set nn
        nn = size(X,4)

        ! tests
        if (size(Y,4).ne.nn) then
            ierr = 1
            err_msg = 'Both matrices X and Y have to be either in full or &
                &lower diagonal storage'
            CHCKERR(err_msg)
        end if

        ! set mi
        m1 = deriv(1)
        m2 = deriv(2)
        m3 = deriv(3)

        ! set dims
        dims = [size(X,1),size(X,2),size(X,3)]

        ! initialize the requested derivative to zero
        X(:,:,:,:,m1,m2,m3) = 0._dp

        ! set up dummy variables
        allocate(dum1(dims(1),dims(2),dims(3),9))
        allocate(dum2(dims(1),dims(2),dims(3),9))

        ! initialize dum2
        dum2 = 0._dp

        ! calculate terms
        if (m1.eq.0 .and. m2.eq.0 .and. m3.eq.0) then                           ! direct inverse
            ierr = calc_inv(X(:,:,:,:,0,0,0),Y(:,:,:,:,0,0,0),3)
            CHCKERR('')

#if ldebug
            ! check if X*Y is unity indeed if debugging
            if (debug_calc_inv_met_ind) then
                if (n_procs.gt.1) call writo('Debugging of calc_inv_met_ind &
                    &should be done with one processor only',warning=.true.)
                call writo('checking if X*Y = 1')
                call lvl_ud(1)
                allocate(XY(dims(1),dims(2),dims(3),9))
                ierr = calc_mult(X(:,:,:,:,0,0,0),Y(:,:,:,:,0,0,0),XY,3)
                CHCKERR('')
                do r = 1,3
                    do t = 1,3
                        call writo(&
                            &trim(r2strt(minval(XY(:,1,:,c([r,t],.false.)))))//&
                            &' < element ('//trim(i2str(t))//','//&
                            &trim(i2str(r))//') < '//&
                            &trim(r2strt(maxval(XY(:,1,:,c([r,t],.false.))))))
                    end do
                end do
                deallocate(XY)
                call lvl_ud(-1)
            end if
#endif
        else                                                                    ! calculate using the other inverses
            do z = 0,m3                                                         ! derivs in third coord
                if (z.eq.0) then                                                ! first term in sum
                    bin_fac(3) = 1.0_dp
                else
                    bin_fac(3) = bin_fac(3)*(m3-(z-1))/z
                end if
                do t = 0,m2                                                     ! derivs in second coord
                    if (t.eq.0) then                                            ! first term in sum
                        bin_fac(2) = 1.0_dp
                    else
                        bin_fac(2) = bin_fac(2)*(m2-(t-1))/t
                    end if
                    do r = 0,m1                                                 ! derivs in first coord
                        if (r.eq.0) then                                        ! first term in sum
                            bin_fac(1) = 1.0_dp
                        else
                            bin_fac(1) = bin_fac(1)*(m1-(r-1))/r
                        end if
                        if (z+t+r .lt. m1+m2+m3) then                           ! only add if not all r,t,z are equal to m1,m2,m3
                            ! multiply X(r,t,z) and Y(m1-r,m2-t,m3-z)
                            ierr = calc_mult(X(:,:,:,:,r,t,z),&
                                &Y(:,:,:,:,m1-r,m2-t,m3-z),dum1,3)
                            CHCKERR('')
                            ! add result, multiplied by bin_fac, to dum2
                            dum2 = dum2 - product(bin_fac)*dum1
                        end if
                    end do
                end do
            end do

            ! right-multiply by X(0,0,0) and save in dum1
            ierr = calc_mult(dum2,X(:,:,:,:,0,0,0),dum1,3)
            CHCKERR('')
            ! save result in X(m1,m2,m3), converting if necessary
            ierr = conv_mat(dum1,X(:,:,:,:,m1,m2,m3),3)
            CHCKERR('')

            ! deallocate local variables
            deallocate(dum1,dum2)
        end if
    end function calc_inv_met_ind
    !> \private individual scalar version
    integer function calc_inv_met_ind_0D(X,Y,deriv) result(ierr)
        character(*), parameter :: rout_name = 'calc_inv_met_ind_0D'

        ! input / output
        real(dp), intent(inout) :: X(1:,1:,1:,0:,0:,0:)                         !< X
        real(dp), intent(in) :: Y(1:,1:,1:,0:,0:,0:)                            !< Y
        integer, intent(in) :: deriv(:)                                         !< derivatives

        ! local variables
        integer :: r, t, z                                                      ! counters for derivatives
        integer :: m1, m2, m3                                                   ! alias for deriv(i)
        real(dp) :: bin_fac(3)                                                  ! binomial factor for norm., pol. and tor. sum

        ! initialize ierr
        ierr = 0

        m1 = deriv(1)
        m2 = deriv(2)
        m3 = deriv(3)

        ! initialize the requested derivative
        X(:,:,:,m1,m2,m3) = 0.0_dp

        ! calculate terms
        if (m1.eq.0 .and. m2.eq.0 .and. m3.eq.0) then                           ! direct inverse
            X(:,:,:,0,0,0) = 1._dp/Y(:,:,:,0,0,0)
        else                                                                    ! calculate using the other inverses
            do z = 0,m3                                                         ! derivs in third coord
                if (z.eq.0) then                                                ! first term in sum
                    bin_fac(3) = 1.0_dp
                else
                    bin_fac(3) = bin_fac(3)*(m3-(z-1))/z
                    ! ADD SOME ERROR CHECKING HERE !!!!
                    CHCKERR('')
                end if
                do t = 0,m2                                                     ! derivs in second coord
                    if (t.eq.0) then                                            ! first term in sum
                        bin_fac(2) = 1.0_dp
                    else
                        bin_fac(2) = bin_fac(2)*(m2-(t-1))/t
                    end if
                    do r = 0,m1                                                 ! derivs in first coord
                        if (r.eq.0) then                                        ! first term in sum
                            bin_fac(1) = 1.0_dp
                        else
                            bin_fac(1) = bin_fac(1)*(m1-(r-1))/r
                        end if
                        if (z+t+r .lt. m1+m2+m3) then                           ! only add if not all r,t,z are equal to m1,m2,m3
                            X(:,:,:,m1,m2,m3) = X(:,:,:,m1,m2,m3)-&
                                &bin_fac(1)*bin_fac(2)*bin_fac(3)* &
                                &X(:,:,:,r,t,z)*Y(:,:,:,m1-r,m2-t,m3-z)
                        end if
                    end do
                end do
            end do

            ! right-multiply by X(0,0,0)
            X(:,:,:,m1,m2,m3) = X(:,:,:,m1,m2,m3)*X(:,:,:,0,0,0)
        end if
    end function calc_inv_met_ind_0D
    !< \private array matrix version
    integer function calc_inv_met_arr(X,Y,deriv) result(ierr)
        character(*), parameter :: rout_name = 'calc_inv_met_arr'

        ! input / output
        real(dp), intent(inout) :: X(1:,1:,1:,1:,0:,0:,0:)                      !< X
        real(dp), intent(in) :: Y(1:,1:,1:,1:,0:,0:,0:)                         !< Y
        integer, intent(in) :: deriv(:,:)                                       !< derivatives

        ! local variables
        integer :: id

        ! initialize ierr
        ierr = 0

        do id = 1, size(deriv,2)
            ierr = calc_inv_met_ind(X,Y,deriv(:,id))
            CHCKERR('')
        end do
    end function calc_inv_met_arr
    !< \private array scalar version
    integer function calc_inv_met_arr_0D(X,Y,deriv) result(ierr)
        character(*), parameter :: rout_name = 'calc_inv_met_arr_0D'

        ! input / output
        real(dp), intent(inout) :: X(1:,1:,1:,0:,0:,0:)                         !< X
        real(dp), intent(in) :: Y(1:,1:,1:,0:,0:,0:)                            !< Y
        integer, intent(in) :: deriv(:,:)                                       !< derivatives

        ! local variables
        integer :: id

        ! initialize ierr
        ierr = 0

        do id = 1, size(deriv,2)
            ierr = calc_inv_met_ind_0D(X,Y,deriv(:,id))
            CHCKERR('')
        end do
    end function calc_inv_met_arr_0D

    !> Calculate  the metric coefficients in  a coordinate system B  ! using the
    !metric  coefficients in  a coordinate  system  A and  the !  transformation
    !matrix \f$\overline{\text{T}}_\text{B}^\text{A}\f$.
    !!
    !! This is  based on the  general treatment  using the formula  described in
    !! \cite Weyens3D :
    !!  \f[ \vec{D}_1^{m_1} \vec{D}_2^{m_2} \vec{D}_3^{m_3} g_\text{B}
    !!      = \sum_1 \sum_2 \sum_3 C_1 C_2 C_3 \vec{D}^{i_1,j_1,k_1}
    !!      \overline{\text{T}}_\text{B}^\text{A}
    !!      \vec{D}^{i_2,j_2,k_2} g_\text{A} \vec{D}^{i_3,j_3,k_3}
    !!      \left(\overline{\text{T}}_\text{B}^\text{A}\right)^T \ ,
    !!  \f]
    !! with
    !!  \f[ k_l = m_l-i_l-j_l \ , \f]
    !! and with  the \f$\sum_i\f$  double summations, with  the first  one going
    !! from \f$0\f$ to \f$m_i\f$ and the second one from \f$m_j\f$ to \f$0\f$.
    !!
    !! The coefficients \f$C_l\f$ are calculated as
    !!  \f[
    !!      C_l = \left(\begin{array}{c}m_l\\i_l,j_l,k_l\end{array}\right)
    !!      \equiv \frac{m_l!}{i_l!j_l!(m_l-i_l-j_l)!} \ .
    !!  \f]
    !!
    !! \note It is assumed that the lower order derivatives have been calculated
    !! already. If not, the results will be incorrect. This is not checked.
    integer function calc_g(g_A,T_BA,g_B,deriv,max_deriv) result(ierr)
        use num_utilities, only: calc_mult, conv_mat

        character(*), parameter :: rout_name = 'calc_g'

        ! input / output
        real(dp), intent(in) :: g_A(:,:,:,:,0:,0:,0:)                           !< \f$g_\text{A}\f$
        real(dp), intent(in) :: T_BA(:,:,:,:,0:,0:,0:)                          !< \f$\overline{\text{T}}_\text{B}^\text{A}\f$
        real(dp), intent(inout) :: g_B(:,:,:,:,0:,0:,0:)                        !< \f$g_\text{B}\f$
        integer, intent(in) :: deriv(3)                                         !< derivatives
        integer, intent(in) :: max_deriv                                        !< maximum derivative

        ! local variables
        integer :: i1, j1, i2, j2, i3, j3, k1, k2, k3                           ! counters
        integer :: m1, m2, m3                                                   ! alias for deriv
        real(dp), allocatable :: C1(:), C2(:), C3(:)                            ! coeff. for (il)
        real(dp), allocatable :: dum1(:,:,:,:)                                  ! dummy variable representing metric matrix for some derivatives
        real(dp), allocatable :: dum2(:,:,:,:)                                  ! dummy variable representing metric matrix for some derivatives

        ! initialize ierr
        ierr = 0

#if ldebug
        ! check the derivatives requested
        ierr = check_deriv(deriv,max_deriv,'calc_g')
        CHCKERR('')
#endif

        ! set ml
        m1 = deriv(1)
        m2 = deriv(2)
        m3 = deriv(3)

        ! set up dummies
        allocate(dum1(size(g_A,1),size(g_A,2),size(g_A,3),9))
        allocate(dum2(size(g_A,1),size(g_A,2),size(g_A,3),9))

        ! initialize the requested derivative to zero
        g_B(:,:,:,:,m1,m2,m3) = 0.0_dp

        ! calculate the terms in the summation
        d1: do j1 = 0,m1                                                        ! derivatives in first coordinate
            call calc_C(m1,j1,C1)                                               ! calculate coeff. C1
            do i1 = m1-j1,0,-1
                d2: do j2 = 0,m2                                                ! derivatives in second coordinate
                    call calc_C(m2,j2,C2)                                       ! calculate coeff. C2
                    do i2 = m2-j2,0,-1
                        d3: do j3 = 0,m3                                        ! derivatives in third coordinate
                            call calc_C(m3,j3,C3)                               ! calculate coeff. C3
                            do i3 = m3-j3,0,-1
                                ! set up ki
                                k1 = m1 - j1 - i1
                                k2 = m2 - j2 - i2
                                k3 = m3 - j3 - i3
                                ! calculate term to add to the summation
                                ierr = calc_mult(g_A(:,:,:,:,j1,j2,j3),&
                                    &T_BA(:,:,:,:,k1,k2,k3),dum1,3,&
                                    &transp=[.false.,.true.])
                                CHCKERR('')
                                ierr = calc_mult(T_BA(:,:,:,:,i1,i2,i3),&
                                    &dum1,dum2,3)
                                CHCKERR('')
                                ! convert result to lower-diagonal storage
                                ierr = conv_mat(dum2,dum1(:,:,:,1:6),3)
                                CHCKERR('')
                                g_B(:,:,:,:,m1,m2,m3) = g_B(:,:,:,:,m1,m2,m3) &
                                    &+C1(i1)*C2(i2)*C3(i3)*dum1(:,:,:,1:6)
                            end do
                        end do d3
                    end do
                end do d2
            end do
        end do d1

        ! deallocate local variables
        deallocate(dum1,dum2)
    contains
        ! Calculate the coeff. C  at the all i values for  the current value for
        ! j, optionally making use of the coeff. C at previous value for j:
        ! - If it is the very first value (0,m), then it is just equal to 1
        ! - If  it is  the first value  in the current  i-summation, then  it is
        ! calculated from the first coeff. of the previous i-summation:
        !   C(j,m) = C(j-1,m) * (m-j+1)/j
        ! - If it is not the first  value in the current i-summation, then it is
        ! calculated from the previous value of the current i-summation
        !   C(j,i) = C(j,i+1) * (i+1)/(m-i-j)
        ! - If  it is  the last  value in  the current  i-summation, then  it is
        ! divided by 2 if (m-j) is even (see [ADD REF])
        !> \private
        subroutine calc_C(m,j,C)
            ! input / output
            integer, intent(in) :: m, j
            real(dp), intent(inout), allocatable :: C(:)

            ! local variables
            integer :: i                                                        ! counter
            real(dp) :: Cm_prev

            ! if j>0, save the value Cm_prev
            if (j.gt.0) Cm_prev = C(m-j+1)

            ! allocate C
            if (allocated(C)) deallocate (C)
            allocate(C(0:m-j))

            ! first value i = m-j
            if (j.eq.0) then                                                    ! first coeff., for j = 0
                C(m) = 1.0_dp
            else                                                                ! first coeff., for j > 0 -> need value Cm_prev from previous array
                C(m-j) = (m-j+1.0_dp)/j * Cm_prev
            end if

            ! all other values i = m-1 .. 0
            do i = m-j-1,0,-1
                C(i) = (i+1.0_dp)/(m-i-j) * C(i+1)
            end do
        end subroutine
    end function calc_g

    !> \private 3-D scalar version with one derivative
    integer recursive function transf_deriv_3_ind(X_A,T_BA,X_B,max_deriv,&
        &deriv_B,deriv_A_input) result(ierr)
        use num_utilities, only: add_arr_mult, c

        character(*), parameter :: rout_name = 'transf_deriv_3_ind'

        ! input / output
        real(dp), intent(in) :: X_A(1:,1:,1:,0:,0:,0:)                          !< variable and derivs. in coord. system A
        real(dp), intent(in) :: T_BA(1:,1:,1:,1:,0:,0:,0:)                      !< transf. mat. and derivs. between coord. systems A and B
        real(dp), intent(inout) :: X_B(1:,1:,1:)                                !< requested derivs. of variable in coord. system B
        integer, intent(in) :: max_deriv                                        !< maximum degrees of derivs.
        integer, intent(in) :: deriv_B(:)                                       !< derivs. in coord. system B
        integer, intent(in), optional :: deriv_A_input(:)                       !< derivs. in coord. system A (optional)

        ! local variables
        integer :: id, jd, kd, ld                                               ! counters
        integer :: deriv_id_B                                                   ! holds the deriv. currently calculated
        integer, allocatable :: deriv_A(:)                                      ! holds either deriv_A or 0
        real(dp), allocatable :: X_B_x(:,:,:,:,:,:)                             ! X_B and derivs. D^p-q_A with extra 1 exchanged deriv. D_A
        integer, allocatable :: deriv_A_x(:)                                    ! holds A derivs. for exchanged X_B_x
        integer, allocatable :: deriv_B_x(:)                                    ! holds B derivs. for exchanged X_B_x

        ! initialize ierr
        ierr = 0

        ! setup deriv_A
        allocate(deriv_A(size(deriv_B)))
        if (present(deriv_A_input)) then
            deriv_A = deriv_A_input
        else
            deriv_A = 0
        end if

#if ldebug
        ! check the derivatives requested
        ! (every B deriv. needs all the A derivs. -> sum(deriv_B) needed)
        ierr = check_deriv(deriv_A + sum(deriv_B),max_deriv,'transf_deriv')
        CHCKERR('')
#endif

        ! detect first deriv. in the B coord. system that needs to be exchanged,
        ! with derivs in the A coord. system going from B coord. 1 to B coord. 2
        ! to B coord. 3
        ! if equal to  zero on termination, this means that  no more exchange is
        ! necessary
        deriv_id_B = 0
        do id = 1,3
            if (deriv_B(id).gt.0) then
                deriv_id_B = id
                exit
            end if
        end do

        ! calculate the  derivative in coord.  deriv_id_B of coord. system  B of
        ! one order lower than requested here
        ! check if we have reached the zeroth derivative in coord. B
        if (deriv_id_B.eq.0) then                                               ! return the function with its required A derivs.
            X_B = X_A(:,:,:,deriv_A(1),deriv_A(2),deriv_A(3))
        else                                                                    ! apply the formula to obtain X_B using exchanged derivs.
            ! allocate  the  exchanged  X_B_x  and  the  derivs.  in  A  and  B,
            ! corresponding to D^m-1_B X
            allocate(X_B_x(size(X_B,1),size(X_B,2),size(X_B,3),&
                &0:deriv_A(1),0:deriv_A(2),0:deriv_A(3)))
            allocate(deriv_A_x(size(deriv_A)))
            allocate(deriv_B_x(size(deriv_B)))

            ! initialize X_B
            X_B = 0.0_dp

            ! loop over the 3 terms in the sum due to the transf. mat.
            do id = 1,3
                ! calculate X_B_x for orders 0 up to deriv_A
                do jd = 0,deriv_A(1)
                    do kd = 0,deriv_A(2)
                        do ld = 0,deriv_A(3)
                            ! calculate the  derivs. in  A for X_B_x:  for every
                            ! component in the sum due  to the transf. mat., the
                            ! deriv. is one order  higher than [jd,kd,ld] at the
                            ! corresponding coord. id
                            deriv_A_x = [jd,kd,ld]
                            deriv_A_x(id) = deriv_A_x(id) + 1

                            ! calculate the derivs. in B  for X_B_x: this is one
                            ! order lower in the coordinate deriv_id_B
                            deriv_B_x = deriv_B
                            deriv_B_x(deriv_id_B) = deriv_B_x(deriv_id_B) - 1

                            ! recursively call the subroutine again to calculate
                            ! X_B_x for the current derivatives
                            ierr = transf_deriv_3_ind(X_A,T_BA,&
                                &X_B_x(:,:,:,jd,kd,ld),max_deriv,deriv_B_x,&
                                &deriv_A_x)
                            CHCKERR('')
                        end do
                    end do
                end do

                ! use X_B_x at this term in summation due to the transf. mat. to
                ! update X_B using the formula
                ierr = add_arr_mult(&
                    &T_BA(:,:,:,c([deriv_id_B,id],.false.),0:,0:,0:),&
                    &X_B_x(:,:,:,0:,0:,0:),X_B,deriv_A)
                CHCKERR('')
            end do
        end if
    end function transf_deriv_3_ind
    !> \private 3-D scalar version with multiple derivatives
    integer function transf_deriv_3_arr(X_A,T_BA,X_B,max_deriv,derivs) &
        &result(ierr)
        character(*), parameter :: rout_name = 'transf_deriv_3_arr'

        ! input / output
        real(dp), intent(in) :: X_A(1:,1:,1:,0:,0:,0:)                          !< variable and derivs. in coord. system A
        real(dp), intent(in) :: T_BA(1:,1:,1:,1:,0:,0:,0:)                      !< transf. mat. and derivs. between coord. systems A and B
        real(dp), intent(inout) :: X_B(1:,1:,1:,0:,0:,0:)                       !< requested derivs. of variable in coord. system B
        integer, intent(in) :: max_deriv                                        !< maximum degrees of derivs.
        integer, intent(in) :: derivs(:,:)                                      !< series of derivs. (in coordinate system B)

        ! local variables
        integer :: id                                                           ! counter

        ! initialize ierr
        ierr = 0

        do id = 1, size(derivs,2)
            ierr = transf_deriv_3_ind(X_A,T_BA,&
                &X_B(:,:,:,derivs(1,id),derivs(2,id),derivs(3,id)),&
                &max_deriv,derivs(:,id))
            CHCKERR('')
        end do
    end function transf_deriv_3_arr
    !> \private 3-D matrix version  with multiple derivatives
    integer function transf_deriv_3_arr_2D(X_A,T_BA,X_B,max_deriv,derivs) &
        &result(ierr)
        use num_utilities, only: is_sym, c

        character(*), parameter :: rout_name = 'transf_deriv_3_arr_2D'

        ! input / output
        real(dp), intent(in) :: X_A(1:,1:,1:,1:,0:,0:,0:)                       !< variable and derivs. in coord. system A
        real(dp), intent(in) :: T_BA(1:,1:,1:,1:,0:,0:,0:)                      !< transf. mat. and derivs. between coord. systems A and B
        real(dp), intent(inout) :: X_B(1:,1:,1:,1:,0:,0:,0:)                    !< requested derivs. of variable in coord. system B
        integer, intent(in) :: max_deriv                                        !< maximum degrees of derivs.
        integer, intent(in) :: derivs(:,:)                                      !< series of derivs. (in coordinate system B)

        ! local variables
        integer :: id, kd                                                       ! counters
        character(len=max_str_ln) :: err_msg                                    ! error message
        logical :: sym                                                          ! sym

        ! initialize ierr
        ierr = 0

        ! test whether the dimensions of X_A and X_B agree
        if (size(X_A,4).ne.size(X_B,4)) then
            err_msg = 'X_A and X_B need to have the same sizes'
            ierr = 1
            CHCKERR(err_msg)
        end if

        ierr = is_sym(3,size(X_A,4),sym)
        CHCKERR('')

        do kd = 1,size(X_A,4)
            do id = 1, size(derivs,2)
                ierr = transf_deriv_3_ind(X_A(:,:,:,kd,:,:,:),T_BA,&
                    &X_B(:,:,:,kd,derivs(1,id),derivs(2,id),derivs(3,id)),&
                    &max_deriv,derivs(:,id))
                CHCKERR('')
            end do
        end do
    end function transf_deriv_3_arr_2D
    !> \private 1-D scalar version with one derivative
    integer recursive function transf_deriv_1_ind(X_A,T_BA,X_B,max_deriv,&
        &deriv_B,deriv_A_input) result(ierr)
        use num_utilities, only: add_arr_mult

        character(*), parameter :: rout_name = 'transf_deriv_1_ind'

        ! input / output
        real(dp), intent(in) :: X_A(1:,0:)                                      !< variable and derivs. in coord. system A
        real(dp), intent(inout) :: X_B(1:)                                      !< requested derivs. of variable in coord. system B
        real(dp), intent(in) :: T_BA(1:,0:)                                     !< transf. mat. and derivs. between coord. systems A and B
        integer, intent(in), optional :: deriv_A_input                          !< derivs. in coord. system A (optional)
        integer, intent(in) :: deriv_B                                          !< derivs. in coord. system B
        integer, intent(in) :: max_deriv                                        !< maximum degrees of derivs.

        ! local variables
        integer :: jd                                                           ! counters
        integer :: deriv_A                                                      ! holds either deriv_A or 0
        real(dp), allocatable :: X_B_x(:,:)                                     ! X_B and derivs. D^p-q_A with extra 1 exchanged deriv. D_A
        integer :: deriv_A_x                                                    ! holds A derivs. for exchanged X_B_x
        integer :: deriv_B_x                                                    ! holds B derivs. for exchanged X_B_x

        ! initialize ierr
        ierr = 0

        ! setup deriv_A
        if (present(deriv_A_input)) then
            deriv_A = deriv_A_input
        else
            deriv_A = 0
        end if

#if ldebug
        ! check the derivatives requested
        ! (every B deriv. needs all the A derivs. -> sum(deriv_B) needed)
        ierr = check_deriv([deriv_A+deriv_B,0,0],max_deriv,'transf_deriv')
        CHCKERR('')
#endif

        ! calculate the  derivative in coord.  deriv_id_B of coord. system  B of
        ! one order lower than requested here
        ! check if we have reached the zeroth derivative in coord. B
        if (deriv_B.eq.0) then                                                  ! return the function with its required A derivs.
            X_B = X_A(:,deriv_A)
        else                                                                    ! apply the formula to obtain X_B using exchanged derivs.
            ! allocate  the  exchanged  X_B_x  and  the  derivs.  in  A  and  B,
            ! corresponding to D^m-1_B X
            allocate(X_B_x(size(X_B,1),0:deriv_A))

            ! initialize X_B
            X_B = 0.0_dp

            ! calculate X_B_x for orders 0 up to deriv_A
            do jd = 0,deriv_A
                ! calculate the derivs.  in A for X_B_x: for  every component in
                ! the  sum due  to the  transf. mat.,  the deriv.  is one  order
                ! higher than jd
                deriv_A_x = jd+1

                ! calculate the derivs. in B for X_B_x: this is one order lower
                deriv_B_x = deriv_B-1

                ! recursively call  the subroutine again to  calculate X_B_x for
                ! the current derivatives
                ierr = transf_deriv_1_ind(X_A,T_BA,X_B_x(:,jd),max_deriv,&
                    &deriv_B_x,deriv_A_input=deriv_A_x)
                CHCKERR('')
            end do

            ! use X_B_x to calculate X_B using the formula
            ierr = add_arr_mult(T_BA(:,0:),X_B_x(:,0:),X_B,[deriv_A,0,0])
            CHCKERR('')
        end if
    end function transf_deriv_1_ind

    !> \private flux version
    integer function calc_F_derivs_1(grid_eq,eq) result(ierr)
        use num_vars, only: eq_style, max_deriv, use_pol_flux_F
        use num_utilities, only: derivs, c, fac
        use eq_vars, only: max_flux_E

        character(*), parameter :: rout_name = 'calc_F_derivs_1'

        ! input / output
        type(grid_type), intent(in) :: grid_eq                                  !< equilibrium grid
        type(eq_1_type), intent(inout) :: eq                                    !< flux equilibrium variables

        ! local variables
        integer :: id
        real(dp), allocatable :: T_FE_loc(:,:)                                  ! T_FE(2,1)

        ! initialize ierr
        ierr = 0

        ! Transform depending on equilibrium style being used:
        !   1:  VMEC
        !   2:  HELENA
        select case (eq_style)
            case (1)                                                            ! VMEC
                ! user output
                call writo('Transform flux equilibrium quantities to flux &
                    &coordinates')

                call lvl_ud(1)

                ! set up local T_FE
                allocate(T_FE_loc(grid_eq%loc_n_r,0:max_deriv+1))
                if (use_pol_flux_F) then
                    do id = 0,max_deriv+1
                        T_FE_loc(:,id) = 2*pi/max_flux_E*eq%q_saf_E(:,id)
                    end do
                else
                    T_FE_loc(:,0) = -2*pi/max_flux_E
                    T_FE_loc(:,1:max_deriv+1) = 0._dp
                end if

                ! Transform the  derivatives in E coordinates  to derivatives in
                ! the F coordinates.
                do id = 0,max_deriv+1
                    ! pres_FD
                    ierr = transf_deriv(eq%pres_E,T_FE_loc,eq%pres_FD(:,id),&
                        &max_deriv+1,id)
                    CHCKERR('')

                    ! flux_p_FD
                    ierr = transf_deriv(eq%flux_p_E,T_FE_loc,&
                        &eq%flux_p_FD(:,id),max_deriv+1,id)
                    CHCKERR('')

                    ! flux_t_FD
                    ierr = transf_deriv(eq%flux_t_E,T_FE_loc,&
                        &eq%flux_t_FD(:,id),max_deriv+1,id)
                    CHCKERR('')
                    eq%flux_t_FD(:,id) = -eq%flux_t_FD(:,id)                    ! multiply by plus minus one

                    ! q_saf_FD
                    ierr = transf_deriv(eq%q_saf_E,T_FE_loc,eq%q_saf_FD(:,id),&
                        &max_deriv+1,id)
                    CHCKERR('')
                    eq%q_saf_FD(:,id) = -eq%q_saf_FD(:,id)                      ! multiply by plus minus one

                    ! rot_t_FD
                    ierr = transf_deriv(eq%rot_t_E,T_FE_loc,eq%rot_t_FD(:,id),&
                        &max_deriv+1,id)
                    CHCKERR('')
                    eq%rot_t_FD(:,id) = -eq%rot_t_FD(:,id)                      ! multiply by plus minus one
                end do

                call lvl_ud(-1)
            case (2)                                                            ! HELENA
                ! E derivatives are equal to F derivatives
                eq%flux_p_FD = eq%flux_p_E
                eq%flux_t_FD = eq%flux_t_E
                eq%pres_FD = eq%pres_E
                eq%q_saf_FD = eq%q_saf_E
                eq%rot_t_FD = eq%rot_t_E
        end select
    end function calc_F_derivs_1
    !> \private metric version
    integer function calc_F_derivs_2(eq) result(ierr)
        use num_vars, only: eq_style
        use num_utilities, only: derivs, c

        character(*), parameter :: rout_name = 'calc_F_derivs_2'

        ! input / output
        type(eq_2_type), intent(inout) :: eq                                    !< metric equilibrium variables

        ! local variables
        integer :: id
        integer :: pmone                                                        ! plus or minus one

        ! initialize ierr
        ierr = 0

        ! Set up pmone, depending on equilibrium style being used
        !   1:  VMEC
        !   2:  HELENA
        select case (eq_style)
            case (1)                                                            ! VMEC
                pmone = -1                                                      ! conversion VMEC LH -> RH coord. system
            case (2)                                                            ! HELENA
                pmone = 1
        end select

        ! user output
        call writo('Transform metric equilibrium quantities to flux &
            &coordinates')

        call lvl_ud(1)

        ! Transform the  derivatives in E coordinates  to derivatives in
        ! the F coordinates.
        do id = 0,max_deriv
            ! g_FD
            ierr = transf_deriv(eq%g_F,eq%T_FE,eq%g_FD,max_deriv,derivs(id))
            CHCKERR('')

            ! h_FD
            ierr = transf_deriv(eq%h_F,eq%T_FE,eq%h_FD,max_deriv,derivs(id))
            CHCKERR('')

            ! jac_FD
            ierr = transf_deriv(eq%jac_F,eq%T_FE,eq%jac_FD,max_deriv,&
                &derivs(id))
            CHCKERR('')
        end do

        call lvl_ud(-1)
    end function calc_F_derivs_2

    !> Calculate memory in MB necessary for variables in equilibrium job.
    !!
    !! The size of  these variables is equal to the  product of the non-parallel
    !! dimensions (e.g. \c n_geo x \c loc_n_r), times the number of variables.
    !!
    !! The latter should be:
    !!  -  PB3D:  only take  into  account  (\f$2\cdot6+1 =  13\f$)  equilibrium
    !!  variables \c g_FD, \c h_FD and  \c jac_FD, as the perturbation variables
    !!  are  divided in  jobs occupying  the remaning  space. These  equilibrium
    !!  variables are tabulated on the  equilibrium grid. Note that they contain
    !!  derivatives in extra dimensions, so that their size should be multiplied
    !!  by (\c max_deriv+1)^3.
    !!  - POST: take  into account these 13 equilibrium variables,  as well as 4
    !!  variables \c U and \c DU, with double size due to being complex, and the
    !!  additional dimension equal to \c n_mod_X, but without derivatives.
    !!
    !! \return ierr
    integer function calc_memory_eq(arr_size,n_par,mem_size) result(ierr)
        use ISO_C_BINDING

        character(*), parameter :: rout_name = 'calc_memory_eq'

        ! input / output
        integer, intent(in) :: arr_size                                         !< size of part of X array
        integer, intent(in) :: n_par                                            !< number of parallel points
        real(dp), intent(inout) :: mem_size                                     !< total size

        ! local variables
        integer(C_SIZE_T) :: dp_size                                            ! size of dp

        ! initialize ierr
        ierr = 0

        call lvl_ud(1)

        ! get size of real variable
        dp_size = sizeof(1._dp)

        ! set memory size for metric equilibrium variables
        mem_size = 13._dp*arr_size
        mem_size = mem_size*n_par*(1+max_deriv)**3
        mem_size = mem_size*dp_size

        ! convert B to MB
        mem_size = mem_size*1.E-6_dp

        ! apply 50% safety factor (empirical)
        mem_size = mem_size*1.5_dp

        ! test overflow
        if (mem_size.lt.0) then
            ierr = 1
            CHCKERR('Overflow occured')
        end if

        call lvl_ud(-1)
    end function calc_memory_eq

    !> If this equilibrium job should be done, also increment \c eq_job_nr.
    logical function do_eq()
        use num_vars, only: eq_jobs_lims, eq_job_nr, rich_restart_lvl, &
            &jump_to_sol
        use rich_vars, only: rich_lvl

        ! increment equilibrium job nr.
        eq_job_nr = eq_job_nr + 1

        if (rich_lvl.eq.rich_restart_lvl .and. jump_to_sol) then                ! jumping to solution for restart level
            if (eq_job_nr.eq.1) then
                do_eq = .true.
            else
                do_eq = .false.
            end if
        else
            if (eq_job_nr.le.size(eq_jobs_lims,2)) then                         ! normal behavior, not yet at last equilibrium job
                do_eq = .true.
            else                                                                ! normal behavior, at last equilibrium job
                do_eq = .false.
            end if
        end if
    end function do_eq

    !> Returns string  with possible extension  with equilibrium job as  well as
    !! parallel job, or nothing if only one level and one parallel job.
    elemental character(len=max_str_ln) function eq_info()
        use num_vars, only: eq_jobs_lims, eq_job_nr

        if (size(eq_jobs_lims,2).gt.1) then
            eq_info = ' for Equilibrium job '//trim(i2str(eq_job_nr))//&
                &' of '//trim(i2str(size(eq_jobs_lims,2)))
        else
            eq_info = ''
        end if
    end function eq_info

    !> Prints information for equilibrium parallel job.
    subroutine print_info_eq(n_par_X_rich)
        use num_vars, only: eq_job_nr, eq_jobs_lims

        ! input / output
        integer, intent(in) :: n_par_X_rich                                     !< number of parallel points in this Richardson level

        ! user output
        if (size(eq_jobs_lims,2).gt.1) then
            call writo('but parallel limits for this job only ['//&
                &trim(i2str(eq_jobs_lims(1,eq_job_nr)))//'..'//&
                &trim(i2str(eq_jobs_lims(2,eq_job_nr)))//&
                &'] of [1..'//trim(i2str(n_par_X_rich))//']')
        end if
    end subroutine print_info_eq
end module eq_utilities


module zn_prob_module
   use precision_module, only : wp
   use constants_module
   use input_module,     only : maxn

   implicit none
   public

contains
!---------------------------------------------------------------------
subroutine zn_prob_sloped(aa,bb,sigma,delta,probZN)
 implicit none
 integer          :: i, k
 real(wp) :: corr, arg, phi, g1, g2, UIm, URe, p, temp
 real(wp) :: x, part_i, part_r, arggamma, phase
 real(wp), intent(in)  :: aa
 real(wp), dimension(:),intent(in)   :: bb, sigma, delta
 real(wp), dimension(:), intent(out) :: probZN
 integer  :: jerr

do i=1,maxn
  if (bb(i) .lt. zero) then

    g2 = three*sigma(i)*log(1.2d0 + aa)
    g2 = g2/(delta(i)*pi) - one/aa
    g1 = 1.8d0*(aa**0.23d0)*exp(-delta(i))
    temp = bfunc(sigma(i)/pi)

    URe = sqrt(temp)*exp(delta(i)) - g1*sin(sigma(i))**two
    URe = cos(sigma(i))*URe

    UIm = -(g1*sin(sigma(i))*cos(sigma(i)))**two
    UIm = UIm*exp(-two*delta(i))/temp
    UIm = UIm + temp*exp(two*delta(i))
    UIm = UIm + two*g1*(cos(sigma(i))**two) - g2
    UIm = sin(sigma(i))*sqrt(UIm)

    phase = atan(UIm/URe)
    p = one + temp*exp(two*delta(i))
    p = p - g2*(sin(sigma(i))**two)
    p = one/p
    probZN(i) = four*p*(one - p)*(sin(phase)**two)

  else if (bb(i) .ge. zero) then

    corr = five*(aa**0.25d0)*(10.0d0**(-sigma(i)))
    corr = corr/(0.8d0+(aa**0.25d0))
    arg = delta(i)*(one + corr)/pi
    x = zero
    k = 1
    part_r = zero
    part_i = zero
    call cgamma(x,arg,k,part_r,part_i)
    arggamma = atan(part_i/part_r)
    phi = -arg + arg*log(arg) - arggamma - 0.25d0*pi
    corr = one + sqrt(one + (bb(i)**(-two))*(0.4d0*aa + 0.7d0))
    corr = sqrt(two/corr)
    p = exp(-0.25d0*pi*corr/sqrt(bb(i)*aa))
    probZN(i) = four*p*(one - p)
    probZN(i) = probZN(i)*sin(phi + sigma(i))**two

  endif
enddo

end subroutine zn_prob_sloped
!------------------------------------------------------------------------
subroutine zn_prob_peaked(binLower,binUpper,aa,bb,sigma,delta,probZN)
implicit none
integer             :: i, k, n
integer, allocatable :: m(:)
real(wp) :: arg, phi, phibar, h1, h2, h3, h4, p, temp, corr
real(wp) :: sigmac, w, t, temp2
real(wp) :: x, part_i, part_r, arggamma, phase
integer,  intent(in)  :: binLower, binUpper
real(wp), intent(in)  :: aa
real(wp), intent(in)  :: bb(:), sigma(:), delta(:)
real(wp), dimension(:),intent(out) :: probZN
real(wp), allocatable :: grid_small_aa_column(:), integral_matrix(:,:)

probZN = 0.0d0

do i=1,maxn
   if(i.lt.binLower) then

       sigmac=1.0d0-0.32d0*(10.0d0**(-2.0d0/aa))*exp(-delta(i))
       sigmac=sigmac*sigma(i)
       temp=bfunc(sigmac/pi)*exp(-2.0d0*delta(i))
       probZN(i)=1.0d0+(0.5d0*sqrt(aa)/(1.0d0+sqrt(aa)))*temp
       probZN(i)=temp/(probZN(i)**2.0d0+temp)

   elseif (i.ge.binLower .and. i.le.binUpper) then

       h4=0.61d0*sqrt(2.0d0+bb(i))
       h3=(sqrt(aa)-3.0d0*bb(i))*sqrt(1.23d0+bb(i))
       h3=h3/(sqrt(aa)+3.0d0)
       h2=(1.0d0+bb(i))**(1.2d0-0.4d0*bb(i))
       h2=1.0d0+0.38d0*h2/aa
       call omega_solver(aa,bb(i),h2,h3,h4,probZN(i))

   elseif (i.gt.binUpper) then

       arg=delta(i)/pi
       x=0.0d0
       k=1
       part_r = 0.0d0
       part_i = 0.0d0
       call cgamma(x,arg,k,part_r,part_i)
       arggamma=atan(part_i/part_r)
       phi=-arg+arg*log(arg)-arggamma-0.25d0*pi
       h1=0.23d0*(aa**0.25d0)*(40.0d0**(-sigma(i)))
       h1=h1/(aa**0.25d0+0.75d0)
       phibar=phi+h1
       p=bb(i)**(-2.0d0)*(0.72d0-0.62d0*(aa**(1.43d0/2.0d0)))
       p=1.0d0+sqrt(1.0d0-p)
       p=sqrt(2.0d0/p)
       p=exp(-0.25d0*pi*p/sqrt(bb(i)*aa))
       probZN(i)=4.0d0*(cos(sigma(i)-phibar)**2.0d0)
       probZN(i)=probZN(i)/(probZN(i)+p*p/(1.0d0-p))

   endif
 enddo

if ( sqrt(aa) .lt. one ) then
 allocate ( m((binUpper-1) - (binLower+1)) )
 allocate ( grid_small_aa_column(101), integral_matrix(100,101) )
 open( 12, file="omega_grid_small_aa" )
 read( 12,*) integral_matrix
 close(12)
 n=int( sqrt(aa)/0.01 )
 m=int( 50*bb(binLower+1:binUpper-1) + 1)
 grid_small_aa_column = integral_matrix(n,:)
 deallocate (integral_matrix)

 do i = binLower+1, binUpper-1
  corr = 0.0d0
  corr = (h2/(aa**(1.0d0/3.0d0)))*grid_small_aa_column(m(i))
  corr = (corr**2)/((corr**2)+1)
  probZN(i) = probZN(i) + corr
 end do

end if

end subroutine zn_prob_peaked
!-------------------------------------------------------------------
subroutine omega_solver(aa,bb,h2,h3,h4,prob)
! ********
! *
! Below is the heuristic algorithm how to solve a highly
! oscillatory integral using the QUADPACK integration library of Fortran.
! Wolfram Mathematica solution of this integral has been used as a reference
! to estimate an error of the below Fortran alogirthm. The error has been
! estimated to be of the order of 10-4.
! *
! The original integral is W = (pre-factor)*INT(0,oo,t,aa,bb)dt
! What we do is divide W in two integrals, I1 + I2: INT(0,1) + INT(1,oo)
! Then, we transform I2: INT(1,oo) -> INT(0,1) by changing the integration variable.
! Function f01 implements I2 integrand, while f02 - I1.
! *
! ********
implicit none
real(wp), intent(in) :: aa,bb,h2,h3,h4
real(wp), intent(out) :: prob
real ( kind = 4 ), parameter :: a1 = 0.02e+00
real ( kind = 4 ), parameter :: b1 = 0.1e+00
real ( kind = 4 ) abserr, resabs, resasc
integer ( kind = 4 ) ier
integer ( kind = 4 ) neval
real ( kind = 4 ) result, res, tmp
!real ( kind = 4 ), external :: f01, f02
real ( kind = 4 ) dq, q1, q2, dd, n1, n2
integer :: i, j
integer, parameter :: nq = 1000000, nn = 8

res = 0.0e+00
dd = (b1-a1)/nn
! *
! Get I2 ( 0.02 , 0.1 )
! *
do j = 0, nn-1

  n1 = a1 + dble(j)*dd
  n2 = a1 + dble(j+1)*dd
  dq = (n2 - n1)/nq
  tmp = 0.0e+00
  result = 0.0e+00

  do i=0, nq-1
     q1 = n1 + dble(i)*dq
     q2 = n1 + dble(i+1)*dq
     call qk61 (f01, q1, q2, result, abserr, resabs, resasc)
     tmp = tmp + result
  end do

  res = res + tmp
end do
! *
! Get I2 ( 0.1 , 0.2 )
! *
dd = 0.0e+00
tmp = 0.0e+00
result = 0.0e+00

dd = (0.2e+00 - 0.1e+00)/100000
n1 = 0.0e+00
n2 = 0.0e+00

do i = 0, 99999
  n1 = 0.1e+00 + dble(i)*dd
  n2 = 0.1e+00 + dble(i+1)*dd
  call qk61 (f01, n1, n2, result, abserr, resabs, resasc)
  tmp = tmp + result
end do

res = res + tmp
result = 0.0e+00
tmp = 0.0e+00
! *
! Get I2 ( 0.2 , 0.6 ) and I2 ( 0.6 , 1.0 )
! *
call qk61 (f01, 0.2e+00, 0.6e+00, result, abserr, resabs, resasc)
res = res + result
result=0.0e+00
call qk61 (f01, 0.6e+00, 1.0e+00, result, abserr, resabs, resasc)
res = res + result
result = 0.0e+00
! *
! Divide I1 ( 0.0, 1.0 ) in two parts to reduce the error
! *
call qk61 (f02, 0.0e+00, 0.5e+00, result, abserr, resabs, resasc)
tmp = result
result = 0.0e+00
call qk61 (f02, 0.5e+00, 1.0e+00, result, abserr, resabs, resasc)
tmp = tmp + result
res = res + tmp
result = 0.0e+00
tmp = 0.0e+00

prob = (h2/(aa**(1.0d0/3.0d0)))*res
prob = (prob**2)/((prob**2)+1)
contains
!-------------------------------------------------------------------
real ( kind = 4 ) function f01(x)
implicit none
real ( kind = 4 ) x

f01 = cos(0.333333/(x**3) - (bb/(aa**(1.0d0/3.0d0)))/x - &
         (h3/(aa**(1.0d0/3.0d0)))/(h4*x+(sqrt(aa)**(1.0d0/3.0d0))))/(x**2)

end function
!-------------------------------------------------------------------
real ( kind = 4 ) function f02(x)
implicit none
real ( kind = 4 ) x

f02 = cos(0.333333*(x**3) - (bb/(aa**(1.0d0/3.0d0)))*x - &
          (h3/(aa**(1.0d0/3.0d0)))*x/(h4+(sqrt(aa)**(1.0d0/3.0d0))*x))

end function
!-------------------------------------------------------------------
end subroutine omega_solver
!-------------------------------------------------------------------
function bfunc(x)
   implicit none
   real(wp) :: bfunc,x,g,temp

   call vdtgamma(1,x,g) !MKL Gamma function for real values only
   temp=2.d0*pi*x**(2.0d0*x)*exp(-2.0d0*x)
   bfunc=temp/(x*g**2.0d0)
end function
!---------------------------------------------------------------------
end module zn_prob_module


subroutine miev0_simple(xx, indreal, indimg, &
                        Qabs, Qsca, g)

  implicit none
  !
  real, intent(in) :: xx, indreal, indimg
  real, intent(out) :: Qabs, Qsca, g
  !
  integer, parameter :: maxang=11, momdim=1
  complex crefin
  real mimcut
  integer nmom, IPOLZN, numang
  real :: xmu(maxang)
  logical perfect, anyang, PRT(2)
  !
  real Qext, GQsc
  complex :: S1(maxang), S2(maxang)
  complex sforw, sback
  complex :: tforw(2), tback(2)
  real spike
  real :: pmom(0:momdim, 4)
  !
  integer i
  real dmu, Qback
  !
  external miev0, adt_sphere, bhmie
  !
  crefin = cmplx(indreal, indimg)
  !
  perfect = .false.
  anyang = .true.
  PRT = .false.
  mimcut = 1e-8
  nmom = momdim
  IPOLZN = 0
  numang = maxang
  !
  dmu = 2e0 / real(numang-1)
  xmu(1) = 1e0
  do i=2, numang
    xmu(i) = xmu(i-1) - dmu
  end do
  xmu(numang) = -1e0
  if (mod(numang, 2) .eq. 1) then
    xmu(numang/2+1) = 0e0
  end if
  !
  if (xx .gt. 1e4) then
    call adt_sphere(xx, crefin, Qext, Qabs, Qsca, g)
  else if (((real(crefin) .lt. 0e0) .and. (.not. perfect)) .or. &
           (real(crefin) .gt. 2e2) .or. &
           (abs(aimag(crefin)) .gt. 2e2)) then
    Qext = -1.0
    Qabs = -1.0
    Qsca = -1.0
    GQsc = -1.0
    g    = sqrt(Qext-1.0)
  else
    call miev0(xx, crefin, perfect, mimcut, anyang, numang, xmu, &
               nmom, IPOLZN, momdim, PRT, &
               Qext, Qsca, GQsc, pmom, &
               sforw, sback, S1, S2, tforw, tback, spike)
    Qabs = Qext - Qsca
    g = GQsc / (Qsca + 1e-30)
  end if
  !
  if ((Qabs .le. 0.0) .and. (xx .le. 1e5)) then
    call bhmie(xx, crefin, 2, S1, S2, Qext, Qsca, Qback, g)
    Qabs = Qext - Qsca
  end if
  !
  Qabs = max(Qabs, 0.0)
  Qsca = max(Qsca, 0.0)
end subroutine miev0_simple

subroutine adt_sphere(xx, crefin, Qext, Qabs, Qsca, g)
  implicit none
  real, intent(in) :: xx
  complex, intent(in) :: crefin
  real, intent(out) :: Qext, Qabs, Qsca, g
  complex rho
  real rho1, rho2, beta, rr
  !
  rho = 2.0 * xx * (crefin - 1.0)
  rr = abs(rho)
  rho1 = real(rho)
  rho2 = aimag(rho)
  !
  if (rr .le. 1e-3) then
    Qext = 2.0
    Qabs = 4.0/3.0 * rho2
    Qsca = Qext - Qabs
    g = 1.0
  else
    !
    beta = atan2(rho2, rho1)
    !
    Qext = 2.0 + 4.0/(rr*rr) * &
      (cos(2.0*beta) - &
       exp(-rho2) * &
       (cos(rho1-2.0*beta) - rr*sin(rho1-beta)))
    Qabs = 1.0 + (exp(-2.0*rho2)*(2.0*rho2+1.0) - 1.0) / (2.0*rho2*rho2)
    Qsca = Qext - Qabs
    g = 1.0
  end if
end subroutine adt_sphere


    subroutine calculate_boop(n_atoms, atom_coords, pbc, bds, &
        n_neighbor_limit, n_neighbor_list, neighbor_lists, &
        low_order, higher_order, coarse_lower_order, coarse_higher_order, &
        Ql, Wlbar, coarse_Ql, coarse_Wlbar)

        use :: angle
!        use :: CG_function

        integer :: n_atoms, n_neighbor_limit
        integer, dimension(n_atoms):: n_neighbor_list
        REAL(8), dimension(n_atoms, 3):: atom_coords
        integer, dimension(3) :: pbc
        REAL(8), dimension(3, 2) :: bds
        integer, dimension(n_atoms, n_neighbor_limit):: neighbor_lists
        integer :: low_order, higher_order, coarse_lower_order, coarse_higher_order
        REAL(8), dimension(n_atoms, 4):: Ql, Wlbar, coarse_Ql, coarse_Wlbar
        REAL(16), dimension(n_atoms, 4):: Ql2, Wlbar2, coarse_Ql2, coarse_Wlbar2

!f2py   intent(in) n_atoms, atom_coords, pbc, bds
!f2py   intent(in) n_neighbor_limit, n_neighbor_list, neighbor_lists
!f2py   intent(in) low_order, higher_order, coarse_lower_order, coarse_higher_order
!f2py   intent(in, out) Ql, Wlbar, coarse_Ql, coarse_Wlbar

        integer :: atom, i, j, l, m, m1, m2, m3, neighs
        REAL(8) :: ksai, theta
        COMPLEX(16) ::  qtemp, comp
        COMPLEX(16), allocatable:: Q2(:,:,:), Wl(:,:)
        COMPLEX(16), allocatable:: QQ2(:,:,:), WWl(:,:)
        INTEGER err_mesg

        REAL(16), dimension(2:5, -10:10, -10:10, -10:10) :: CG

        integer :: v, s
        REAL(16) :: v0, v1, v2
        REAL(16), dimension(0:100) :: fac

      !!!!!!!!!!!!!!!!!!! calculate Ql !!!!!!!!!!!!!!!!!!!!!
        allocate(Q2(n_atoms, 2:5, -10:10), stat = err_mesg)
        Q2 = 0

        comp=(0.,1.)

        do atom = 1, n_atoms
          do i = 1, n_neighbor_list(atom)
            j = neighbor_lists(atom, i)
            call angle_info(atom_coords(atom, :), atom_coords(j, :), bds, pbc, ksai, theta)
            do l = 4, 10, 2
              do m = -l, l
                  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!Q4!!!!!!!!!!!!!!!!!!!!!!!!!!!
                  if((l == 4).and.(m == (-4))) then
                    qtemp = 3.0/16.0 * sqrt(35.0/(2.0*3.1415926)) * exp(-4*comp*ksai) * &
                            (sin(theta))**4

                  else if((l == 4).and.(m == (-3))) then
                    qtemp = 3.0/8.0 * sqrt(35.0/(3.1415926)) * exp(-3*comp*ksai) * &
                            (sin(theta))**3 * cos(theta)

                  else if((l == 4).and.(m == (-2))) then
                    qtemp = 3.0/8.0 * sqrt(5.0/(2.0*3.1415926)) * exp(-2*comp*ksai) * &
                            (sin(theta))**2 * (7.0*(cos(theta))**2 - 1.0)

                  else if((l == 4).and.(m == (-1))) then
                    qtemp = 3.0/8.0 * sqrt(5.0/(3.1415926))* exp(-1*comp*ksai) * &
                            (sin(theta)) * (7.0*(cos(theta))**3-3.0*cos(theta))

                  else if((l == 4).and.(m == (0))) then
                    qtemp = 3.0/16.0 * sqrt(1.0/(3.1415926))* &
                            (35.0*(cos(theta))**4 - 30.0*(cos(theta))**2+3)

                  else if((l == 4).and.(m == 1)) then
                    qtemp = -3.0/8.0 * sqrt(5.0/(3.1415926))* exp(1*comp*ksai) * &
                            (sin(theta)) * (7.0*(cos(theta))**3-3.0*cos(theta))

                  else if((l == 4).and.(m == 2)) then
                    qtemp = 3.0/8.0 * sqrt(5.0/(2.0*3.1415926)) * exp(2*comp*ksai)* &
                            (sin(theta))**2* (7.0*(cos(theta))**2-1.0)

                  else if((l == 4).and.(m == 3)) then
                    qtemp = -3.0/8.0 * sqrt(35.0/(3.1415926)) * exp(3*comp*ksai)* &
                            (sin(theta))**3*cos(theta)

                  else if((l == 4).and.(m == 4)) then
                    qtemp = 3.0/16.0 * sqrt(35.0/(2.0*3.1415926)) * exp(4*comp*ksai)* &
                            (sin(theta))**4

                  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!Q6!!!!!!!!!!!!!!!!!!!!!!!!!!!

                  else if((l == 6).and.(m == (-6))) then
                    qtemp = 1.0/64.0 * sqrt(3003.0/(3.1415926)) * exp(-6*comp*ksai)* &
                            (sin(theta))**6

                  else if((l == 6).and.(m == (-5))) then
                    qtemp = 3.0/32.0 * sqrt(1001.0/(3.1415926)) * exp(-5*comp*ksai)* &
                            (sin(theta))**5*cos(theta)

                  else if((l == 6).and.(m == (-4))) then
                    qtemp = 3.0/32.0 * sqrt(91.0/(2.0*3.1415926)) * exp(-4*comp*ksai)* &
                            (sin(theta))**4* (11.0*(cos(theta))**2-1)

                  else if((l == 6).and.(m == (-3))) then
                    qtemp = 1.0/32.0 * sqrt(1365.0/(3.1415926)) * exp(-3*comp*ksai)* &
                            (sin(theta))**3* (11.0*(cos(theta))**3-3.0*cos(theta))

                  else if((l == 6).and.(m == (-2))) then
                    qtemp = 1.0/64.0 * sqrt(1365.0/(3.1415926)) * exp(-2*comp*ksai)* &
                            (sin(theta))**2 * (33.0*(cos(theta))**4 - 18.0*(cos(theta))**2 + 1)

                  else if((l == 6).and.(m == (-1))) then
                    qtemp = 1.0/16.0 * sqrt(273.0/(2*3.1415926)) * exp(-1*comp*ksai)* &
                            (sin(theta))* (33.0*(cos(theta))**5 - 30.0*(cos(theta))**3 + &
                            5.0*cos(theta))

                  !! no exp(-1*comp*ksai)?
                  else if((l == 6).and.(m == (0))) then
                    qtemp = 1.0/32.0 * sqrt(13.0/(3.1415926))* (231.0*(cos(theta))**6 - &
                            315.0*(cos(theta))**4 + 105.0*(cos(theta))**2 - 5)

                  else if((l == 6).and.(m == (1))) then
                    qtemp = -1.0/16.0 * sqrt(273.0/(2*3.1415926)) * exp(1*comp*ksai)* &
                            (sin(theta)) * (33.0*(cos(theta))**5-30.0*(cos(theta))**3 + &
                            5.0*cos(theta))

                  else if((l == 6).and.(m == (2))) then
                    qtemp = 1.0/64.0 * sqrt(1365.0/(3.1415926))* exp(2*comp*ksai)* &
                            (sin(theta))**2 * (33.0*(cos(theta))**4 - 18.0*(cos(theta))**2 + 1)

                  else if((l == 6).and.(m == (3))) then
                    qtemp = -1.0/32.0 * sqrt(1365.0/(3.1415926)) * exp(3*comp*ksai)* &
                            (sin(theta))**3 * (11.0*(cos(theta))**3 - 3.0*cos(theta))

                  else if((l == 6).and.(m == (4))) then
                    qtemp = 3.0/32.0 * sqrt(91.0/(2.0*3.1415926)) * exp(4*comp*ksai)* &
                            (sin(theta))**4 * (11.0*(cos(theta))**2-1)

                  else if((l == 6).and.(m == (5))) then
                    qtemp = -3.0/32.0 * sqrt(1001.0/(3.1415926)) * exp(5*comp*ksai)* &
                            (sin(theta))**5 * cos(theta)

                  else if((l == 6).and.(m == (6))) then
                    qtemp = 1.0/64.0 * sqrt(3003.0/(3.1415926)) * exp(6*comp*ksai)* &
                            (sin(theta))**6

                  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!Q8!!!!!!!!!!!!!!!!!!!!!!!!!!!

                  else if((l == 8).and.(m == (-8))) then
                    qtemp = 3.0/256.0 * sqrt(12155.0/(2*3.1415926)) * exp(-8*comp*ksai)* &
                            (sin(theta))**8

                  else if((l == 8).and.(m == (-7))) then
                    qtemp = 3.0/64.0 * sqrt(12155.0/(2*3.1415926)) * exp(-7*comp*ksai)* &
                            (sin(theta))**7 * cos(theta)

                  else if((l == 8).and.(m == (-6))) then
                    qtemp = 1.0/128.0 * sqrt(7293.0/(3.1415926)) * exp(-6.0*comp*ksai)* &
                            (sin(theta))**6 * (15.0*(cos(theta))**2 - 1)

                  else if((l == 8).and.(m == (-5))) then
                    qtemp = 3.0/64.0 * sqrt(17017.0/(2*3.1415926)) * exp(-5.0*comp*ksai)* &
                            (sin(theta))**5 * (5.0*(cos(theta))**3 - 1.0*cos(theta))

                  else if((l == 8).and.(m == (-4))) then
                    qtemp = 3.0/128.0 * sqrt(1309.0/(2*3.1415926)) * exp(-4.0*comp*ksai)* &
                            (sin(theta))**4 * (65.0*(cos(theta))**4 - 26.0*(cos(theta))**2 + 1)

                  else if((l == 8).and.(m == (-3))) then
                    qtemp = 1.0/64.0 * sqrt(19635.0/(2*3.1415926)) * exp(-3.0*comp*ksai)* &
                            (sin(theta))**3 * (39.0*(cos(theta))**5 - 26.0*(cos(theta))**3 + &
                            3.0*cos(theta))

                  else if((l == 8).and.(m == (-2))) then
                    qtemp = 3.0/128.0 * sqrt(595.0/(3.1415926)) * exp(-2.0*comp*ksai)* &
                            (sin(theta))**2 * (143.0*(cos(theta))**6 - 143.0*(cos(theta))**4 + &
                            33.0*(cos(theta))**2 - 1)

                  else if((l == 8).and.(m == (-1))) then
                    qtemp = 3.0/64.0 * sqrt(17.0/(2.0*3.1415926)) * exp(-1.0*comp*ksai)* &
                            (sin(theta))**1 * (715.0*(cos(theta))**7-1001.0*(cos(theta))**5 + &
                            385.0*(cos(theta))**3 - 35.0*cos(theta))

                  else if((l == 8).and.(m == (0))) then
                    qtemp = 1.0/256.0 * sqrt(17.0/(3.1415926)) * (6435.0*(cos(theta))**8 - &
                            12012.0*(cos(theta))**6 + 6930.0*(cos(theta))**4 - &
                            1260.0*(cos(theta))**2 + 35.0)

                  else if((l == 8).and.(m == (1))) then
                    qtemp = -3.0/64.0 * sqrt(17.0/(2.0*3.1415926)) * exp(1.0*comp*ksai)* &
                            (sin(theta))**1 * (715.0*(cos(theta))**7 - 1001.0*(cos(theta))**5 + &
                            385.0*(cos(theta))**3 - 35.0*cos(theta))

                  else if((l == 8).and.(m == (2))) then
                    qtemp = 3.0/128.0 * sqrt(595.0/(3.1415926)) * exp(2.0*comp*ksai)* &
                            (sin(theta))**2 * (143.0*(cos(theta))**6 - 143.0*(cos(theta))**4 + &
                            33.0*(cos(theta))**2-1)

                  else if((l == 8).and.(m == (3))) then
                    qtemp = -1.0/64.0 * sqrt(19635.0/(2.0*3.1415926)) * exp(3.0*comp*ksai)* &
                            (sin(theta))**3 * (39.0*(cos(theta))**5-26.0*(cos(theta))**3 + &
                            3.0*cos(theta))

                  else if((l == 8).and.(m == (4))) then
                    qtemp = 3.0/128.0 * sqrt(1309.0/(2.0*3.1415926)) * exp(4.0*comp*ksai)* &
                            (sin(theta))**4* (65.0*(cos(theta))**4 - 26.0*(cos(theta))**2 + 1)

                  else if((l == 8).and.(m == (5))) then
                    qtemp = -3.0/64.0 * sqrt(17017.0/(2.0*3.1415926)) * exp(5.0*comp*ksai)* &
                            (sin(theta))**5* (5.0*(cos(theta))**3 - 1.0*cos(theta))

                  else if((l == 8).and.(m == (6))) then
                    qtemp = 1.0/128.0 * sqrt(7293.0/(3.1415926)) * exp(6.0*comp*ksai)* &
                            (sin(theta))**6 * (15.0*(cos(theta))**2-1)

                  else if((l == 8).and.(m == (7))) then
                    qtemp = -3.0/64.0 * sqrt(12155.0/(2.0*3.1415926)) * exp(7.0*comp*ksai)* &
                            (sin(theta))**7 * cos(theta)

                  else if((l == 8).and.(m == (8))) then
                    qtemp = 3.0/256.0 * sqrt(12155.0/(2.0*3.1415926)) * exp(8.0*comp*ksai)* &
                            (sin(theta))**8

                  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!Q10!!!!!!!!!!!!!!!!!!!!!!!!!!!

                  else if((l == 10).and.(m == (-10))) then
                    qtemp = 1.0/1024.0 * sqrt(969969.0/(3.1415926)) * exp(-10.0*comp*ksai)* &
                            (sin(theta))**10

                  else if((l == 10).and.(m == (-9))) then
                    qtemp = 1.0/512.0 * sqrt(4849845.0/(3.1415926)) * exp(-9.0*comp*ksai)* &
                            (sin(theta))**9 * cos(theta)

                  else if((l == 10).and.(m == (-8))) then
                    qtemp = 1.0/512.0 * sqrt(255255.0/(2.0*3.1415926)) * exp(-8.0*comp*ksai)* &
                            (sin(theta))**8 * (19.0*(cos(theta))**2-1)

                  else if((l == 10).and.(m == (-7))) then
                    qtemp = 3.0/512.0 * sqrt(85085.0/(3.1415926)) * exp(-7.0*comp*ksai)* &
                            (sin(theta))**7 * (19.0*(cos(theta))**3-3.0*cos(theta))

                  else if((l == 10).and.(m == (-6))) then
                    qtemp = 3.0/1024.0 * sqrt(5005.0/(3.1415926)) * exp(-6.0*comp*ksai)* &
                            (sin(theta))**6 * (323.0*(cos(theta))**4-102.0*(cos(theta))**2 + 3)

                  else if((l == 10).and.(m == (-5))) then
                    qtemp = 3.0/256.0 * sqrt(1001.0/(3.1415926)) * exp(-5.0*comp*ksai)* &
                            (sin(theta))**5 * (323.0*(cos(theta))**5 - 170.0*(cos(theta))**3 + &
                            15.0*cos(theta))

                  else if((l == 10).and.(m == (-4))) then
                    qtemp = 3.0/256.0 * sqrt(5005.0/(2.0*3.1415926)) * exp(-4.0*comp*ksai)* &
                            (sin(theta))**4 * (323.0*(cos(theta))**6 - 255.0*(cos(theta))**4 + &
                            45.0*(cos(theta))**2-1)

                  else if((l == 10).and.(m == (-3))) then
                    qtemp = 3.0/256.0 * sqrt(5005.0/(3.1415926)) * exp(-3.0*comp*ksai)* &
                            (sin(theta))**3 * (323.0*(cos(theta))**7 - 357.0*(cos(theta))**5 + &
                            105.0*(cos(theta))**3-7.0*cos(theta))

                  else if((l == 10).and.(m == (-2))) then
                    qtemp = 3.0/512.0 * sqrt(385.0/(2.0*3.1415926)) * exp(-2.0*comp*ksai)* &
                            (sin(theta))**2 * (4199.0*(cos(theta))**8 - 6188.0*(cos(theta))**6 + &
                            2730.0*(cos(theta))**4 - 364.0*(cos(theta))**2 + 7)

                  else if((l == 10).and.(m == (-1))) then
                    qtemp = 1.0/256.0 * sqrt(1155.0/(2.0*3.1415926)) * exp(-1.0*comp*ksai)* &
                            (sin(theta))**1 * (4199.0*(cos(theta))**9 - 7956.0*(cos(theta))**7 + &
                            4914.0*(cos(theta))**5 - 1092.0*(cos(theta))**3 + 63.0*cos(theta))

                  else if((l == 10).and.(m == (0))) then
                    qtemp = 1.0/512.0 * sqrt(21.0/(3.1415926)) * (46189.0*(cos(theta))**10 - &
                            109395.0*(cos(theta))**8 + 90090.0*(cos(theta))**6 - 30030.0*(cos(theta))**4 + &
                            3465.0*(cos(theta))**2-63)

                  else if((l == 10).and.(m == (1))) then
                    qtemp = -1.0/256.0 * sqrt(1155.0/(2.0*3.1415926)) * exp(1.0*comp*ksai)* &
                            (sin(theta))**1 * (4199.0*(cos(theta))**9 - 7956.0*(cos(theta))**7 + &
                            4914.0*(cos(theta))**5 - 1092.0*(cos(theta))**3 + 63.0*cos(theta))

                  else if((l == 10).and.(m == (2))) then
                    qtemp = 3.0/512.0 * sqrt(385.0/(2.0*3.1415926)) * exp(2.0*comp*ksai)* &
                            (sin(theta))**2 * (4199.0*(cos(theta))**8 - 6188.0*(cos(theta))**6 + &
                            2730.0*(cos(theta))**4 - 364.0*(cos(theta))**2 + 7)

                  else if((l == 10).and.(m == (3))) then
                    qtemp = -3.0/256.0 * sqrt(5005.0/(3.1415926)) * exp(3.0*comp*ksai)* &
                            (sin(theta))**3 * (323.0*(cos(theta))**7 - 357.0*(cos(theta))**5 + &
                            105.0*(cos(theta))**3 - 7.0*cos(theta))

                  else if((l == 10).and.(m == (4))) then
                    qtemp = 3.0/256.0 * sqrt(5005.0/(2.0*3.1415926)) * exp(4.0*comp*ksai)* &
                            (sin(theta))**4 * (323.0*(cos(theta))**6 - 255.0*(cos(theta))**4 + &
                            45.0*(cos(theta))**2 - 1)

                  else if((l == 10).and.(m == (5))) then
                    qtemp = -3.0/256.0 * sqrt(1001.0/(3.1415926)) * exp(5.0*comp*ksai)* &
                            (sin(theta))**5 * (323.0*(cos(theta))**5 - 170.0*(cos(theta))**3 + &
                            15.0*cos(theta))

                  else if((l == 10).and.(m == (6))) then
                    qtemp = 3.0/1024.0 * sqrt(5005.0/(3.1415926)) * exp(6.0*comp*ksai)* &
                            (sin(theta))**6 * (323.0*(cos(theta))**4 - 102.0*(cos(theta))**2 + 3)

                  else if((l == 10).and.(m == (7))) then
                    qtemp = -3.0/512.0 * sqrt(85085.0/(3.1415926)) * exp(7.0*comp*ksai)* &
                            (sin(theta))**7 * (19.0*(cos(theta))**3 - 3.0*cos(theta))

                  else if((l == 10).and.(m == (8))) then
                    qtemp = 1.0/512.0 * sqrt(255255.0/(2.0*3.1415926)) * exp(8.0*comp*ksai)* &
                            (sin(theta))**8 * (19.0*(cos(theta))**2-1)

                  else if((l == 10).and.(m == (9))) then
                    qtemp = -1.0/512.0 * sqrt(4849845.0/(3.1415926)) * exp(9.0*comp*ksai)* &
                            (sin(theta))**9 * cos(theta)

                  else if((l == 10).and.(m == (10))) then
                    qtemp = 1.0/1024.0 * sqrt(969969.0/(3.1415926)) * exp(10.0*comp*ksai)* &
                            (sin(theta))**10

                  end if

                Q2(atom, l/2, m) = Q2(atom, l/2, m) + qtemp

              end do
            end do
	      end do

	      do l = 4, 10, 2
	        do m = -l, l
		      Q2(atom, l/2, m) = Q2(atom, l/2, m) / (1.0*n_neighbor_list(atom))
	          Ql2(atom, l/2-1) = Ql2(atom, l/2-1) + (abs(Q2(atom, l/2, m)))**2
	          Ql(atom, l/2-1) = Ql2(atom, l/2-1)
	        end do
	        Ql2(atom, l/2-1) = sqrt(Ql2(atom, l/2-1) * 4.0 * 3.1415926 / (1.0 * (2.0*l + 1.0)))
            Ql(atom, l/2-1) = Ql2(atom, l/2-1)
!              write(*,*) "calc ql", Ql(atom, l/2-1), Ql2(atom, l/2-1), Ql2(atom, l/2-1)
          end do

	    end do

      !!!!!!!!!!!!!!!!!!! calculate Wl !!!!!!!!!!!!!!!!!!!!!
      if (higher_order == 1) then

        allocate(Wl(n_atoms, 2:5), stat = err_mesg)

!        CG = calculate_CG(2, 5)

        do i = 0, 50
        if(i == 0) then
          fac(i)=0
        else
          do j = 1, i
            fac(i) = fac(i) + log10(1.0*j)
          end do
        end if
        end do

        CG = 0

        do l = 4, 10, 2
        do m1 = -l, l
          do m2 = max(-l, -l-m1), min(l, l-m1)
            m3 = -(m1 + m2)
            s = 0
            v2 = 0
            do v = max(0, -m1, m2), min(l, l-m1, l+m2)
              s = s + 1
              v1 = fac(v) + fac(l-v) + fac(l-m1-v) + fac(l+m2-v) + fac(-m2+v) + fac(m1+v)
              if(s == 1) then
                v0 = v1
              end if
              v2 = v2 + (-1)**(-v) * 10**(1.0*(v0-v1))
            end do
            CG(l/2, m1, m2, m3) = 10**(1.0/2 * &
                (log10(1.0*2*l+1) + 3*fac(l)-fac(3*l+1) + &
                fac(l+m1)+fac(l-m1)+fac(l+m2)+fac(l-m2)+fac(l+m3)+fac(l-m3))-v0) * v2 * &
                (-1)**(-m3) / sqrt(1.0*(2*l+1))
!            write(*,*) CG(l/2, m1, m2, m3)
          end do
        end do
        end do

        do atom = 1, n_atoms
!            if(atom > 10) then
!                exit
!            end if

          do l = 4, 10, 2
            do m1 = -l, l
              do m2 = max(-l,-l-m1), min(l,l-m1)
                m3 = -(m1+m2)
                Wl(atom, l/2) = Wl(atom, l/2) + CG(l/2, m1, m2, m3) * &
                    Q2(atom, l/2, m1) * Q2(atom, l/2, m2) * Q2(atom, l/2, m3)

!                write(*,*) CG(l/2, m1, m2, m3), Q2(atom, l/2, m1), Q2(atom, l/2, m2), Q2(atom, l/2, m3)

              end do
            end do
            Wlbar2(atom, l/2-1) = Wl(atom, l/2) / (Ql2(atom, l/2-1)/sqrt(4.0*3.1415926/(1.0*(2*l+1))))**3

            Wlbar(atom, l/2-1) = Wlbar2(atom, l/2-1)
!            write(*,*) Ql(atom, l/2-1), Ql2(atom, l/2-1)
!            write(*,*) Wl(atom, l/2)
!            write(*,*) Wlbar(atom, l/2-1), Wlbar2(atom, l/2-1)

          end do
        end do

      end if

      !!!!!!!!!!!!!!!!!!! calculate coarse_Ql !!!!!!!!!!!!!!!!!!!!!
      if ((coarse_lower_order == 1) .OR. (coarse_higher_order == 1)) then

        allocate(QQ2(n_atoms, 2:5, -10:10), stat = err_mesg)

        do atom = 1, n_atoms
          do l = 4, 10, 2
            do m = -l, l
              QQ2(atom, l/2, m) = QQ2(atom, l/2, m) + Q2(atom, l/2, m)
              do i = 1, n_neighbor_list(atom)
	            j = neighbor_lists(atom, i)
		        QQ2(atom, l/2, m) = QQ2(atom, l/2, m) + Q2(j, l/2,m)
		      end do
		      QQ2(atom, l/2, m) = QQ2(atom, l/2, m) / (1.0*n_neighbor_list(atom)+1.0)
	          coarse_Ql2(atom, l/2-1) = coarse_Ql2(atom, l/2-1) + (abs(QQ2(atom, l/2, m)))**2
	          coarse_Ql(atom, l/2-1) = coarse_Ql2(atom, l/2-1)
	        end do
	        coarse_Ql2(atom, l/2-1)= sqrt(coarse_Ql2(atom, l/2-1)*4.0*3.1415926/(1.0*(2.0*l+1.0)))
	        coarse_Ql(atom, l/2-1)= coarse_Ql2(atom, l/2-1)
	      end do
	    end do

	  end if

      !!!!!!!!!!!!!!!!!!! calculate coarse_Wlbar !!!!!!!!!!!!!!!!!!!!!
      if (coarse_higher_order == 1) then

        allocate(WWl(n_atoms, 2:5), stat = err_mesg)

!        CG = calculate_CG(2, 5)
        fac = 0
        do i = 0, 50
        if(i == 0) then
          fac(i)=0
        else
          do j = 1, i
            fac(i) = fac(i) + log10(1.0*j)
          end do
        end if
        end do

        CG = 0

        do l = 4, 10, 2
        do m1 = -l, l
          do m2 = max(-l, -l-m1), min(l, l-m1)
            m3 = -(m1 + m2)
            s = 0
            v2 = 0
            do v = max(0, -m1, m2), min(l, l-m1, l+m2)
              s = s + 1
              v1 = fac(v) + fac(l-v) + fac(l-m1-v) + fac(l+m2-v) + fac(-m2+v) + fac(m1+v)
              if(s == 1) then
                v0 = v1
              end if
              v2 = v2 + (-1)**(-v) * 10**(1.0*(v0-v1))
            end do
            CG(l/2, m1, m2, m3) = 10**(1.0/2 * &
                (log10(1.0*2*l+1) + 3*fac(l)-fac(3*l+1) + &
                fac(l+m1)+fac(l-m1)+fac(l+m2)+fac(l-m2)+fac(l+m3)+fac(l-m3))-v0) * v2 * &
                (-1)**(-m3) / sqrt(1.0*(2*l+1))
!            write(*,*) CG(l/2, m1, m2, m3)
          end do
        end do
        end do

        do atom = 1, n_atoms
          do l = 4, 10, 2
            do m1 = -l, l
              do m2 = max(-l,-l-m1), min(l,l-m1)
                m3 = -(m1+m2)
                WWl(atom, l/2) = WWl(atom, l/2) + CG(l/2, m1, m2, m3) * &
                    QQ2(atom, l/2, m1) * QQ2(atom, l/2, m2) * QQ2(atom, l/2, m3)
              end do
            end do
           coarse_Wlbar2(atom, l/2-1) = WWl(atom, l/2) / (coarse_Ql2(atom, l/2-1)/sqrt(4.0*3.1415926/(1.0*(2*l+1))))**3
           coarse_Wlbar(atom, l/2-1) = coarse_Wlbar2(atom, l/2-1)
          end do
        end do

      end if

      deallocate(Q2, Wl)
      deallocate(QQ2, WWl)

    end subroutine calculate_boop

!
!    function calculate_CG(half_l_min, half_l_max) result(CG)
!    integer, intent(in) :: half_l_min, half_l_max
!    integer:: l_min, l_max
!    REAL(16), dimension(half_l_min:half_l_max, -half_l_max*2:half_l_max*2, &
!      -half_l_max*2:half_l_max*2, -half_l_max*2:half_l_max*2):: CG
!
!    integer :: i, j, l, m1, m2, m3, v, s
!    REAL(16) :: v0, v1, v2
!    REAL(16), dimension(0:100) :: fac
!
!    do i = 0, 50
!    if(i == 0) then
!      fac(i)=0
!    else
!      do j = 1, i
!        fac(i) = fac(i) + log10(1.0*j)
!      end do
!    end if
!    end do
!
!
!    CG = 0
!
!    do l = 4, 10, 2
!    do m1 = -l, l
!      do m2 = max(-l, -l-m1), min(l, l-m1)
!        m3 = -(m1 + m2)
!        s = 0
!        v2 = 0
!        do v = max(0, -m1, m2), min(l, l-m1, l+m2)
!          s = s + 1
!          v1 = fac(v) + fac(l-v) + fac(l-m1-v) + fac(l+m2-v) + fac(-m2+v) + fac(m1+v)
!          if(s == 1) then
!            v0 = v1
!          end if
!          v2 = v2 + (-1)**(-v) * 10**(1.0*(v0-v1))
!        end do
!        CG(l/2, m1, m2, m3) = 10**(1.0/2 * &
!            (log10(1.0*2*l+1) + 3*fac(l)-fac(3*l+1) + &
!            fac(l+m1)+fac(l-m1)+fac(l+m2)+fac(l-m2)+fac(l+m3)+fac(l-m3))-v0) * v2 * &
!            (-1)**(-m3) / sqrt(1.0*(2*l+1))
!        write(*,*) CG(l/2, m1, m2, m3)
!      end do
!    end do
!    end do
!
!    end function calculate_CG


c*************************************************************************
c                        HELIO_DRAG.F
c*************************************************************************
c This subroutine loops through the particles (EXCEPT j=2) and applies
c kick due to gas drag
c
c             Input:
c                 nbod          ==>  number of massive bodies (int scalar)
c                 mass          ==>  mass of bodies (real array)
c                 xh,yh,zh      ==>  initial position in helio coord
c                                    (real arrays)
c                 vxh,vyh,vzh   ==>  initial velocity in helio coord
c                                    (real arrays)
c                 dt            ==>  time step
c                 rpl           ==>  physical size of a planet
c                                    (real array)
c                 kdrag0,nkdrag ==>  Drag constant and exponent
c                                    (real scalars)
c                 eta0,neta     ==>  Gas velocity parameter and exponent
c                                    (real scalars)
c             Output:
c                 vxh,vyh,vzh   ==>  final velocity in helio coord
c                                    (real arrays)
c
c Remarks:
c Authors:  Man Hoi Lee
c Date:    12/22/99
c Last revision:

      subroutine helio_drag(nbod,mass,xh,yh,zh,vxh,vyh,vzh,dt,rpl,
     &     kdrag0,nkdrag,eta0,neta)

      include '../swift.inc'

c...  Inputs Only:
      integer nbod
      real*8 mass(nbod),dt
      real*8 xh(nbod),yh(nbod),zh(nbod)
      real*8 rpl(nbod),kdrag0,nkdrag,eta0,neta

c...  Inputs and Outputs:
      real*8 vxh(nbod),vyh(nbod),vzh(nbod)

c...  Internals:
      integer j
      real*8 varpi,varpi2,rj,rj2,kdrag,vgas,vgasx,vgasy,u,fac

c----
c...  Executable code

      do j = 3,nbod
         if(mass(j).ne.0.0d0) then
            varpi2 = xh(j)**2 + yh(j)**2
            varpi = sqrt(varpi2)
            rj2 = varpi2 + zh(j)**2
            rj = sqrt(rj2)
            kdrag = kdrag0*(varpi**nkdrag)*(rpl(j)**2)/mass(j)
            vgas = sqrt((mass(1)/rj)*
     &                  (varpi2/rj2 -2.d0*eta0*(rj**neta)))
            vgasx = (-yh(j)/varpi)*vgas
            vgasy =  (xh(j)/varpi)*vgas
            u = sqrt((vxh(j) - vgasx)**2 + (vyh(j) - vgasy)**2 +
     &               vzh(j)**2)
            fac = u*kdrag*dt
            vxh(j) = (vxh(j) + fac*vgasx)/(1 + fac)
            vyh(j) = (vyh(j) + fac*vgasy)/(1 + fac)
            vzh(j) = vzh(j)/(1 + fac)
         endif
      enddo

      return
      end
c--------------------------------------------------------------------------


      subroutine neo_hooke_elasticity_1D(matDat,lam,stre,cc,dlam,
     *                                   finite,sss)
      implicit none

      integer          finite, sss

      double precision matDat(*), lam(*), stre(*), cc(2,*), dlam(*),
     *                 E, nu, mu, K, Lamb, eps11, eps33, J, dJ, stre0,
     *                 lam0,
     *                 fct, fct1, fct2, fct3, dJ1, dJ3

c
c     1D (TRUSS) MATERIAL SUBROUTINE
c
c     Neo-Hookean elasticity  (Wriggers, page 45)
c     -------------------------------------------
c
c     ss  = 1 -> uniaxial stress (plane stress), stre_22 = stre_33 = 0
c     ss  = 2 -> plane strain (membrane), stre_22 = 0, strain_33 = 0
c     ss  = 3 -> axisymmetric (membrane), stre_22 = 0
c    (ss  = 4 -> like 1, but incompressible
c     ss  = 5 -> like 2, but incompressible
c     ss  = 6 -> like 3, but incompressible)
c
c     stre: 11  33
c
c     cc:  1111  1133
c          3311  3333
c

      K      = matDat(1)
      mu     = matDat(2)
      Lamb   = K - 2.d0/3.d0 * mu

      if (finite.lt.1) goto 100

c...  finite strains .........

      if (sss.le.1) then

c       uniaxial stress

        fct     = 1.d0 / (lam(1) * lam(1))
        fct2    = mu / Lamb * fct
        fct3    = fct2 * fct2
        lam(2)  = sqrt( sqrt( fct3 + 2.d0*fct2 + fct) - fct2)
        lam(3)  = lam(2)
        dlam(2) = .5d0 / lam(2)
     *              * (.5d0 / sqrt( fct3 + 2.d0*fct2 + fct)
     *                  * (- fct3 - fct2 - .5d0 * fct) * 4.d0 / lam(1)
     *                     + 2.d0 * fct2 / lam(1))
        dlam(3) = dlam(2)
        J       = lam(1) * lam(2) * lam(3)
        dJ      = lam(2) * lam(3) + 2.d0 * lam(1) * lam(2) * dlam(2)
        stre(1) = .5d0 * Lamb / J * ( J    * J     - 1.d0)
     *                   + mu / J * (lam(1)*lam(1) - 1.d0)
        cc(1,1) = .5d0*Lamb * ((-1.d0/(J*J)*dJ)*(J*J-1.d0) + 2.d0*dJ)
     *                 + mu * ((-1.d0/(J*J)*dJ)*(lam(1)*lam(1)-1.d0)
     *                               + 2.d0/J*lam(1))

      elseif (sss.eq.2) then

c       plane strain

        lam(2)  = sqrt((Lamb+2.d0*mu)/(Lamb*lam(1)*lam(1)+2.d0*mu))
        lam(3)  = 1.d0
        dlam(2) = - lam(2)/(Lamb*lam(1)*lam(1)+2.d0*mu)*Lamb*lam(1)
        dlam(3) = 0.d0
        J       = lam(1) * lam(2)
        dJ      = lam(2) + lam(1) * dlam(2)
        stre(1) = .5d0 * Lamb / J * ( J    * J     - 1.d0)
     *                   + mu / J * (lam(1)*lam(1) - 1.d0)
        cc(1,1) = .5d0*Lamb * ((-1.d0/(J*J)*dJ)*(J*J-1.d0) + 2.d0*dJ)
     *                 + mu * ((-1.d0/(J*J)*dJ)*(lam(1)*lam(1)-1.d0)
     *                               + 2.d0/J*lam(1))

      elseif (sss.eq.3) then

c       axisymmetric

        fct     = Lamb * lam(1)*lam(1) * lam(3)*lam(3) + 2.d0*mu
        lam(2)  = sqrt( (Lamb+2.d0*mu) / fct)
        J       = lam(1) * lam(2) * lam(3)
        dlam(1) = - Lamb * J * lam(3) / fct     ! d lam2 / d lam1
        dlam(3) = dlam(1) / lam(3) * lam(1)     ! d lam2 / d lam3
        dJ1     = lam(2) * lam(3) + lam(1) * dlam(1) * lam(3)
        dJ3     = lam(1) * lam(2) + lam(1) * dlam(3) * lam(3)
        stre(1) = .5d0 * Lamb / J * ( J    * J     - 1.d0)
     *                   + mu / J * (lam(1)*lam(1) - 1.d0)

        stre(2) = .5d0 * Lamb / J * ( J    * J     - 1.d0)
     *                   + mu / J * (lam(3)*lam(3) - 1.d0)
        cc(1,1) = .5d0*Lamb * ((-1.d0/(J*J)*dJ1)*(J*J-1.d0) + 2.d0*dJ1)
     *                 + mu * ((-1.d0/(J*J)*dJ1)*(lam(1)*lam(1)-1.d0)
     *                               + 2.d0/J*lam(1))
        cc(1,2) = .5d0*Lamb * ((-1.d0/(J*J)*dJ3)*(J*J-1.d0) + 2.d0*dJ3)
     *                 + mu * ((-1.d0/(J*J)*dJ3)*(lam(1)*lam(1)-1.d0))
        cc(2,1) = .5d0*Lamb * ((-1.d0/(J*J)*dJ1)*(J*J-1.d0) + 2.d0*dJ1)
     *                 + mu * ((-1.d0/(J*J)*dJ1)*(lam(3)*lam(3)-1.d0))
        cc(2,2) = .5d0*Lamb * ((-1.d0/(J*J)*dJ3)*(J*J-1.d0) + 2.d0*dJ3)
     *                 + mu * ((-1.d0/(J*J)*dJ3)*(lam(3)*lam(3)-1.d0)
     *                               + 2.d0/J*lam(3))

      elseif (sss.eq.4) then

c       uniaxial stress, incompressible

        lam(2)  = 1.d0 / sqrt(lam(1))
        lam(3)  = lam(2)
        dlam(2) = - .5d0 / lam(1) * lam(2)
        dlam(3) = dlam(2)
        fct     = lam(1) * lam(1)
        stre(1) = mu * (fct*fct - 1.d0) / fct
        cc(1,1) = mu*(4.d0*lam(1)-2.d0*(fct*fct-1.d0)/(fct*lam(1)))

      elseif (sss.eq.5) then

c       plane strain, incompressible

        lam(2)  = 1.d0 / lam(1)
        lam(3)  = 1.d0
        dlam(2) = - 1.d0 / lam(1) * lam(2)
        dlam(3) = 0.d0
        fct     = lam(1) * lam(1)
        stre(1) = mu * (fct*fct - 1.d0) / fct
        cc(1,1) = mu*(4.d0*lam(1)-2.d0*(fct*fct-1.d0)/(fct*lam(1)))

      elseif (sss.eq.6) then

c       axisymmetric, incompressible

        lam(2)  = 1.d0 / (lam(1) * lam(3))
        dlam(1) = - lam(2) / lam(1)   ! d lam2 / d lam1
        dlam(3) = - lam(2) / lam(3)   ! d lam2 / d lam3
        fct     = lam(1) * lam(1) * lam(3) * lam(3)
        stre(1) = mu * (fct * lam(1) * lam(1) - 1.d0) / fct
        stre(2) = mu * (fct * lam(3) * lam(3) - 1.d0) / fct
        cc(1,1) = mu * (2.d0*lam(1) + 2.d0/(fct*lam(1)))
        cc(1,2) = mu * (            + 2.d0/(fct*lam(3)))
        cc(2,1) = mu * (            + 2.d0/(fct*lam(1)))
        cc(2,2) = mu * (2.d0*lam(3) + 2.d0/(fct*lam(3)))

      else

        call prgError(1,'neo_Hooke_elasticity_1D','what do you want?')

      endif

      return

 100  continue

c...  small strains .........

      eps11 = lam(1) - 1.d0
      eps33 = lam(3) - 1.d0
      E     = 9.d0 * K * mu / (3.d0 * K + mu)
      nu    = Lamb / (2.d0 * (Lamb+mu))

      if (sss.le.1) then

c       uniaxial stress

        stre(1) = E * eps11
        cc(1,1) = E

      elseif (sss.eq.2) then

c       plane strain

        stre(1) = E / ((1.d0+nu) * (1.d0-nu)) * eps11
        cc(1,1) = E / ((1.d0+nu) * (1.d0-nu))

      elseif (sss.eq.3) then

c       axisymmetric

        fct1 = 4.d0 * mu * (mu + Lamb) / (2.d0 * mu + Lamb)
        fct2 = 2.d0 * mu * Lamb / (2.d0 * mu + Lamb)
        stre(1) = fct1 * eps11 + fct2 * eps33
        stre(2) = fct1 * eps33 + fct2 * eps11
        cc(1,1) = fct1
        cc(1,2) = fct2
        cc(2,1) = fct2
        cc(2,2) = fct1

      elseif (sss.eq.4) then

c       uniaxial stress, incompressible

        stre(1) = 4.d0 * mu * eps11
        cc(1,1) = 4.d0 * mu

      elseif (sss.eq.5) then

c       plane strain, incompressible

        stre(1) = 4.d0 * mu * eps11
        cc(1,1) = 4.d0 * mu

      elseif (sss.eq.6) then

c       axisymmetric, incompressible

        fct2 = mu + mu
        fct1 = fct1 + fct1
        stre(1) = fct1 * eps11 + fct2 * eps33
        stre(2) = fct2 * eps11 + fct1 * eps33
        cc(1,1) = fct1
        cc(1,2) = fct2
        cc(2,1) = fct2
        cc(2,2) = fct1

      else

        call prgError(2,'neo_Hooke_elasticity_1D','what do you want?')

      endif

      return

      end


      subroutine sunmap(r5smap,halfdy,dsunmp)

c
c     +++PURPOSE+++
c     This routine determines the amount of heat unit calories
c     available for melting snow.  The logic as well as the variable
c     comments are taken from "Computational Algorithm for
c     Solar Radiation on Mountain Slopes" paper written by
c     Lloyd W. Swift Jr. and R.J. Luxmoore, 06-73.  The value is then
c     distributed over the daily radiation curve and passed to the
c     weather data structure as HRADMJ.
c
c     Author(s): Cully Hession and Bruce Lucord, USDA-ARS-NCSRL
c                Revised by John Witte, UofMn WCES @ USDA-ARS-NCSRL
c     Date: 03/24/93

c     Verified and tested by Reza Savabi, USDA-ARS, NSERL 317-494-5051
c                  August 1994
c******************************************************************
c                                                                 *
c     +++ARGUMENT DECLARATIONS+++                                 *
c                                                                 *
c******************************************************************
      real     halfdy,r5smap,dsunmp

c     +++ARGUMENT DEFINITIONS+++
c     r2     - Measured daily solar radiation from cligen file (Ly/day).
c     r3     - Potential solar beam on horizontal surface (MJ/m^2/day).
c     halfdy - Number of hours from sunrise until noon.
c     sdate  - Julian date that is being run.
c
c******************************************************************
c                                                                 *
c     + + + PARAMETERS + + +                                      *
c                                                                 *
c******************************************************************
      include 'pmxhil.inc'
      include 'pmxpln.inc'
      include 'pmxelm.inc'
      include 'pmxtls.inc'
      include 'pmxtil.inc'
c******************************************************************
c                                                                 *
c   Common Blocks                                                 *
c                                                                 *
c******************************************************************
      include 'cupdate.inc'
      include 'cstruc.inc'
c
      include  'cangie.inc'
c     read:    eqlat,delong,radlat,radpot
c
      include  'cclim.inc'
c     read:    rpoth,hradmj
c******************************************************************
c                                                                 *
c     +++LOCAL VARIABLES+++                                       *
c                                                                 *
c******************************************************************
      real   r2, r3
      real   d,e,r1,solcon,t,t7,t6,x,t1,t0,t3,t2,r4,pi,t4,
     1       f,langmj,t8,t9,psolr
c    1       f,cratio,langmj
cd    Added by S. Dun, Nov 13, 2006
      real  ms, sb, sd, cosfi,sindlt, cosdlt, tao, fortao
cd    End adding
c
c     +++LOCAL DEFINITIONS+++
c     d      - Declination of the sun in radian units,(+)North (-)South.
c     e      - Radius vertor of the sun in radian units.
c     r1     - Solar constant factor.
c     solcon - Solar constant (Ly/min).
c     t      - Temporary variable.
c     t7     - Hour Angle of sunset on horizontal surface (degrees).
c     t6     - Hour Angle of sunrise on the equivalent slope surface.
c     x      - Temp variable used to determine HA on the equiv slope.
c     t1     - Hour Angle of sunset on the horizontal surface (deg).
c     t0     - Hour Angle of sunrise on the horizontal surface (deg).
c     t3     - Hour Angle of sunset on the sloping surface (deg).
c     t2     - Hour Angle of sunrise on the sloping surface (deg).
c     r4     - Potential solar beam on the sloping surface (MJ/m^2/day)
c     pi     - Estimated value for 22/7.
c     t4     - Number of hours before solar noon of sunrise on slope.
c     langmj - Conversion factor from Cal/cm^2 = Ly to MJ/M2.
c     f      - Slope factor (r4/r3).
c     r6     - Est solar rad on sloping surface map area (MJ/m^2/day).
c     cratio - Hourly radiation adjustment ratio calculated in RADCURV.
c
c     +++OUTPUT FORMATS+++
c2000 format(' Inside SunMap Routine ',/,' d = ',f10.3,/,' e = ',
c     1       f10.3,/,' r1 = ',
c     2      f10.3,/,' t7 = ',f10.3,/,' t6 = ',f10.3,/,' t3 = ',f10.3,
c     3      /,' t2 = ',f10.3,/,' r4 = ',f10.3,/,' t4 = ',f10.3,/)
c
c     +++END SPECIFICATIONS+++
c
      pi = 3.141593
      solcon = 1.94
      langmj = 0.04184
      r2 = radly
c
c -- begin calculations --

      d  = 0.00698 - 0.4067 * cos((sdate + 10.0) * 0.0172)
      e  = 1.00000 - 0.0167 * cos((sdate -  3.0) * 0.0172)
      r1 = (60.0 * solcon) / (e * e)
      x  = -((sin(eqlat)) / (cos(eqlat))) * ((sin(d)) / (cos(d)))

      if (x .gt. 1.0) x =  1.0
      if (x .lt.-1.0) x = -1.0
c
      t = acos(x)
      t7 = t - delong
      t6 = -t - delong

c -- NOTE that the "x" calculations are written out the long way rather
c --  than by simply using the "tan" function.  This is do to a bug in
c --  Lahey compiler with tangent that Dennis F. found on AT&T 6300's.
c
c     x = -((sin(radlat))/(cos(radlat)))*((sin(d))/(cos(d)))
c
c     Use tangent function - as 6300's obsolete and now using newer
c     Lahey compiler.   dcf  2/22/94
c
      x = - (tan(radlat) * tan(d))

      if (x .gt. 1.0) x =  1.0
      if (x .lt.-1.0) x = -1.0
      t = acos(x)

      t1 = t
      t0 = -t

      t3 = t7
      if (t7 .ge. t1) t3 = t1

      t2 = t6
      if (t6 .le. t0) t2 = t0
c
cd      Modified by S. Dun, Nov 07, 2006
c      In responsing Erin Brooks (UI) PMET crash, adding in the alternative routines
c      (supplemental functions) for steep slope at high latitude
c
c      r4 = r1 * ((sin(d) * sin(eqlat) * (t3 - t2) * 12. / pi)
c     1+ (cos(d) * cos(eqlat) * (sin(t3 + delong) - sin(t2 + delong))
c     2* 12. / pi))
c
      If (t3 .lt. t2) t2 = t3
      t6 = t6 + 2*pi
c
      if (t6 .lt. t1) then
         t8 = t6
         t9 = t1
         r4 = r1 * (psolR(d,delong,eqlat,t3,t2) +
     1        psolR(d,delong,eqlat,t9,t8))
      else
         t7 = t7 - 2*pi
c
         if (t7 .gt. t0) then
             t8 = t0
             t9 = t7
             r4 = r1 * (psolR(d,delong,eqlat,t3,t2) +
     1             psolR(d,delong,eqlat,t9,t8))
          else
             r4 = r1 * (psolR(d,delong,eqlat,t3,t2))
          endif
c
      endif
c
cd      radpot=r4
c
cd    End modifying
      r4 = r4 * langmj
c reza 3/2/94      radpot = r4

c -- Now the potential radiation on slope is in units of MJ/m^2.

      t4 = t2 * 12.0 / pi
      halfdy = abs(t4)

      r3 = r1 * ((sin(d) * sin(radlat) * (t1 - t0) * 12.0 / pi)
     1     + (cos(d) * cos(radlat) * (sin(t1) - sin(t0)) * 12.0 / pi))
c
cd      Added by S. Dun, Nov 13, 2006
c      Calculate atmosphere transmittance from measured and potential solar radiation
c      reference: Campbell GS and Norman JM, 1998 "Environmental Biophysics"
c     Equation 11.11 to 11.13
c
c      Note: Solar declination adjustment on a specific location was incorperated in
c      r3 already. r3=Sp0*cosfi
c
c      Solar declination
      sindlt = 0.39785*sin(pi/180*(278.97 + 0.9856*sdate + 1.9165*
     1         sin(pi/180*(356.6 + 0.9856*sdate))))
      cosdlt = sqrt(1 - sindlt**2)
c      Azimuth at solar noon.
      cosfi = sindlt * sin(radlat)+ cosdlt * cos(radlat)
c      initao = 0.4
c      call transm(r3, r2, cosfi, initao, tao)
c
      fortao = (r2-0.3*r3)
c
      if (fortao .gt. 0) then
         tao = (fortao /(r3*0.7))**cosfi
      else
               tao = 0.4
      endif
c
      If (tao .gt. 0.75) tao = 0.75
      if (tao .lt. 0.4) tao = 0.4
c
c      Calculate direct and diffuse solar radation
      ms = 1/cosfi
c
c      Cloud cover calculation using transmisivity appraoch
c      Clear sky has maximum tao = 0.75; cloud sky has minimum Tao = 0.4.
c
c      r2/r3 = (1-C)*(0.3 + 0.7*MaxTao**(1/cosfi)) + C*(0.3 + 0.7*MinTao**(1/cosfi))
c
      cloudC = (0.3 + 0.7* 0.75**ms - r2/r3)/(0.7*(0.75**ms - 0.4**ms))
      if (cloudC .gt. 1.0) cloudC = 1.0
      if (cloudC .lt. 0.0) cloudC = 0.0
cd      End adding
c
cd      Modified by S. Dun Nov. 11, 2006
c      Now radpot represent the potential solar radiation on horizontal surface
c      instead of on a sloped surface.
c
c      For clearest sky day incoming solar energy
c      tao = 0.75
c      radpot = r3*(0.7*tao**(1/cosfi) + 0.3)
cd      End modifying
      radpot = r3
      r3 = r3 * langmj
c
c -- Now the potential radiation on horiz is also in MJ/m^2.

cd      f = r4 / r3
cd      Added by S. Dun, Nov 13, 2006
c
      Sb = r3* tao**ms
      Sd = 0.3* (r3- Sb)
      f = (r4* tao**ms + sd)/(sb+sd)
      solef(iplane) = f
c
      if (sdate .ne. datef) then
cd      write(61,1000) sdate,tao,cosfi,r3,r2,sb, sd, f, cloudC
      endif
c      sunmap was called so many times. I need check it out sometime
      datef = sdate
cd      End adding
c Reza, the next line will make r5smap to be in LY
c because r2=radly, we need to convert r5smap to MJ
      r5smap = f * r2
c Reza  changed the next line, 3/9/94
c --  r5smap = r5smap * langmj

      r5smap = r5smap * langmj
c -- The above was commented out because f and r2 are already in
c -- the desired units.

c -- Make sure that r5smap is in MJ/m*m units.

c      r6 = r5smap / cos(radinc)
c -- The above line is commented out due to Bob's suggestion
c -- we do so.  It was used to project sloping surface to the
c -- horizontal surface (slightly smaller area) resulting in
c -- slightly higher radiation.  We feel that when dealing with
c -- non-mountain slope segments, we don't need such an adjustment.

      rpoth = r3
      dsunmp = d
c
creza 11/16/94
c     if(irdflg .eq. 1) then
c       -- Now we call the RADCUR routine to calc hourly radiation.
c       call radcur(sdate,hour,radlat,d,cratio)
c       cratio = cratio / r3
c       -- Now we know the ratio of daily radiation to hourly radiation.
c       reza, in the next line hradmj is in MJ
c       hradmj = r5smap * cratio
c     endif
creza change 11/16/94
1000      Format(1x,I5,8f10.2)
      return
      end