ekepl2 Function

public pure function ekepl2(em, e)

Kepler's equation, em = ekepl - e*sin(ekepl) with e in range 0 to 1 inclusive, solved accurately

Arguments

Type IntentOptional Attributes Name
real(kind=wp), intent(in) :: em
real(kind=wp), intent(in) :: e

Return Value real(kind=wp)


Calls

proc~~ekepl2~~CallsGraph proc~ekepl2 gooding_module::ekepl2 proc~emkepl gooding_module::emkepl proc~ekepl2->proc~emkepl

Source Code

    pure function ekepl2(em, e)

    implicit none

    real(wp)            :: ekepl2
    real(wp),intent(in) :: em
    real(wp),intent(in) :: e

    real(wp) :: emr, ee, w, e1, fdd, fddd, f, fd, dee
    logical :: l
    integer :: iter

    real(wp),parameter :: sw = 0.1_wp
    real(wp),parameter :: a  = (pi-one)**2/(pi+two/three)
    real(wp),parameter :: b  = two*(pi-asixth)**2/(pi+two/three)

    !range-reduce em to line in range -pi to pi
    emr = mod(em,twopi)
    if (emr<pineg) emr = emr + twopi
    if (emr>pi) emr = emr - twopi
    ee = emr

    if (ee/=zero) then

        if (ee<zero) ee = -ee

        !(emr is range-reduced em & ee is absolute value of emr)
        !started for e = 1 by cube root of bilinear function
        if (ee<asixth) then
            ee = (six*ee)**athird
        else
            w = pi - ee
            ee = pi - a*w/(b - w)
        end if
        if (emr<zero) ee = -ee

        !interpolate for e
        ee = emr + (ee - emr)*e

        !do two iterations of halley, each followed by newton
        e1 = one - e
        l = (e1 + ee*ee/six) >= sw
        do iter=1,2
            fdd = e*sin(ee)
            fddd = e*cos(ee)
            if (l) then
                f = (ee - fdd) - emr
                fd = one - fddd
            else
                f = emkepl(e,ee) - emr
                fd = e1 + two*e*sin(half*ee)**2
            end if
            dee = f*fd/(half*f*fdd - fd*fd)
            f = f + dee*(fd + half*dee*(fdd + athird*dee*fddd))
            !to reduce the danger of underflow replace the last line by
            !w = fd + half*dee*(fdd + athird*dee*fddd)
            fd = fd + dee*(fdd + half*dee*fddd)
            ee = ee + dee - f/fd
            !if replacing as above, then also replace the last line by
            !ee = ee - (f - dee*(fd - w))/fd
        end do

    end if

    !range-expand
    ekepl2 = ee + (em - emr)

    end function ekepl2