! Created by  on 28/02/2020.

! Compile with default real set to 8 bytes (-r8 on ifort)

module AVD

    integer, parameter, private :: sin_f   = 1
    integer, parameter, private :: cos_f   = 2
    integer, parameter, private :: tan_f   = 3
    integer, parameter, private :: sinh_f  = 4
    integer, parameter, private :: cosh_f  = 5
    integer, parameter, private :: tanh_f  = 6
    integer, parameter, private :: asin_f  = 7
    integer, parameter, private :: acos_f  = 8
    integer, parameter, private :: atan_f  = 9
    integer, parameter, private :: exp_f   = 10
    integer, parameter, private :: log_f   = 11
    integer, parameter, private :: log10_f = 12
    integer, parameter, private :: sqrt_f  = 13

    abstract interface
        pure function gen(x) result(r)
            real(8) :: r
            real(8), intent(in) :: x
        end function gen
    end interface

    type f_map_t
        procedure(gen), nopass, pointer :: f_ptr => null()
    end type f_map_t
    type(f_map_t), target :: f_map(0:4,13)

    type :: avd_b
        real(8) :: v
        contains
    end type avd_b

    type, extends(avd_b)  :: avd_d1
        real(8) :: d1 = 1
        contains
        procedure            :: set_from_avd1
        generic, public      :: assignment(=) => set_from_avd1
        procedure            :: avd1_equals_avd1
        generic, public      :: operator(==) => avd1_equals_avd1
        procedure, public    :: as_string => as_string_d1
    end type avd_d1

    type, extends(avd_d1) :: avd_d2
        real(8) :: d2 = 0
        contains
        procedure            :: set_from_avd2
        generic, public      :: assignment(=) => set_from_avd2
        procedure            :: avd2_equals_avd2
        generic, public      :: operator(==) => avd2_equals_avd2
        procedure, public    :: as_string => as_string_d2
        procedure, public    :: print => print_avd_d2
    end type avd_d2

    type, extends(avd_d2) :: avd_d3
        real(8) :: d3 = 0
        contains
        procedure            :: avd3_equals_avd3
        generic, public      :: operator(==) => avd3_equals_avd3
        procedure, public    :: as_string => as_string_d3
    end type avd_d3

    type, extends(avd_d3) :: avd_d4
        real(8) :: d4 = 0
        contains
        procedure            :: avd4_equals_avd4
        generic, public      :: operator(==) => avd4_equals_avd4
        procedure, public    :: as_string => as_string_d4
    end type avd_d4

    interface assignment(=)
        module procedure :: set_d1_from_d2, set_d2_from_d3, set_d3_from_d4, set_v
    end interface

    interface operator(**)
        module procedure :: d0_pow_i, d0_pow_r
        module procedure :: d1_pow_i, d1_pow_r
        module procedure :: d2_pow_i, d2_pow_r
        module procedure :: d3_pow_i, d3_pow_r
        module procedure :: d4_pow_i, d4_pow_r
    end interface

    interface operator(+)
        module procedure :: d0_plus_i, d0_plus_r, i_plus_d0, r_plus_d0, d0_plus_d0
        module procedure :: d1_plus_i, d1_plus_r, i_plus_d1, r_plus_d1, d1_plus_d1
        module procedure :: d2_plus_i, d2_plus_r, i_plus_d2, r_plus_d2, d2_plus_d2
        module procedure :: d3_plus_i, d3_plus_r, i_plus_d3, r_plus_d3, d3_plus_d3
        module procedure :: d4_plus_i, d4_plus_r, i_plus_d4, r_plus_d4, d4_plus_d4
    end interface

    interface operator(-)
        module procedure :: minus_d0,   minus_d1,   minus_d2 ,   minus_d3,   minus_d4
        module procedure :: d0_minus_i, d0_minus_r, i_minus_d0, r_minus_d0, d0_minus_d0
        module procedure :: d1_minus_i, d1_minus_r, i_minus_d1, r_minus_d1, d1_minus_d1
        module procedure :: d2_minus_i, d2_minus_r, i_minus_d2, r_minus_d2, d2_minus_d2
        module procedure :: d3_minus_i, d3_minus_r, i_minus_d3, r_minus_d3, d3_minus_d3
        module procedure :: d4_minus_i, d4_minus_r, i_minus_d4, r_minus_d4, d4_minus_d4
    end interface

    interface operator(*)
        module procedure :: d0_times_i, d0_times_r, i_times_d0, r_times_d0, d0_times_d0
        module procedure :: d1_times_i, d1_times_r, i_times_d1, r_times_d1, d1_times_d1
        module procedure :: d2_times_i, d2_times_r, i_times_d2, r_times_d2, d2_times_d2
        module procedure :: d3_times_i, d3_times_r, i_times_d3, r_times_d3, d3_times_d3
        module procedure :: d4_times_i, d4_times_r, i_times_d4, r_times_d4, d4_times_d4
    end interface

    interface operator( / )
        module function d0_over_i(obj, a) result(r)
            type(avd_b) :: r
            type(avd_b), intent(in) :: obj
            integer, intent(in)     :: a
        end function d0_over_i

        module function d0_over_r(obj, a) result(r)
            type(avd_b) :: r
            type(avd_b), intent(in) :: obj
            real(8), intent(in)     :: a
        end function d0_over_r

        module function i_over_d0(a, obj) result(r)
            type(avd_b) :: r
            type(avd_b), intent(in) :: obj
            integer, intent(in)     :: a
        end function i_over_d0

        module function r_over_d0(a, obj) result(r)
            type(avd_b) :: r
            type(avd_b), intent(in) :: obj
            real(8), intent(in)     :: a
        end function r_over_d0

        module function d1_over_i(obj, a) result(r)
            type(avd_d1) :: r
            type(avd_d1), intent(in) :: obj
            integer, intent(in)     :: a
        end function d1_over_i

        module function d1_over_r(obj, a) result(r)
            type(avd_d1) :: r
            type(avd_d1), intent(in) :: obj
            real(8), intent(in)     :: a
        end function d1_over_r

        module function i_over_d1(a, obj) result(r)
            type(avd_d1) :: r
            type(avd_d1), intent(in) :: obj
            integer, intent(in)     :: a
        end function i_over_d1

        module function r_over_d1(a, obj) result(r)
            type(avd_d1) :: r
            type(avd_d1), intent(in) :: obj
            real(8), intent(in)     :: a
        end function r_over_d1

        module function d2_over_i(obj, a) result(r)
            type(avd_d2) :: r
            type(avd_d2), intent(in) :: obj
            integer, intent(in)     :: a
        end function d2_over_i

        module function d2_over_r(obj, a) result(r)
            type(avd_d2) :: r
            type(avd_d2), intent(in) :: obj
            real(8), intent(in)     :: a
        end function d2_over_r

        module function i_over_d2(a, obj) result(r)
            type(avd_d2) :: r
            type(avd_d2), intent(in) :: obj
            integer, intent(in)     :: a
        end function i_over_d2

        module function r_over_d2(a, obj) result(r)
            type(avd_d2) :: r
            type(avd_d2), intent(in) :: obj
            real(8), intent(in)     :: a
        end function r_over_d2

        module function d3_over_i(obj, a) result(r)
            type(avd_d3) :: r
            type(avd_d3), intent(in) :: obj
            integer, intent(in)     :: a
        end function d3_over_i

        module function d3_over_r(obj, a) result(r)
            type(avd_d3) :: r
            type(avd_d3), intent(in) :: obj
            real(8), intent(in)     :: a
        end function d3_over_r

        module function i_over_d3(a, obj) result(r)
            type(avd_d3) :: r
            type(avd_d3), intent(in) :: obj
            integer, intent(in)     :: a
        end function i_over_d3

        module function r_over_d3(a, obj) result(r)
            type(avd_d3) :: r
            type(avd_d3), intent(in) :: obj
            real(8), intent(in)     :: a
        end function r_over_d3

        module function d4_over_i(obj, a) result(r)
            type(avd_d4) :: r
            type(avd_d4), intent(in) :: obj
            integer, intent(in)     :: a
        end function d4_over_i

        module function d4_over_r(obj, a) result(r)
            type(avd_d4) :: r
            type(avd_d4), intent(in) :: obj
            real(8), intent(in)     :: a
        end function d4_over_r

        module function i_over_d4(a, obj) result(r)
            type(avd_d4) :: r
            type(avd_d4), intent(in) :: obj
            integer, intent(in)     :: a
        end function i_over_d4

        module function r_over_d4(a, obj) result(r)
            type(avd_d4) :: r
            type(avd_d4), intent(in) :: obj
            real(8), intent(in)     :: a
        end function r_over_d4

        module function d4_over_d4(a, b) result(r)
            type(avd_d4) :: r
            type(avd_d4), intent(in) :: a, b
        end function d4_over_d4

    end interface

    interface sin
        module procedure :: sin_d0, sin_d1, sin_d2, sin_d3, sin_d4
    end interface

    interface cos
        module procedure :: cos_d0, cos_d1, cos_d2, cos_d3, cos_d4
    end interface

    interface sinh
        module procedure :: sinh_d0, sinh_d1, sinh_d2, sinh_d3, sinh_d4
    end interface

    interface cosh
        module procedure :: cosh_d0, cosh_d1, cosh_d2, cosh_d3, cosh_d4
    end interface

    interface tanh
        module procedure :: tanh_d0, tanh_d1, tanh_d2, tanh_d3, tanh_d4
    end interface

    interface tan
        module procedure :: tan_d0, tan_d1, tan_d2, tan_d3, tan_d4
    end interface

    interface sqrt
        module procedure :: sqrt_d0, sqrt_d1, sqrt_d2, sqrt_d3, sqrt_d4
    end interface

    interface exp
        module procedure :: exp_d0, exp_d1, exp_d2, exp_d3, exp_d4
    end interface

    interface log
        module procedure :: log_d0, log_d1, log_d2, log_d3, log_d4
    end interface

    interface log10
        module procedure :: log10_d0, log10_d1, log10_d2, log10_d3, log10_d4
    end interface

