module type_FFTpack

    use fftpack_precision, only: &
        wp, & ! working precision
        ip ! integer precision

    use auxiliary_routines

    use fftpack_precision, only: &
        wp, & ! working precision
        ip ! integer precision

    use complex_transform_routines

    use real_transform_routines

    use cosine_transform_routines

    use sine_transform_routines

    use quarter_cosine_transform_routines

    use quarter_sine_transform_routines

    ! Explicit typing only
    implicit none

    ! Everything is private unless stated otherwise
    private
    public :: FFTpack

    ! Declare derived data type
    type, public :: FFTpack
        !----------------------------------------------------------------------
        ! Class variables
        !----------------------------------------------------------------------
        real (wp), allocatable :: saved_workspace(:)
        real (wp), allocatable :: workspace(:)
        !----------------------------------------------------------------------
    contains
        !----------------------------------------------------------------------
        ! Class methods
        !----------------------------------------------------------------------
        procedure, private :: real_1d_forward
        procedure, private :: real_1d_backward
        procedure, private :: real_2d_forward
        procedure, private :: real_2d_backward
        procedure, private :: real_nd_forward
        procedure, private :: real_nd_backward
        procedure, private :: complex_1d_forward
        procedure, private :: complex_1d_backward
        procedure, private :: complex_2d_forward
        procedure, private :: complex_2d_backward
        !procedure, private :: complex_nd_forward
        !procedure, private :: complex_nd_backward
        procedure, private :: cost_1d_forward
        procedure, private :: cost_1d_backward

        generic,   public  :: fft => real_1d_forward, complex_1d_forward
        generic,   public  :: ifft => real_1d_backward, complex_1d_backward
        generic,   public  :: dct => cost_1d_forward
        generic,   public  :: idct => cost_1d_backward
        generic,   public  :: fft2 => real_2d_forward, complex_2d_forward
        generic,   public  :: ifft2 => real_2d_backward, complex_2d_backward
        generic,   public  :: fftn => real_nd_forward!, complex_nd_forward
        generic,   public  :: ifftn => real_nd_backward!, complex_nd_backward

        procedure, public  :: destroy => destroy_fftpack
        procedure, public  :: create => create_fftpack

        procedure, nopass, public :: get_1d_saved_workspace_length
        procedure, nopass, public :: get_1d_saved_workspace
        procedure, nopass, public :: get_1d_workspace_length
        procedure, nopass, public :: get_1d_workspace
        procedure, nopass, public :: get_1d_sin_workspace_length
        procedure, nopass, public :: get_1d_sin_workspace
        procedure, nopass, public :: get_2d_saved_workspace_length
        procedure, nopass, public :: get_2d_saved_workspace
        procedure, nopass, public :: get_2d_workspace_length
        procedure, nopass, public :: get_2d_workspace

        !----------------------------------------------------------------------
        ! Complex transform routines
        !----------------------------------------------------------------------
        procedure, nopass, public :: cfft1i ! 1-d complex initialization
        procedure, nopass, public :: cfft1b ! 1-d complex backward
        procedure, nopass, public :: cfft1f ! 1-d complex forward
        procedure, nopass, public :: cfft2i ! 2-d complex initialization
        procedure, nopass, public :: cfft2b ! 2-d complex backward
        procedure, nopass, public :: cfft2f ! 2-d complex forward
        procedure, nopass, public :: cfftmi ! multiple complex initialization
        procedure, nopass, public :: cfftmb ! multiple complex backward
        procedure, nopass, public :: cfftmf ! multiple complex forward
        !----------------------------------------------------------------------
        ! Real transform routines
        !----------------------------------------------------------------------
        procedure, nopass, public :: rfft1i ! 1-d real initialization
        procedure, nopass, public :: rfft1b ! 1-d real backward
        procedure, nopass, public :: rfft1f ! 1-d real forward
        procedure, nopass, public :: rfft2i ! 2-d real initialization
        procedure, nopass, public :: rfft2b ! 2-d real backward
        procedure, nopass, public :: rfft2f ! 2-d real forward
        procedure, nopass, public :: rfftmi ! multiple real initialization
        procedure, nopass, public :: rfftmb ! multiple real backward
        procedure, nopass, public :: rfftmf ! multiple real forward
        !----------------------------------------------------------------------
        ! Real cosine transform routines
        !----------------------------------------------------------------------
        procedure, nopass, public :: cost1i ! 1-d real cosine initialization
        procedure, nopass, public :: cost1b ! 1-d real cosine backward
        procedure, nopass, public :: cost1f ! 1-d real cosine forward
        procedure, nopass, public :: costmi ! multiple real cosine initialization
        procedure, nopass, public :: costmb ! multiple real cosine backward
        procedure, nopass, public :: costmf ! multiple real cosine forward
        !----------------------------------------------------------------------
        ! Real sine transform routines
        !----------------------------------------------------------------------
        procedure, nopass, public :: sint1i ! 1-d real sine initialization
        procedure, nopass, public :: sint1b ! 1-d real sine backward
        procedure, nopass, public :: sint1f ! 1-d real sine forward
        procedure, nopass, public :: sintmi ! multiple real sine initialization
        procedure, nopass, public :: sintmb ! multiple real sine backward
        procedure, nopass, public :: sintmf ! multiple real sine forward
        !----------------------------------------------------------------------
        ! Real quarter-cosine transform routines
        !----------------------------------------------------------------------
        procedure, nopass, public :: cosq1i ! 1-d real quarter-cosine initialization
        procedure, nopass, public :: cosq1b ! 1-d real quarter-cosine backward
        procedure, nopass, public :: cosq1f ! 1-d real quarter-cosine forward
        procedure, nopass, public :: cosqmi ! multiple real quarter-cosine initialization
        procedure, nopass, public :: cosqmb ! multiple real quarter-cosine backward
        procedure, nopass, public :: cosqmf ! multiple real quarter-cosine forward
        !----------------------------------------------------------------------
        ! Real quarter-sine transform routines
        !----------------------------------------------------------------------
        procedure, nopass, public :: sinq1i ! 1-d real quarter-sine initialization
        procedure, nopass, public :: sinq1b ! 1-d real quarter-sine backward
        procedure, nopass, public :: sinq1f ! 1-d real quarter-sine forward
        procedure, nopass, public :: sinqmi ! multiple real quarter-sine initialization
        procedure, nopass, public :: sinqmb ! multiple real quarter-sine backward
        procedure, nopass, public :: sinqmf ! multiple real quarter-sine forward
        !----------------------------------------------------------------------
    end type FFTpack

    ! Declare constructor
    interface FFTpack
        module procedure fftpack_2d_constructor
        module procedure fftpack_1d_constructor
    end interface

