# Functions used for several Hairer-Wanner Solvers

function hw1rhs(
        n::FInt, t::Float64, x::Array{Float64},
        f::Array{Float64}, cbi::CI
    ) where {FInt, CI}

    lprefix = cbi.rhs_lprefix

    (lio, l) = (cbi.logio, cbi.loglevel)
    l_rhs = l & LOG_RHS > 0

    l_rhs && println(lio, lprefix, "called with n=", n, " t=", t, " x=", x)
    if cbi.rhs_mode == RHS_CALL_INSITU
        cbi.rhs(t, x, f)
    elseif cbi.rhs_mode == RHS_CALL_RETURNS_ARRAY
        result = cbi.rhs(t, x)
        try
            f[:] = getVectorCheckLength(result, Float64, n, false)
        catch e
            throw(
                OutputErrorODE(
                    string(
                        "Cannot convert result $result of ", cbi.rhs, " to ",
                        "Vector{Float64} of length $n"
                    ), cbi.rhs, e
                )
            )
        end
    else
        throw(InternalErrorODE("Unknown cbi.rhs_mode"))
    end
    l_rhs && println(lio, lprefix, "rhs result=", f)
    return nothing
end

"""
     function unsafe_HW1RHSCallback(
             n_::Ptr{FInt}, t_::Ptr{Float64}, x_::Ptr{Float64},
             f_::Ptr{Float64}, rpar_::Ptr{Float64},
             cbi::CI) where {FInt<:FortranInt, CI<:ODEinternalCallInfos}
              -> nothing

This is the right-hand side given as callback to several Fortran-solvers,
e.g. dopri5, dop853, odex.

The `unsafe` prefix in the name indicates that no validations are
performed on the `Ptr`-arguments.
"""
function unsafe_HW1RHSCallback(
        n_::Ptr{FInt}, t_::Ptr{Float64}, x_::Ptr{Float64},
        f_::Ptr{Float64}, rpar_::Ptr{Float64},
        cbi::CI
    ) where {FInt <: FortranInt, CI <: ODEinternalCallInfos}

    n = unsafe_load(n_); t = unsafe_load(t_)
    x = unsafe_wrap(Array, x_, (n,), own = false)
    f = unsafe_wrap(Array, f_, (n,), own = false)

    hw1rhs(n, t, x, f, cbi)
    return nothing
end

"""
     function unsafe_HW1RHSCallback_c(cbi::CI,
             fint_flag::FInt) where {FInt,CI}
        -> C-callable function pointer

This method generates a Pointer to C-callable instructions.
The two method type parameters `FInt` and `CI` are important:
`FInt` is the used Fortran integer type and `CI` is the used
`ODEinternalCallInfos` *SubType*.
Because `unsafe_HW1RHSCallback` is a parameterized method,
special variants are compiled, if `FInt` or `CI` changes.
If `CI` itself is a parameterized type (depending on all the
user-given Julia-functions like right-hand side, etc.) then
calls to such Julia-functions can be resolved at compile-time
(instead of dynamic calls during run-time).
"""
function unsafe_HW1RHSCallback_c(
        cbi::CI,
        fint_flag::FInt
    ) where {FInt, CI}
    return @cfunction(
        unsafe_HW1RHSCallback, Cvoid, (
            Ptr{FInt}, Ptr{Float64},
            Ptr{Float64}, Ptr{Float64}, Ptr{Float64}, Ref{CI},
        )
    )
end