contains

    subroutine init

        f_map(0,sin_f)%f_ptr => d0_sin
        f_map(1,sin_f)%f_ptr => d1_sin
        f_map(2,sin_f)%f_ptr => d2_sin
        f_map(3,sin_f)%f_ptr => d3_sin
        f_map(4,sin_f)%f_ptr => d4_sin

        f_map(0,cos_f)%f_ptr => d0_cos
        f_map(1,cos_f)%f_ptr => d1_cos
        f_map(2,cos_f)%f_ptr => d2_cos
        f_map(3,cos_f)%f_ptr => d3_cos
        f_map(4,cos_f)%f_ptr => d4_cos

        f_map(0,tan_f)%f_ptr => d0_tan
        f_map(1,tan_f)%f_ptr => d1_tan
        f_map(2,tan_f)%f_ptr => d2_tan
        f_map(3,tan_f)%f_ptr => d3_tan
        f_map(4,tan_f)%f_ptr => d4_tan

        f_map(0,sinh_f)%f_ptr => d0_sinh
        f_map(1,sinh_f)%f_ptr => d1_sinh
        f_map(2,sinh_f)%f_ptr => d2_sinh
        f_map(3,sinh_f)%f_ptr => d3_sinh
        f_map(4,sinh_f)%f_ptr => d4_sinh

        f_map(0,cosh_f)%f_ptr => d0_cosh
        f_map(1,cosh_f)%f_ptr => d1_cosh
        f_map(2,cosh_f)%f_ptr => d2_cosh
        f_map(3,cosh_f)%f_ptr => d3_cosh
        f_map(4,cosh_f)%f_ptr => d4_cosh

        f_map(0,tanh_f)%f_ptr => d0_tanh
        f_map(1,tanh_f)%f_ptr => d1_tanh
        f_map(2,tanh_f)%f_ptr => d2_tanh
        f_map(3,tanh_f)%f_ptr => d3_tanh
        f_map(4,tanh_f)%f_ptr => d4_tanh

        f_map(0,sqrt_f)%f_ptr => d0_sqrt
        f_map(1,sqrt_f)%f_ptr => d1_sqrt
        f_map(2,sqrt_f)%f_ptr => d2_sqrt
        f_map(3,sqrt_f)%f_ptr => d3_sqrt
        f_map(4,sqrt_f)%f_ptr => d4_sqrt

        f_map(0,exp_f)%f_ptr => d0_exp
        f_map(1,exp_f)%f_ptr => d1_exp
        f_map(2,exp_f)%f_ptr => d2_exp
        f_map(3,exp_f)%f_ptr => d3_exp
        f_map(4,exp_f)%f_ptr => d4_exp

        f_map(0,log_f)%f_ptr => d0_log
        f_map(1,log_f)%f_ptr => d1_log
        f_map(2,log_f)%f_ptr => d2_log
        f_map(3,log_f)%f_ptr => d3_log
        f_map(4,log_f)%f_ptr => d4_log

        f_map(0,log10_f)%f_ptr => d0_log10
        f_map(1,log10_f)%f_ptr => d1_log10
        f_map(2,log10_f)%f_ptr => d2_log10
        f_map(3,log10_f)%f_ptr => d3_log10
        f_map(4,log10_f)%f_ptr => d4_log10

    end subroutine init

    pure function d0_times_d0(a, b) result(r)
        type(avd_b) :: r
        type(avd_b), intent(in) :: a, b
        r%v = a%v * b%v
    end function d0_times_d0

    pure function d1_times_d1(a, b) result(r)
        type(avd_d1) :: r
        type(avd_d1), intent(in) :: a, b
        r%avd_b = a%avd_b * b%avd_b
        associate(u=>a%v, du=>a%d1, v=>b%v, dv=>b%d1)
            r%d1 = u*dv + v*du
        end associate
    end function d1_times_d1

    pure function d2_times_d2(a, b) result(r)
        type(avd_d2) :: r
        type(avd_d2), intent(in) :: a, b
        r%avd_d1 = a%avd_d1 * b%avd_d1
        associate(u=>a%v, du=>a%d1, d2u=>a%d2, v=>b%v, dv=>b%d1, d2v=>b%d2)
            r%d2 = u*d2v + 2*du*dv + d2u*v
        end associate
    end function d2_times_d2

    pure function d3_times_d3(a, b) result(r)
        type(avd_d3) :: r
        type(avd_d3), intent(in) :: a, b
        r%avd_d2 = a%avd_d2 * b%avd_d2
        associate(u=>a%v, du=>a%d1, d2u=>a%d2, d3u=>a%d3, v=>b%v, dv=>b%d1, d2v=>b%d2, d3v=>b%d3)
            r%d3 = u*d3v + 3*du*d2v + 3*d2u*dv + d3u*v
        end associate
    end function d3_times_d3

    pure function d4_times_d4(a, b) result(r)
        type(avd_d4) :: r
        type(avd_d4), intent(in) :: a, b
        r%avd_d3 = a%avd_d3 * b%avd_d3
        associate(u=>a%v, du=>a%d1, d2u=>a%d2, d3u=>a%d3, d4u=>a%d4, v=>b%v, dv=>b%d1, d2v=>b%d2, d3v=>b%d3, d4v=>b%d4)
            r%d4 = u*d4v + 4*du*d3v + 6*d2u*d2v + 4*d3u*dv + d4u*v
        end associate
    end function d4_times_d4

    pure function d0_sin(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        r = sin(x)
    end function d0_sin

    pure function d1_sin(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        r = cos(x)
    end function d1_sin

    pure function d2_sin(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        r = -sin(x)
    end function d2_sin

    pure function d3_sin(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        r = -cos(x)
    end function d3_sin

    pure function d4_sin(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        r = d0_sin(x)
    end function d4_sin

    pure function d0_cos(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        r = cos(x)
    end function d0_cos

    pure function d1_cos(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        r = -sin(x)
    end function d1_cos

    pure function d2_cos(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        r = -cos(x)
    end function d2_cos

    pure function d3_cos(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        r = sin(x)
    end function d3_cos

    pure function d4_cos(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        r = d0_cos(x)
    end function d4_cos

    pure function d0_sinh(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        r = sinh(x)
    end function d0_sinh

    pure function d1_sinh(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        r = cosh(x)
    end function d1_sinh

    pure function d2_sinh(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        r = sinh(x)
    end function d2_sinh

    pure function d3_sinh(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        r = cosh(x)
    end function d3_sinh

    pure function d4_sinh(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        r = sinh(x)
    end function d4_sinh

    pure function d0_cosh(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        r = cosh(x)
    end function d0_cosh

    pure function d1_cosh(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        r = sinh(x)
    end function d1_cosh

    pure function d2_cosh(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        r = cosh(x)
    end function d2_cosh

    pure function d3_cosh(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        r = sinh(x)
    end function d3_cosh

    pure function d4_cosh(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        r = cosh(x)
    end function d4_cosh

    pure function d0_tanh(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        r = tanh(x)
    end function d0_tanh

    pure function d1_tanh(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        r = 1 - tanh(x)**2
    end function d1_tanh

    pure function d2_tanh(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        r = -2*d0_tanh(x)*d1_tanh(x)
    end function d2_tanh

    pure function d3_tanh(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        r = -2*(d1_tanh(x)**2 + d0_tanh(x)*d2_tanh(x))
    end function d3_tanh

    pure function d4_tanh(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        r = -2*(3*d1_tanh(x)*d2_tanh(x) + d0_tanh(x)*d3_tanh(x))
    end function d4_tanh

    pure function d0_sqrt(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        r = sqrt(x)
    end function d0_sqrt

    pure function d1_sqrt(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        r = 0.5*x**(-0.5)
    end function d1_sqrt

    pure function d2_sqrt(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        real(8), parameter :: c = (0.5)*(-0.5)
        r = c*x**(-1.5)
    end function d2_sqrt

    pure function d3_sqrt(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        real(8), parameter :: c = (0.5)*(-0.5)*(-1.5)
        r = c*x**(-2.5)
    end function d3_sqrt

    pure function d4_sqrt(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        real(8), parameter :: c = (0.5)*(-0.5)*(-1.5)*(-2.5)
        r = c*x**(-3.5)
    end function d4_sqrt

    pure function d0_tan(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        r = tan(x)
    end function d0_tan

    pure function d1_tan(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        real(8) :: y
        y = tan(x)
        r = 1 + y**2
    end function d1_tan

    pure function d2_tan(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        real(8) :: y
        y = tan(x)
        r = 2*y*d1_tan(x)
    end function d2_tan

    pure function d3_tan(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        real(8) :: y
        y = tan(x)
        r = 2*d1_tan(x)**2 + 2*y*d2_tan(x)
    end function d3_tan

    pure function d4_tan(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        real(8) :: y
        y = tan(x)
        r = 4*d1_tan(x)*d2_tan(x) + 2*(d1_tan(x)*d2_tan(x)+y*d3_tan(x))
    end function d4_tan

    pure function d0_exp(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        r = exp(x)
    end function d0_exp

    pure function d1_exp(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        r = exp(x)
    end function d1_exp

    pure function d2_exp(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        r = exp(x)
    end function d2_exp

    pure function d3_exp(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        r = exp(x)
    end function d3_exp

    pure function d4_exp(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        r = exp(x)
    end function d4_exp

    pure function d0_log(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        r = log(x)
    end function d0_log

    pure function d1_log(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        r = 1/x
    end function d1_log

    pure function d2_log(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        r = -1/x**2
    end function d2_log

    pure function d3_log(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        r = 2/x**3
    end function d3_log

    pure function d4_log(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        r = -6/x**4
    end function d4_log

    pure function d0_log10(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        r = log10(x)
    end function d0_log10

    pure function d1_log10(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        real(8), parameter :: b = 1/log(10.0)
        r = b/x
    end function d1_log10

    pure function d2_log10(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        real(8), parameter :: b = 1/log(10.0)
        r = -b/x**2
    end function d2_log10

    pure function d3_log10(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        real(8), parameter :: b = 1/log(10.0)
        r = 2*b/x**3
    end function d3_log10

    pure function d4_log10(x) result(r)
        real(8) :: r
        real(8), intent(in) :: x
        real(8), parameter :: b = 1/log(10.0)
        r = -6*b/x**4
    end function d4_log10

    pure function Q0_f(ft, av) result(r)
        type(avd_b) :: r
        integer, intent(in)     :: ft
        type(avd_b), intent(in) :: av
        r%v = f_map(0,ft)%f_ptr(av%v)
    end function Q0_f

    pure function Q1_f(ft, av) result(r)
        type(avd_d1) :: r
        integer, intent(in)      :: ft
        type(avd_d1), intent(in) :: av

        procedure(gen), pointer :: f1
        r%avd_b = Q0_f(ft, avd_b(av%v))
        f1 => f_map(1,ft)%f_ptr
        associate(g1=>av%d1, x=>av%v)
            r%d1 = f1(x)*av%d1
        end associate
    end function Q1_f

    pure function Q2_f(ft, av) result(r)
        type(avd_d2) :: r
        integer, intent(in)      :: ft
        type(avd_d2), intent(in) :: av

        procedure(gen), pointer :: f1, f2
        r%avd_d1 = Q1_f(ft, avd_d1(av%v, av%d1))
        f1 => f_map(1,ft)%f_ptr
        f2 => f_map(2,ft)%f_ptr
        associate(g1=>av%d1, g2=>av%d2, x=>av%v)
            r%d2 = f2(x)*g1**2 + f1(x)*g2
        end associate
    end function Q2_f

    pure function Q3_f(ft, av) result(r)
        type(avd_d3) :: r
        integer, intent(in)      :: ft
        type(avd_d3), intent(in) :: av

        procedure(gen), pointer :: f1, f2, f3
        r%avd_d2 = Q2_f(ft, avd_d2(av%v, av%d1, av%d2))
        f1 => f_map(1,ft)%f_ptr
        f2 => f_map(2,ft)%f_ptr
        f3 => f_map(3,ft)%f_ptr
        associate(g1=>av%d1, g2=>av%d2, g3=>av%d3, x=>av%v)
            r%d3 = f3(x)*g1**3 + 3*g1*g2*f2(x) + f1(x)*g3
        end associate
    end function Q3_f

    pure function Q4_f(ft, av) result(r)
        type(avd_d4) :: r
        integer, intent(in)      :: ft
        type(avd_d4), intent(in) :: av

        procedure(gen), pointer :: f1, f2, f3, f4
        r%avd_d3 = Q3_f(ft, avd_d3(av%v, av%d1, av%d2, av%d3))
        f1 => f_map(1,ft)%f_ptr
        f2 => f_map(2,ft)%f_ptr
        f3 => f_map(3,ft)%f_ptr
        f4 => f_map(4,ft)%f_ptr
        associate(g1=>av%d1, g2=>av%d2, g3=>av%d3, g4=>av%d4, x=>av%v)
            r%d4 = g4*f1(x) + 4*g3*g1*f2(x) + 3*g2**2*f2(x) + 6*g1**2*g2*f3(x) + g1**4*f4(x)
        end associate
    end function Q4_f

    pure function sin_d0(obj) result(r)
        type(avd_b), intent(in) :: obj
        type(avd_b)             ::r
        r%v = sin(obj%v)
    end function sin_d0

    pure function sin_d1(obj) result(r)
        type(avd_d1), intent(in) :: obj
        type(avd_d1) :: r
        r = Q1_f(sin_f, obj)
    end function sin_d1

    pure function sin_d2(obj) result(r)
        type(avd_d2), intent(in) :: obj
        type(avd_d2)             ::r
        r = Q2_f(sin_f,obj)
    end function sin_d2

    pure function sin_d3(obj) result(r)
        type(avd_d3), intent(in) :: obj
        type(avd_d3)             ::r
        r = Q3_f(sin_f,obj)
    end function sin_d3

    pure function sin_d4(obj) result(r)
        type(avd_d4), intent(in) :: obj
        type(avd_d4)             ::r
        r = Q4_f(sin_f,obj)
    end function sin_d4

    pure function cos_d0(obj) result(r)
        type(avd_b), intent(in) :: obj
        type(avd_b)             ::r
        r%v = cos(obj%v)
    end function cos_d0

    pure function cos_d1(obj) result(r)
        type(avd_d1), intent(in) :: obj
        type(avd_d1)             ::r
        r = Q1_f(cos_f,obj)
    end function cos_d1

    pure function cos_d2(obj) result(r)
        type(avd_d2), intent(in) :: obj
        type(avd_d2)             ::r
        r = Q2_f(cos_f,obj)
    end function cos_d2

    pure function cos_d3(obj) result(r)
        type(avd_d3), intent(in) :: obj
        type(avd_d3)             ::r
        r = Q3_f(cos_f,obj)
    end function cos_d3

    pure function cos_d4(obj) result(r)
        type(avd_d4), intent(in) :: obj
        type(avd_d4)             ::r
        r = Q4_f(cos_f,obj)
    end function cos_d4

    pure function tan_d0(obj) result(r)
        type(avd_b), intent(in) :: obj
        type(avd_b)             ::r
        r = tan(obj%v)
    end function tan_d0

    pure function tan_d1(obj) result(r)
        type(avd_d1), intent(in) :: obj
        type(avd_d1)             ::r
        r = Q1_f(tan_f,obj)
    end function tan_d1

    pure function tan_d2(obj) result(r)
        type(avd_d2), intent(in) :: obj
        type(avd_d2)             ::r
        r = Q2_f(tan_f,obj)
    end function tan_d2

    pure function tan_d3(obj) result(r)
        type(avd_d3), intent(in) :: obj
        type(avd_d3)             ::r
        r = Q3_f(tan_f,obj)
    end function tan_d3

    pure function tan_d4(obj) result(r)
        type(avd_d4), intent(in) :: obj
        type(avd_d4)             ::r
        r = Q4_f(tan_f,obj)
    end function tan_d4

    pure function sqrt_d0(obj) result(r)
        type(avd_b), intent(in) :: obj
        type(avd_b)             ::r
        r%v = sqrt(obj%v)
    end function sqrt_d0

    pure function sqrt_d1(obj) result(r)
        type(avd_d1), intent(in) :: obj
        type(avd_d1)             ::r
        r = Q1_f(sqrt_f,obj)
    end function sqrt_d1

    pure function sqrt_d2(obj) result(r)
        type(avd_d2), intent(in) :: obj
        type(avd_d2)             ::r
        r = Q2_f(sqrt_f,obj)
    end function sqrt_d2

    pure function sqrt_d3(obj) result(r)
        type(avd_d3), intent(in) :: obj
        type(avd_d3)             ::r
        r = Q3_f(sqrt_f,obj)
    end function sqrt_d3

    pure function sqrt_d4(obj) result(r)
        type(avd_d4), intent(in) :: obj
        type(avd_d4)             ::r
        r = Q4_f(sqrt_f,obj)
    end function sqrt_d4

    pure function sinh_d0(obj) result(r)
        type(avd_b), intent(in) :: obj
        type(avd_b)             ::r
        r%v = sinh(obj%v)
    end function sinh_d0

    pure function sinh_d1(obj) result(r)
        type(avd_d1), intent(in) :: obj
        type(avd_d1) :: r
        r = Q1_f(sinh_f, obj)
    end function sinh_d1

    pure function sinh_d2(obj) result(r)
        type(avd_d2), intent(in) :: obj
        type(avd_d2)             ::r
        r = Q2_f(sinh_f,obj)
    end function sinh_d2

    pure function sinh_d3(obj) result(r)
        type(avd_d3), intent(in) :: obj
        type(avd_d3)             ::r
        r = Q3_f(sinh_f,obj)
    end function sinh_d3

    pure function sinh_d4(obj) result(r)
        type(avd_d4), intent(in) :: obj
        type(avd_d4)             ::r
        r = Q4_f(sinh_f,obj)
    end function sinh_d4

    pure function cosh_d0(obj) result(r)
        type(avd_b), intent(in) :: obj
        type(avd_b)             ::r
        r%v = cosh(obj%v)
    end function cosh_d0

    pure function cosh_d1(obj) result(r)
        type(avd_d1), intent(in) :: obj
        type(avd_d1) :: r
        r = Q1_f(cosh_f, obj)
    end function cosh_d1

    pure function cosh_d2(obj) result(r)
        type(avd_d2), intent(in) :: obj
        type(avd_d2)             ::r
        r = Q2_f(cosh_f,obj)
    end function cosh_d2

    pure function cosh_d3(obj) result(r)
        type(avd_d3), intent(in) :: obj
        type(avd_d3)             ::r
        r = Q3_f(cosh_f,obj)
    end function cosh_d3

    pure function cosh_d4(obj) result(r)
        type(avd_d4), intent(in) :: obj
        type(avd_d4)             ::r
        r = Q4_f(cosh_f,obj)
    end function cosh_d4

    pure function tanh_d0(obj) result(r)
        type(avd_b), intent(in) :: obj
        type(avd_b)             ::r
        r%v = tanh(obj%v)
    end function tanh_d0

    pure function tanh_d1(obj) result(r)
        type(avd_d1), intent(in) :: obj
        type(avd_d1) :: r
        r = Q1_f(tanh_f, obj)
    end function tanh_d1

    pure function tanh_d2(obj) result(r)
        type(avd_d2), intent(in) :: obj
        type(avd_d2)             ::r
        r = Q2_f(tanh_f,obj)
    end function tanh_d2

    pure function tanh_d3(obj) result(r)
        type(avd_d3), intent(in) :: obj
        type(avd_d3)             ::r
        r = Q3_f(tanh_f,obj)
    end function tanh_d3

    pure function tanh_d4(obj) result(r)
        type(avd_d4), intent(in) :: obj
        type(avd_d4)             ::r
        r = Q4_f(tanh_f,obj)
    end function tanh_d4

    pure function exp_d0(obj) result(r)
        type(avd_b), intent(in) :: obj
        type(avd_b)             ::r
        r%v = exp(obj%v)
    end function exp_d0

    pure function exp_d1(obj) result(r)
        type(avd_d1), intent(in) :: obj
        type(avd_d1)             ::r
        r = Q1_f(exp_f,obj)
    end function exp_d1

    pure function exp_d2(obj) result(r)
        type(avd_d2), intent(in) :: obj
        type(avd_d2)             ::r
        r = Q2_f(exp_f,obj)
    end function exp_d2

    pure function exp_d3(obj) result(r)
        type(avd_d3), intent(in) :: obj
        type(avd_d3)             ::r
        r = Q3_f(exp_f,obj)
    end function exp_d3

    pure function exp_d4(obj) result(r)
        type(avd_d4), intent(in) :: obj
        type(avd_d4)             ::r
        r = Q4_f(exp_f,obj)
    end function exp_d4

    pure function log_d0(obj) result(r)
        type(avd_b), intent(in) :: obj
        type(avd_b)             ::r
        r%v = log(obj%v)
    end function log_d0

    pure function log_d1(obj) result(r)
        type(avd_d1), intent(in) :: obj
        type(avd_d1)             ::r
        r = Q1_f(log_f,obj)
    end function log_d1

    pure function log_d2(obj) result(r)
        type(avd_d2), intent(in) :: obj
        type(avd_d2)             ::r
        r = Q2_f(log_f,obj)
    end function log_d2

    pure function log_d3(obj) result(r)
        type(avd_d3), intent(in) :: obj
        type(avd_d3)             ::r
        r = Q3_f(log_f,obj)
    end function log_d3

    pure function log_d4(obj) result(r)
        type(avd_d4), intent(in) :: obj
        type(avd_d4)             ::r
        r = Q4_f(log_f,obj)
    end function log_d4

    pure function log10_d0(obj) result(r)
        type(avd_b), intent(in) :: obj
        type(avd_b)             ::r
        r%v = log(obj%v)
    end function log10_d0

    pure function log10_d1(obj) result(r)
        type(avd_d1), intent(in) :: obj
        type(avd_d1)             ::r
        r = Q1_f(log10_f,obj)
    end function log10_d1

    pure function log10_d2(obj) result(r)
        type(avd_d2), intent(in) :: obj
        type(avd_d2)             ::r
        r = Q2_f(log10_f,obj)
    end function log10_d2

    pure function log10_d3(obj) result(r)
        type(avd_d3), intent(in) :: obj
        type(avd_d3)             ::r
        r = Q3_f(log10_f,obj)
    end function log10_d3

    pure function log10_d4(obj) result(r)
        type(avd_d4), intent(in) :: obj
        type(avd_d4)             ::r
        r = Q4_f(log10_f,obj)
    end function log10_d4

    pure function avd1_equals_avd1(this, a) result(r)
        logical :: r
        class(avd_d1), intent(in) :: this
        type(avd_d1), intent(in) :: a
        r =  (abs(this%v - a%v) < 1.0e-6 .and. abs(this%d1 - a%d1) < 1.0e-6)
    end function avd1_equals_avd1

    pure function avd2_equals_avd2(this, a) result(r)
        logical :: r
        class(avd_d2), intent(in) :: this
        type(avd_d2), intent(in) :: a
        r =  (this%avd_d1 == a%avd_d1) .and. abs(this%d2 - a%d2) < 1.0e-6
    end function avd2_equals_avd2

    pure function avd3_equals_avd3(this, a) result(r)
        logical :: r
        class(avd_d3), intent(in) :: this
        type(avd_d3), intent(in) :: a
        r =  (this%avd_d2 == a%avd_d2) .and. abs(this%d3 - a%d3) < 1.0e-6
    end function avd3_equals_avd3

    pure function avd4_equals_avd4(this, a) result(r)
        logical :: r
        class(avd_d4), intent(in) :: this
        type(avd_d4), intent(in) :: a
        r =  (this%avd_d3 == a%avd_d3) .and. abs(this%d4 - a%d4) < 1.0e-6
    end function avd4_equals_avd4

    subroutine print_avd_d2(this, str)
        class(avd_d2), intent(in) :: this
        character(len=*), intent(in)  :: str
        character(len=200), target :: buff
        character(len=:), pointer  :: c
        c => buff(1:)
        write(c,fmt='(f0.4,a,f0.4)') this%v,':',this%d1
        c => buff(len_trim(buff):)
        write(c,fmt='(a,f0.4)') ',',this%d2
        write(*,'(a)') str//trim(buff)
    end subroutine print_avd_d2

    pure function as_string_d1(this) result(r)
        class(avd_d1), intent(in) :: this
        character(len=:), allocatable :: r
        character(len=200), target :: buff
        character(len=:), pointer  :: c
        c => buff(1:)
        write(c,fmt='(2(a,f0.6))') '[',this%v,':',this%d1
        c => buff(len_trim(buff):)
        write(c,fmt='(a)') ']'
        r = trim(buff)
    end function as_string_d1

    pure function as_string_d2(this) result(r)
        class(avd_d2), intent(in) :: this
        character(len=:), allocatable :: r
        character(len=200), target :: buff
        character(len=:), pointer  :: c
        c => buff(1:)
        write(c,fmt='(2(a,f0.6))') '[',this%v,':',this%d1
        c => buff(len_trim(buff):)
        write(c,fmt='(a,f0.6,a)') ',',this%d2,']'
        r = trim(buff)
    end function as_string_d2

    pure function as_string_d3(this) result(r)
        class(avd_d3), intent(in) :: this
        character(len=:), allocatable :: r
        character(len=200), target :: buff
        character(len=:), pointer  :: c
        c => buff(1:)
        write(c,fmt='(3(a,f0.6))') '[',this%v,':',this%d1,',',this%d2
        c => buff(len_trim(buff):)
        write(c,fmt='(a,f0.6,a)') ',',this%d3,']'
        r = trim(buff)
    end function as_string_d3

    pure function as_string_d4(this) result(r)
        class(avd_d4), intent(in) :: this
        character(len=:), allocatable :: r
        character(len=200), target :: buff
        character(len=:), pointer  :: c
        c => buff(1:)
        write(c,fmt='(4(a,f0.6))') '[',this%v,':',this%d1,',',this%d2,',',this%d3
        c => buff(len_trim(buff):)
        write(c,fmt='(a,f0.6,a)') ',',this%d4,']'
        r = trim(buff)
    end function as_string_d4

    ! Times - d0  =============================================================

    pure function i_times_d0(this, a) result(r)
        type(avd_b), intent(in) :: this
        integer, intent(in)       :: a
        type(avd_b) :: r
        r%v = this%v * a
    end function i_times_d0

    pure function r_times_d0(this, a) result(r)
        type(avd_b), intent(in) :: this
        real(8), intent(in)       :: a
        type(avd_b) :: r
        r%v = this%v * a
    end function r_times_d0

    pure function d0_times_i(a, obj) result(r)
        type(avd_b), intent(in) :: obj
        integer, intent(in)       :: a
        type(avd_b) :: r
        r = obj*a
    end function d0_times_i

    pure function d0_times_r(a, obj) result(r)
        type(avd_b), intent(in) :: obj
        real(8), intent(in)       :: a
        type(avd_b) :: r
        r = obj*a
    end function d0_times_r

    ! Times - d1  =============================================================

    pure function i_times_d1(this, a) result(r)
        type(avd_d1), intent(in) :: this
        integer, intent(in)       :: a
        type(avd_d1) :: r
        r%v = this%v * a
        r%d1 = this%d1 * a
    end function i_times_d1

    pure function r_times_d1(this, a) result(r)
        type(avd_d1), intent(in) :: this
        real(8), intent(in)       :: a
        type(avd_d1) :: r
        r%v = this%v * a
        r%d1 = this%d1 * a
    end function r_times_d1

    pure function d1_times_i(a, obj) result(r)
        type(avd_d1), intent(in) :: obj
        integer, intent(in)       :: a
        type(avd_d1) :: r
        r = obj*a
    end function d1_times_i

    pure function d1_times_r(a, obj) result(r)
        type(avd_d1), intent(in) :: obj
        real(8), intent(in)       :: a
        type(avd_d1) :: r
        r = obj*a
    end function d1_times_r

    ! Times - d2  =============================================================

    pure function i_times_d2(this, a) result(r)
        type(avd_d2), intent(in) :: this
        integer, intent(in)       :: a
        type(avd_d2) :: r
        r%avd_d1 = this%avd_d1 * a
        r%d2 = this%d2 * a
    end function i_times_d2

    pure function r_times_d2(this, a) result(r)
        type(avd_d2), intent(in) :: this
        real(8), intent(in)       :: a
        type(avd_d2) :: r
        r%avd_d1 = this%avd_d1 * a
        r%d2 = this%d2 * a
    end function r_times_d2

    pure function d2_times_i(a, obj) result(r)
        type(avd_d2), intent(in) :: obj
        integer, intent(in)       :: a
        type(avd_d2) :: r
        r = obj*a
    end function d2_times_i

    pure function d2_times_r(a, obj) result(r)
        type(avd_d2), intent(in) :: obj
        real(8), intent(in)       :: a
        type(avd_d2) :: r
        r = obj*a
    end function d2_times_r

    ! Times - d3  =============================================================

    pure function i_times_d3(this, a) result(r)
        type(avd_d3), intent(in) :: this
        integer, intent(in)       :: a
        type(avd_d3) :: r
        r%avd_d2 = this%avd_d2 * a
        r%d3 = this%d3 * a
    end function i_times_d3

    pure function r_times_d3(this, a) result(r)
        type(avd_d3), intent(in) :: this
        real(8), intent(in)       :: a
        type(avd_d3) :: r
        r%avd_d2 = this%avd_d2 * a
        r%d3 = this%d3 * a
    end function r_times_d3

    pure function d3_times_i(a, obj) result(r)
        type(avd_d3), intent(in) :: obj
        integer, intent(in)       :: a
        type(avd_d3) :: r
        r = obj*a
    end function d3_times_i

    pure function d3_times_r(a, obj) result(r)
        type(avd_d3), intent(in) :: obj
        real(8), intent(in)       :: a
        type(avd_d3) :: r
        r = obj*a
    end function d3_times_r

    ! Times - d4  =============================================================

    pure function i_times_d4(this, a) result(r)
        type(avd_d4), intent(in) :: this
        integer, intent(in)       :: a
        type(avd_d4) :: r
        r%avd_d3 = this%avd_d3 * a
        r%d4 = this%d4 * a
    end function i_times_d4

    pure function r_times_d4(this, a) result(r)
        type(avd_d4), intent(in) :: this
        real(8), intent(in)       :: a
        type(avd_d4) :: r
        r%avd_d3 = this%avd_d3 * a
        r%d4 = this%d4 * a
    end function r_times_d4

    pure function d4_times_i(a, obj) result(r)
        type(avd_d4), intent(in) :: obj
        integer, intent(in)       :: a
        type(avd_d4) :: r
        r = obj*a
    end function d4_times_i

    pure function d4_times_r(a, obj) result(r)
        type(avd_d4), intent(in) :: obj
        real(8), intent(in)       :: a
        type(avd_d4) :: r
        r = obj*a
    end function d4_times_r

    ! minus  d0  =================================================================

    pure function d0_minus_d0(a, b) result(r)
        type(avd_b) :: r
        type(avd_b), intent(in) :: a, b
        r%v = a%v - b%v
    end function d0_minus_d0

    pure function minus_d0(this) result(r)
        type(avd_b), intent(in) :: this
        type(avd_b) :: r
        r%v = -this%v
    end function minus_d0

    pure function i_minus_d0(a, obj) result(r)
        type(avd_b), intent(in) :: obj
        integer, intent(in)     :: a
        type(avd_b) :: r
        r%v = a - obj%v
    end function i_minus_d0

    pure function r_minus_d0(a, obj) result(r)
        type(avd_b), intent(in) :: obj
        real(8), intent(in)     :: a
        type(avd_b) :: r
        r%v = a - obj%v
    end function r_minus_d0

    pure function d0_minus_i(obj, a) result(r)
        type(avd_b), intent(in) :: obj
        integer, intent(in)     :: a
        type(avd_b) :: r
        r = -(a - obj)
    end function d0_minus_i

    pure function d0_minus_r(obj, a) result(r)
        type(avd_b), intent(in) :: obj
        real(8), intent(in)     :: a
        type(avd_b) :: r
        r = -(a - obj)
    end function d0_minus_r

    ! minus  d1  =================================================================

    pure function d1_minus_d1(a, b) result(r)
        type(avd_d1) :: r
        type(avd_d1), intent(in) :: a, b
        r%avd_b = a%avd_b - b%avd_b
        r%d1 = a%d1 - b%d1
    end function d1_minus_d1

    pure function minus_d1(this) result(r)
        type(avd_d1), intent(in) :: this
        type(avd_d1) :: r
        r%v = -this%v
        r%d1 = -this%d1
    end function minus_d1

    pure function i_minus_d1(this, a) result(r)
        type(avd_d1), intent(in) :: this
        integer, intent(in)       :: a
        type(avd_d1) :: r
        r%v = this%v - a
        r%d1 = this%d1
    end function i_minus_d1

    pure function r_minus_d1(this, a) result(r)
        type(avd_d1), intent(in) :: this
        real(8), intent(in)       :: a
        type(avd_d1) :: r
        r%v = this%v - a
        r%d1 = this%d1
    end function r_minus_d1

    pure function d1_minus_i(a, obj) result(r)
        type(avd_d1), intent(in) :: obj
        integer, intent(in)       :: a
        type(avd_d1) :: r
        r%v = a - obj%v
        r%d1 = -obj%d1
    end function d1_minus_i

    pure function d1_minus_r(a, obj) result(r)
        type(avd_d1), intent(in) :: obj
        real(8), intent(in)       :: a
        type(avd_d1) :: r
        r%v = a - obj%v
        r%d1 = -obj%d1
    end function d1_minus_r

    ! minus  d2  =================================================================

    pure function d2_minus_d2(a, b) result(r)
        type(avd_d2) :: r
        type(avd_d2), intent(in) :: a, b
        r%avd_d1 = a%avd_d1 - b%avd_d1
        r%d2 = a%d2 - b%d2
    end function d2_minus_d2

    pure function minus_d2(this) result(r)
        type(avd_d2), intent(in) :: this
        type(avd_d2) :: r
        r%avd_d1 = -this%avd_d1
        r%d2 = -this%d2
    end function minus_d2

    pure function i_minus_d2(a, obj) result(r)
        type(avd_d2), intent(in) :: obj
        integer, intent(in)       :: a
        type(avd_d2) :: r
        r%avd_d1 = a - obj%avd_d1
        r%d2 = -obj%d2
    end function i_minus_d2

    pure function r_minus_d2(a, obj) result(r)
        type(avd_d2), intent(in) :: obj
        real(8), intent(in)      :: a
        type(avd_d2) :: r
        r%avd_d1 = a - obj%avd_d1
        r%d2 = -obj%d2
    end function r_minus_d2

    pure function d2_minus_i(obj, a) result(r)
        type(avd_d2), intent(in) :: obj
        integer, intent(in)       :: a
        type(avd_d2) :: r
        r = -(a - obj)
    end function d2_minus_i

    pure function d2_minus_r(obj, a) result(r)
        type(avd_d2), intent(in) :: obj
        real(8), intent(in)       :: a
        type(avd_d2) :: r
        r = -(a - obj)
    end function d2_minus_r

    ! minus  d3  =================================================================

    pure function d3_minus_d3(a, b) result(r)
        type(avd_d3) :: r
        type(avd_d3), intent(in) :: a, b
        r%avd_d2 = a%avd_d2 - b%avd_d2
        r%d3 = a%d3 - b%d3
    end function d3_minus_d3

    pure function minus_d3(this) result(r)
        type(avd_d3), intent(in) :: this
        type(avd_d3) :: r
        r%avd_d2 = -this%avd_d2
        r%d3 = -this%d3
    end function minus_d3

    pure function i_minus_d3(a, obj) result(r)
        type(avd_d3), intent(in) :: obj
        integer, intent(in)      :: a
        type(avd_d3) :: r
        r%avd_d2 = a - obj%avd_d2
        r%d3 = -obj%d3
    end function i_minus_d3

    pure function r_minus_d3(a, obj) result(r)
        type(avd_d3), intent(in) :: obj
        real(8), intent(in)       :: a
        type(avd_d3) :: r
        r%avd_d2 = a - obj%avd_d2
        r%d3 = -obj%d3
    end function r_minus_d3

    pure function d3_minus_i(obj, a) result(r)
        type(avd_d3), intent(in) :: obj
        integer, intent(in)       :: a
        type(avd_d3) :: r
        r = -(a - obj)
    end function d3_minus_i

    pure function d3_minus_r(obj, a) result(r)
        type(avd_d3), intent(in) :: obj
        real(8), intent(in)       :: a
        type(avd_d3) :: r
        r = -(a - obj)
    end function d3_minus_r

    ! minus  d4  =================================================================

    pure function d4_minus_d4(a, b) result(r)
        type(avd_d4) :: r
        type(avd_d4), intent(in) :: a, b
        r%avd_d3 = a%avd_d3 - b%avd_d3
        r%d4 = a%d4 - b%d4
    end function d4_minus_d4

    pure function minus_d4(this) result(r)
        type(avd_d4), intent(in) :: this
        type(avd_d4) :: r
        r%avd_d3 = -this%avd_d3
        r%d4 = -this%d4
    end function minus_d4

    pure function i_minus_d4(a, obj) result(r)
        type(avd_d4), intent(in) :: obj
        integer, intent(in)      :: a
        type(avd_d4) :: r
        r%avd_d3 = a - obj%avd_d3
        r%d4 = -obj%d4
    end function i_minus_d4

    pure function r_minus_d4(a, obj) result(r)
        type(avd_d4), intent(in) :: obj
        real(8), intent(in)      :: a
        type(avd_d4) :: r
        r%avd_d3 = a - obj%avd_d3
        r%d4 = -obj%d4
    end function r_minus_d4

    pure function d4_minus_i(obj, a) result(r)
        type(avd_d4), intent(in) :: obj
        integer, intent(in)       :: a
        type(avd_d4) :: r
        r = -(a - obj)
    end function d4_minus_i

    pure function d4_minus_r(obj, a) result(r)
        type(avd_d4), intent(in) :: obj
        real(8), intent(in)       :: a
        type(avd_d4) :: r
        r = -(a - obj)
    end function d4_minus_r

    ! set  =================================================================
    pure subroutine set_v(this, v)
        class(avd_b), intent(inout) :: this
        real(8), intent(in)         :: v
        this%v = v
    end subroutine set_v

    pure subroutine set_d1_from_d2(this, v)
        type(avd_d1), intent(inout) :: this
        type(avd_d2), intent(in)    :: v
        this%v = v%v
        this%d1 = v%d1
    end subroutine set_d1_from_d2

    pure subroutine set_d2_from_d3(this, v)
        type(avd_d2), intent(inout) :: this
        type(avd_d3), intent(in)    :: v
        this%avd_d1 = avd_d1(v%v,v%d1)
        this%d2 = v%d2
    end subroutine set_d2_from_d3

    pure subroutine set_d3_from_d4(this, v)
        type(avd_d3), intent(inout) :: this
        type(avd_d4), intent(in)    :: v
        this%avd_d2 = avd_d2(v%v,v%d1,v%d2)
        this%d3 = v%d3
    end subroutine set_d3_from_d4

    pure subroutine set_from_avd1(this, v)
        class(avd_d1), intent(inout) :: this
        type(avd_d1), intent(in)    :: v
        this%v = v%v
        this%d1 = v%d1
    end subroutine set_from_avd1

    pure subroutine set_from_avd2(this, v)
        class(avd_d2), intent(inout) :: this
        type(avd_d2), intent(in)    :: v
        this%avd_d1 = avd_d1(v%v,v%d1)
        this%d2 = v%d2
    end subroutine set_from_avd2

    pure subroutine set_from_avd3(this, v)
        class(avd_d3), intent(inout) :: this
        type(avd_d3), intent(in)    :: v
        this%avd_d2 = avd_d2(v%v,v%d1,v%d2)
        this%d3 = v%d3
    end subroutine set_from_avd3

    pure subroutine set_from_avd4(this, v)
        class(avd_d4), intent(inout) :: this
        type(avd_d4), intent(in)    :: v
        this%avd_d3 = avd_d3(v%v,v%d1,v%d2,v%d3)
        this%d4 = v%d4
    end subroutine set_from_avd4

    ! Power =================================================================
    pure function d0_pow_i(obj, n) result(r)
        type(avd_b) :: r
        type(avd_b), intent(in) :: obj
        integer, intent(in)     :: n
        r%v = obj%v**n
    end function d0_pow_i

    pure function d0_pow_r(obj, x) result(r)
        type(avd_b) :: r
        type(avd_b), intent(in) :: obj
        real(8), intent(in)     :: x
        r%v = obj%v**x
    end function d0_pow_r

    pure function d1_pow_i(obj, n) result(r)
        type(avd_d1) :: r
        type(avd_d1), intent(in) :: obj
        integer, intent(in)     :: n
        r = obj**(real(n,8))
    end function d1_pow_i

    pure function d1_pow_r(obj, x) result(r)
        type(avd_d1) :: r
        type(avd_d1), intent(in) :: obj
        real(8), intent(in)     :: x
        real(8) :: f1
        r%avd_b = obj%avd_b**x
        f1 = x*obj%v**(x-1)
        associate(g1=>obj%d1)
            r%d1 = f1*g1
        end associate
    end function d1_pow_r

    pure function d2_pow_i(obj, n) result(r)
        type(avd_d2) :: r
        type(avd_d2), intent(in) :: obj
        integer, intent(in)     :: n
        r = obj**(real(n,8))
    end function d2_pow_i

    pure function d2_pow_r(obj, x) result(r)
        type(avd_d2) :: r
        type(avd_d2), intent(in) :: obj
        real(8), intent(in)     :: x
        real(8) :: f1, f2
        r%avd_d1 = obj%avd_d1**x
        f1 = x*obj%v**(x-1)
        f2 = x*(x-1)*obj%v**(x-2)
        associate(g1=>obj%d1, g2=>obj%d2)
            r%d2 = f2*g1**2 + f1*g2
        end associate
    end function d2_pow_r

    pure function d3_pow_i(obj, n) result(r)
        type(avd_d3) :: r
        type(avd_d3), intent(in) :: obj
        integer, intent(in)      :: n
        r = obj**(real(n,8))
    end function d3_pow_i

    pure function d3_pow_r(obj, x) result(r)
        type(avd_d3) :: r
        type(avd_d3), intent(in) :: obj
        real(8), intent(in)     :: x
        real(8) :: f1, f2, f3
        r%avd_d2 = obj%avd_d2**x
        f1 = x*obj%v**(x-1)
        f2 = x*(x-1)*obj%v**(x-2)
        f3 = x*(x-1)*(x-2)*obj%v**(x-3)
        associate(g1=>obj%d1, g2=>obj%d2, g3=>obj%d3)
            r%d3 = f3*g1**3 + 3*g1*g2*f2 + f1*g3
        end associate
    end function d3_pow_r

    pure function d4_pow_i(obj, n) result(r)
        type(avd_d4) :: r
        type(avd_d4), intent(in) :: obj
        integer, intent(in)     :: n
        r = obj**(real(n,8))
   end function d4_pow_i

    pure function d4_pow_r(obj, x) result(r)
        type(avd_d4) :: r
        type(avd_d4), intent(in) :: obj
        real(8), intent(in)     :: x
        real(8) :: f1, f2, f3, f4
        r%avd_d3 = obj%avd_d3**x
        f1 = x*obj%v**(x-1)
        f2 = x*(x-1)*obj%v**(x-2)
        f3 = x*(x-1)*(x-2)*obj%v**(x-3)
        f4 = x*(x-1)*(x-2)*(x-3)*obj%v**(x-4)
        associate(g1=>obj%d1, g2=>obj%d2, g3=>obj%d3, g4=>obj%d4)
            r%d4 = g4*f1 + 4*g3*g1*f2 + 3*g2**2*f2 + 6*g1**2*g2*f3 + g1**4*f4
        end associate
    end function d4_pow_r

    ! Plus  =================================================================

    pure function d0_plus_d0(a, b) result(r)
        type(avd_b) :: r
        type(avd_b), intent(in) :: a, b
        r%v = a%v + b%v
    end function d0_plus_d0

    pure function d0_plus_i(obj, n) result(r)
        type(avd_b) :: r
        type(avd_b), intent(in) :: obj
        integer, intent(in)     :: n
        r%v = obj%v + n
    end function d0_plus_i

    pure function d0_plus_r(obj, x) result(r)
        type(avd_b) :: r
        type(avd_b), intent(in) :: obj
        real(8), intent(in)     :: x
        r%v = obj%v + x
    end function d0_plus_r

    pure function i_plus_d0(n, obj) result(r)
        type(avd_b) :: r
        type(avd_b), intent(in) :: obj
        integer, intent(in)     :: n
        r%v = obj%v + n
    end function i_plus_d0

    pure function r_plus_d0(x, obj) result(r)
        type(avd_b) :: r
        type(avd_b), intent(in) :: obj
        real(8), intent(in)     :: x
        r%v = obj%v + x
    end function r_plus_d0

    pure function d1_plus_d1(a, b) result(r)
        type(avd_d1) :: r
        type(avd_d1), intent(in) :: a, b
        r%avd_b = a%avd_b + b%avd_b
        r%d1 = a%d1 + b%d1
    end function d1_plus_d1

    pure function d1_plus_i(obj, n) result(r)
        type(avd_d1) :: r
        type(avd_d1), intent(in) :: obj
        integer, intent(in)     :: n
        r%avd_b = obj%avd_b + n
        r%d1 = obj%d1
    end function d1_plus_i

    pure function d1_plus_r(obj, x) result(r)
        type(avd_d1) :: r
        type(avd_d1), intent(in) :: obj
        real(8), intent(in)     :: x
        r%avd_b = obj%avd_b + x
        r%d1 = obj%d1
    end function d1_plus_r

    pure function i_plus_d1(n, obj) result(r)
        type(avd_d1) :: r
        type(avd_d1), intent(in) :: obj
        integer, intent(in)     :: n
        r%avd_b = obj%avd_b + n
        r%d1 = obj%d1
    end function i_plus_d1

    pure function r_plus_d1(x, obj) result(r)
        type(avd_d1) :: r
        type(avd_d1), intent(in) :: obj
        real(8), intent(in)     :: x
        r%avd_b = obj%avd_b + x
        r%d1 = obj%d1
    end function r_plus_d1

    pure function d2_plus_d2(a, b) result(r)
        type(avd_d2) :: r
        type(avd_d2), intent(in) :: a, b
        r%avd_d1 = a%avd_d1 + b%avd_d1
        r%d2 = a%d2 + b%d2
    end function d2_plus_d2

    pure function d2_plus_i(obj, n) result(r)
        type(avd_d2) :: r
        type(avd_d2), intent(in) :: obj
        integer, intent(in)     :: n
        r%avd_d1 = obj%avd_d1 + n
        r%d2 = obj%d2
    end function d2_plus_i

    pure function d2_plus_r(obj, x) result(r)
        type(avd_d2) :: r
        type(avd_d2), intent(in) :: obj
        real(8), intent(in)     :: x
        r%avd_d1 = obj%avd_d1 + x
        r%d2 = obj%d2
    end function d2_plus_r

    pure function i_plus_d2(n, obj) result(r)
        type(avd_d2) :: r
        type(avd_d2), intent(in) :: obj
        integer, intent(in)     :: n
        r%avd_d1 = obj%avd_d1 + n
        r%d2 = obj%d2
    end function i_plus_d2

    pure function r_plus_d2(x, obj) result(r)
        type(avd_d2) :: r
        type(avd_d2), intent(in) :: obj
        real(8), intent(in)     :: x
        r%avd_d1 = obj%avd_d1 + x
        r%d2 = obj%d2
    end function r_plus_d2

    pure function d3_plus_d3(a, b) result(r)
        type(avd_d3) :: r
        type(avd_d3), intent(in) :: a, b
        r%avd_d2 = a%avd_d2 + b%avd_d2
        r%d3 = a%d3 + b%d3
    end function d3_plus_d3

    pure function d3_plus_i(obj, n) result(r)
        type(avd_d3) :: r
        type(avd_d3), intent(in) :: obj
        integer, intent(in)     :: n
        r%avd_d2 = obj%avd_d2 + n
        r%d3 = obj%d3
    end function d3_plus_i

    pure function d3_plus_r(obj, x) result(r)
        type(avd_d3) :: r
        type(avd_d3), intent(in) :: obj
        real(8), intent(in)     :: x
        r%avd_d2 = obj%avd_d2 + x
        r%d3 = obj%d3
    end function d3_plus_r

    pure function i_plus_d3(n, obj) result(r)
        type(avd_d3) :: r
        type(avd_d3), intent(in) :: obj
        integer, intent(in)     :: n
        r%avd_d2 = obj%avd_d2 + n
        r%d3 = obj%d3
    end function i_plus_d3

    pure function r_plus_d3(x, obj) result(r)
        type(avd_d3) :: r
        type(avd_d3), intent(in) :: obj
        real(8), intent(in)     :: x
        r%avd_d2 = obj%avd_d2 + x
        r%d3 = obj%d3
    end function r_plus_d3

    pure function d4_plus_d4(a, b) result(r)
        type(avd_d4) :: r
        type(avd_d4), intent(in) :: a, b
        r%avd_d3 = a%avd_d3 + b%avd_d3
        r%d4 = a%d4 + b%d4
    end function d4_plus_d4

    pure function d4_plus_i(obj, n) result(r)
        type(avd_d4) :: r
        type(avd_d4), intent(in) :: obj
        integer, intent(in)     :: n
        r%avd_d3 = obj%avd_d3 + n
        r%d4 = obj%d4
    end function d4_plus_i

    pure function d4_plus_r(obj, x) result(r)
        type(avd_d4) :: r
        type(avd_d4), intent(in) :: obj
        real(8), intent(in)     :: x
        r%avd_d3 = obj%avd_d3 + x
        r%d4 = obj%d4
    end function d4_plus_r

    pure function i_plus_d4(n, obj) result(r)
        type(avd_d4) :: r
        type(avd_d4), intent(in) :: obj
        integer, intent(in)     :: n
        r%avd_d3 = obj%avd_d3 + n
        r%d4 = obj%d4
    end function i_plus_d4

    pure function r_plus_d4(x, obj) result(r)
        type(avd_d4) :: r
        type(avd_d4), intent(in) :: obj
        real(8), intent(in)     :: x
        r%avd_d3 = obj%avd_d3 + x
        r%d4 = obj%d4
    end function r_plus_d4

end module AVD


C HAMILEIG.F - Gateway function to compute the eigenvalues of a
C              Hamiltonian matrix using the square-reduced approach
C              implemented in SLICOT routines MB03SD and MB04ZD.
C
C RELEASE 2.0 of SLICOT Basic Systems and Control Toolbox.
C Based on SLICOT RELEASE 5.7. Copyright (c) 2002-2020 NICONET e.V.
C
C Matlab call:
C   [Ao,QGo(,U)]       = Hamileig(A,QG,job(,compu,S)),        job = -1;
C   [WR,WI(,Ao,QGo,U)] = Hamileig(A,QG(,job,jobscl,compu,S)), job =  0,
C                                                          or job =  1.
C
C   [Ao,QGo(,U)]       = Hamileig(A,QG,-1(,compu,S))
C   [WR,WI(,Ao,QGo,U)] = Hamileig(A,QG(,0, jobscl,compu,S))
C   [WR,WI]            = Hamileig(A,QG, 1(,jobscl))
C
C Purpose:
C   To transform a Hamiltonian matrix
C
C             ( A   G  )
C         H = (      T )                                           (1)
C             ( Q  -A  )
C
C   (with G and Q symmetric matrices) into a square-reduced Hamiltonian
C   matrix
C
C              ( A'   G'  )
C         H' = (        T ),                                       (2)
C              ( Q'  -A'  )
C                                                               T
C   by an orthogonal symplectic similarity transformation H' = U H U,
C   where
C
C               (  U1   U2 )
C           U = (          ),                                      (3)
C               ( -U2   U1 )
C
C   and to compute the eigenvalues of H.  Therefore, H' is such that
C
C         2    ( A''   G'' )
C       H'  =  (         T ),                                      (4)
C              ( 0    A''  )
C
C   with A'' upper Hessenberg and G'' skew symmetric.  The square roots
C   of the eigenvalues of A'' = A'*A' + G'*Q' are the eigenvalues of H.
C
C Input parameters:
C   A      - the n-by-n matrix A.
C   QG     - an  n-by-(n+1) matrix containing the triangles of the
C            symmetric matrices Q and G, as follows:
C            the leading n-by-n lower triangular part contains the lower
C            triangle of the matrix Q, and the n-by-n upper triangular
C            part of the submatrix in the columns 2 to n+1 contains the
C            upper triangle of the matrix G of H in (1).
C            So, if i >= j, then Q(i,j) = Q(j,i) is stored in QG(i,j)
C            and G(i,j) = G(j,i) is stored in QG(j,i+1).
C            QG is an empty matrix if n = 0.
C   job    - (optional) scalar indicating the computation to be
C            performed, as follows:
C            =-1 :  compute the square-reduced matrix H' in (2);
C            = 0 :  compute the eigenvalues of H (default);
C            = 1 :  compute the eigenvalues of H, assuming that the
C                   given Hamiltonian matrix is already in the reduced
C                   form (2).
C   jobscl - (optional) if job >= 0, scalar specifying whether or not
C            balancing operations should be performed when computing the
C            eigenvalues of A'', as follows:
C            = 0 :  do not use balancing;
C            = 1 :  do scaling in order to equilibrate the rows
C                   and columns of A'' (default).
C            If job = -1, jobscl is not used.
C   compu  - (optional) if job <= 0, scalar indicating whether the
C            orthogonal symplectic similarity transformation matrix U is
C            returned or accumulated into an orthogonal symplectic
C            matrix, or if the transformation matrix is not required,
C            as follows:
C            = 0 :  U is not required (default);
C            = 1 :  on entry, U need not be set;
C                   on exit, U contains the orthogonal symplectic
C                   matrix U;
C            = 2 :  the orthogonal symplectic similarity transformations
C                   are accumulated into U;
C                   on input, U must contain an orthogonal symplectic
C                   matrix S;
C                   on exit, U contains S*U.
C            If job = 1, compu is not used.
C   S      - (optional) if job <= 0 and compu = 2, an n-by-2*n matrix
C            containing the first n rows of the given orthogonal
C            symplectic matrix S.
C
C Output parameters:
C   WR,WI  - if job >= 0, the n-vectors of real parts and imaginary
C            parts, respectively, of the n computed eigenvalues of H'
C            with non-negative real part. The remaining n eigenvalues
C            are the negatives of these eigenvalues.
C            Eigenvalues are stored in WR and WI in decreasing order of
C            magnitude of the real parts, i.e., WR(I) >= WR(I+1).
C            (In particular, an eigenvalue closest to the imaginary
C             axis is WR(N)+WI(N)i.)
C            In addition, eigenvalues with zero real part are sorted in
C            decreasing order of magnitude of imaginary parts.  Note
C            that non-real eigenvalues with non-zero real part appear
C            in complex conjugate pairs, but eigenvalues with zero real
C            part do not, in general, appear in complex conjugate
C            pairs.
C   Ao     - if job <= 0, the computed n-by-n submatrix A' of H' in (2).
C   QGo    - if job <= 0, the computed n-by-(n+1) matrix containing the
C            triangles of the symmetric matrices Q' and G' of H' in (2),
C            stored in the same way as the initial matrices Q and G.
C   U      - if job <= 0 and compu > 0, an n-by-2*n matrix containing
C            the first n rows of the computed orthogonal symplectic
C            matrix U.
C
C Contributor:
C   V. Sima, Research Institute for Informatics, Bucharest, Nov. 2002.
C
C Revisions:
C   V. Sima, Research Institute for Informatics, Bucharest, Apr. 2009,
C   Dec. 2012.
C
C **********************************************************************
C
      SUBROUTINE MEXFUNCTION( NLHS, PLHS, NRHS, PRHS )
C
C .. Mex-file interface parameters ..
      INTEGER           PLHS(*), PRHS(*)
      INTEGER*4         NLHS, NRHS
C
C .. Mex-file integer functions ..
      INTEGER           mxCreateDoubleMatrix, mxGetPr
      INTEGER*4         mxGetM, mxGetN, mxIsNumeric, mxIsComplex
C
C .. Scalar parameters used by SLICOT subroutines ..
      CHARACTER         COMPU, JOBSCL
      INTEGER           INFO, LDA, LDQG, LDU, LDWORK, N
C
C .. Allocatable arrays ..
C !Fortran 90/95 (Fixed dimensions should be used with Fortran 77.)
      DOUBLE PRECISION, ALLOCATABLE :: A(:,:), DWORK(:), QG(:,:),
     $                                 U(:,:), WI(:), WR(:)
C
C .. Local variables and constant dimension arrays ..
      CHARACTER*120     TEXT
      INTEGER           ICOMP, IJOBS, IP, ITMP, JOB
      DOUBLE PRECISION  TEMP
C
C .. External subroutines ..
      EXTERNAL          MB03SD, MB04ZD
C
C .. Intrinsic functions ..
      INTRINSIC         MAX, MIN
C
C Check for proper number of arguments.
C
      IF ( NRHS.LT.2 ) THEN
         CALL mexErrMsgTxt
     $        ( 'HAMILEIG requires at least 2 input arguments' )
      ELSE IF ( NLHS.LT.2 ) THEN
         CALL mexErrMsgTxt
     $        ( 'HAMILEIG requires at least 2 output arguments' )
      END IF
C
C   A(nxn), QG(nx(n+1)) (, job(, jobscl), compu, S).
C
      N = mxGetM( PRHS(1) )
      IF ( mxGetN( PRHS(1) ).NE.N ) THEN
         WRITE( TEXT, '(''A must have '',I5,'' rows and columns'')' ) N
         CALL mexErrMsgTxt( TEXT )
      END IF
      IF ( mxIsNumeric( PRHS(1) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(1) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'A must be a real matrix' )
      END IF
C
      IF ( mxGetM( PRHS(2) ).NE.N ) THEN
         WRITE( TEXT, '(''QG must have '',I5,'' rows'')' ) N
         CALL mexErrMsgTxt( TEXT )
      END IF
      IF ( mxGetN( PRHS(2) ).NE.N + MIN( N, 1 ) ) THEN
         WRITE( TEXT, '(''QG must have '',I5,'' columns'')' )
     $          N + MIN( N, 1 )
         CALL mexErrMsgTxt( TEXT )
      END IF
      IF ( mxIsNumeric( PRHS(2) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(2) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'QG must be a real matrix' )
      END IF
C
C   job
C
      IP = 3
      IF ( NRHS.GE.IP ) THEN
         IF ( mxGetM( PRHS(IP) ).NE.1 .OR.
     $        mxGetN( PRHS(IP) ).NE.1 ) THEN
            CALL mexErrMsgTxt( 'JOB must be a scalar' )
         END IF
         IF ( mxIsNumeric( PRHS(IP) ).EQ.0 .OR.
     $        mxIsComplex( PRHS(IP) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'JOB must be an integer scalar' )
         END IF
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(IP) ), TEMP, 1 )
         JOB = TEMP
         IF ( JOB.LT.-1 .OR. JOB.GT.1 ) THEN
            CALL mexErrMsgTxt
     $           ( 'JOB has -1, 0, or 1 the only admissible values' )
         END IF
         IP = IP + 1
      ELSE
         JOB = 0
      END IF
C
C   jobscl
C
      IF ( JOB.GE.0 ) THEN
         IF ( NRHS.GE.IP ) THEN
            IF ( mxGetM( PRHS(IP) ).NE.1 .OR.
     $           mxGetN( PRHS(IP) ).NE.1 ) THEN
               CALL mexErrMsgTxt( 'JOBSCL must be a scalar' )
            END IF
            IF ( mxIsNumeric( PRHS(IP) ).EQ.0 .OR.
     $           mxIsComplex( PRHS(IP) ).EQ.1 ) THEN
               CALL mexErrMsgTxt( 'JOBSCL must be an integer scalar' )
            END IF
            CALL mxCopyPtrToReal8( mxGetPr( PRHS(IP) ), TEMP, 1 )
            IJOBS = TEMP
            IF ( IJOBS.LT.0 .OR. IJOBS.GT.1 ) THEN
               CALL mexErrMsgTxt
     $           ( 'JOBSCL has 0 or 1 the only admissible values' )
            END IF
            IP = IP + 1
         ELSE
            IJOBS = 1
         END IF
C
         IF ( IJOBS.EQ.0 ) THEN
            JOBSCL = 'N'
         ELSE
            JOBSCL = 'S'
         END IF
      END IF
C
C   compu
C
      IF ( JOB.LE.0 ) THEN
         IF ( NRHS.GE.IP ) THEN
            IF ( mxGetM( PRHS(IP) ).NE.1 .OR.
     $           mxGetN( PRHS(IP) ).NE.1 ) THEN
               CALL mexErrMsgTxt( 'COMPU must be a scalar' )
            END IF
            IF ( mxIsNumeric( PRHS(IP) ).EQ.0 .OR.
     $           mxIsComplex( PRHS(IP) ).EQ.1 ) THEN
               CALL mexErrMsgTxt( 'COMPU must be an integer scalar' )
            END IF
            CALL mxCopyPtrToReal8( mxGetPr( PRHS(IP) ), TEMP, 1 )
            ICOMP = TEMP
            IF ( ICOMP.LT.0 .OR. ICOMP.GT.2 ) THEN
               CALL mexErrMsgTxt
     $              ( 'COMPU has 0, 1 or 2 the only admissible values' )
            END IF
            IP = IP + 1
         ELSE
            ICOMP = 0
         END IF
C
         IF ( ICOMP.EQ.0 ) THEN
            COMPU = 'N'
         ELSE IF ( ICOMP.EQ.1 ) THEN
            COMPU = 'I'
         ELSE
            COMPU = 'V'
         END IF
      END IF
C
      IF ( JOB.LE.0 .AND .ICOMP.EQ.2 ) THEN
         IF ( NRHS.LT.IP ) THEN
            WRITE( TEXT, '(''HAMILEIG requires '',I2,
     $                     '' input arguments'')' ) IP
            CALL mexErrMsgTxt( TEXT )
         END IF
         IF ( mxGetM( PRHS(IP) ).NE.N ) THEN
            WRITE( TEXT, '(''S must have '', I5, '' rows'')' ) N
            CALL mexErrMsgTxt( TEXT )
         END IF
         IF ( mxGetN( PRHS(IP) ).NE.2*N ) THEN
            WRITE( TEXT, '(''S must have '', I5, '' columns'')' ) 2*N
            CALL mexErrMsgTxt( TEXT )
         END IF
         IF ( mxIsNumeric( PRHS(IP) ).EQ.0 .OR.
     $        mxIsComplex( PRHS(IP) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'S must be a real matrix' )
         END IF
      END IF
C
C Determine the lenghts of working arrays.
C
      LDA  = MAX( 1, N )
      LDQG = LDA
      IF ( JOB.LE.0 .AND. ICOMP.GT.0 ) THEN
         LDU  = LDA
         ITMP = 2*N
      ELSE
         LDU  = 1
         ITMP = 1
      END IF
C
C   ldwork
C
      IF ( JOB.LT.0 ) THEN
         LDWORK = 2*N
      ELSE
         LDWORK = MAX( 1, N*( N + 1 ) )
      END IF
C
C Allocate variable dimension local arrays.
C !Fortran 90/95
C
      ALLOCATE ( A( LDA, N ), DWORK( LDWORK ), QG( LDQG, N+1 ) )
      IF ( JOB.LE.0 )
     $   ALLOCATE ( U( LDU, ITMP ) )
      IF ( JOB.GE.0 )
     $   ALLOCATE ( WI( N ), WR( N ) )
C
C Copy inputs from MATLAB workspace to locally allocated arrays.
C
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(1) ), A,  N*N )
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(2) ), QG, N*( N + 1 ) )
      IF ( JOB.LE.0 .AND. ICOMP.EQ.2 )
     $   CALL mxCopyPtrToReal8( mxGetPr( PRHS(IP) ), U, 2*N*N )
C
C Do the actual computations.
C
      IF ( JOB.LE.0 )
     $   CALL MB04ZD( COMPU, N, A, LDA, QG, LDQG, U, LDU, DWORK, INFO )
C
      IF ( JOB.GE.0 )
     $   CALL MB03SD( JOBSCL, N, A, LDA, QG, LDQG, WR, WI, DWORK,
     $                LDWORK, INFO )
C
C Copy output to MATLAB workspace.
C
      IF ( JOB.LT.0 ) THEN
         IP = 1
      ELSE
         IP = 3
      END IF
C
      IF ( NLHS.GE.IP ) THEN
         PLHS(IP) = mxCreateDoubleMatrix( N, N, 0 )
         CALL mxCopyReal8ToPtr( A, mxGetPr( PLHS(IP) ), N*N )
         IP = IP + 1
         IF ( NLHS.GE.IP ) THEN
            PLHS(IP) = mxCreateDoubleMatrix( N, N + MIN( N, 1 ), 0 )
            CALL mxCopyReal8ToPtr( QG, mxGetPr( PLHS(IP) ),
     $                             N*( N + MIN( N, 1 ) ) )
            IP = IP + 1
         END IF
         IF ( ICOMP.GT.0 .AND. NLHS.GE.IP ) THEN
            PLHS(IP) = mxCreateDoubleMatrix( N, 2*N, 0 )
            CALL mxCopyReal8ToPtr( U, mxGetPr( PLHS(IP) ), 2*N*N )
         END IF
      END IF
C
      IF ( JOB.GE.0 ) THEN
         PLHS(1) = mxCreateDoubleMatrix( N, MIN( N, 1 ), 0 )
         CALL mxCopyReal8ToPtr( WR, mxGetPr( PLHS(1) ), N )
         PLHS(2) = mxCreateDoubleMatrix( N, MIN( N, 1 ), 0 )
         CALL mxCopyReal8ToPtr( WI, mxGetPr( PLHS(2) ), N )
      END IF
C
C Deallocate local arrays.
C !Fortran 90/95
C
      DEALLOCATE( A, DWORK, QG )
      IF ( JOB.LE.0 )
     $   DEALLOCATE ( U )
      IF ( JOB.GE.0 )
     $   DEALLOCATE ( WI, WR )
C
C Error and warning handling.
C
      IF ( INFO.NE.0 ) THEN
         WRITE( TEXT, '('' INFO = '',I4,'' ON EXIT FROM MB03SD'')'
     $        ) INFO
         CALL mexErrMsgTxt( TEXT )
      END IF
C
      RETURN
C *** Last line of HAMILEIG ***
      END


      SUBROUTINE WF_QUARTC
     &          (fourb3,sixb2,fourb1,b0,q)

c     Finds the roots of a quartic polynomial from the closed form.

      implicit real*8 (a-h,o-z)

      character*200 error_msg
      real     *  8 mgplus,mgmnus
      complex  * 16 b3,b2,b1,b0,q,fourb3,sixb2,fourb1,b3sq,h,i,g,
     &              hprime,gprime,sqroot,pplus,p,cbert0,cbert1,cbert2,
     &              rootp,rootq,rootr

      dimension     q(4),part(2)

      equivalence  (p,part)

      b3=fourb3*0.25d0
      b2=sixb2/6.d0
      b1=fourb1*0.25d0
      b3sq=b3**2
      h=b2-b3sq
      i=b0-4.d0*b3*b1+3.d0*b2**2
      g=b1+b3*(-3.d0*b2+2.d0*b3sq)
      hprime=-i/12.d0
      gprime=-g**2/4.d0-h*(h**2+3.d0*hprime)
      sqroot=SQRT(gprime**2+4.d0*hprime**3)
      p=(-gprime+sqroot)*0.5d0
      mgplus=ABS(part(1))+ABS(part(2))
      pplus=p
      p=(-gprime-sqroot)*0.5d0
      mgmnus=ABS(part(1))+ABS(part(2))
      if (mgplus .gt. mgmnus) p=pplus
      cbert0=EXP(LOG(p)/3.d0)
      cbert1=cbert0*(-.5d0, .8660254038d0)
      cbert2=cbert0*(-.5d0,-.8660254038d0)
      rootp=SQRT(cbert0-hprime/cbert0-h)
      rootq=SQRT(cbert1-hprime/cbert1-h)
      rootr=SQRT(cbert2-hprime/cbert2-h)
      if (ABS(g) .gt. 1.d-30) then
         sign=-rootp*rootq*rootr*2.d0/g
         if (sign .lt. 0.d0) rootr=-rootr
      end if
      q(1)=+rootp+rootq+rootr-b3
      q(2)=+rootp-rootq-rootr-b3
      q(3)=-rootp+rootq-rootr-b3
      q(4)=-rootp-rootq+rootr-b3
      do n=1,4
         iter=0
         do while (iter .le. 10)
            rootp=(((q(n)+fourb3)*q(n)+sixb2)*q(n)+fourb1)*q(n)+b0
            rootq=((4.d0*q(n)+3.d0*fourb3)*q(n)+2.d0*sixb2)*q(n)+fourb1
            rootr=rootp/rootq
            q(n)=q(n)-rootr
            if (ABS(rootr) .lt. 1.d-10) then
               iter=99
            else
               iter=iter+1
            end if
         end do

         if (iter .eq. 11) then
             write(error_msg,
     &           '(''[WF_QUARTC]: '',
     &             ''q= '',1p2e13.5,'' fails to converge after'',i3,1x,
     &             ''iterations'')')
     &               q(n),iter
            call LWPC_ERROR ('Warning',error_msg)
         end if
      end do
      RETURN
      END      ! WF_QUARTC


!--------------------------------------------------------------------
!
!
! PURPOSE
!
! This subroutine program calculates the energy for the nonlinear
! sine-Gordon equation in 2 dimensions
! u_{tt}-u_{xx}+u_{yy}=-sin(u)
!
! The energy density is given by
! 0.5u_t^2+0.5u_x^2+0.5u_y^2+(1-cos(u))
!
! AUTHORS
!
! B. Cloutier, B.K. Muite, P. Rigge
! 4 June 2012
!
! INPUT
!
! .. Scalars ..
!  Nx                           = number of modes in x - power of 2 for FFT
!  Ny                           = number of modes in y - power of 2 for FFT
!  planfxy                      = Forward 2d fft plan
!  planbxy                      = Backward 2d fft plan
!  dt                           = timestep
! .. Arrays ..
!  u                            = approximate solution
!  v                            = Fourier transform of approximate solution
!  uold                         = approximate solution
!  vold                         = Fourier transform of approximate solution
!  temp1                        = array to hold temporary values
!  temp2                        = array to hold temporary values
! .. Vectors ..
!  kx                           = fourier frequencies in x direction
!  ky                           = fourier frequencies in y direction
!
! OUTPUT
!
! .. Scalars ..
!  enkin                        = Kinetic energy
!  enstr                        = Strain energy
!  enpot                        = Potential energy
!  en                           = Total energy
!
! LOCAL VARIABLES
!
! .. Scalars ..
!  j                            = loop counter in y direction
!
! FURTHER COMMENTS
! Check that the initial iterate is consistent with the
! boundary conditions for the domain specified
!--------------------------------------------------------------------
! External routines required
!
! External libraries required
!       FFTW3    -- Fast Fourier Transform in the West Library
!                       (http://www.fftw.org/)
!       OpenMP library
SUBROUTINE enercalc(Nx,Ny,planfxy,planbxy,dt,enkin,enstr,&
     enpot,en,kx,ky,temp1,temp2,u,uold)
  USE omp_lib
  IMPLICIT NONE
  INTEGER(KIND=4), INTENT(IN)                             :: Nx,Ny
  REAL(KIND=8), INTENT(IN)                                :: dt
  INTEGER(KIND=8), INTENT(IN)                             :: planfxy
  INTEGER(KIND=8), INTENT(IN)                             :: planbxy
  COMPLEX(KIND=8), DIMENSION(1:Nx),INTENT(IN)             :: kx
  COMPLEX(KIND=8), DIMENSION(1:Ny),INTENT(IN)             :: ky
  REAL   (KIND=8), DIMENSION(1:Nx,1:Ny),INTENT(IN)        :: u,uold
  COMPLEX(KIND=8), DIMENSION(1:Nx,1:Ny),INTENT(INOUT)     :: temp1,temp2
  REAL(KIND=8), INTENT(OUT)                               :: enkin,enstr
  REAL(KIND=8), INTENT(OUT)                               :: enpot,en
  INTEGER(KIND=4)                                         :: j
  !$OMP PARALLEL DO PRIVATE(j) SCHEDULE(static)
  DO j=1,Ny
     temp1(1:Nx,j)=0.5d0*(uold(1:Nx,j)+u(1:Nx,j))
  END DO
  CALL dfftw_execute_dft_(planfxy,temp1,temp2)
  !.. Strain energy ..
  !$OMP PARALLEL DO PRIVATE(j) SCHEDULE(static)
  DO j=1,Ny
     temp1(1:Nx,j)=kx(1:Nx)*temp2(1:Nx,j)
  END DO
  !$OMP END PARALLEL DO
  CALL dfftw_execute_dft_(planbxy,temp1(1:Nx,1:Ny),temp2(1:Nx,1:Ny))
  !$OMP PARALLEL DO PRIVATE(j) SCHEDULE(static)
  DO j=1,Ny
     temp2(1:Nx,j)=abs(temp2(1:Nx,j)/REAL(Nx*Ny,kind(0d0)))**2
  END DO
  !$OMP END PARALLEL DO
  CALL dfftw_execute_dft_(planfxy,temp2(1:Nx,1:Ny),temp1(1:Nx,1:Ny))
  enstr=0.5d0*REAL(abs(temp1(1,1)),kind(0d0))/REAL(Nx*Ny,kind(0d0))
  !$OMP PARALLEL DO PRIVATE(j) SCHEDULE(static)
  DO j=1,Ny
     temp1(1:Nx,j)=0.5d0*(uold(1:Nx,j)+u(1:Nx,j))
  END DO
  CALL dfftw_execute_dft_(planfxy,temp1,temp2)
  !$OMP PARALLEL DO PRIVATE(j) SCHEDULE(static)
  DO j=1,Ny
     temp1(1:Nx,j)=ky(j)*temp2(1:Nx,j)
  END DO
  !$OMP END PARALLEL DO
  CALL dfftw_execute_dft_(planbxy,temp1(1:Nx,1:Ny),temp2(1:Nx,1:Ny))
  !$OMP PARALLEL DO PRIVATE(j) SCHEDULE(static)
  DO j=1,Ny
     temp2(1:Nx,j)=abs(temp2(1:Nx,j)/REAL(Nx*Ny,kind(0d0)))**2
  END DO
  !$OMP END PARALLEL DO
  CALL dfftw_execute_dft_(planfxy,temp2(1:Nx,1:Ny),temp1(1:Nx,1:Ny))
  enstr=enstr+0.5d0*REAL(abs(temp1(1,1)),kind(0d0))/REAL(Nx*Ny,kind(0d0))
  ! .. Kinetic Energy ..
  !$OMP PARALLEL DO PRIVATE(j) SCHEDULE(static)
  DO j=1,Ny
     temp2(1:Nx,j)=( abs(u(1:Nx,j)-uold(1:Nx,j))/dt )**2
  END DO
  !$OMP END PARALLEL DO
  CALL dfftw_execute_dft_(planfxy,temp2(1:Nx,1:Ny),temp1(1:Nx,1:Ny))
  enkin=0.5d0*REAL(abs(temp1(1,1)),kind(0d0))/REAL(Nx*Ny,kind(0d0))
  ! .. Potential Energy ..
  !$OMP PARALLEL DO PRIVATE(j) SCHEDULE(static)
  DO j=1,Ny
     temp2(1:Nx,j)=1-cos(0.5*u(1:Nx,j)+0.5*uold(1:Nx,j))
  END DO
  !$OMP END PARALLEL DO
  CALL dfftw_execute_dft_(planfxy,temp2(1:Nx,1:Ny),temp1(1:Nx,1:Ny))
  enpot=REAL(abs(temp1(1,1)),kind(0d0))/REAL(Nx*Ny,kind(0d0))
  en=enpot+enkin+enstr
END SUBROUTINE enercalc


c     program DRDWCOMP
c>> 1994-10-19 DRDWCOMP Krogh  Changes to use M77CON
c>> 1987-12-09 DRDWCOMP Lawson  Initial Code.
c--D replaces "?": DR?WCOMP, ?WSET, ?VECP, ?WSQRT, ?WLOG, ?WPRO1, ?WEXP,
c--&               ?WDIF, ?WCOMP
c     Demo driver for the DWCOMP package.  Derivative arithmetic.
c     ------------------------------------------------------------------
      integer N, NDIM, NMAX
      parameter(NMAX = 3, NDIM = NMAX+1)
      double precision T(NDIM), X1(NDIM), Z1(NDIM), X2(NDIM), Z2(NDIM)
      double precision DIFF(NDIM), ONE, TWO
      parameter(ONE = 1.0D0, TWO = 2.0D0)
c     ------------------------------------------------------------------
      print*,'DRDWCOMP..  Demo driver for the DWCOMP package.'
      N = NMAX
c                                      Set T = 2.0
      call DWSET(N, TWO, ONE, T)
      call DVECP(T,N+1,'0 T =')
c                                      Compute Z1 = log(sqrt(T))
      call DWSQRT(N, T, X1)
      call DWLOG(N, X1, Z1)
      call DVECP(Z1,N+1,'0 Z1 = log(sqrt(T)) =')
c
c                                      Compute Z2 = exp(2.0 * Z1)
      call DWPRO1(N, TWO, Z1, X2)
      call DWEXP(N, X2, Z2)
      call DVECP(Z2,N+1,'0 Z2 = exp(2.0 * Z1) =')
c
c                                      Diff = Z2 - T
      call DWDIF(N, Z2, T, DIFF)
      call DVECP(DIFF,N+1,'0 DIFF = Z2 - T =')
      stop
      end


      subroutine transport5_set_velocity(blockno, mx,my,mbc,
     &        dx,dy,xlower,ylower, t, xp,yp,zp,
     &        xnormals,ynormals,
     &        surfnormals, aux, maux)
      implicit none

      integer mx,my,mbc,maux,blockno
      double precision dx,dy, xlower,ylower, t
      double precision aux(maux,1-mbc:mx+mbc,1-mbc:my+mbc)

      double precision     xnormals(-mbc:mx+mbc+2,-mbc:my+mbc+2,3)
      double precision     ynormals(-mbc:mx+mbc+2,-mbc:my+mbc+2,3)
      double precision surfnormals(-mbc:mx+mbc+1,-mbc:my+mbc+1,3)
      double precision xp(-mbc:mx+mbc+1,-mbc:my+mbc+1)
      double precision yp(-mbc:mx+mbc+1,-mbc:my+mbc+1)
      double precision zp(-mbc:mx+mbc+1,-mbc:my+mbc+1)

      double precision xc, yc
      double precision xc1,yc1,nv(3), vel(3), vdotn
      double precision transport5_map_dot

      double precision nl(3), nr(3), nb(3), nt(3)
      double precision urrot, ulrot, ubrot, utrot

      integer i,j, k

c     # Cell-centered velocities : entries (4,5,6)
      do i = 1-mbc,mx+mbc
         do j = 1-mbc,my+mbc
            xc = xlower + (i-0.5)*dx
            yc = ylower + (j-0.5)*dy

c           # Mapping local coordinates (xc,yc) on patch to global
c           # coordinates in a [0,1]x[0,1] space.
c           # This is possible for the sphere, square and torus.
            call user_map2comp(blockno,xc,yc,
     &                   xp(i,j),yp(i,j),zp(i,j),xc1,yc1)

c           # This routine is specified for each example :
            call user_velocity_components_cart(xc1,yc1,t, vel)

c           # subtract out normal components
            do k = 1,3
                nv(k) = surfnormals(i,j,k)
            enddo

            vdotn = transport5_map_dot(vel,nv)

c           # Subtract out component in the normal direction
            do k = 1,3
                vel(k) = vel(k) - vdotn*nv(k)
            end do

            do k = 1,3
                nl(k)  = xnormals(i,  j,  k)
                nr(k)  = xnormals(i+1,j,  k)
                nb(k)  = ynormals(i,  j,  k)
                nt(k)  = ynormals(i,  j+1,k)
            enddo

            ulrot = transport5_map_dot(nl,vel)
            urrot = transport5_map_dot(nr,vel)
            ubrot = transport5_map_dot(nb,vel)
            utrot = transport5_map_dot(nt,vel)

            aux(2,i,j) = ulrot
            aux(3,i,j) = urrot
            aux(4,i,j) = ubrot
            aux(5,i,j) = utrot
         enddo
      enddo

      end

      double precision function transport5_map_dot(u,v)
      implicit none

      double precision u(3),v(3)

      transport5_map_dot = u(1)*v(1) + u(2)*v(2) + u(3)*v(3)

      end


subroutine init_jcdfi
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    init_jcdfi
!   prgmmr: tremolet
!
! abstract: Setup weights for Dolph-Chebyshev window digital filter
!
! program history log:
!   2007-10-18  tremolet - initial code
!   2009-08-17  lueken   - update documentation
!   2011-08-01  lueken   - changed F90 to f90 (no machine logic)
!   2020-02-26  todling - reset obsbin from hr to min
!
!   input argument list:
!
!   output argument list:
!
! attrbiutes:
!   language: f90
!   machine:
!
!$$$ end documentation block

!----------------------------------------------------------------------

use kinds, only: r_kind,i_kind
use gsi_4dvar, only: nobs_bins, mn_obsbin
use constants, only: zero, one, two, pi,r3600
use mpimod, only: mype
use jcmod, only: wgtdfi

implicit none

real(r_kind) :: tauc,rtdfi
real(r_kind) :: zx(0:nobs_bins),zp(0:nobs_bins)
real(r_kind) :: zd,zh,zl,zn,zr,zs,zt
integer(i_kind) :: nstdfi,jj,jn

!----------------------------------------------------------------------

tauc   = 6.0_r_kind*r3600
rtdfi  = mn_obsbin *60.0_r_kind
nstdfi = (nobs_bins-1)/2

if (mype==0) then
   write(6,*)'Setup weights for Dolph-Chebyshev window digital filter'
   write(6,*)'Number of DFI timesteps: ',2*nstdfi
   write(6,*)'DFI timestep: ',rtdfi
   write(6,*)'Cut-off period: ',tauc/r3600
   write(6,*)'Time-span: ',(two*nstdfi*rtdfi)/r3600
   write(6,*)'Filtered fields valid at initial time + ',INT(nstdfi*rtdfi),' s.'
   write(6,*)'init_jcdfi: tauc,rtdfi,nstdfi=',tauc,rtdfi,nstdfi
endif

allocate(wgtdfi(nobs_bins))
wgtdfi=zero
zx=zero
zp=zero

! Discretization of [0,pi/2]; computation of Chebyshev polynomials
zl=real(nobs_bins,r_kind)
zd=pi/zl
zt=pi/real(nstdfi,r_kind)
zs=one/cos(zt)
DO jj=0,nstdfi
   zx(jj)=real(jj,r_kind)*zd
   zp(jj)=fcheby(zs*cos(zx(jj)),2*nstdfi)
ENDDO
zr=two/zp(0)

! Computing weights : forward then backward time-steps
DO jn=0,nstdfi
   zh=one
   DO jj=1,nstdfi
      zh = zh + zr*zp(jj)*cos(real(2*jj,r_kind)*zx(jn))
   ENDDO
   wgtdfi(nstdfi+1+jn) = zh/zl
ENDDO
DO jn=1,nstdfi
   wgtdfi(nstdfi+1-jn) = wgtdfi(nstdfi+1+jn)
ENDDO

! Combining with simple filter
zt=two*pi*rtdfi/tauc
zs=zero
DO jn=-nstdfi,nstdfi
   zn = real(jn,r_kind)
   if (jn==0) then
      zh = zt/pi
   else
      zh = sin(zn*zt)/(zn*pi)
   endif
   wgtdfi(nstdfi+1+jn) = wgtdfi(nstdfi+1+jn)*zh
   zs = zs + wgtdfi(nstdfi+1+jn)
ENDDO
DO jn=-nstdfi,nstdfi
   wgtdfi(nstdfi+1+jn) = wgtdfi(nstdfi+1+jn)/zs
ENDDO

! Checking...
if (mype==0) write(6,*)'init_jcdfi: wgtdfi=',wgtdfi

zs=zero
DO jj=1,nobs_bins
   zs=zs+wgtdfi(jj)
ENDDO
if (ABS(zs-one)>EPSILON(zs)) then
   write(6,*)'init_jcdfi: Sum of weights is not 1',zs
   call stop2(318)
end if

!----------------------------------------------------------------------
contains
!----------------------------------------------------------------------
real(r_kind) function fcheby(px,kn)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    fcheby
!   pgrmmr:
!
! abstract:
!
! program history log:
!   2009-08-04  lueken - added subprogram doc block
!   2010-09-05  todling - bug fix: replace loop index jj to ii
!
!   input argument list:
!    kn
!    px
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block

implicit none
integer(i_kind), intent(in   ) :: kn
real(r_kind)   , intent(in   ) :: px

integer(i_kind) :: ii
real(r_kind) :: z0,z1,z2

jn=ABS(kn)
z0=one
z1=px

if (jn==0) then
   fcheby=z0
elseif (jn==1) then
   fcheby=z1
else
   do ii=2,jn
      z2=two*px*z1-z0
      z0=z1
      z1=z2
   enddo
   fcheby=z2
endif

return
end function fcheby
!----------------------------------------------------------------------
end subroutine init_jcdfi


      double precision function  fdisc(blockno,xc,yc)
      implicit none

      double precision xc,yc, xp, yp, zp, rp
      integer blockno
      integer*8 cont, get_context
      double precision th, tp, r2, w1, w2, thc, g, r

      double precision pi, pi2
      common /compi/ pi, pi2

      double precision alpha, beta
      common /torus_comm/ alpha, beta

      double precision a

      cont = get_context()

      call fclaw2d_map_c2m(cont,
     &      blockno,xc,yc,xp,yp,zp)

      thc = pi/2.0
      thc = 0
      w1 = pi/8.d0
      w2 = pi/4.0

c     # atan2(y,x) \in [-pi,pi]
      th = atan2(yp,xp)

c     # Distance from thc
      r2 = (th-thc)**2

      fdisc = r2 - w1**2

      end


program mkgpspos

implicit none

real(8) :: amax, amin, omax, omin, alat, alon, dlat, dlon
integer :: lat, lon, i, j, ii

amin = 31.d0 	! LAT min
amax = 36.d0 	! LAT max
omin = 131.d0 	! LON min
omax = 138.d0 	! LON max

lat  = 25 		! number of grid
lon  = 35 		! number of grid

!=========

dlat = (amax-amin) / dble(lat-1)
dlon = (omax-omin) / dble(lon-1)

if(lat*lon > 1000) stop 'grid number is too large'
if(amin > amax) stop 'lat error'
if(omin > omax) stop 'lon error'

open(10,file="./check/gps_grid.dat")
open(11,file="./check/grid_dummyg.dat")

write(10,*) lat*lon
write(11,*) lat*lon, lat*lon, 0, 0

ii = 0

do i = 1, lat
	alat = amin + dlat * dble(i-1)

	do j = 1, lon
		ii = ii + 1
		alon = omin + dlon * dble(j-1)
		write(10,'(F11.7,1X,F11.8,1X,"#  gsi ")') alon, alat
		write(11,'(I5,1X,F11.7,1X,F11.8,1X,"0.0 0.0  1  1")') ii, alon, alat
	end do

end do

close(10)
close(11)
print *, "FILE : ./check/gps_grid.dat"

end


!  *********************************************************************
!  *                                                                   *
!  *                S U B R O U T I N E   P H Y L L O                  *
!  *                                                      gm   1/21/05 *
!  *                                                                   *
!  *                                                                   *
!  *********************************************************************
!  The PHYLLO subroutine calculates the phyllochron (i.e., rate of leaf
!  appearance).  The user can either use a set phyllochron or it can use
!  an equation.

! Following is from SHOOTGRO:
c  Calculate phyllochron for each seedling cohort according to
c  Baker et al. (1980) in Plant, Cell, and Environment 3:285-7.  Pchron
c  is a function of change in day length at emergence.
c  Errors in day length published in Figure 3 were corrected to give a
c  slope of 0.026, a y-intercept of 0.0104, and r**2 of 0.95.  Day
c  length values were derived from WGEN (used in function DAYLTH) and
c  latitude of 51.50.

!  NOTE:  Equations still need to be added.  For now, values are set in
!         setup.for

!  INPUTS:  list variables here with C and R for each variable

!  OUTPUTS: list variables here with C and R for each variable

      subroutine phyllo(chg)

      implicit none

      real chg, phyllonw

      phyllonw = 1.0 / (0.026 * chg + 0.0104)

!      print *, 'phyllonw = ', phyllonw

      return
      end