contains

    subroutine real_1d_forward(this, real_data)
        !-----------------------------------------------------------------
        ! Dummy arguments
        !-----------------------------------------------------------------
        class (FFTpack), intent (in out) :: this
        real(wp),        intent(in out)  :: real_data(:)
        !-----------------------------------------------------------------
        ! Local variables
        !-----------------------------------------------------------------
        integer (ip) :: n, error_flag
        !-----------------------------------------------------------------

        n = size(real_data)

        associate( &
            r => real_data, &
            lenwrk => get_real_1d_workspace_length(n), &
            lensav => get_real_1d_saved_workspace_length(n) , &
            lenr => size(real_data), &
            inc => 1, &
            ier => error_flag &
            )

            !
            !==> Allocate memory
            !
            call this%create(lensav, lenwrk)

            associate( &
                wsave => this%saved_workspace, &
                work => this%workspace &
                )

                !
                !==> Initialize real transform
                !
                call rfft1i(n,wsave,lensav,ier)

                ! Check error_flag
                if(ier == 2) then
                    error stop "rfft1i: lensave not big enough"
                end if

                !
                !==> Perform real forward transform
                !
                call rfft1f(n,inc,r,lenr,wsave,lensav,work,lenwrk,ier)

            end associate
        end associate

        !
        !==> Release memory
        !
        call this%destroy()

        ! Check error_flag
        select case (error_flag)
            case (0)
                return
            case (1)
                error stop "rfft1f: lenr not big enough"
            case (2)
                error stop "rfft1f: lensav not big enough"
            case (3)
                error stop "rfft1f: lenwrk not big enough"
            case (20)
                error stop "rfft1f: input error returned by lower level routine"
        end select

    end subroutine real_1d_forward

    subroutine real_1d_backward(this, real_data)
        !-----------------------------------------------------------------
        ! Dummy arguments
        !-----------------------------------------------------------------
        class (FFTpack), intent (in out) :: this
        real (wp),       intent(in out)  :: real_data(:)
        !-----------------------------------------------------------------
        ! Local variables
        !-----------------------------------------------------------------
        integer (ip) :: n, error_flag
        !-----------------------------------------------------------------

        n = size(real_data)

        associate( &
            r => real_data, &
            lenwrk => get_real_1d_workspace_length(n), &
            lensav => get_real_1d_saved_workspace_length(n) , &
            lenr => size(real_data), &
            inc => 1, &
            ier => error_flag &
            )

            !
            !==> Allocate memory
            !
            call this%create(lensav, lenwrk)

            associate( &
                wsave => this%saved_workspace, &
                work => this%workspace &
                )

                !
                !==> Initialize real transform
                !
                call rfft1i(n,wsave,lensav,ier)

                ! Check error_flag
                if(ier == 2) then
                    error stop "rfft1i: lensave not big enough"
                end if

                call rfft1b(n,inc,r,lenr,wsave,lensav,work,lenwrk,ier)

            end associate
        end associate

        !
        !==> Release memory
        !
        call this%destroy()

        ! Check error_flag
        select case (error_flag)
            case (0)
                return
            case (1)
                error stop "rfft1b: lenr not big enough"
            case (2)
                error stop "rfft1b: lensav not big enough"
            case (3)
                error stop "rfft1b: lenwrk not big enough"
            case (20)
                error stop "rfft1b: input error returned by lower level routine"
        end select

    end subroutine real_1d_backward

    subroutine complex_1d_forward(this, complex_data)
        !-----------------------------------------------------------------
        ! Dummy arguments
        !-----------------------------------------------------------------
        class (FFTpack), intent (in out) :: this
        complex (wp),    intent (in out) :: complex_data(:)
        !-----------------------------------------------------------------
        ! Local variables
        !-----------------------------------------------------------------
        integer (ip) :: n, error_flag
        !-----------------------------------------------------------------

        n = size(complex_data)

        associate( &
            c => complex_data, &
            lenwrk => get_complex_1d_workspace_length(n), &
            lensav => get_complex_1d_saved_workspace_length(n), &
            lenc => n, &
            inc => 1, &
            ier => error_flag &
            )

            !
            !==> Allocate memory
            !
            call this%create(lensav, lenwrk)

            associate( &
                wsave => this%saved_workspace, &
                work => this%workspace &
                )

                !
                !==> Initialize complex transform
                !
                call cfft1i(n,wsave,lensav,ier)

                ! Check error_flag
                if(ier == 2) then
                    error stop "cfft1i: lensav not big enough"
                end if

                !
                !==> Perform complex forward transform
                !
                call cfft1f(n,inc,c,lenc,wsave,lensav,work,lenwrk,ier)

            end associate
        end associate

        !
        !==> Release memory
        !
        call this%destroy()

        select case (error_flag)
            case (0)
                return
            case (1)
                error stop "cfft1f: lenc not big enough"
            case (2)
                error stop "cfft1f: lensav not big enough"
            case (3)
                error stop "cfft1f: lenwrk not big enough"
            case (20)
                error stop "cfft1f: input error returned by lower level routine"
        end select

    end subroutine complex_1d_forward

    subroutine complex_1d_backward(this, complex_data)
        !-----------------------------------------------------------------
        ! Dummy arguments
        !-----------------------------------------------------------------
        class (FFTpack), intent (in out) :: this
        complex (wp),    intent (in out) :: complex_data(:)
        !-----------------------------------------------------------------
        ! Local variables
        !-----------------------------------------------------------------
        integer (ip) :: n, error_flag
        !-----------------------------------------------------------------

        n = size(complex_data)

        associate( &
            c => complex_data, &
            lenwrk => get_complex_1d_workspace_length(n), &
            lensav => get_complex_1d_saved_workspace_length(n), &
            lenc => n, &
            inc => 1, &
            ier => error_flag &
            )

            !
            !==> Allocate memory
            !
            call this%create(lensav, lenwrk)

            associate( &
                wsave => this%saved_workspace, &
                work => this%workspace &
                )

                !
                !==> Initialize complex transform
                !
                call cfft1i(n,wsave,lensav,ier)

                ! Check error_flag
                if(ier == 2) then
                    error stop "cfft1i: lensav not big enough"
                end if

                !
                !==> Perform complex backward transform
                !
                call cfft1b(n,inc,c,lenc,wsave,lensav,work,lenwrk,ier)

            end associate
        end associate

        !
        !==> Release memory
        !
        call this%destroy()

        select case (error_flag)
            case (0)
                return
            case (1)
                error stop "cfft1b: lenc not big enough"
            case (2)
                error stop "cfft1b: lensav not big enough"
            case (3)
                error stop "cfft1b: lenwrk not big enough"
            case (20)
                error stop "cfft1b: input error returned by lower level routine"
        end select

    end subroutine complex_1d_backward

    subroutine cost_1d_forward(this, real_data)
        !-----------------------------------------------------------------
        ! Dummy arguments
        !-----------------------------------------------------------------
        class (FFTpack), intent (in out) :: this
        real (wp),       intent(in out)  :: real_data(:)
        !-----------------------------------------------------------------
        ! Local variables
        !-----------------------------------------------------------------
        integer (ip) :: n, error_flag
        !-----------------------------------------------------------------

        n = size(real_data)

        associate( &
            r => real_data, &
            lenwrk => get_cost_1d_workspace_length(n), &
            lensav => get_cost_1d_saved_workspace_length(n) , &
            lenr => n, &
            inc => 1, &
            ier => error_flag &
            )

            !
            !==> Allocate memory
            !
            call this%create(lensav, lenwrk)

            associate( &
                wsave => this%saved_workspace, &
                work => this%workspace &
                )

                !
                !==> Initialize transform
                !
                call cost1i(n, wsave, lensav, ier)

                ! Check error_flag
                if (ier == 2) then
                    error stop "cost_1d_backward: lensave not big enough"
                else if (ier == 20) then
                    error stop "cost_1d_backward: input error returned by lower level routine"
                end if

                !
                !==> Perform transform
                !
                call cost1f(n, inc, r, lenr, wsave, lensav, work, lenwrk, ier)

            end associate
        end associate

        !
        !==> Release memory
        !
        call this%destroy()

        ! Check error_flag
        select case (error_flag)
            case (0)
                return
            case (1)
                error stop "cost1f: lenr not big enough"
            case (2)
                error stop "cost1f: lensav not big enough"
            case (3)
                error stop "cost1f: lenwrk not big enough"
            case (20)
                error stop "cost1f: input error returned by lower level routine"
        end select

    end subroutine cost_1d_forward

    subroutine cost_1d_backward(this, real_data)
        !-----------------------------------------------------------------
        ! Dummy arguments
        !-----------------------------------------------------------------
        class (FFTpack), intent (in out) :: this
        real (wp),       intent(in out)  :: real_data(:)
        !-----------------------------------------------------------------
        ! Local variables
        !-----------------------------------------------------------------
        integer (ip) :: n, error_flag
        !-----------------------------------------------------------------

        n = size(real_data)

        associate( &
            r => real_data, &
            lenwrk => get_cost_1d_workspace_length(n), &
            lensav => get_cost_1d_saved_workspace_length(n) , &
            lenr => n, &
            inc => 1, &
            ier => error_flag &
            )

            !
            !==> Allocate memory
            !
            call this%create(lensav, lenwrk)

            associate( &
                wsave => this%saved_workspace, &
                work => this%workspace &
                )

                !
                !==> Initialize transform
                !
                call cost1i(n, wsave, lensav, ier)

                ! Check error_flag
                if (ier == 2) then
                    error stop "cost_1d_backward: lensave not big enough"
                else if (ier == 20) then
                    error stop "cost_1d_backward: input error returned by lower level routine"
                end if

                !
                !==> Perform transform
                !
                call cost1b(n, inc, r, lenr, wsave, lensav, work, lenwrk, ier)

            end associate
        end associate

        !
        !==> Release memory
        !
        call this%destroy()

        ! Check error_flag
        select case (error_flag)
            case (0)
                return
            case (1)
                error stop "cost_1d_backward: lenr not big enough"
            case (2)
                error stop "cost_1d_backward: lensav not big enough"
            case (3)
                error stop "cost_1d_backward: lenwrk not big enough"
            case (20)
                error stop "cost_1d_backward: input error returned by lower level routine"
        end select

    end subroutine cost_1d_backward

    subroutine real_2d_forward(this, real_data)
        !-----------------------------------------------------------------
        ! Dummy arguments
        !-----------------------------------------------------------------
        class (FFTpack), intent (in out) :: this
        real (wp),       intent (in out) :: real_data(:,:)
        !-----------------------------------------------------------------
        ! Local variables
        !-----------------------------------------------------------------
        integer (ip) :: l, m, error_flag
        !-----------------------------------------------------------------

        l = size(real_data, dim=1)
        m = size(real_data, dim=2)

        associate( &
            ldim => l, &
            r => real_data, &
            lensav => get_real_2d_saved_workspace_length(l, m), &
            lenwrk => get_real_2d_workspace_length(l, m), &
            ier => error_flag &
            )

            !
            !==> Allocate memory
            !
            call this%create(lensav, lenwrk)

            associate( &
                wsave => this%saved_workspace, &
                work => this%workspace &
                )

                !
                !==> Initialize transform
                !
                call rfft2i(l,m,wsave,lensav,ier)

                ! Check error flag
                select case (ier)
                    case (2)
                        error stop "rfft2i: lensav not big enough"
                    case (20)
                        error stop "rfft2i: input error returned by lower level routine"
                end select

                !
                !==> Perform transform
                !
                call rfft2f(ldim,l,m,real_data,wsave,lensav,work,lenwrk,ier)

            end associate
        end associate

        !
        !==> Release memory
        !
        call this%destroy()

        ! Check error flag
        select case (error_flag)
            case (0)
                return
            case (6)
                error stop "rfft2f: ldim is less than 2*((l+1)/2)"
            case (2)
                error stop "rfft2f: lensav not big enough"
            case (3)
                error stop "rfft2f: lenwrk not big enough"
            case (20)
                error stop "rfft2f: input error returned by lower level routine"
        end select

    end subroutine real_2d_forward

    subroutine real_2d_backward(this, real_data)
        !-----------------------------------------------------------------
        ! Dummy arguments
        !-----------------------------------------------------------------
        class (FFTpack), intent (in out) :: this
        real (wp),       intent (in out) :: real_data(:,:)
        !-----------------------------------------------------------------
        ! Local variables
        !-----------------------------------------------------------------
        integer (ip) :: l, m, error_flag
        !-----------------------------------------------------------------

        l = size(real_data, dim=1)
        m = size(real_data, dim=2)

        associate( &
            ldim => l, &
            r => real_data, &
            lensav => get_real_2d_saved_workspace_length(l, m), &
            lenwrk => get_real_2d_workspace_length(l, m), &
            ier => error_flag &
            )

            !
            !==> Allocate memory
            !
            call this%create(lensav, lenwrk)

            associate( &
                wsave => this%saved_workspace, &
                work => this%workspace &
                )

                !
                !==> Initialize transform
                !
                call rfft2i(l,m,wsave,lensav,ier)

                ! Check error flag
                select case (ier)
                    case (2)
                        error stop "rfft2i: lensav not big enough"
                    case (20)
                        error stop "rfft2i: input error returned by lower level routine"
                end select

                !
                !==> perform transform
                call rfft2b(ldim,l,m,real_data,wsave,lensav,work,lenwrk,ier)

            end associate
        end associate

        !
        !==> Release memory
        !
        call this%destroy()

        ! Check error flag
        select case(error_flag)
            case (0)
                return
            case (6)
                error stop "rfft2b: ldim is less than 2*((l+1)/2)"
            case (2)
                error stop "rfft2b: lensav not big enough"
            case (3)
                error stop "rfft2b: lenwrk not big enough"
            case (20)
                error stop "rfft2b: input error returned by lower level routine"
        end select

    end subroutine real_2d_backward

    subroutine complex_2d_forward(this, complex_data)
        !-----------------------------------------------------------------
        ! Dummy arguments
        !-----------------------------------------------------------------
        class (FFTpack), intent (in out) :: this
        complex (wp),    intent (in out) :: complex_data(:,:)
        !-----------------------------------------------------------------
        ! Local variables
        !-----------------------------------------------------------------
        integer (ip) :: l, m, error_flag
        !-----------------------------------------------------------------

        l = size(complex_data, dim=1)
        m = size(complex_data, dim=2)

        associate( &
            c => complex_data, &
            ldim => l, &
            lensav => get_complex_2d_saved_workspace_length(l, m), &
            lenwrk => get_complex_2d_workspace_length(l, m), &
            ier => error_flag &
            )

                        !
                        !==> Allocate memory
                        !
            call this%create(lensav, lenwrk)

            associate( &
                wsave => this%saved_workspace, &
                work => this%workspace &
                )

                !
                !==> Initialize transform
                !
                call cfft2i(l,m,wsave,lensav,ier)

                select case (ier)
                    case (2)
                        error stop "cfft2i: lensav not big enough"
                    case (20)
                        error stop "cfft2i: input error returned by lower level routine"
                end select

                !
                !==> Perform transform
                !
                call cfft2f(ldim,l,m,c,wsave,lensav,work,lenwrk,ier)

            end associate
        end associate
        !
        !==> Release memory
        !
        call this%destroy()

        ! Check error flag
        select case(error_flag)
            case (0)
                return
            case (5)
                error stop "cfft2f: l > ldim"
            case (2)
                error stop "cfft2f: lensav not big enough"
            case (3)
                error stop "cfft2f: lenwrk not big enough"
            case (20)
                error stop "cfft2f: input error returned by lower level routine"
        end select

    end subroutine complex_2d_forward

    subroutine complex_2d_backward(this, complex_data)
        !-----------------------------------------------------------------
        ! Dummy arguments
        !-----------------------------------------------------------------
        class (FFTpack), intent (in out) :: this
        complex (wp),    intent (in out) :: complex_data(:,:)
        !-----------------------------------------------------------------
        ! Local variables
        !-----------------------------------------------------------------
        integer (ip) :: l, m, error_flag
        !-----------------------------------------------------------------

        l = size(complex_data, dim=1)
        m = size(complex_data, dim=2)

        associate( &
            c => complex_data, &
            ldim => l, &
            lensav => get_complex_2d_saved_workspace_length(l, m), &
            lenwrk => get_complex_2d_workspace_length(l, m), &
            ier => error_flag &
            )

             !
             !==> Allocate memory
             !
            call this%create(lensav, lenwrk)

            associate( &
                wsave => this%saved_workspace, &
                work => this%workspace &
                )

                !
                !==> Initialize transform
                !
                call cfft2i(l,m,wsave,lensav,ier)

                select case (ier)
                    case (2)
                        error stop "cfft2i: lensav not big enough"
                    case (20)
                        error stop "cfft2i: input error returned by lower level routine"
                end select

                !
                !==> Perform transform
                !
                call cfft2b(ldim, l, m, c, wsave, lensav, work, lenwrk, ier)

            end associate
        end associate

        !
        !==> Release memory
        !
        call this%destroy()

        ! Check error flag
        select case (error_flag)
            case (0)
                return
            case (5)
                error stop "cfft2b: l > ldim"
            case (2)
                error stop "cfft2b: lensav not big enough"
            case (3)
                error stop "cfft2b: lenwrk not big enough"
            case (20)
                error stop "cfft2b: input error returned by lower level routine"
        end select

    end subroutine complex_2d_backward

    subroutine real_nd_forward(this, n, lot, real_data)
        !-----------------------------------------------------------------
        ! Dummy arguments
        !-----------------------------------------------------------------
        class (FFTpack), intent (in out) :: this
        integer (ip),    intent (in)     :: n   ! length of each sequence
        integer (ip),    intent (in)     :: lot ! number of sequences
        real(wp),        intent(in out)  :: real_data(:)
        !-----------------------------------------------------------------
        ! Local variables
        !-----------------------------------------------------------------
        integer (ip) :: l, error_flag
        !-----------------------------------------------------------------

        l = size(real_data)

        if (mod(n*lot,l)/=0) then
            error stop "real_nd_forward: "&
                //"incommensurate input arguments "&
                //"mod(n*lot,size(real_data)) /= 0."
        end if

        associate( &
            r => real_data, &
            lenwrk => get_real_nd_workspace_length(n, lot), &
            lensav => get_real_nd_saved_workspace_length(n) , &
            lenr => n*lot, &
            jump => n, &
            inc => 1, &
            ier => error_flag &
            )

             !
             !==> Allocate memory
             !
            call this%create(lensav, lenwrk)

            associate( &
                wsave => this%saved_workspace, &
                work => this%workspace &
                )

                !
                !==> Initialize transform
                !
                call rfftmi(n, wsave, lensav, ier)

                ! Check error_flag
                if(ier == 2) then
                    error stop "rfftmi: lensave not big enough"
                end if

                !
                !==> Perform forward transform
                !
                call rfftmf(lot,jump,n,inc,r,lenr,wsave,lensav,work,lenwrk,ier)

            end associate
        end associate

        !
        !==> Release memory
        !
        call this%destroy()

        ! Check error_flag
        select case (error_flag)
            case (0)
                return
            case (1)
                error stop "rfftmf: lenr not big enough"
            case (2)
                error stop "rfftmf: lensav not big enough"
            case (3)
                error stop "rfftmf: lenwrk not big enough"
            case (4)
                error stop "rfftmf: inc, jump, n, lot are not consistent"
        end select

    end subroutine real_nd_forward

    subroutine real_nd_backward(this, n, lot, real_data)
        !-----------------------------------------------------------------
        ! Dummy arguments
        !-----------------------------------------------------------------
        class (FFTpack), intent (in out) :: this
        integer (ip),    intent (in)     :: n   ! length of each sequence
        integer (ip),    intent (in)     :: lot ! number of sequences
        real (wp),       intent(in out)  :: real_data(:)
        !-----------------------------------------------------------------
        ! Local variables
        !-----------------------------------------------------------------
        integer (ip) :: l, error_flag
        !-----------------------------------------------------------------

        l = size(real_data)

        if (mod(n*lot,l)/=0) then
            error stop "real_nd_backward: "&
                //"incommensurate input arguments "&
                //"mod(n*lot,size(real_data)) /= 0."
        end if

        associate( &
            r => real_data, &
            lenwrk => get_real_nd_workspace_length(n, lot), &
            lensav => get_real_nd_saved_workspace_length(n) , &
            lenr => n*lot, &
            jump => n, &
            inc => 1, &
            ier => error_flag &
            )

            !
            !==> Allocate memory
            !
            call this%create(lensav, lenwrk)

            associate( &
                wsave => this%saved_workspace, &
                work => this%workspace &
                )

                !
                !==> Initialize transform
                !
                call rfftmi(n, wsave, lensav, ier)

                ! Check error_flag
                if(ier == 2) then
                    error stop "rfftmi: lensave not big enough"
                end if

                !
                !==> Perform forward transform
                !
                call rfftmb(lot,jump,n,inc,r,lenr,wsave,lensav,work,lenwrk,ier)

            end associate
        end associate

        !
        !==> Release memory
        !
        call this%destroy()

        ! Check error_flag
        select case (error_flag)
            case (0)
                return
            case (1)
                error stop "rfftmb: lenr not big enough"
            case (2)
                error stop "rfftmb: lensav not big enough"
            case (3)
                error stop "rfftmb: lenwrk not big enough"
            case (4)
                error stop "rfftmb: inc, jump, n, lot are not consistent"
        end select

    end subroutine real_nd_backward

    !    subroutine complex_nd_forward(this, n, lot, complex_data)
    !        !-----------------------------------------------------------------
    !        ! Dummy arguments
    !        !-----------------------------------------------------------------
    !        class (FFTpack), intent (in out) :: this
    !        integer (ip),    intent (in)     :: n   ! length of each sequence
    !        integer (ip),    intent (in)     :: lot ! number of sequences
    !        complex (wp),    intent(in out)  :: complex_data(:)
    !        !-----------------------------------------------------------------
    !        ! Local variables
    !        !-----------------------------------------------------------------
    !        integer (ip) :: l, error_flag
    !        !-----------------------------------------------------------------
    !
    !        l = size(complex_data)
    !
    !        if (mod(n*lot,l)/=0) then
    !            error stop "complex_nd_forward: "&
    !                //"incommensurate input arguments "&
    !                //"mod(n*lot,size(complex_data)) /= 0."
    !        end if
    !
    !
    !        associate( &
    !            c => complex_data, &
    !            lenwrk => get_complex_nd_workspace_length(n, lot), &
    !            lensav => get_complex_nd_saved_workspace_length(n) , &
    !            lenc => n*lot, &
    !            jump => n, &
    !            inc => 1, &
    !            ier => error_flag &
    !            )
    !
    !            !
    !            !==> Allocate memory
    !            !
    !            allocate( this%saved_workspace(lensav) )
    !            allocate( this%workspace(lenwrk) )
    !
    !            associate( &
    !                wsave => this%saved_workspace, &
    !                work => this%workspace &
    !                )
    !
    !                !
    !                !==> Initialize transform
    !                !
    !                call cfftmi(n, wsave, lensav, ier)
    !
    !                ! Check error_flag
    !                if(ier == 2) then
    !                    error stop "cfftmi: lensave not big enough"
    !                end if
    !
    !                 !
    !                 !==> Perform transform
    !                 !
    !                call cfftmf(lot, jump, n, inc, c, lenc, wsave, lensav, work, lenwrk, ier)
    !
    !            end associate
    !        end associate
    !
    !        !
    !        !==> Release memory
    !        !
    !        call this%destroy()
    !
    !        ! Check error_flag
    !        select case (error_flag)
    !            case (0)
    !                return
    !            case (1)
    !                error stop "cfftmf: lenc not big enough"
    !            case (2)
    !                error stop "cfftmf: lensav not big enough"
    !            case (3)
    !                error stop "cfftmf: lenwrk not big enough"
    !            case (4)
    !                error stop "cfftmf: inc, jump, n, lot are not consistent"
    !        end select
    !
    !    end subroutine complex_nd_forward
    !
    !    subroutine complex_nd_backward(this, n, lot, complex_data)
    !        !-----------------------------------------------------------------
    !        ! Dummy arguments
    !        !-----------------------------------------------------------------
    !        class (FFTpack), intent (in out) :: this
    !        integer (ip),    intent (in)     :: n   ! length of each sequence
    !        integer (ip),    intent (in)     :: lot ! number of sequences
    !        complex (wp),    intent(in out)  :: complex_data(:)
    !        !-----------------------------------------------------------------
    !        ! Local variables
    !        !-----------------------------------------------------------------
    !        integer (ip) :: l, error_flag
    !        !-----------------------------------------------------------------
    !
    !        l = size(complex_data)
    !
    !        if (mod(n*lot,l)/=0) then
    !            error stop "complex_nd_backward: "&
    !                //"incommensurate input arguments "&
    !                //"mod(n*lot,size(complex_data)) /= 0."
    !        end if
    !
    !
    !        associate( &
    !            c => complex_data, &
    !            lenwrk => get_complex_nd_workspace_length(n, lot), &
    !            lensav => get_complex_nd_saved_workspace_length(n) , &
    !            lenc => n*lot, &
    !            jump => n, &
    !            inc => 1, &
    !            ier => error_flag &
    !            )
    !
    !            !
    !            !==> Allocate memory
    !            !
    !            allocate( this%saved_workspace(lensav) )
    !            allocate( this%workspace(lenwrk) )
    !
    !            associate( &
    !                wsave => this%saved_workspace, &
    !                work => this%workspace &
    !                )
    !
    !                !
    !                !==> Initialize transform
    !                !
    !                call cfftmi(n, wsave, lensav, ier)
    !
    !                ! Check error_flag
    !                if(ier == 2) then
    !                    error stop "cfftmi: lensave not big enough"
    !                end if
    !
    !                !
    !                !==> Perform transform
    !                !
    !                call cfftmb(lot,jump,n,inc,c,lenc,wsave,lensav,work,lenwrk,ier)
    !
    !            end associate
    !        end associate
    !
    !        !
    !        !==> Release memory
    !        !
    !        call this%destroy()
    !
    !        ! Check error_flag
    !        select case (error_flag)
    !            case (0)
    !                return
    !            case (1)
    !                error stop "cfftmb: lenc not big enough"
    !            case (2)
    !                error stop "cfftmb: lensav not big enough"
    !            case (3)
    !                error stop "cfftmb: lenwrk not big enough"
    !            case (4)
    !                error stop "cfftmb: inc, jump, n, lot are not consistent"
    !        end select
    !
    !    end subroutine complex_nd_backward

    pure function fftpack_2d_constructor(l, m) result (return_value)
        !------------------------------------------------------------------
        ! Dummy arguments
        !------------------------------------------------------------------
        integer (ip), intent (in) :: l
        integer (ip), intent (in) :: m
        type (FFTpack)            :: return_value
        !------------------------------------------------------------------

        !
        !==> Allocate memory
        !
        return_value %saved_workspace = get_2d_saved_workspace(l,m)
        return_value%workspace = get_2d_workspace(l,m)

    end function fftpack_2d_constructor

    pure function fftpack_1d_constructor(n) result (return_value)
        !------------------------------------------------------------------
        ! Dummy arguments
        !------------------------------------------------------------------
        integer (ip), intent (in) :: n
        type (FFTpack)            :: return_value
        !------------------------------------------------------------------

        !
        !==> Allocate memory
        !
        return_value %saved_workspace = get_1d_saved_workspace(n)
        return_value%workspace = get_1d_workspace(n)

    end function fftpack_1d_constructor

    subroutine create_fftpack(this, lensav, lenwrk)
        !------------------------------------------------------------------
        ! Dummy arguments
        !------------------------------------------------------------------
        class (FFTpack) , intent (in out) :: this
        integer (ip),     intent (in)     :: lensav
        integer (ip),     intent (in)     :: lenwrk
        !------------------------------------------------------------------

        ! Ensure that object is usable
        call this%destroy()

        !
        !==> Allocate memory
        !
        allocate( this%saved_workspace(lensav) )
        allocate( this%workspace(lenwrk) )

    end subroutine create_fftpack

    subroutine destroy_fftpack(this)
        !------------------------------------------------------------------
        ! Dummy arguments
        !------------------------------------------------------------------
        class (FFTpack) , intent (in out) :: this
        !------------------------------------------------------------------

        !
        !==> Release memory
        !
        if (allocated(this%saved_workspace)) then
            deallocate( this%saved_workspace )
        end if

        if (allocated(this%workspace)) then
            deallocate( this%workspace )
        end if

    end subroutine destroy_fftpack