"""
     function unsafe_HW2RHSCallback(
             n_::Ptr{FInt}, t_::Ptr{Float64}, x_::Ptr{Float64},
             f_::Ptr{Float64}, rpar_::Ptr{Float64},
             cbi::CI) where {FInt<:FortranInt, CI<:ODEinternalCallInfos}
              -> nothing

This is the right-hand side given as callback to Fortran-solvers
(e.g. radau5 and radau) that can handle problems with "special structure",
see `help_specialstructure`.

The `unsafe` prefix in the name indicates that no validations are
performed on the `Ptr`-arguments.
"""
function unsafe_HW2RHSCallback(
        n_::Ptr{FInt}, t_::Ptr{Float64}, x_::Ptr{Float64},
        f_::Ptr{Float64}, rpar_::Ptr{Float64},
        cbi::CI
    ) where {FInt <: FortranInt, CI <: ODEinternalCallInfos}

    n = unsafe_load(n_); t = unsafe_load(t_)
    x = unsafe_wrap(Array, x_, (n,), own = false)
    f = unsafe_wrap(Array, f_, (n,), own = false)

    lprefix = cbi.rhs_lprefix

    (lio, l) = (cbi.logio, cbi.loglevel)
    l_rhs = l & LOG_RHS > 0

    l_rhs && println(lio, lprefix, "called with n=", n, " t=", t, " x=", x)
    if cbi.M1 > 0
        # Problem with special structure, fill in special structure in f
        for k in 1:cbi.M1
            f[k] = x[k + cbi.M2]
        end
    end
    if cbi.rhs_mode == RHS_CALL_INSITU
        cbi.rhs(t, x, f)
    elseif cbi.rhs_mode == RHS_CALL_RETURNS_ARRAY
        result = cbi.rhs(t, x)
        try
            f[(cbi.M1 + 1):n] = getVectorCheckLength(result, Float64, n - cbi.M1, false)
        catch e
            throw(
                OutputErrorODE(
                    string(
                        "Cannot convert result $result of ", cbi.rhs, " to ",
                        "Vector{Float64} of length d-M1=", n, "-", cbi.M1, "=", n - cbi.M1
                    ),
                    cbi.rhs, e
                )
            )
        end
    else
        throw(InternalErrorODE("Unknown cbi.rhs_mode"))
    end
    l_rhs && println(lio, lprefix, "rhs result=", f)
    return nothing
end

"""
     function unsafe_HW2RHSCallback_c(cbi::CI,
             fint_flag::FInt) where {FInt,CI}
        -> C-callable function pointer

see `unsafe_HW1RHSCallback_c` for an explanation of `FInt`, `CI`.
"""
function unsafe_HW2RHSCallback_c(
        cbi::CI,
        fint_flag::FInt
    ) where {FInt, CI}
    return @cfunction(
        unsafe_HW2RHSCallback, Cvoid, (
            Ptr{FInt}, Ptr{Float64},
            Ptr{Float64}, Ptr{Float64}, Ptr{Float64}, Ref{CI},
        )
    )
end

"""
     function unsafe_HW1MassCallback(n_::Ptr{FInt}, am_::Ptr{Float64},
             lmas_::Ptr{FInt}, rpar_::Ptr{Float64},
             cbi::CI) where {FInt<:FortranInt,CI<:ODEinternalCallInfos}
              -> nothing

This is the MAS callback given to radau5, radau and seulex.

The `unsafe` prefix in the name indicates that no validations are
performed on the `Ptr`-pointers.

This function takes the values of  the mass matrix saved in
the InternalCallInfos.
"""
function unsafe_HW1MassCallback(
        n_::Ptr{FInt}, am_::Ptr{Float64},
        lmas_::Ptr{FInt}, rpar_::Ptr{Float64},
        cbi::CI
    ) where {FInt <: FortranInt, CI <: ODEinternalCallInfos}
    n = unsafe_load(n_)
    lmas = unsafe_load(lmas_)
    am = unsafe_wrap(Array, am_, (lmas, n), own = false)
    lprefix = "unsafe_HW1MassCallback: "

    (lio, l) = (cbi.logio, cbi.loglevel)
    l_mas = l & LOG_MASS > 0

    l_mas && println(lio, lprefix, "called with n=", n, " lmas=", lmas)

    mas = cbi.massmatrix

    if isa(mas, BandedMatrix)
        @assert n == size(mas, 2)
        @assert lmas == 1 + mas.l + mas.u
        bm = BandedMatrix{Float64}(mas.m, mas.n, mas.l, mas.u, am::Matrix{Float64})
        setdiagonals!(bm, mas)
    else
        @assert (lmas, n) == size(mas)
        am[:] = mas
    end

    l_mas && println(lio, lprefix, "am=", am)
    return nothing
end