end module type_FFTpack


!============================================================================
! CALCULO DE LA ENERGIA DE UNA DE LA CONFIGURACION DE LA CELDA
! POZO CUADRADO (SW)
!
! Autor: Martin Alejandro Paredes Sosa
!============================================================================

Subroutine EnergyConfig(V)
  Use cte
  Implicit None
  Real ::  V, Rx1, Rxd, Ry1, Ryd, Rz1, Rzd, Dist, VNew
  Integer :: i, j
  V = 0
  IterPart: Do i=1, N-1

     Rx1 = X(i)
     Ry1 = Y(i)
     Rz1 = Z(i)

     IterPart2: Do j = i+1, N
        Rxd = Rx1 - X(j)
        Ryd = Ry1 - Y(j)
        Rzd = Rz1 - Z(j)

        !CONDICION DE IMAGEN MINIMA (LOCALIZAR PARTICULAS EN CELDAS CERCANAS)
        Rxd = Rxd - BoxL*Anint(Rxd/BoxL)
        Ryd = Ryd - BoxL*Anint(Ryd/BoxL)
	Rzd = Rzd - BoxL*Anint(Rzd/BoxL)

        !INGRESANDO MODELO DE INTERACCON (DISCOS DUROS)
        Dist = sqrt( Rxd*Rxd + Ryd*Ryd + Rzd*Rzd )

        ChecarInter: If(Dist .LT. RCut)  Then

           ChecarCercania: If (Dist .LE. 1.0) Then                   ! DESPUES DEL POZO
              VNew = 1.0E+10
           Else If( (Dist .GT. 1.0) .AND. (Dist .LT. Lambda)  ) Then ! ZONA DEL POZO
              VNew = -1.0 / TP
           Else                                                      ! ANTES DEL POZO
              VNew = 0
           End If ChecarCercania

           V = V + VNew
        End If ChecarInter

     End Do IterPart2
  End Do IterPart

End Subroutine EnergyConfig


      FUNCTION VKAPPA(R)
C ----------------------------------------------------------------
C RETURNS VKAPPA = THE MAXIMUM LIKELIHOOD ESTIMATE OF 'KAPPA', THE
C CONCENTRATION PARAMETER OF VON MISES' DISTRIBUTION OF DIRECTIONS
C IN 2 DIMENSIONS, CORRESPONDING TO A SAMPLE MEAN VECTOR MODULUS R.
C VKAPPA = K(A), THE INVERSE FUNCTION OF  A(K) = RATIO OF MODIFIED
C BESSEL FUNCTIONS OF THE FIRST KIND, VIZ., A(K) = I1(K)/I0(K).
C ----------------------------------------------------------------
C
C  FOR 8S (SIGNIFICANT DECIMAL DIGITS) PRECISION AUXILIARY ROUTINE
C  FUNCTION BESRAT(V) MUST BE SET TO AT LEAST 9.3S
      DATA V1 /0.642/, V2 /0.95/
      A = R
      S = -1.0
C
C   ERROR SIGNAL: VALUE -1.0 RETURNED IF ARGUMENT -VE OR 1.0 OR MORE.
      IF (A.LT.0.0 .OR. A.GE.1.0) GO TO 30
      Y = 2.0/(1.0-A)
      IF (A.GT.0.85) GO TO 10