"""
     function unsafe_HW1MassCallback_c(cbi::CI,
             fint_flag::FInt) where {FInt,CI}
        -> C-callable function pointer
"""
function unsafe_HW1MassCallback_c(
        cbi::CI,
        fint_flag::FInt
    ) where {FInt, CI}
    return @cfunction(
        unsafe_HW1MassCallback, Cvoid, (
            Ptr{FInt},
            Ptr{Float64}, Ptr{FInt}, Ptr{Float64}, Ref{CI},
        )
    )
end

"""
     function extractSpecialStructureOpt(
             d::FInt,opt::AbstractOptionsODE) where FInt<:FortranInt

extracts parameters for special structure (M1, M2).

reads options: `OPT_M1`, `OPT_M2`
"""
function extractSpecialStructureOpt(
        d::FInt, opt::AbstractOptionsODE
    ) where {FInt <: FortranInt}
    OPT = nothing
    M1 = 0; M2 = 0; NM1 = 0
    try
        OPT = OPT_M1; M1 = convert(FInt, getOption(opt, OPT, 0))
        @assert M1 ≥ 0
        OPT = OPT_M2; M2 = convert(FInt, getOption(opt, OPT, M1))
        @assert M2 ≥ 0

        OPT = string(OPT_M1, " & ", OPT_M2)
        @assert M1 + M2 ≤ d
        @assert (M1 == M2 == 0) || (M1 ≠ 0 ≠ M2)
        @assert (M1 == 0) || (0 == M1 % M2)
        NM1 = d - M1
    catch e
        throw(ArgumentErrorODE("Option '$OPT': Not valid", :opt, e))
    end
    return (M1, M2, NM1)
end

"""
     function extractMassMatrix(M1::FInt, M2::FInt,
             NM1::FInt, args::AbstractArgumentsODESolver{FInt},
             opt::AbstractOptionsODE) where FInt<:FortranInt

extracts mass matrix and fills `IMAS`, `MLMAS` und `MUMAS` in args.

reads options: `OPT_MASSMATRIX`
"""
function extractMassMatrix(
        M1::FInt, M2::FInt,
        NM1::FInt, args::AbstractArgumentsODESolver{FInt},
        opt::AbstractOptionsODE
    ) where {FInt <: FortranInt}
    OPT = nothing
    massmatrix = nothing
    try
        OPT = OPT_MASSMATRIX
        massmatrix = getOption(opt, OPT, nothing)
        if massmatrix === nothing
            args.IMAS = [0]; args.MLMAS = [0]; args.MUMAS = [0]
        else
            @assert 2 == ndims(massmatrix)
            @assert (NM1, NM1) == size(massmatrix)
            massmatrix = deepcopy(massmatrix)
            args.IMAS = [1]
            # A BandedMatrix with lower bandwidth == NM1 is treated as full!
            if isa(massmatrix, BandedMatrix) && massmatrix.l == NM1
                massmatrix = full(massmatrix)
            end
            if isa(massmatrix, BandedMatrix)
                @assert massmatrix.l < NM1
                args.MLMAS = [massmatrix.l]
                args.MUMAS = [massmatrix.u]
            else
                massmatrix = convert(Matrix{Float64}, massmatrix)
                args.MLMAS = [NM1]; args.MUMAS = [NM1]
            end
        end
    catch e
        throw(ArgumentErrorODE("Option '$OPT': Not valid", :opt, e))
    end
    return massmatrix
end

"""
     function unsafe_HW1JacCallback(n_::Ptr{FInt},
             t_::Ptr{Float64},x_::Ptr{Float64},dfx_::Ptr{Float64},
             ldfx_::Ptr{FInt}, rpar_::Ptr{Float64},
             cbi::CI) where {FInt<:FortranInt, CI<:ODEinternalCallInfos}
              -> nothing

This is the JAC callback given to radau5, radau and seulex.

The `unsafe` prefix in the name indicates that no validations are
performed on the `Ptr`-pointers.

This function calls the user-given Julia function cbi.jacobimatrix
with the appropriate arguments (depending on M1 and jacobibandstruct).
"""
function unsafe_HW1JacCallback(
        n_::Ptr{FInt},
        t_::Ptr{Float64}, x_::Ptr{Float64}, dfx_::Ptr{Float64},
        ldfx_::Ptr{FInt}, rpar_::Ptr{Float64},
        cbi::CI
    ) where {FInt <: FortranInt, CI <: ODEinternalCallInfos}
    n = unsafe_load(n_)
    t = unsafe_load(t_)
    x = unsafe_wrap(Array, x_, (n,), own = false)
    ldfx = unsafe_load(ldfx_)

    lprefix = cbi.jac_lprefix
    (lio, l) = (cbi.logio, cbi.loglevel)
    l_jac = l & LOG_JAC > 0

    l_jac && println(lio, lprefix, "called with n=", n, " ldfx=", ldfx)
    jac = cbi.jacobimatrix
    jb = cbi.jacobibandstruct
    M = unsafe_wrap(Array, dfx_, (ldfx, n), own = false)::Matrix{Float64}
    if jb === nothing
        @assert ldfx == n - cbi.M1
        J = M
        jac(t, x, J)
    else
        @assert ldfx == 1 + jb[1] + jb[2]
        if cbi.M1 == 0
            J = BandedMatrix{Float64}(n, n, jb[1], jb[2], M)
            jac(t, x, J)
        else
            no = Int(cbi.M1 / cbi.M2 + 1)
            J = Vector{BandedMatrix{Float64}}(undef, no)
            for k in 1:no
                ptr = dfx_ + (k - 1) * ldfx * cbi.M2 * sizeof(Float64)
                darr = unsafe_wrap(Array, ptr, (ldfx, cbi.M2), own = false)
                J[k] = BandedMatrix{Float64}(cbi.M2, cbi.M2, jb[1], jb[2], darr)
            end
            jac(t, x, J...)
        end
    end

    l_jac && println(lio, lprefix, "dfx=", M)
    return nothing
end

"""
     function unsafe_HW1JacCallback_c(cbi::CI,
             fint_flag::FInt) where {FInt,CI}
        -> C-callable function pointer
"""
function unsafe_HW1JacCallback_c(
        cbi::CI,
        fint_flag::FInt
    ) where {FInt, CI}
    return @cfunction(
        unsafe_HW1JacCallback, Cvoid, (
            Ptr{FInt},
            Ptr{Float64}, Ptr{Float64}, Ptr{Float64},
            Ptr{FInt}, Ptr{Float64}, Ref{CI},
        )
    )
end


"""
     function unsafe_HWRhsTimeDerivCallback(
             n_::Ptr{FInt}, t_::Ptr{Float64},x_::Ptr{Float64},
             dfdt_::Ptr{Float64}, rpar_::Ptr{Float64},
             cbi::CI) where {FInt<:FortranInt, CI<:ODEinternalCallInfos}
              -> nothing

This is the DFX callback given to rodas.

The `unsafe` prefix in the name indicates that no validations are
performed on the `Ptr`-pointers.

This function calls the user-given Julia function cbi.rhstimederiv
with the appropriate arguments.
"""
function unsafe_HWRhsTimeDerivCallback(
        n_::Ptr{FInt}, t_::Ptr{Float64}, x_::Ptr{Float64},
        dfdt_::Ptr{Float64}, rpar_::Ptr{Float64},
        cbi::CI
    ) where {FInt <: FortranInt, CI <: ODEinternalCallInfos}
    n = unsafe_load(n_)
    t = unsafe_load(t_)
    x = unsafe_wrap(Array, x_, (n,), own = false)
    dfdt = unsafe_wrap(Array, dfdt_, (n,), own = false)

    lprefix = cbi.rhsdt_prefix
    (lio, l) = (cbi.logio, cbi.loglevel)
    l_rhsdt = l & LOG_RHSDT > 0

    l_rhsdt && println(lio, lprefix, "called with n=", n, " t=", t)
    cbi.rhsdt(t, x, dfdt)
    l_rhsdt && println(lio, lprefix, "dfdt=", dfdt)

    return nothing
end