C
C   FOR R BELOW 0.85 USE ADJUSTED INVERSE TAYLOR SERIES.
      X = A*A
      S = (((A-5.6076)*A+5.0797)*A-4.6494)*Y*X - 1.0
      S = ((((S*X+15.0)*X+60.0)*X/360.0+1.0)*X-2.0)*A/(X-1.0)
      IF (V1-A) 20, 20, 30
C
C   FOR R ABOVE 0.85 USE CONTINUED FRACTION APPROXIMATION.
   10 IF (A.GE.0.95) X = 32.0/(120.0*A-131.5+Y)
      IF (A.LT.0.95) X = (-2326.0*A+4317.5526)*A - 2001.035224
      S = (Y+1.0+3.0/(Y-5.0-12.0/(Y-10.0-X)))*0.25
      IF (A.GE.V2) GO TO 30
C
C   FOR R IN (0.642,0.95) APPLY NEWTON-RAPHSON, TWICE IF R IN
C   (0.75,0.875), FOR 8S PRECISION, USING APPROXIMATE DERIVATIVE -
   20 Y = ((0.00048*Y-0.1589)*Y+0.744)*Y - 4.2932
      IF (A.LE.0.875) S = (BESRAT(S)-A)*Y + S
      IF (A.GE.0.75) S = (BESRAT(S)-A)*Y + S
   30 VKAPPA = S
      RETURN
      END


module mod_initial_data
!=============================================================================
   use mod_prec
   use mod_field,  only: field
   use mod_cheb,   only: Rvec
   use mod_swal,   only: swal
   use mod_params, only: &
      ZI, dt, nx, ny, &
      min_m, max_m, &
      lin_m, &
      spin=>psi_spin, &
      cl=>compactification_length, &
      bhm=>black_hole_mass, &
      bhs=>black_hole_spin, &
      R_max, &
! initial data parameters
      initial_data_direction_v=>initial_data_direction, &
      amp_re_v=>amp_re, &
      amp_im_v=>amp_im, &
      rl_v=>rl, &
      ru_v=>ru, &
      l_ang_v=>l_ang
!=============================================================================
   implicit none
   private

   public :: set_initial_data
!=============================================================================
contains
!=============================================================================
   subroutine set_initial_data(m_i,p,q,f)
      integer(ip), intent(in) :: m_i
      type(field), intent(inout) :: p, q, f

      integer(ip) :: i, j
      integer(ip) :: m_ang, l_ang
      real(rp) :: max_val, bump, r
      real(rp) :: width, rl, ru

      complex(rp) :: amp

      character(:), allocatable :: initial_data_direction

      m_ang = lin_m(m_i)
      amp   = amp_re_v(m_i) + ZI*amp_im_v(m_i)
      ru    = ru_v(m_i)
      rl    = rl_v(m_i)
      l_ang = l_ang_v(m_i)
      initial_data_direction = initial_data_direction_v(m_i:m_i)

      max_val = 0.0_rp
      width = maxval([ru-rl,1e-16_rp]) ! need width>0 so no NaNs
!-----------------------------------------------------------------------------
      y_loop: do j=1,ny
      x_loop: do i=1,nx-1 ! index 'i=nx' is at 'r=infinity'
         r = (cl**2) / Rvec(i)

         if ((r<ru).and.(r>rl)) then
            bump = exp(-1.0_rp*width/(r-rl))*exp(-2.0_rp*width/(ru-r))
         else
            bump = 0.0_rp
         end if

         f%n(i,j,m_ang) = (((r-rl)/width)**2) * (((ru-r)/width)**2) * bump

         q%n(i,j,m_ang) = ( &
            (2.0_rp*(((r-rl)/width)   )*(((ru-r)/width)**2)) &
         -  (2.0_rp*(((r-rl)/width)**2)*( (ru-r)/width    )) &
         +  (1.0_rp*(1.0_rp           )*(((ru-r)/width)**2)) &
         -  (2.0_rp*(((r-rl)/width)**2)*(1.0_rp              )) &
         )*bump/width
         !--------------------------------------------------------------------
         ! rescale q as q = \partial_R f = -(r/cl)^2 partial_r f
         !--------------------------------------------------------------------
         q%n(i,j,m_ang) = q%n(i,j,m_ang)*(-(r**2)/(cl**2))

         p%n(i,j,m_ang) = 0.0_rp

         f%n(i,j,m_ang) = f%n(i,j,m_ang) * swal(j,l_ang,m_ang,spin)
         q%n(i,j,m_ang) = q%n(i,j,m_ang) * swal(j,l_ang,m_ang,spin)

         max_val = max(abs(f%n(i,j,m_ang)),max_val)

      end do x_loop
      end do y_loop
!-----------------------------------------------------------------------------
! rescale to make max val = 'amp'
!-----------------------------------------------------------------------------
      f%n(:,:,m_ang) = f%n(:,:,m_ang) * (amp / max_val)
      q%n(:,:,m_ang) = q%n(:,:,m_ang) * (amp / max_val)
!-----------------------------------------------------------------------------
! p = (...)\phi_{,t} + (...), so use p to set \phi_{,t}
!-----------------------------------------------------------------------------
      select case (initial_data_direction)
         !-----------------------------------------------------------------------
         ! tangent to outgoing principal null direction
         case ("o")
            do j=1,ny
            do i=1,nx
               R = Rvec(i)

               p%n(i,j,m_ang) = &
                  0.5_rp*(   &
                     cl**2   &
                  -  2*bhm*R &
                  +  (bhs*R/cl)**2 &
                  )*q%n(i,j,m_ang) &
               -  ZI*bhs*f%n(i,j,m_ang)

               p%n(i,j,m_ang) = &
                  p%n(i,j,m_ang) / (  &
                     2*bhm*(2*bhm - ((bhs/cl)**2) * R) &
                  )
            end do
            end do
         !-----------------------------------------------------------------------
         ! tangent to ingoing principal null direction
         case ("i")
            do j=1,ny
            do i=1,nx
               R = Rvec(i)

               p%n(i,j,m_ang) = &
               -  ((R/cl)**2) * q%n(i,j,m_ang)

               p%n(i,j,m_ang) = &
                  p%n(i,j,m_ang) / (  &
                     2 + (4*bhm*R)/(cl**2) &
                  )
            end do
            end do
         !-----------------------------------------------------------------------
         ! time symmetric
         case ("t")

            p%n(:,:,m_ang) = 0.0_rp

         case default
            ! do nothing
      end select
!-----------------------------------------------------------------------------
! copy to np1 so can be saved
!-----------------------------------------------------------------------------
      p%np1(:,:,m_ang) = p%n(:,:,m_ang)
      q%np1(:,:,m_ang) = q%n(:,:,m_ang)
      f%np1(:,:,m_ang) = f%n(:,:,m_ang)

   end subroutine set_initial_data
!=============================================================================
end module mod_initial_data


c=======================================================================
c
c     subroutine HLPRIM
c
c     This function computes the matrix of values with log-returns
c
c         price(t+1) = price(t)*exp[x(t)] fot t=1,...,n-1
c
c-----------------------------------------------------------------------
      SUBROUTINE hlprim ( n, p, logret, inipri, m, mprice, info )
c-----------------------------------------------------------------------
c
c     INPUT :
c            n      : number of log-return(s) (n >= 1)           integer
c            p      : number of asset(s) (p >= 1)                integer
c            logret : log-return (n*p)                            double
c            inipri : initial price(s) (p)                        double
c
c     OUTPUT :
c            m      : number of price(s)                         integer
c            mprice : price(s) (n*p)                              double
c            info   : diagnostic argument                        integer
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, p, m, info
      DOUBLE PRECISION mprice(n + 1,*), logret(n,*), inipri(*)
c
c     local variables
      INTEGER i, j
c
c     intrinsic functions
      INTRINSIC exp
c
c-----------------------------------------------------------------------
c
c     initialization
      info = 0
      m    = n + 1
c
      DO j = 1,p
         mprice(1,j) = inipri(j)
         DO i = 1,n
            mprice(i+1,j) = mprice(i,j) * exp (logret(i,j))
         ENDDO
      ENDDO
c
      RETURN
      END


      SUBROUTINE LMRGEV(PARA,XMOM,NMOM)
C***********************************************************************
C*                                                                     *
C*  FORTRAN CODE WRITTEN FOR INCLUSION IN IBM RESEARCH REPORT RC20525, *
C*  'FORTRAN ROUTINES FOR USE WITH THE METHOD OF L-MOMENTS, VERSION 3' *
C*                                                                     *
C*  J. R. M. HOSKING                                                   *
C*  IBM RESEARCH DIVISION                                              *
C*  T. J. WATSON RESEARCH CENTER                                       *
C*  YORKTOWN HEIGHTS                                                   *
C*  NEW YORK 10598, U.S.A.                                             *
C*                                                                     *
C*  VERSION 3     AUGUST 1996                                          *
C*                                                                     *
C***********************************************************************
C
C  L-MOMENT RATIOS FOR THE GENERALIZED EXTREME-VALUE DISTRIBUTION
C
C  PARAMETERS OF ROUTINE:
C  PARA   * INPUT* ARRAY OF LENGTH 3. CONTAINS THE PARAMETERS OF THE
C                  DISTRIBUTION, IN THE ORDER XI, ALPHA, K (LOCATION,
C                  SCALE, SHAPE).
C  XMOM   *OUTPUT* ARRAY OF LENGTH NMOM. ON EXIT, CONTAINS THE L-MOMENTS
C                  LAMBDA-1, LAMBDA-2, TAU-3, TAU-4, ... .
C  NMOM   * INPUT* NUMBER OF L-MOMENTS TO BE FOUND. AT MOST 20.
C
C  OTHER ROUTINES USED: DLGAMA
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION PARA(3),XMOM(NMOM),ZMOM(20)
      DATA ZERO/0D0/,ONE/1D0/,TWO/2D0/,THREE/3D0/,FOUR/4D0/,SIX/6D0/
C
C         ARRAY ZMOM CONTAINS THE L-MOMENT RATIOS OF THE STANDARD
C         GUMBEL DISTRIBUTION (XI=0, ALPHA=1).
C         ZMOM(1) IS EULER'S CONSTANT, ZMOM(2) IS LOG(2).
C
      DATA ZMOM/
     *  0.57721 56649 01532 861D 0,  0.69314 71805 59945 309D 0,
     *  0.16992 50014 42312 363D 0,  0.15037 49927 88438 185D 0,
     *  0.55868 35005 77583 138D-1,  0.58110 02399 99710 876D-1,
     *  0.27624 25842 97309 125D-1,  0.30556 37665 79053 126D-1,
     *  0.16465 02822 58328 802D-1,  0.18784 66242 98170 912D-1,
     *  0.10932 82150 63027 148D-1,  0.12697 31266 76329 530D-1,
     *  0.77898 28180 57231 804D-2,  0.91483 61796 21999 726D-2,
     *  0.58333 23893 28363 588D-2,  0.69010 42875 90348 154D-2,
     *  0.45326 79701 80679 549D-2,  0.53891 68113 26595 459D-2,
     *  0.36240 77677 72368 790D-2,  0.43238 76086 05538 096D-2/
C
C         SMALL IS USED TO TEST WHETHER K IS EFFECTIVELY ZERO
C
      DATA SMALL/1D-6/
C
      U=PARA(1)
      A=PARA(2)
      G=PARA(3)
      IF(A.LE.ZERO.OR.G.LE.-ONE)GOTO 1000
      IF(NMOM.GT.20)GOTO 1010
C
C         TEST FOR K=0
C
      IF(DABS(G).GT.SMALL)GOTO 5
      XMOM(1)=U
      IF(NMOM.EQ.1)RETURN
      XMOM(2)=A*ZMOM(2)
      IF(NMOM.EQ.2)RETURN
      DO 2 I=3,NMOM
    2 XMOM(I)=ZMOM(I)
      RETURN
    5 CONTINUE
C
C         FIRST 2 MOMENTS
C
   10 CONTINUE
      GAM=DEXP(DLGAMA(ONE+G))
      XMOM(1)=U+A*(ONE-GAM)/G
      IF(NMOM.EQ.1)RETURN
      XX2=ONE-TWO**(-G)
      XMOM(2)=A*XX2*GAM/G
      IF(NMOM.EQ.2)RETURN
C
C         HIGHER MOMENTS
C
      Z0=ONE
      DO 50 J=3,NMOM
      DJ=J
      BETA=(ONE-DJ**(-G))/XX2
      Z0=Z0*(FOUR*DJ-SIX)/DJ
      Z=Z0*THREE*(DJ-ONE)/(DJ+ONE)
      SUM=Z0*BETA-Z
      IF(J.EQ.3)GOTO 40
      DO 30 I=2,J-2
      DI=I
      Z=Z*(DI+DI+ONE)*(DJ-DI)/((DI+DI-ONE)*(DJ+DI))
      SUM=SUM-Z*XMOM(I+1)
   30 CONTINUE
   40 XMOM(J)=SUM
   50 CONTINUE
      RETURN
C
 1000 WRITE(6,7000)
      RETURN
 1010 WRITE(6,7010)
      RETURN
C
 7000 FORMAT(' *** ERROR *** ROUTINE LMRGEV : PARAMETERS INVALID')
 7010 FORMAT(' *** ERROR *** ROUTINE LMRGEV : PARAMETER NMOM TOO LARGE')
      END


        program test_nint
          real :: k = 0.5
          real :: x = 1.45
          real :: y = 12.76
          real :: z = -0.5

          integer a, b, c, d
          a = nint(k)
          b = nint(x)
          c = nint(y)
          d = nint(z)

          print *, a, b, c, d
        end program test_nint


SUBROUTINE rotmat(a,b,c,s)

!----------------------------------------------------
!
! Compute the Givens rotation matrix parameters c, s
!  for given a, b
!
!----------------------------------------------------

IMPLICIT NONE
REAL*8, INTENT(IN) :: a, b
REAL*8, INTENT(OUT) :: c, s
REAL*8 :: temp

IF (b == 0.0) THEN
   c = 1.0
   s = 0.0
ELSE IF (abs(b) > abs(a)) THEN
   temp = a/b
   s = 1.0/SQRT(1.0 + temp**2)
   c = temp*s
ELSE
   temp = b/a
   c = 1.0/SQRT(1.0 + temp**2)
   s = temp*c
END IF

RETURN
END SUBROUTINE rotmat


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                          Spherepack                           *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!
!
!     12/96
!
!     a program for testing all gradient and inverse gradient routines
!
!     (1) first a scalar field is set in st by restricting a poly in x, y, z
!         to the sphere surface
!
!     (2) a scalar analysis is used to compute the coefs a, b of st
!
!     (3) a, b are input to the various gradient routines to compute a vector field
!         (v, w)
!
!     (4) the vector field (v, w) is compared with the gradient of st obtained
!         analytically
!
!     (5) the inverse gradient of (v, w) is computed and compared with (1)
!
program tgrad

    use, intrinsic :: ISO_Fortran_env, only: &
        stdout => OUTPUT_UNIT

    use spherepack, only: &
        ip, & ! Integer precision
        wp, & ! Working precision
        Sphere, &
        Regularsphere, &
        GaussianSphere

    ! Explicit typing only
    implicit none

    ! Dictionary
    class(Sphere), allocatable :: solver

    !  Test gaussian grid
    allocate (GaussianSphere :: solver)
    call test_gradient_routines(solver)
    deallocate (solver)

    !  Test regular grid
    allocate (RegularSphere :: solver)
    call test_gradient_routines(solver)
    deallocate (solver)

contains

    subroutine test_gradient_routines(sphere_type)

        ! Dummy arguments
        class(Sphere), intent(inout)  :: sphere_type

        ! Local variables
        integer(ip), parameter        :: NLATS = 33
        integer(ip), parameter        :: NLONS = 18
        integer(ip), parameter        :: NSYNTHS = 4
        integer(ip)                   :: i, j, k ! Counters
        real(wp)                      :: original_polar_gradient_component(NLATS, NLONS, NSYNTHS)
        real(wp)                      :: original_azimuthal_gradient_component(NLATS, NLONS, NSYNTHS)
        real(wp)                      :: original_scalar_function(NLATS, NLONS, NSYNTHS)
        real(wp)                      :: approximate_polar_gradient_component(NLATS, NLONS, NSYNTHS)
        real(wp)                      :: approximate_azimuthal_gradient_component(NLATS, NLONS, NSYNTHS)
        real(wp)                      :: approximate_scalar_function(NLATS, NLONS, NSYNTHS)
        character(len=:), allocatable :: previous_gradient_inversion_error
        character(len=:), allocatable :: previous_polar_gradient_error
        character(len=:), allocatable :: previous_azimuthal_gradient_error

        !  Set up workspace arrays
        select type(sphere_type)
            type is (GaussianSphere)

            !  Initialize gaussian sphere object
            sphere_type = GaussianSphere(NLATS, NLONS)

            ! Allocate known error from previous platform
            allocate (previous_polar_gradient_error, source='     polar inversion error     = 2.953193e-14')
            allocate (previous_azimuthal_gradient_error, source='     azimuthal inversion error = 1.720846e-14')
            allocate (previous_gradient_inversion_error, source='     gradient error     = 6.106227e-16')

            type is (RegularSphere)

            ! Initialize regular sphere
            sphere_type = RegularSphere(NLATS, NLONS)

            ! Allocate known error from previous platform

            allocate (previous_polar_gradient_error, source='     polar inversion error     = 2.126077e-14')
            allocate (previous_azimuthal_gradient_error, source='     azimuthal inversion error = 3.663736e-15')
            allocate (previous_gradient_inversion_error, source='     gradient error     = 6.661338e-16')
        end select

        !
        !  set scalar stream and velocity potential fields as polys in x, y, z
        !    and then set v, w from st, sv scalar fields
        !
        associate (&
            ve => original_polar_gradient_component, &
            we => original_azimuthal_gradient_component, &
            sfe => original_scalar_function, &
            radial => sphere_type%unit_vectors%radial, &
            theta => sphere_type%unit_vectors%polar, &
            phi => sphere_type%unit_vectors%azimuthal &
           )
            do k=1, NSYNTHS
                do j=1, NLONS
                    do i=1, NLATS
                        associate (&
                            x => radial(i, j)%x, & !sint*cosp
                            y => radial(i, j)%y, & !sint*sinp
                            z => radial(i, j)%z, & !cost
                            dxdt => theta(i, j)%x, &! cost*cosp
                            dxdp => -radial(i, j)%y, & !-sint*sinp
                            dydt => theta(i, j)%y, &! cost*sinp
                            dydp => radial(i, j)%x, & ! sint*cosp
                            dzdt => theta(i, j)%z, & ! -sint
                            dzdp => phi(i, j)%z, & ! 0.0
                            cosp => phi(i, j)%y, &
                            sinp => -phi(i, j)%x &
                           )
                            select case (k)
                                case (1)
                                    associate (&
                                        dsfdt => x*dydt+y*dxdt, &
                                        dsfdp => x*dydp+y*dxdp &
                                       )
                                        sfe(i, j, k) = x*y
                                        ve(i, j, k) = dsfdt
                                        we(i, j, k) = (cosp*dydp+sinp*dxdp)
                                    end associate
                                case (2)
                                    associate (&
                                        dsfdp => x*dzdp+z*dxdp, &
                                        dsfdt => x*dzdt+z*dxdt &
                                       )
                                        sfe(i, j, k) = x*z
                                        ve(i, j, k) = dsfdt
                                        we(i, j, k) = cosp*dzdp-z*sinp
                                    end associate
                                case (3)
                                    associate (&
                                        dsfdt => y*dzdt + z*dydt, &
                                        dsfdp => y*dzdp+ z*dydp &
                                       )
                                        sfe(i, j, k) = y*z
                                        ve(i, j, k) = dsfdt
                                        we(i, j, k) = sinp*dzdp + z*cosp
                                    end associate
                                case (4)
                                    associate (&
                                        dsfdt => x*y*dzdt + x*z*dydt + y*z*dxdt, &
                                        dsfdp => x*y*dzdp + x*z*dydp + y*z*dxdp &
                                       )
                                        sfe(i, j, k) = x*y*z
                                        ve(i, j, k) = dsfdt
                                        we(i, j, k) = cosp*y*dzdp+cosp*z*dydp+sinp*z*dxdp
                                    end associate
                            end select
                        end associate
                    end do
                end do
            end do
        end associate

        !
        !  Compute gradient
        !
        do k=1, NSYNTHS
            associate (&
                v => approximate_polar_gradient_component(:, :, k), &
                w => approximate_azimuthal_gradient_component(:, :, k), &
                sfe => original_scalar_function(:, :, k) &
               )
                call sphere_type%get_gradient(sfe, v, w)
            end associate
        end do

        !
        !  compare this v, w with original
        !
        associate (&
            ve => original_polar_gradient_component, &
            we => original_azimuthal_gradient_component, &
            v => approximate_polar_gradient_component, &
            w => approximate_azimuthal_gradient_component &
           )
            associate (&
                err2v => maxval(abs(v-ve)), &
                err2w => maxval(abs(w-we)) &
               )
                !
                !  Print earlier output from platform with 64-bit floating point
                !    arithmetic followed by the output from this computer
                !
                write (stdout, '(a)') ''
                write (stdout, '(a)') '     tgrad *** TEST RUN *** '
                write (stdout, '(a)') ''
                write (stdout, '(a)') '     grid type = '//sphere_type%grid%grid_type
                write (stdout, '(a)') '     Testing gradient'
                write (stdout, '(2(a, i3))') '     nlat = ', NLATS, ' nlon = ', NLONS
                write (stdout, '(a)') '     Previous 64 bit floating point arithmetic result '
                write (stdout, '(a)') previous_polar_gradient_error
                write (stdout, '(a)') previous_azimuthal_gradient_error
                write (stdout, '(a)') '     The output from your computer is: '
                write (stdout, '(a, 1pe15.6)') '     polar gradient error     = ', err2v
                write (stdout, '(a, 1pe15.6)') '     azimuthal gradient error = ', err2w
                write (stdout, '(a)') ''
            end associate
        end associate

        !
        !  Now recompute sf inverting (ve, we)
        !
        do k=1, NSYNTHS
            associate (&
                ve => original_polar_gradient_component(:, :, k), &
                we => original_azimuthal_gradient_component(:, :, k), &
                sf => approximate_scalar_function(:, :, k) &
               )
                call sphere_type%invert_gradient(ve, we, sf)
            end associate
        end do
        !
        !  Compute gradient inversion error
        !
        associate (&
            sf => approximate_scalar_function, &
            sfe => original_scalar_function &
           )
            associate (err2 => maxval(abs(sf-sfe)))
                !
                !  Print earlier output from platform with 64-bit floating point
                !    arithmetic followed by the output from this computer
                !
                write (stdout, '(a)') ''
                write (stdout, '(a)') '     test gradient routines *** TEST RUN *** '
                write (stdout, '(a)') ''
                write (stdout, '(a)') '     grid type = '//sphere_type%grid%grid_type
                write (stdout, '(a)') '     Testing gradient inversion'
                write (stdout, '(2(a, i3))') '     nlat = ', NLATS, ' nlon = ', NLONS
                write (stdout, '(a)') '     Previous 64 bit floating point arithmetic result '
                write (stdout, '(a)') previous_gradient_inversion_error
                write (stdout, '(a)') '     The output from your computer is: '
                write (stdout, '(a, 1pe15.6)') '     gradient inversion error     = ', err2
                write (stdout, '(a)') ''
            end associate
        end associate
        !
        !  Release memory
        !
        deallocate (previous_gradient_inversion_error)
        deallocate (previous_polar_gradient_error)
        deallocate (previous_azimuthal_gradient_error)
        call sphere_type%destroy()

    end subroutine test_gradient_routines

end program tgrad