"""
     function unsafe_HWRhsTimeDerivCallback_c(cbi::CI,
             fint_flag::FInt) where {FInt,CI}
        -> C-callable function pointer
"""
function unsafe_HWRhsTimeDerivCallback_c(
        cbi::CI,
        fint_flag::FInt
    ) where {FInt, CI}
    return @cfunction(
        unsafe_HWRhsTimeDerivCallback, Cvoid, (
            Ptr{FInt},
            Ptr{Float64}, Ptr{Float64}, Ptr{Float64}, Ptr{Float64}, Ref{CI},
        )
    )
end

"""
     function extractJacobiOpt(d::FInt,
             M1::FInt,M2::FInt, NM1::FInt,
             args::AbstractArgumentsODESolver{FInt},
             opt::AbstractOptionsODE) where FInt<:FortranInt

extracts jacobi options and
fills `IJAC`, `MLJAC` and `MUJAC` in args.

reads options: `OPT_JACOBIMATRIX`, `OPT_JACOBIBANDSTRUCT`
"""
function extractJacobiOpt(
        d::FInt,
        M1::FInt, M2::FInt, NM1::FInt,
        args::AbstractArgumentsODESolver{FInt},
        opt::AbstractOptionsODE
    ) where {FInt <: FortranInt}
    OPT = nothing
    jacobimatrix = nothing
    jacobibandstruct = nothing
    try
        OPT = OPT_JACOBIMATRIX
        jacobimatrix = getOption(opt, OPT, nothing)
        # @assert (jacobimatrix === nothing) || isa(jacobimatrix,Function)

        OPT = OPT_JACOBIBANDSTRUCT
        bs = getOption(opt, OPT, nothing)

        if bs !== nothing
            jacobibandstruct = (convert(FInt, bs[1]), convert(FInt, bs[2]))
            if jacobibandstruct[1] == NM1
                # A BandedMatrix with lower bandwidth == NM1 is treated as full!
                jacobibandstruct = nothing
            end
        end
        if jacobibandstruct !== nothing
            @assert (M1 == 0) || (M1 + M2 == d)
            @assert 0 ≤ jacobibandstruct[1] < NM1
            @assert  (M1 == 0 && 0 ≤ jacobibandstruct[2] ≤ d)  ||
                (M1 > 0  && 0 ≤ jacobibandstruct[2] ≤ M2)
        end
    catch e
        throw(ArgumentErrorODE("Option '$OPT': Not valid", :opt, e))
    end

    args.IJAC = [jacobimatrix === nothing ? 0 : 1]
    args.MLJAC = [jacobibandstruct === nothing ? d : jacobibandstruct[1]]
    args.MUJAC = [jacobibandstruct === nothing ? d : jacobibandstruct[2]]
    jac_lprefix = "unsafe_HW1JacCallback: "
    return (jacobimatrix, jacobibandstruct, jac_lprefix)
end

"""
     function extractRhsTimeDerivOpt(
             args::AbstractArgumentsODESolver{FInt},
             opt::AbstractOptionsODE) where FInt<:FortranInt

extracts options for callback function for time-derivatives
of the right-hand-side and
fills `IDFX` in args.
"""
function extractRhsTimeDerivOpt(
        args::AbstractArgumentsODESolver{FInt},
        opt::AbstractOptionsODE
    ) where {FInt <: FortranInt}
    OPT = OPT_RHSTIMEDERIV
    rhstimederiv = nothing
    try
        rhstimederiv = getOption(opt, OPT, nothing)
        # @assert (rhstimederiv === nothing) || isa(rhstimederiv,Function)
    catch e
        throw(ArgumentErrorODE("Option '$OPT': Not valid", :opt, e))
    end

    args.IDFX = [rhstimederiv === nothing ? 0 : 1]
    rhsdt_prefix = "unsafe_HWRhsTimeDerivCallback: "
    return (rhstimederiv, rhsdt_prefix)
end

"""
## License

This is the license text, which can also be found at

     http://www.unige.ch/~hairer/prog/licence.txt

Copyright (c) 2004, Ernst Hairer

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

- Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.

- Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS “AS
IS” AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR
CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
"""
const hw_license = nothing

# vim:syn=julia:cc=79:fdm=indent:
