module type_Sphere

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

    use type_Workspace, only: &
        Workspace

    use type_SphericalGrid, only: &
        SphericalGrid

    use type_SphericalUnitVectors, only: &
        SphericalUnitVectors

    use type_TrigonometricTable, only: &
        TrigonometricTable

    use type_Vector3D, only: &
        Vector => Vector3D, &
        assignment(=), &
        operator(*)

    ! Explicit typing only
    implicit none

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

    ! Parameters confined to the module
    real(wp), parameter :: ZERO = 0.0_wp
    real(wp), parameter :: HALF = 0.5_wp
    real(wp), parameter :: ONE = 1.0_wp
    real(wp), parameter :: TWO = 2.0_wp

    type, public, abstract :: Sphere
        ! Type components
        logical,                           public :: initialized = .false.
        integer(ip),                       public :: NUMBER_OF_LONGITUDES = 0
        integer(ip),                       public :: NUMBER_OF_LATITUDES = 0
        integer(ip),                       public :: TRIANGULAR_TRUNCATION_LIMIT = 0
        integer(ip),                       public :: SCALAR_SYMMETRIES = 0
        integer(ip),                       public :: VECTOR_SYMMETRIES = 0
        integer(ip),                       public :: NUMBER_OF_SYNTHESES = 0
        integer(ip),          allocatable, public :: INDEX_ORDER_M(:)
        integer(ip),          allocatable, public :: INDEX_DEGREE_N(:)
        real(wp),                          public :: RADIUS_OF_SPHERE = ZERO
        real(wp),             allocatable, public :: COEFFICIENT_MULTIPLIERS(:)
        real(wp),             allocatable, public :: LAPLACIAN_COEFFICIENT_MULTIPLIERS(:)
        real(wp),             allocatable, public :: INVERSE_LAPLACIAN_COEFFICIENT_MULTIPLIERS(:)
        complex(wp),          allocatable, public :: complex_spectral_coefficients(:)
        class(Workspace),     allocatable, public :: workspace
        class(SphericalGrid), allocatable, public :: grid
        type(TrigonometricTable),          public :: trigonometric_table
        type(SphericalUnitVectors),        public :: unit_vectors
    contains
        ! Type-bound procedures
        procedure, public  :: create_sphere
        procedure, public  :: destroy => destroy_sphere
        procedure, public  :: destroy_sphere
        procedure, public  :: get_index
        procedure, public  :: get_coefficient
        procedure, public  :: invert_helmholtz
        procedure, public  :: invert_vorticity
        procedure, public  :: get_gradient
        procedure, private :: invert_gradient_from_spherical_components
        procedure, private :: get_vorticity_from_spherical_components
        procedure, private :: get_vorticity_from_vector_field
        procedure, private :: get_divergence_from_vector_field
        procedure, private :: get_divergence_from_spherical_components
        procedure, public  :: invert_divergence
        procedure, public  :: get_rotation_operator => compute_angular_momentum
        procedure, private :: get_scalar_symmetries
        procedure, private :: get_vector_symmetries
        procedure, public  :: perform_complex_analysis
        procedure, public  :: perform_complex_synthesis
        procedure, private :: perform_vector_analysis_from_vector_field
        procedure, public  :: synthesize_from_complex_spectral_coefficients
        procedure, public  :: analyze_into_complex_spectral_coefficients
        procedure, public  :: get_vorticity_and_divergence_from_velocities
        procedure, private :: get_velocities_from_vorticity_and_divergence_coefficients
        procedure, public  :: get_velocities_from_vorticity_and_divergence
        procedure, private :: get_scalar_laplacian
        procedure, private :: compute_vector_laplacian_coefficients
        procedure, private :: get_vector_laplacian_from_spherical_components
        procedure, private :: get_vector_laplacian_from_vector_field
        procedure, private :: invert_scalar_laplacian
        procedure, private :: invert_vector_laplacian
        ! Deferred type-bound procedures
        procedure(assert_init), deferred, public :: &
            assert_initialized
        procedure(scalar_analysis), deferred, public :: &
            perform_scalar_analysis
        procedure(scalar_synthesis), deferred, public :: &
            perform_scalar_synthesis
        procedure(vector_analysis), deferred, public :: &
            vector_analysis_from_spherical_components
        procedure(vector_synthesis), deferred, public :: &
            perform_vector_synthesis
        ! Generic type-bound procedures
        generic, public :: perform_vector_analysis => &
            perform_vector_analysis_from_vector_field
        generic, public :: invert_laplacian => &
            invert_scalar_laplacian, &
            invert_vector_laplacian
        generic, public :: get_divergence => &
            get_divergence_from_vector_field, &
            get_divergence_from_spherical_components
        generic, public :: get_laplacian => &
            get_scalar_laplacian, &
            get_vector_laplacian_from_spherical_components, &
            get_vector_laplacian_from_vector_field
        generic, public :: get_vorticity => &
            get_vorticity_from_spherical_components, &
            get_vorticity_from_vector_field
        generic, public :: invert_gradient => &
            invert_gradient_from_spherical_components
    end type Sphere

    ! Declare interfaces for deferred type-bound procedures
    abstract interface
        subroutine assert_init(self, routine)
            import:: Sphere

            ! Dummy arguments
            class(Sphere),    intent(inout) :: self
            character(len=*), intent(in)    :: routine
        end subroutine assert_init

        subroutine scalar_analysis(self, scalar_function)
            import :: Sphere, wp

            ! Dummy arguments
            class(Sphere), intent(inout)  :: self
            real(wp),      intent(in)     :: scalar_function(:, :)
        end subroutine scalar_analysis

        subroutine scalar_synthesis(self, scalar_function)
            import :: Sphere, wp

            ! Dummy arguments
            class(Sphere), intent(inout)  :: self
            real(wp),      intent(out)   :: scalar_function(:, :)
        end subroutine scalar_synthesis

        subroutine vector_analysis(self, polar_component, azimuthal_component)
            import :: Sphere, wp

            ! Dummy arguments
            class(Sphere), intent(inout)  :: self
            real(wp),      intent(in)     :: polar_component(:, :)
            real(wp),      intent(in)     :: azimuthal_component(:, :)
        end subroutine vector_analysis

        subroutine vector_synthesis(self, polar_component, azimuthal_component)
            import :: Sphere, wp

            ! Dummy arguments
            class(Sphere), intent(inout)  :: self
            real(wp),      intent(out)    :: polar_component(:, :)
            real(wp),      intent(out)    :: azimuthal_component(:, :)
        end subroutine vector_synthesis
    end interface

contains

    subroutine create_sphere(self, nlat, nlon, ntrunc, isym, itype, nt, rsphere)

        ! Dummy arguments
        class(Sphere), intent(inout)  :: self
        integer(ip),   intent(in)     :: nlat
        integer(ip),   intent(in)     :: nlon
        integer(ip),   intent(in)     :: ntrunc
        integer(ip),   intent(in)     :: isym  ! Either 0, 1, or 2
        integer(ip),   intent(in)     :: itype ! Either 0, 1, 2, 3, ..., 8
        integer(ip),   intent(in)     :: nt
        real(wp),      intent(in)     :: rsphere

        ! Local variables
        integer(ip) :: m, n

        ! Ensure that object is usable
        call self%destroy_sphere()

        !  Set constants
        self%NUMBER_OF_LATITUDES = nlat
        self%NUMBER_OF_LONGITUDES = nlon
        self%TRIANGULAR_TRUNCATION_LIMIT = ntrunc
        self%NUMBER_OF_SYNTHESES = nt
        self%RADIUS_OF_SPHERE = rsphere

        !  Set scalar symmetries
        call self%get_scalar_symmetries(isym)

        !  Set vector symmetries
        call self%get_vector_symmetries(itype)

        !  Allocate memory
        associate (nm_dim => (ntrunc+1)*(ntrunc+2)/2)
            allocate(self%INDEX_ORDER_M(nm_dim))
            allocate(self%INDEX_DEGREE_N(nm_dim))
            allocate(self%LAPLACIAN_COEFFICIENT_MULTIPLIERS(nm_dim))
            allocate(self%INVERSE_LAPLACIAN_COEFFICIENT_MULTIPLIERS(nm_dim))
            allocate(self%complex_spectral_coefficients(nm_dim))
            allocate(self%COEFFICIENT_MULTIPLIERS(nlat))

            !  Fill arrays
            associate (&
                ntrunc => self%TRIANGULAR_TRUNCATION_LIMIT, &
                indxm => self%INDEX_ORDER_M, &
                indxn => self%INDEX_DEGREE_N, &
                lap => self%LAPLACIAN_COEFFICIENT_MULTIPLIERS, &
                ilap => self%INVERSE_LAPLACIAN_COEFFICIENT_MULTIPLIERS, &
                sqnn => self%COEFFICIENT_MULTIPLIERS &
               )

                !  Precompute indices of order m
                indxm = [((m, n=m, ntrunc), m=0, ntrunc)]

                !  Precompute indices of degree n
                indxn = [((n, n=m, ntrunc), m=0, ntrunc)]

                !  Precompute laplacian coefficients
                lap = -real(indxn, kind=wp) * real(indxn + 1, kind=wp)/(rsphere**2)

                !  Precompute inverse laplacian coefficients
                ilap(1) = ZERO
                ilap(2:nm_dim) = ONE/lap(2:nm_dim)
                !
                !  Precompute vorticity and divergence coefficients
                sqnn = [(sqrt(real((n - 1) * n, kind=wp)/rsphere), n=1, nlat)]

            end associate
        end associate

        !  Initialize derived data types
        associate (&
            grid => self%grid, &
            trig_func => self%trigonometric_table, &
            unit_vectors => self%unit_vectors &
           )
            trig_func = TrigonometricTable(grid)
            unit_vectors = SphericalUnitVectors(grid)
        end associate

        !  Set initialization flag
        self%initialized = .true.

    end subroutine create_sphere

    subroutine destroy_sphere(self)

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

        ! Check flag
        if (.not.self%initialized) return

        !  Release memory
        if (allocated(self%INDEX_ORDER_M)) then
            deallocate (self%INDEX_ORDER_M)
        end if

        if (allocated(self%INDEX_DEGREE_N)) then
            deallocate (self%INDEX_DEGREE_N)
        end if

        if (allocated(self%LAPLACIAN_COEFFICIENT_MULTIPLIERS)) then
            deallocate (self%LAPLACIAN_COEFFICIENT_MULTIPLIERS)
        end if

        if (allocated(self%INVERSE_LAPLACIAN_COEFFICIENT_MULTIPLIERS)) then
            deallocate (self%INVERSE_LAPLACIAN_COEFFICIENT_MULTIPLIERS)
        end if

        if (allocated(self%complex_spectral_coefficients)) then
            deallocate (self%complex_spectral_coefficients)
        end if

        if (allocated(self%COEFFICIENT_MULTIPLIERS)) then
            deallocate (self%COEFFICIENT_MULTIPLIERS)
        end if

        !  Release memory from polymorphic class variables
        if (allocated(self%grid)) deallocate (self%grid)
        if (allocated(self%workspace)) deallocate (self%workspace)

        !   Release memory from derived data types
        call self%trigonometric_table%destroy()
        call self%unit_vectors%destroy()

        !  Reset constants
        self%NUMBER_OF_LONGITUDES = 0
        self%NUMBER_OF_LATITUDES = 0
        self%TRIANGULAR_TRUNCATION_LIMIT = 0
        self%SCALAR_SYMMETRIES = 0
        self%VECTOR_SYMMETRIES = 0
        self%NUMBER_OF_SYNTHESES = 0

        !  Reset initialization flag
        self%initialized = .false.

    end subroutine destroy_sphere

    !
    ! Purpose:
    !
    ! Converts gridded input array (scalar_function) to (complex)
    ! spherical harmonic coefficients (psi).
    !
    ! The spectral data is assumed to be in a complex array of dimension
    ! (mtrunc+1)*(mtrunc+2)/2, whre mtrunc is the triangular truncation limit,
    ! for instance, mtrunc = 42 for T42.
    ! mtrunc must be <= nlat-1.
    ! Coefficients are ordered so that first (nm=1) is m=0, n=0, second is m=0, n=1,
    ! nm=mtrunc is m=0, n=mtrunc, nm=mtrunc+1 is m=1, n=1, etc.
    !
    ! In Fortran syntax, values of m (degree) and n (order) as a function
    ! of the index nm are:
    !
    ! integer(ip), dimension ((mtrunc+1)*(mtrunc+2)/2) :: indxm, indxn
    ! indxm = [((m, n=m, mtrunc), m=0, mtrunc)]
    ! indxn = [((n, n=m, mtrunc), m=0, mtrunc)]
    !
    ! Conversely, the index nm as a function of m and n is:
    ! nm = sum([(i, i=mtrunc+1, mtrunc-m+2, -1)])+n-m+1
    !
    subroutine perform_complex_analysis(self, scalar_function)

        ! Dummy arguments
        class(Sphere), intent(inout) :: self
        real(wp),      intent(in)    :: scalar_function(:, :)

        ! Local variables
        integer(ip) :: n, m

        ! Check if object is usable
        call self%assert_initialized('perform_complex_analysis')

        !   compute the (real) spherical harmonic coefficients
        call self%perform_scalar_analysis(scalar_function)

        !  Set complex spherical harmonic coefficients
        associate (&
            ntrunc => self%TRIANGULAR_TRUNCATION_LIMIT, &
            a => self%workspace%scalar_coefficients%real_component, &
            b => self%workspace%scalar_coefficients%imaginary_component, &
            psi => self%complex_spectral_coefficients &
           )
            psi = HALF * cmplx( &
                [((a(m+1, n+1), n=m, ntrunc), m=0, ntrunc)], &
                [((b(m+1, n+1), n=m, ntrunc), m=0, ntrunc)], &
                kind=wp)
        end associate

    end subroutine perform_complex_analysis

    !
    ! Purpose:
    !
    ! Converts gridded input array to (complex) spherical harmonic coefficients
    !
    subroutine perform_complex_synthesis(self, scalar_function)

        ! Dummy arguments
        class(Sphere), intent(inout) :: self
        real(wp),      intent(out)   :: scalar_function(:, :)

        ! Local variables
        integer(ip) :: n, m, nm

        ! Check if object is usable
        call self%assert_initialized('perform_complex_synthesis')

        !  Convert complex spherical harmonic coefficients to real version
        associate (&
            indxn => self%INDEX_DEGREE_N, &
            indxm => self%INDEX_ORDER_M, &
            a => self%workspace%scalar_coefficients%real_component, &
            b => self%workspace%scalar_coefficients%imaginary_component, &
            psi => self%complex_spectral_coefficients &
           )
            ! Initialize (real) coefficients
            a = ZERO
            b = ZERO

            ! Fill real arrays with contents of spec
            do nm = 1, size(psi)
                n = indxn(nm) ! Set degree n
                m = indxm(nm) ! Set order m

                ! set the real component
                a(m + 1, n + 1) = TWO * real(psi(nm))

                ! set the imaginary component
                b(m + 1, n + 1) = TWO * aimag(psi(nm))
            end do
        end associate

        ! Synthesise the scalar function from the (real) harmonic coefficients
        call self%perform_scalar_synthesis(scalar_function)

    end subroutine perform_complex_synthesis

    subroutine analyze_into_complex_spectral_coefficients(self, &
        scalar_function, spectral_coefficients)

        ! Dummy arguments
        class(Sphere), intent(inout)  :: self
        real(wp),      intent(in)     :: scalar_function(:, :)
        complex(wp),   intent(out)    :: spectral_coefficients(:)

        ! Check if object is usable
        call self%assert_initialized('analyze_into_complex_spectral_coefficients')

        ! analyze the scalar function into (complex) harmonic coefficients
        call self%perform_complex_analysis(scalar_function)

        ! copy coefficients
        spectral_coefficients = self%complex_spectral_coefficients

    end subroutine analyze_into_complex_spectral_coefficients

    subroutine synthesize_from_complex_spectral_coefficients(self, &
        spectral_coefficients, scalar_function)

        ! Dummy arguments
        class(Sphere), intent(inout) :: self
        complex(wp),   intent(in)    :: spectral_coefficients(:)
        real(wp),      intent(out)   :: scalar_function(:, :)

        ! Local variables
        integer(ip) :: n, m, nm

        ! Check if object is usable
        call self%assert_initialized('synthesize_from_complex_spectral_coefficients')

        ! Convert complex coefficients to real version
        associate (&
            indxn => self%INDEX_DEGREE_N, &
            indxm => self%INDEX_ORDER_M, &
            a => self%workspace%scalar_coefficients%real_component, &
            b => self%workspace%scalar_coefficients%imaginary_component, &
            psi => spectral_coefficients &
           )
            ! Initialize (real) coefficients
            a = ZERO
            b = ZERO

            ! Fill real arrays with contents of spec
            do nm = 1, size(psi)
                n = indxn(nm) ! Set degree n
                m = indxm(nm) ! Set order m

                ! Set the real component
                a(m + 1, n + 1) = TWO * real(psi(nm))

                ! Set the imaginary component
                b(m + 1, n + 1) = TWO * aimag(psi(nm))
            end do
        end associate

        ! synthesise the scalar function from the (real) harmonic coefficients
        call self%perform_scalar_synthesis(scalar_function)

    end subroutine synthesize_from_complex_spectral_coefficients

    subroutine perform_vector_analysis_from_vector_field(self, vector_field)

        ! Dummy arguments
        class(Sphere), intent(inout) :: self
        real(wp),      intent(in)    :: vector_field(:, :, :)

        ! Local variables
        integer(ip) :: nlat, nlon

        ! Check if object is usable
        call self%assert_initialized('perform_vector_analysis')

        nlat = self%NUMBER_OF_LATITUDES
        nlon = self%NUMBER_OF_LONGITUDES

        ! Compute spherical angle components
        block
            real(wp) :: polar_component(nlat, nlon)
            real(wp) :: azimuthal_component(nlat, nlon)

            associate (&
                vecF => vector_field, &
                v => polar_component, &
                w => azimuthal_component &
               )

                ! Get spherical components
                call self%unit_vectors%get_spherical_angle_components(vecF, v, w)

                ! Perform vector analysis
                call self%vector_analysis_from_spherical_components(v, w)
            end associate
        end block

    end subroutine perform_vector_analysis_from_vector_field

    subroutine get_scalar_laplacian(self, scalar_function, scalar_laplacian)

        ! Dummy arguments
        class(Sphere), intent(inout) :: self
        real(wp),      intent(in)    :: scalar_function(:, :)
        real(wp),      intent(out)   :: scalar_laplacian(:, :)

        ! Check if object is usable
        call self%assert_initialized('get_scalar_laplacian')

        ! Set (real) scalar spherica harmonic coefficients
        call self%perform_complex_analysis(scalar_function)

        ! Associate various quantities
        associate (&
            psi => self%complex_spectral_coefficients, &
            lap => self%LAPLACIAN_COEFFICIENT_MULTIPLIERS &
           )
            psi = lap * psi
        end associate

        ! Synthesize complex coefficients into gridded array
        call self%perform_complex_synthesis(scalar_laplacian)

    end subroutine get_scalar_laplacian

    subroutine invert_scalar_laplacian(self, source, solution)

        ! Dummy arguments
        class(Sphere), intent(inout) :: self
        real(wp),      intent(in)    :: source(:, :)
        real(wp),      intent(out)   :: solution(:, :)

        ! Check if object is usable
        call self%assert_initialized('invert_scalar_laplacian')

        ! Set (real) scalar spherica harmonic coefficients
        call self%perform_complex_analysis(source)

        ! Associate various quantities
        associate (&
            psi => self%complex_spectral_coefficients, &
            ilap => self%INVERSE_LAPLACIAN_COEFFICIENT_MULTIPLIERS &
           )
            psi = ilap * psi
        end associate

        ! Synthesize complex coefficients into gridded array
        call self%perform_complex_synthesis(solution)

    end subroutine invert_scalar_laplacian

    subroutine compute_vector_laplacian_coefficients(self)

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

        ! Local variables
        integer(ip) :: n

        ! Check if object is usable
        call self%assert_initialized('compute_vector_laplacian_coefficients')

        ! Compute vector laplacian
        associate (&
            nlat => self%NUMBER_OF_LATITUDES, &
            ityp => self%VECTOR_SYMMETRIES, &
            lap => self%LAPLACIAN_COEFFICIENT_MULTIPLIERS, &
            br => self%workspace%vector_coefficients%polar%real_component, &
            bi => self%workspace%vector_coefficients%polar%imaginary_component, &
            cr => self%workspace%vector_coefficients%azimuthal%real_component, &
            ci => self%workspace%vector_coefficients%azimuthal%imaginary_component &
           )
            select case (ityp)
                case (0, 3, 6)

                    ! All coefficients needed
                    do n=1, nlat

                        ! Set polar coefficients
                        br(:, n) = lap(n) * br(:, n)
                        bi(:, n) = lap(n) * bi(:, n)

                        ! Set azimuthal coefficients
                        cr(:, n) = lap(n) * cr(:, n)
                        ci(:, n) = lap(n) * ci(:, n)
                    end do
                case (1, 4, 7)

                    ! Vorticity is zero so cr, ci=0 not used
                    do n=1, nlat
                        ! Set polar coefficients
                        br(:, n) = lap(n) * br(:, n)
                        bi(:, n) = lap(n) * bi(:, n)
                    end do
                case default

                    ! Divergence is zero so br, bi=0 not used
                    do n=1, nlat
                        ! Set azimuthal coefficients
                        cr(:, n) = lap(n) * cr(:, n)
                        ci(:, n) = lap(n) * ci(:, n)
                    end do
            end select
        end associate

    end subroutine compute_vector_laplacian_coefficients

    subroutine get_vector_laplacian_from_spherical_components(self, &
        polar_component, azimuthal_component, polar_laplacian, azimuthal_laplacian)

        ! Dummy arguments
        class(Sphere), intent(inout) :: self
        real(wp),      intent(in)    :: polar_component(:, :)
        real(wp),      intent(in)    :: azimuthal_component(:, :)
        real(wp),      intent(out)   :: polar_laplacian(:, :)
        real(wp),      intent(out)   :: azimuthal_laplacian(:, :)

        ! Check if object is usable
        call self%assert_initialized('get_vector_laplacian_from_spherical_components')

        ! Set vector spherical harmonic coefficients
        associate (&
            v => polar_component, &
            w => azimuthal_component &
           )
            call self%vector_analysis_from_spherical_components(v, w)
        end associate

        ! Compute vector laplacian coefficients
        call self%compute_vector_laplacian_coefficients()

        ! Synthesize vector laplacian from coefficients
        associate (&
            vlap => polar_laplacian, &
            wlap => azimuthal_laplacian &
           )
            call self%perform_vector_synthesis(vlap, wlap)
        end associate

    end subroutine get_vector_laplacian_from_spherical_components

    subroutine get_vector_laplacian_from_vector_field(self, &
        vector_field, polar_laplacian, azimuthal_laplacian)

        ! Dummy arguments
        class(Sphere), intent(inout) :: self
        real(wp),      intent(in)    :: vector_field(:, :, :)
        real(wp),      intent(out)   :: polar_laplacian(:, :)
        real(wp),      intent(out)   :: azimuthal_laplacian(:, :)

        ! Check if object is usable
        call self%assert_initialized('get_vector_laplacian_from_vector_field')

        ! Compute vector laplacian coefficients
        call self%perform_vector_analysis(vector_field)

        ! Synthesize vector laplacian from coefficients
        associate (&
            vlap => polar_laplacian, &
            wlap => azimuthal_laplacian &
           )
            call self%perform_vector_synthesis(vlap, wlap)
        end associate

    end subroutine get_vector_laplacian_from_vector_field

    subroutine invert_vector_laplacian(self, &
        polar_source, azimuthal_source, polar_solution, azimuthal_solution)

        ! Dummy arguments
        class(Sphere), intent(inout) :: self
        real(wp),      intent(in)    :: polar_source(:, :)
        real(wp),      intent(in)    :: azimuthal_source(:, :)
        real(wp),      intent(out)   :: polar_solution(:, :)
        real(wp),      intent(out)   :: azimuthal_solution(:, :)

        ! Local variables
        integer(ip) :: n

        ! Check if object is usable
        call self%assert_initialized('invert_vector_laplacian')

        ! Set vector spherical harmonic coefficients
        associate (&
            vlap => polar_source, &
            wlap => azimuthal_source &
           )
            call self%vector_analysis_from_spherical_components(vlap, wlap)
        end associate

        ! compute vector laplacian
        associate (&
            nlat => self%NUMBER_OF_LATITUDES, &
            ityp => self%VECTOR_SYMMETRIES, &
            ilap => self%INVERSE_LAPLACIAN_COEFFICIENT_MULTIPLIERS, &
            br => self%workspace%vector_coefficients%polar%real_component, &
            bi => self%workspace%vector_coefficients%polar%imaginary_component, &
            cr => self%workspace%vector_coefficients%azimuthal%real_component, &
            ci => self%workspace%vector_coefficients%azimuthal%imaginary_component, &
            v => polar_solution, &
            w => azimuthal_solution &
           )
            select case (ityp)
                case (0, 3, 6)

                    !   All coefficients needed
                    do n=1, nlat

                        ! Set polar coefficients
                        br(:, n) = ilap(n) * br(:, n)
                        bi(:, n) = ilap(n) * bi(:, n)

                        ! Set azimuthal coefficients
                        cr(:, n) = ilap(n) * cr(:, n)
                        ci(:, n) = ilap(n) * ci(:, n)
                    end do
                case (1, 4, 7)

                    ! Vorticity is zero so cr, ci=0 not used
                    do n=1, nlat

                        ! Set polar coefficients
                        br(:, n) = ilap(n) * br(:, n)
                        bi(:, n) = ilap(n) * bi(:, n)
                    end do
                case default

                    ! Divergence is zero so br, bi=0 not used
                    do n=1, nlat

                        ! Set azimuthal coefficients
                        cr(:, n) = ilap(n) * cr(:, n)
                        ci(:, n) = ilap(n) * ci(:, n)
                    end do
            end select

            ! Synthesize coefficients inot vector field (v, w)
            call self%perform_vector_synthesis(v, w)
        end associate

    end subroutine invert_vector_laplacian

    subroutine invert_helmholtz(self, helmholtz_constant, source, solution)

        ! Dummy arguments
        class(Sphere), target, intent(inout) :: self
        real(wp),              intent(in)    :: helmholtz_constant
        real(wp),              intent(in)    :: source(:, :)
        real(wp),              intent(out)   :: solution(:, :)

        ! Local variables
        real(wp), pointer :: iptr(:) => null()

        ! Check if object is usable
        call self%assert_initialized('invert_helmholtz')

        !  Set (real) scalar spherica harmonic coefficients
        call self%perform_complex_analysis(source)

        ! Associate various quantities
        associate (&
            nm_dim => size(self%complex_spectral_coefficients), &
            psi => self%complex_spectral_coefficients, &
            ilap => self%INVERSE_LAPLACIAN_COEFFICIENT_MULTIPLIERS, &
            lap => self%LAPLACIAN_COEFFICIENT_MULTIPLIERS, &
            xlmbda => helmholtz_constant &
           )

            !  Associate local pointer
            if (xlmbda == ZERO) then

                ! Assign pointer
                iptr => ilap
            else

                ! Allocate memory
                allocate (iptr(nm_dim))
                iptr = ONE/(lap - xlmbda)
            end if

            ! Set coefficients
            psi = iptr * psi

            !  Synthesize complex coefficients into gridded array
            call self%perform_complex_synthesis(solution)

            !  Garbage collection
            if ( xlmbda == ZERO) then
                nullify( iptr)
            else
                deallocate (iptr)
            end if
        end associate

    end subroutine invert_helmholtz

    subroutine get_gradient(self, scalar_function, &
        polar_gradient_component, azimuthal_gradient_component)

        ! Dummy arguments
        class(Sphere), intent(inout) :: self
        real(wp),      intent(in)    :: scalar_function(:, :)
        real(wp),      intent(out)   :: polar_gradient_component(:, :)
        real(wp),      intent(out)   :: azimuthal_gradient_component(:, :)

        ! Local variables
        integer(ip) :: n

        ! Check if object is usable
        call self%assert_initialized('get_gradient')

        ! Compute the (real) spherical harmonic coefficients
        call self%perform_scalar_analysis(scalar_function)

        ! Compute gradient
        associate (&
            nlat => self%NUMBER_OF_LATITUDES, &
            v => polar_gradient_component, &
            w => azimuthal_gradient_component, &
            sqnn => self%COEFFICIENT_MULTIPLIERS, &
            a => self%workspace%scalar_coefficients%real_component, &
            b => self%workspace%scalar_coefficients%imaginary_component, &
            br => self%workspace%vector_coefficients%polar%real_component, &
            bi => self%workspace%vector_coefficients%polar%imaginary_component, &
            cr => self%workspace%vector_coefficients%azimuthal%real_component, &
            ci => self%workspace%vector_coefficients%azimuthal%imaginary_component &
           )
            ! Initialize polar coefficients
            br = ZERO
            bi = ZERO

            ! Set polar coefficients
            do n=1, nlat
                br(:, n) = a(:, n) * sqnn(n)
                bi(:, n) = b(:, n) * sqnn(n)
            end do

            ! Set azimuthal coefficients
            cr = ZERO
            ci = ZERO

            ! Compute vector harmonic synthesis
            call self%perform_vector_synthesis(v, w)
        end associate

    end subroutine get_gradient

    subroutine invert_gradient_from_spherical_components(self, &
        polar_source, azimuthal_source, solution)

        ! Dummy arguments
        class(Sphere), intent(inout) :: self
        real(wp),      intent(in)    :: polar_source(:, :)
        real(wp),      intent(in)    :: azimuthal_source(:, :)
        real(wp),      intent(out)   :: solution(:, :)

        ! Local variables
        integer(ip) :: n, m

        ! Check if object is usable
        call self%assert_initialized('invert_gradient_from_spherical_components')

        ! Set vector spherical harmonic coefficients
        associate (&
            v => polar_source, &
            w => azimuthal_source &
           )
            call self%vector_analysis_from_spherical_components(v, w)
        end associate

        ! Invert gradient
        associate (&
            nlat => self%NUMBER_OF_LATITUDES, &
            nlon => self%NUMBER_OF_LONGITUDES, &
            f => solution, &
            sqnn => self%COEFFICIENT_MULTIPLIERS, &
            a => self%workspace%scalar_coefficients%real_component, &
            b => self%workspace%scalar_coefficients%imaginary_component, &
            br => self%workspace%vector_coefficients%polar%real_component, &
            bi => self%workspace%vector_coefficients%polar%imaginary_component &
           )

            ! Initialize (real) coefficients
            a = ZERO
            b = ZERO

            ! Compute m=0 coefficients
            do n=2, nlat
                a(1, n) = br(1, n)/sqnn(n)
                b(1, n) = bi(1, n)/sqnn(n)
            end do

            !  Set upper limit for vector m subscript
            associate (mmax => min(nlat, (nlon + 1)/2))

                ! Compute m > 0 coefficients
                do m=2, mmax
                    do n=m, nlat
                        a(m, n) = br(m, n)/sqnn(n)
                        b(m, n) = bi(m, n)/sqnn(n)
                    end do
                end do
            end associate

            !  Perform scalar synthesis
            call self%perform_scalar_synthesis(f)
        end associate

    end subroutine invert_gradient_from_spherical_components

    subroutine get_vorticity_from_spherical_components(self, &
        polar_component, azimuthal_component, vorticity)

        ! Dummy arguments
        class(Sphere), intent(inout) :: self
        real(wp),      intent(in)    :: polar_component(:, :)
        real(wp),      intent(in)    :: azimuthal_component(:, :)
        real(wp),      intent(out)   :: vorticity(:, :)

        ! Local variables
        integer(ip) :: n, m

        ! Check if object is usable
        call self%assert_initialized('get_vorticity_from_spherical_components')

        associate (&
            v => polar_component, &
            w => azimuthal_component, &
            nlat => self%NUMBER_OF_LATITUDES, &
            nlon => self%NUMBER_OF_LONGITUDES, &
            vt => vorticity, &
            sqnn => self%COEFFICIENT_MULTIPLIERS, &
            a => self%workspace%scalar_coefficients%real_component, &
            b => self%workspace%scalar_coefficients%imaginary_component, &
            cr => self%workspace%vector_coefficients%azimuthal%real_component, &
            ci => self%workspace%vector_coefficients%azimuthal%imaginary_component &
           )

            !  Perform vector analysis
            call self%vector_analysis_from_spherical_components(v, w)

            !  Initialize (real) coefficients
            a = ZERO
            b = ZERO

            ! Set upper limit for vector m subscript
            associate (mmax => min(nlat, (nlon + 1)/2))

                ! Compute m > 0 coefficients
                do m=1, mmax
                    do n=m, nlat
                        a(m, n) = sqnn(n) * cr(m, n)
                        b(m, n) = sqnn(n) * ci(m, n)
                    end do
                end do
            end associate

            ! Compute vector harmonic synthesis
            call self%perform_scalar_synthesis(vt)
        end associate

    end subroutine get_vorticity_from_spherical_components

    subroutine get_vorticity_from_vector_field(self, vector_field, vorticity)

        ! Dummy arguments
        class(Sphere), intent(inout) :: self
        real(wp),      intent(in)    :: vector_field(:, :, :)
        real(wp),      intent(out)   :: vorticity(:, :)

        ! Local variables
        integer(ip) :: nlat, nlon

        ! Check if object is usable
        call self%assert_initialized('get_vorticity_from_vector_field')

        nlat = self%NUMBER_OF_LATITUDES
        nlon = self%NUMBER_OF_LONGITUDES
        block
            real(wp) :: polar_component(nlat, nlon)
            real(wp) :: azimuthal_component(nlat, nlon)

            ! Compute vorticity
            associate (&
                vecF => vector_field, &
                v => polar_component, &
                w => azimuthal_component, &
                vort => vorticity &
               )

                !  Get spherical components
                call self%unit_vectors%get_spherical_angle_components(vecF, v, w)

                !  Get vorticity from spherical components
                call self%get_vorticity_from_spherical_components(v, w, vort)
            end associate
        end block

    end subroutine get_vorticity_from_vector_field

    subroutine invert_vorticity(self, source, polar_solution, azimuthal_solution)

        ! Dummy arguments
        class(Sphere), intent(inout) :: self
        real(wp),      intent(in)    :: source(:, :)
        real(wp),      intent(out)   :: polar_solution(:, :)
        real(wp),      intent(out)   :: azimuthal_solution(:, :)

        ! Local variables
        integer(ip) :: n, m
        integer(ip) :: ityp_temp_save

         ! Check if object is usable
        call self%assert_initialized('invert_vorticity')

        ! Compute the (real) spherical harmonic coefficients
        call self%perform_scalar_analysis(source)

        !  Invert vorticity
        associate (&
            nlat => self%NUMBER_OF_LATITUDES, &
            nlon => self%NUMBER_OF_LONGITUDES, &
            v => polar_solution, &
            w => azimuthal_solution, &
            sqnn => self%COEFFICIENT_MULTIPLIERS, &
            a => self%workspace%scalar_coefficients%real_component, &
            b => self%workspace%scalar_coefficients%imaginary_component, &
            cr => self%workspace%vector_coefficients%azimuthal%real_component, &
            ci => self%workspace%vector_coefficients%azimuthal%imaginary_component, &
            isym => self%SCALAR_SYMMETRIES, &
            ityp => self%VECTOR_SYMMETRIES &
           )
            associate (mmax => min(nlat, (nlon + 1)/2))

                !  Initialize coefficients
                cr = ZERO
                ci = ZERO

                !   Compute m = 0 coefficients
                do n = 2, nlat
                    cr(1, n) = a(1, n)/sqnn(n)
                    ci(1, n) = b(1, n)/sqnn(n)
                end do

                ! Compute m > 0 coefficients
                do m=2, mmax
                    do n=m, nlat
                        cr(m, n) = a(m, n)/sqnn(n)
                        ci(m, n) = b(m, n)/sqnn(n)
                    end do
                end do

                !  Save old vector symmetry
                ityp_temp_save = ityp

                !  Set symmetries for synthesis
                select case (isym)
                    case (0)
                        ityp = 2
                    case (1)
                        ityp = 5
                    case(2)
                        ityp = 8
                end select

                ! Compute vector synthesis
                call self%perform_vector_synthesis(v, w)

                !  Reset old vector symmetry
                ityp = ityp_temp_save
            end associate
        end associate

    end subroutine invert_vorticity

    subroutine get_divergence_from_vector_field(self, vector_field, divergence)

        ! Dummy arguments
        class(Sphere), intent(inout) :: self
        real(wp),      intent(in)    :: vector_field(:, :, :)
        real(wp),      intent(out)   :: divergence(:, :)

        ! Local variables
        integer(ip) :: nlat, nlon

        ! Check if object is usable
        call self%assert_initialized('get_divergence_from_vector_field')

        nlat = self%NUMBER_OF_LATITUDES
        nlon = self%NUMBER_OF_LONGITUDES

        block
            real(wp) :: polar_component(nlat, nlon)
            real(wp) :: azimuthal_component(nlat, nlon)

            ! Compute vorticity
            associate (&
                vecF => vector_field, &
                v => polar_component, &
                w => azimuthal_component, &
                dv => divergence &
               )

                !  Get spherical components
                call self%unit_vectors%get_spherical_angle_components(vecF, v, w)

                !  Get vorticity from spherical components
                call self%get_divergence_from_spherical_components(v, w, dv)
            end associate
        end block

    end subroutine get_divergence_from_vector_field

    subroutine get_divergence_from_spherical_components(self, &
        polar_component, azimuthal_component, divergence)

        ! Dummy arguments
        class(Sphere), intent(inout) :: self
        real(wp),      intent(in)    :: polar_component(:, :)
        real(wp),      intent(in)    :: azimuthal_component(:, :)
        real(wp),      intent(out)   :: divergence(:, :)

        ! Local variables
        integer(ip) :: n, m

         ! Check if object is usable
        call self%assert_initialized('get_divergence_from_spherical_components')

        associate (&
            v => polar_component, &
            w => azimuthal_component, &
            nlat => self%NUMBER_OF_LATITUDES, &
            nlon => self%NUMBER_OF_LONGITUDES, &
            dv => divergence, &
            sqnn => self%COEFFICIENT_MULTIPLIERS, &
            a => self%workspace%scalar_coefficients%real_component, &
            b => self%workspace%scalar_coefficients%imaginary_component, &
            br => self%workspace%vector_coefficients%polar%real_component, &
            bi => self%workspace%vector_coefficients%polar%imaginary_component &
           )

            !  Perform vector analysis
            call self%vector_analysis_from_spherical_components(v, w)

            !  Initialize (real) coefficients
            a = ZERO
            b = ZERO

            !  Set upper limit for vector m subscript
            associate (mmax => min(nlat, (nlon + 1)/2))

                ! Compute m > 0 coefficients
                do m=1, mmax
                    do n=m, nlat
                        a(m, n) = -sqnn(n) * br(m, n)
                        b(m, n) = -sqnn(n) * bi(m, n)
                    end do
                end do
            end associate

            ! Compute vector harmonic synthesis
            call self%perform_scalar_synthesis(dv)
        end associate

    end subroutine get_divergence_from_spherical_components

    subroutine invert_divergence(self, source, polar_solution, azimuthal_solution)

        ! Dummy arguments
        class(Sphere), intent(inout) :: self
        real(wp),      intent(in)    :: source(:, :)
        real(wp),      intent(out)   :: polar_solution(:, :)
        real(wp),      intent(out)   :: azimuthal_solution(:, :)

        ! Local variables
        integer(ip) :: n, m

        ! Check if object is usable
        call self%assert_initialized('invert_divergence')

        ! Calculate the (real) scalar harmonic coefficients
        call self%perform_scalar_analysis(source)

        ! Invert gradient
        associate (&
            nlat => self%NUMBER_OF_LATITUDES, &
            ntrunc => self%TRIANGULAR_TRUNCATION_LIMIT, &
            v => polar_solution, &
            w => azimuthal_solution, &
            sqnn => self%COEFFICIENT_MULTIPLIERS, &
            a => self%workspace%scalar_coefficients%real_component, &
            b => self%workspace%scalar_coefficients%imaginary_component, &
            br => self%workspace%vector_coefficients%polar%real_component, &
            bi => self%workspace%vector_coefficients%polar%imaginary_component, &
            cr => self%workspace%vector_coefficients%azimuthal%real_component, &
            ci => self%workspace%vector_coefficients%azimuthal%imaginary_component &
           )
            ! Initialize polar coefficients
            br = ZERO
            bi = ZERO

            ! Compute m = 0 coefficients
            do n = 1, nlat
                ! Set real coefficients
                br(1, n) = -a(1, n)/sqnn(n)
                ! Set imaginary coeffients
                bi(1, n) = -b(1, n)/sqnn(n)
            end do

            ! Compute m >0 coefficients
            do m=2, ntrunc+1
                do n=m, ntrunc+1
                    ! Set real coefficients
                    br(m, n) = -a(m, n)/sqnn(n)
                    ! Set imaginary coefficients
                    bi(m, n) = -b(m, n)/sqnn(n)
                end do
            end do
            ! Set azimuthal coefficients
            cr = ZERO !Not present in original source
            ci = ZERO
            ! Compute scalar synthesis
            call self%perform_vector_synthesis(v, w)
        end associate

    end subroutine invert_divergence

    subroutine get_vorticity_and_divergence_from_velocities(self, &
        polar_component, azimuthal_component, vorticity, divergence)

        ! Dummy arguments
        class(Sphere), intent(inout)  :: self
        real(wp),      intent(in)     :: polar_component(:, :)
        real(wp),      intent(in)     :: azimuthal_component(:, :)
        real(wp),      intent(out)    :: vorticity(:, :)
        real(wp),      intent(out)    :: divergence(:, :)

        ! Check if object is usable
        call self%assert_initialized('get_vorticity_and_divergence_from_velocities')

        associate (&
            v => polar_component, &
            w => azimuthal_component, &
            vt => vorticity, &
            dv => divergence &
           )

            ! Compute vorticity
            call self%get_vorticity(v, w, vt)

            ! Compute divergence
            call self%get_divergence(v, w, dv)
        end associate

    end subroutine get_vorticity_and_divergence_from_velocities

    subroutine get_velocities_from_vorticity_and_divergence_coefficients(self, &
        vort_spec, div_spec, polar_component, azimuthal_component)

        ! Dummy arguments
        class(Sphere), intent(inout) :: self
        complex(wp),   intent(in)    :: vort_spec(:)
        complex(wp),   intent(in)    :: div_spec(:)
        real(wp),      intent(out)   :: polar_component(:, :)
        real(wp),      intent(out)   :: azimuthal_component(:, :)

        ! Local variables
        integer(ip) :: nm, n, m

        ! Check if object is usable
        call self%assert_initialized( &
            'get_velocities_from_vorticity_and_divergence_coefficients')

        ! Associate various quantities
        associate (&
            v => polar_component, &
            w => azimuthal_component, &
            nlat => self%NUMBER_OF_LATITUDES, &
            indxn => self%INDEX_DEGREE_N, &
            indxm => self%INDEX_ORDER_M, &
            sqnn => self%COEFFICIENT_MULTIPLIERS, &
            a => self%workspace%scalar_coefficients%real_component, &
            b => self%workspace%scalar_coefficients%imaginary_component, &
            br => self%workspace%vector_coefficients%polar%real_component, &
            bi => self%workspace%vector_coefficients%polar%imaginary_component, &
            cr => self%workspace%vector_coefficients%azimuthal%real_component, &
            ci => self%workspace%vector_coefficients%azimuthal%imaginary_component &
           )

            ! Preset (real) scalar coefficients
            a = ZERO
            b = ZERO

            !  Set (real) auxiliary coefficients
            !  from complex divergence harmonic coefficients
            do nm=1, size(div_spec)
                n = indxn(nm) ! Set degree n
                m = indxm(nm) ! Set order m
                a(m + 1, n + 1) = -TWO * real(div_spec(nm))
                b(m + 1, n + 1) = -TWO * aimag(div_spec(nm))
            end do

            ! Preset polar vector coefficients
            br = ZERO
            bi = ZERO

            !  Set polar vector coefficients
            do n=2, nlat
                br(:, n) = a(:, n)/sqnn(n)
                bi(:, n) = b(:, n)/sqnn(n)
            end do

            !  Re-set (real) scalar coefficients
            a = ZERO
            b = ZERO

            !  Set (real) auxiliary coefficients
            !  from complex vorticity harmonic coefficients
            do nm=1, size(vort_spec)
                n = indxn(nm) ! Set degree n
                m = indxm(nm) ! Set order m
                a(m + 1, n + 1) = TWO * real(vort_spec(nm))
                b(m + 1, n + 1) = TWO * aimag(vort_spec(nm))
            end do

            !  Initialize azimuthal vector coefficients
            cr = ZERO
            ci = ZERO

            !  Set azimuthal vector coefficients
            do n=2, nlat
                cr(:, n) = a(:, n)/sqnn(n)
                ci(:, n) = b(:, n)/sqnn(n)
            end do

            ! Compute vector harmonic sysnthesis to get components
            call self%perform_vector_synthesis(v, w)
        end associate

    end subroutine get_velocities_from_vorticity_and_divergence_coefficients

    subroutine get_velocities_from_vorticity_and_divergence(self, &
        vorticity, divergence, polar_component, azimuthal_component)

        ! Dummy arguments
        class(Sphere), intent(inout)  :: self
        real(wp),      intent(in)     :: vorticity(:, :)
        real(wp),      intent(in)     :: divergence(:, :)
        real(wp),      intent(out)    :: polar_component(:, :)
        real(wp),      intent(out)    :: azimuthal_component(:, :)

        ! Local variables
        integer(ip) :: nm_dim

        ! Check if object is usable
        call self%assert_initialized('get_velocities_from_vorticity_and_divergence')

        nm_dim = size(self%complex_spectral_coefficients)

        block
            complex(wp) :: vorticity_coefficients(nm_dim)
            complex(wp) :: divergence_coefficients(nm_dim)

            associate (&
                v => polar_component, &
                w => azimuthal_component, &
                vt_spec => vorticity_coefficients, &
                dv_spec => divergence_coefficients, &
                vt => vorticity, &
                dv => divergence &
               )

                ! Compute complex spectral coefficients
                call self%analyze_into_complex_spectral_coefficients(vt, vt_spec)
                call self%analyze_into_complex_spectral_coefficients(dv, dv_spec)

                ! Compute velocities
                call self%get_velocities_from_vorticity_and_divergence_coefficients( &
                    vt_spec, dv_spec, v, w)
            end associate
        end block

    end subroutine get_velocities_from_vorticity_and_divergence

    subroutine compute_angular_momentum(self, scalar_function, angular_momentum)

        ! Dummy arguments
        class(Sphere), intent(inout)  :: self
        real(wp),      intent(in)     :: scalar_function(:, :)
        real(wp),      intent(out)    :: angular_momentum(:, :, :)

        ! Local variables
        integer(ip) :: i, j, nlat, nlon

        ! Check if object is usable
        call self%assert_initialized('compute_angular_momentum')

        nlat = self%NUMBER_OF_LATITUDES
        nlon = self%NUMBER_OF_LONGITUDES

        block
            real(wp) :: polar_gradient_component(nlat, nlon)
            real(wp) :: azimuthal_gradient_component(nlat, nlon)

            associate (&
                f => scalar_function, &
                grad_theta => polar_gradient_component, &
                grad_phi => azimuthal_gradient_component &
               )

                !  Calculate the spherical surface gradient components
                call self%get_gradient(f, grad_theta, grad_phi)
            end associate

            associate (R => angular_momentum)
                do j = 1, nlon
                    do i = 1, nlat
                        associate (&
                            theta => self%unit_vectors%polar(i, j), &
                            phi => self%unit_vectors%azimuthal(i, j), &
                            grad_theta => polar_gradient_component(i, j), &
                            grad_phi => azimuthal_gradient_component(i, j) &
                           )

                            !  Calculate the rotation operator applied to a scalar function
                            R(:, i, j) = phi * grad_theta - theta * grad_phi
                        end associate
                    end do
                end do
            end associate
        end block

    end subroutine compute_angular_momentum

    ! Purpose:
    !
    ! The spectral data is assumed to be in a complex array of dimension
    ! (mtrunc+1)*(mtrunc+2)/2. mtrunc is the triangular truncation limit
    ! (mtrunc = 42 for T42). mtrunc must be <= nlat-1.
    !
    ! The coefficients are ordered so that
    !
    ! first (nm=1)  is m=0, n=0, second (nm=2) is m=0, n=1,
    ! nm=mtrunc is m=0, n=mtrunc, nm=mtrunc+1 is m=1, n=1, etc.
    !
    ! In other words,
    !
    ! 00, 01, 02, 03, 04.........0mtrunc
    !     11, 12, 13, 14.........1mtrunc
    !         22, 23, 24.........2mtrunc
    !             33, 34.........3mtrunc
    !                 44.........4mtrunc
    !                    .
    !                      .
    !                        .etc...
    !
    ! In Fortran syntax, values of m (degree) and n (order)
    ! as a function of the index nm are:
    !
    ! integer(ip), dimension ((mtrunc+1)*(mtrunc+2)/2) :: indxm, indxn
    ! indxm = [((m, n=m, mtrunc), m=0, mtrunc)]
    ! indxn = [((n, n=m, mtrunc), m=0, mtrunc)]
    !
    ! Conversely, the index nm as a function of m and n is:
    ! nm = sum([(i, i=mtrunc+1, mtrunc-m+2, -1)])+n-m+1
    !
    function get_index(self, n, m) &
        result (return_value)

        ! Dummy arguments
        class(Sphere), intent(inout) :: self
        integer(ip),   intent(in)    :: n
        integer(ip),   intent(in)    :: m
        integer(ip)                  :: return_value

        ! Local variables
        integer(ip) :: i

        ! Check if object is usable
        call self%assert_initialized('get_index')

        associate (ntrunc => self%TRIANGULAR_TRUNCATION_LIMIT)
            if ( m <= n .and. max(n, m) <= ntrunc) then
                return_value = sum ([(i, i=ntrunc+1, ntrunc-m+2, -1)]) + n-m+1
            else
                return_value = -1
            end if
        end associate

    end function get_index

    function get_coefficient(self, n, m) &
        result (return_value)

        ! Dummy arguments
        class(Sphere), intent(inout) :: self
        integer(ip),   intent(in)    :: n
        integer(ip),   intent(in)    :: m
        complex(wp)                  :: return_value

        ! Check if object is usable
        call self%assert_initialized('get_coefficient')

        associate (&
            ntrunc => self%TRIANGULAR_TRUNCATION_LIMIT, &
            nm  => self%get_index(n, m), &
            nm_conjg => self%get_index(n, -m), &
            psi => self%complex_spectral_coefficients &
           )

            if (m < 0 .and. nm_conjg > 0) then
                return_value = ( (-ONE)**(-m)) * conjg(psi(nm_conjg))
            else if (nm > 0) then
                return_value = psi(nm)
            else
                return_value = ZERO
            end if

        end associate

    end function get_coefficient

    subroutine get_scalar_symmetries(self, isym)

        ! Dummy arguments
        class(Sphere), intent(inout) :: self
        integer(ip),   intent(in)    :: isym

        select case (isym)
            case (0:2)
                self%SCALAR_SYMMETRIES = isym
            case default
                error stop 'Object of class(Sphere) in get_scalar_symmetries: '&
                    //'Optional argument isym must be either '&
                    //'0, 1, or 2 (default isym = 0)'
        end select

    end subroutine get_scalar_symmetries

    subroutine get_vector_symmetries(self, itype)

        ! Dummy arguments
        class(Sphere), intent(inout) :: self
        integer(ip),   intent(in)    :: itype

        select case (itype)
            case (0:8)
                self%VECTOR_SYMMETRIES = itype
            case default
                error stop 'Object of class(Sphere) in get_vector_symmetries: '&
                    //'Optional argument itype must be either '&
                    //'0, 1, 2, ..., 8 (default itype = 0)'
        end select

    end subroutine get_vector_symmetries

end module type_Sphere


      SUBROUTINE MB02CD( JOB, TYPET, K, N, T, LDT, G, LDG, R, LDR, L,
     $                   LDL, CS, LCS, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute the Cholesky factor and the generator and/or the
C     Cholesky factor of the inverse of a symmetric positive definite
C     (s.p.d.) block Toeplitz matrix T, defined by either its first
C     block row, or its first block column, depending on the routine
C     parameter TYPET. Transformation information is stored.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Specifies the output of the routine, as follows:
C             = 'G':  only computes the generator G of the inverse;
C             = 'R':  computes the generator G of the inverse and the
C                     Cholesky factor R of T, i.e., if TYPET = 'R',
C                     then R'*R = T, and if TYPET = 'C', then R*R' = T;
C             = 'L':  computes the generator G and the Cholesky factor L
C                     of the inverse, i.e., if TYPET = 'R', then
C                     L'*L = inv(T), and if TYPET = 'C', then
C                     L*L' = inv(T);
C             = 'A':  computes the generator G, the Cholesky factor L
C                     of the inverse and the Cholesky factor R of T;
C             = 'O':  only computes the Cholesky factor R of T.
C
C     TYPET   CHARACTER*1
C             Specifies the type of T, as follows:
C             = 'R':  T contains the first block row of an s.p.d. block
C                     Toeplitz matrix; if demanded, the Cholesky factors
C                     R and L are upper and lower triangular,
C                     respectively, and G contains the transposed
C                     generator of the inverse;
C             = 'C':  T contains the first block column of an s.p.d.
C                     block Toeplitz matrix; if demanded, the Cholesky
C                     factors R and L are lower and upper triangular,
C                     respectively, and G contains the generator of the
C                     inverse. This choice results in a column oriented
C                     algorithm which is usually faster.
C             Note:   in the sequel, the notation x / y means that
C                     x corresponds to TYPET = 'R' and y corresponds to
C                     TYPET = 'C'.
C
C     Input/Output Parameters
C
C     K       (input)  INTEGER
C             The number of rows / columns in T, which should be equal
C             to the blocksize.  K >= 0.
C
C     N       (input)  INTEGER
C             The number of blocks in T.  N >= 0.
C
C     T       (input/output)  DOUBLE PRECISION array, dimension
C             (LDT,N*K) / (LDT,K)
C             On entry, the leading K-by-N*K / N*K-by-K part of this
C             array must contain the first block row / column of an
C             s.p.d. block Toeplitz matrix.
C             On exit, if INFO = 0, then the leading K-by-N*K / N*K-by-K
C             part of this array contains, in the first K-by-K block,
C             the upper / lower Cholesky factor of T(1:K,1:K), and in
C             the remaining part, the Householder transformations
C             applied during the process.
C
C     LDT     INTEGER
C             The leading dimension of the array T.
C             LDT >= MAX(1,K),    if TYPET = 'R';
C             LDT >= MAX(1,N*K),  if TYPET = 'C'.
C
C     G       (output)  DOUBLE PRECISION array, dimension
C             (LDG,N*K) / (LDG,2*K)
C             If INFO = 0 and JOB = 'G', 'R', 'L', or 'A', the leading
C             2*K-by-N*K / N*K-by-2*K part of this array contains, in
C             the first K-by-K block of the second block row / column,
C             the lower right block of L (necessary for updating
C             factorizations in SLICOT Library routine MB02DD), and
C             in the remaining part, the generator of the inverse of T.
C             Actually, to obtain a generator one has to set
C                 G(K+1:2*K, 1:K) = 0,    if TYPET = 'R';
C                 G(1:K, K+1:2*K) = 0,    if TYPET = 'C'.
C
C     LDG     INTEGER
C             The leading dimension of the array G.
C             LDG >= MAX(1,2*K),  if TYPET = 'R' and
C                                    JOB = 'G', 'R', 'L', or 'A';
C             LDG >= MAX(1,N*K),  if TYPET = 'C' and
C                                    JOB = 'G', 'R', 'L', or 'A';
C             LDG >= 1,           if JOB = 'O'.
C
C     R       (output)  DOUBLE PRECISION array, dimension (LDR,N*K)
C             If INFO = 0 and JOB = 'R', 'A', or 'O', then the leading
C             N*K-by-N*K part of this array contains the upper / lower
C             Cholesky factor of T.
C             The elements in the strictly lower / upper triangular part
C             are not referenced.
C
C     LDR     INTEGER
C             The leading dimension of the array R.
C             LDR >= MAX(1,N*K),  if JOB = 'R', 'A', or 'O';
C             LDR >= 1,           if JOB = 'G', or 'L'.
C
C     L       (output)  DOUBLE PRECISION array, dimension (LDL,N*K)
C             If INFO = 0 and JOB = 'L', or 'A', then the leading
C             N*K-by-N*K part of this array contains the lower / upper
C             Cholesky factor of the inverse of T.
C             The elements in the strictly upper / lower triangular part
C             are not referenced.
C
C     LDL     INTEGER
C             The leading dimension of the array L.
C             LDL >= MAX(1,N*K),  if JOB = 'L', or 'A';
C             LDL >= 1,           if JOB = 'G', 'R', or 'O'.
C
C     CS      (output)  DOUBLE PRECISION array, dimension (LCS)
C             If INFO = 0, then the leading 3*(N-1)*K part of this
C             array contains information about the hyperbolic rotations
C             and Householder transformations applied during the
C             process. This information is needed for updating the
C             factorizations in SLICOT Library routine MB02DD.
C
C     LCS     INTEGER
C             The length of the array CS.  LCS >= 3*(N-1)*K.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0,  DWORK(1)  returns the optimal
C             value of LDWORK.
C             On exit, if  INFO = -16,  DWORK(1)  returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX(1,(N-1)*K).
C             For optimum performance LDWORK should be larger.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  the reduction algorithm failed. The Toeplitz matrix
C                   associated with T is not (numerically) positive
C                   definite.
C
C     METHOD
C
C     Householder transformations and modified hyperbolic rotations
C     are used in the Schur algorithm [1], [2].
C
C     REFERENCES
C
C     [1] Kailath, T. and Sayed, A.
C         Fast Reliable Algorithms for Matrices with Structure.
C         SIAM Publications, Philadelphia, 1999.
C
C     [2] Kressner, D. and Van Dooren, P.
C         Factorizations and linear system solvers for matrices with
C         Toeplitz structure.
C         SLICOT Working Note 2000-2, 2000.
C
C     NUMERICAL ASPECTS
C
C     The implemented method is numerically stable.
C                               3 2
C     The algorithm requires 0(K N ) floating point operations.
C
C     CONTRIBUTOR
C
C     D. Kressner, Technical Univ. Chemnitz, Germany, June 2000.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, July 2000,
C     February 2004.
C
C     KEYWORDS
C
C     Elementary matrix operations, Householder transformation, matrix
C     operations, Toeplitz matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         JOB, TYPET
      INTEGER           INFO, K, LCS, LDG, LDL, LDR, LDT, LDWORK, N
C     .. Array Arguments ..
      DOUBLE PRECISION  CS(*), DWORK(*), G(LDG, *), L(LDL,*), R(LDR,*),
     $                  T(LDT,*)
C     .. Local Scalars ..
      INTEGER           I, IERR, MAXWRK, STARTI, STARTR, STARTT
      LOGICAL           COMPG, COMPL, COMPR, ISROW
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DLACPY, DLASET, DPOTRF, DTRSM, MB02CX, MB02CY,
     $                  XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         INT, MAX, MIN
C
C     .. Executable Statements ..
C
C     Decode the scalar input parameters.
C
      INFO  = 0
      COMPL = LSAME( JOB, 'L' ) .OR. LSAME( JOB, 'A' )
      COMPG = LSAME( JOB, 'G' ) .OR. LSAME( JOB, 'R' ) .OR. COMPL
      COMPR = LSAME( JOB, 'R' ) .OR. LSAME( JOB, 'A' ) .OR.
     $        LSAME( JOB, 'O' )
      ISROW = LSAME( TYPET, 'R' )
C
C     Check the scalar input parameters.
C
      IF ( .NOT.( COMPG .OR. COMPR ) ) THEN
         INFO = -1
      ELSE IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN
         INFO = -2
      ELSE IF ( K.LT.0 ) THEN
         INFO = -3
      ELSE IF ( N.LT.0 ) THEN
         INFO = -4
      ELSE IF ( LDT.LT.1 .OR. ( ISROW .AND. LDT.LT.K ) .OR.
     $                   ( .NOT.ISROW .AND. LDT.LT.N*K ) ) THEN
         INFO = -6
      ELSE IF ( LDG.LT.1 .OR.
     $           ( COMPG .AND. ( ( ISROW .AND. LDG.LT.2*K )
     $                 .OR. ( .NOT.ISROW .AND. LDG.LT.N*K ) ) ) ) THEN
         INFO = -8
      ELSE IF ( LDR.LT.1 .OR. ( COMPR .AND. ( LDR.LT.N*K ) ) ) THEN
         INFO = -10
      ELSE IF ( LDL.LT.1 .OR. ( COMPL .AND. ( LDL.LT.N*K ) ) ) THEN
         INFO = -12
      ELSE IF ( LCS.LT.3*( N - 1 )*K ) THEN
         INFO = -14
      ELSE IF ( LDWORK.LT.MAX( 1, ( N - 1 )*K ) ) THEN
         DWORK(1) = MAX( 1, ( N - 1 )*K )
         INFO = -16
      END IF
C
C     Return if there were illegal values.
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB02CD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( MIN( K, N ).EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
      MAXWRK = 1
      IF ( ISROW ) THEN
C
C        T is the first block row of a block Toeplitz matrix.
C        Bring T to proper form by triangularizing its first block.
C
         CALL DPOTRF( 'Upper', K, T, LDT, IERR )
         IF ( IERR.NE.0 )  THEN
C
C           Error return:  The matrix is not positive definite.
C
            INFO = 1
            RETURN
         END IF
C
         IF ( N.GT.1 )
     $      CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K,
     $                  (N-1)*K, ONE, T, LDT, T(1,K+1), LDT )
C
C        Initialize the output matrices.
C
         IF ( COMPG ) THEN
            CALL DLASET( 'All', 2*K, N*K, ZERO, ZERO, G, LDG )
            CALL DLASET( 'All', 1, K, ONE, ONE, G(K+1,1), LDG+1 )
            CALL DTRSM(  'Left', 'Upper', 'Transpose', 'NonUnit', K, K,
     $                   ONE, T, LDT, G(K+1,1), LDG )
            IF ( N.GT.1 )
     $         CALL DLACPY( 'Upper', K, (N-1)*K, T, LDT, G(K+1,K+1),
     $                      LDG )
            CALL DLACPY( 'Lower', K, K, G(K+1,1), LDG, G, LDG )
         END IF
C
         IF ( COMPL ) THEN
            CALL DLACPY( 'Lower', K, K, G(K+1,1), LDG, L, LDL )
         END IF
C
         IF ( COMPR ) THEN
            CALL DLACPY( 'Upper', K, N*K, T, LDT, R, LDR )
         END IF
C
C        Processing the generator.
C
         IF ( COMPG ) THEN
C
C           Here we use G as working array for holding the generator.
C           T contains the second row of the generator.
C           G contains in its first block row the second row of the
C           inverse generator.
C           The second block row of G is partitioned as follows:
C
C           [ First block of the inverse generator, ...
C             First row of the generator, ...
C             The rest of the blocks of the inverse generator ]
C
C           The reason for the odd partitioning is that the first block
C           of the inverse generator will be thrown out at the end and
C           we want to avoid reordering.
C
C           (N-1)*K locations of DWORK are used by SLICOT Library
C           routine MB02CY.
C
            DO 10  I = 2, N
               STARTR = ( I - 1 )*K + 1
               STARTI = ( N - I + 1 )*K + 1
               STARTT = 3*( I - 2 )*K + 1
C
C              Transformations acting on the generator:
C
               CALL MB02CX( 'Row', K, K, K, G(K+1,K+1), LDG,
     $                      T(1,STARTR), LDT, CS(STARTT), 3*K, DWORK,
     $                      LDWORK, IERR )
C
               IF ( IERR.NE.0 )  THEN
C
C                 Error return:  The matrix is not positive definite.
C
                  INFO = 1
                  RETURN
               END IF
C
               MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
               IF ( N.GT.I )  THEN
                  CALL MB02CY( 'Row', 'NoStructure', K, K, (N-I)*K, K,
     $                         G(K+1,2*K+1), LDG, T(1,STARTR+K), LDT,
     $                         T(1,STARTR), LDT, CS(STARTT), 3*K, DWORK,
     $                         LDWORK, IERR )
                  MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
               END IF
C
               IF ( COMPR ) THEN
                  CALL DLACPY( 'Upper', K, (N-I+1)*K, G(K+1,K+1), LDG,
     $                         R(STARTR,STARTR), LDR)
               END IF
C
C              Transformations acting on the inverse generator:
C
               CALL DLASET( 'All', K, K, ZERO, ZERO, G(K+1,STARTI),
     $                      LDG )
               CALL MB02CY( 'Row', 'Triangular', K, K, K, K, G(K+1,1),
     $                      LDG, G(1,STARTR), LDG, T(1,STARTR), LDT,
     $                      CS(STARTT), 3*K, DWORK, LDWORK, IERR )
               MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
C
               CALL MB02CY( 'Row', 'NoStructure', K, K, (I-1)*K, K,
     $                      G(K+1,STARTI), LDG, G, LDG, T(1,STARTR),
     $                      LDT, CS(STARTT), 3*K, DWORK, LDWORK, IERR )
               MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
C
               IF ( COMPL ) THEN
                  CALL DLACPY( 'All', K, (I-1)*K, G(K+1,STARTI), LDG,
     $                         L(STARTR,1), LDL )
                  CALL DLACPY( 'Lower', K, K, G(K+1,1), LDG,
     $                         L(STARTR,(I-1)*K+1), LDL )
               END IF
   10       CONTINUE
C
         ELSE
C
C           Here R is used as working array for holding the generator.
C           Again, T contains the second row of the generator.
C           The current row of R contains the first row of the
C           generator.
C
            IF ( N.GT.1 )
     $         CALL DLACPY( 'Upper', K, (N-1)*K, T, LDT, R(K+1,K+1),
     $                      LDR )
C
            DO 20  I = 2, N
               STARTR = ( I - 1 )*K + 1
               STARTT = 3*( I - 2 )*K + 1
               CALL MB02CX( 'Row', K, K, K, R(STARTR,STARTR), LDR,
     $                      T(1,STARTR), LDT, CS(STARTT), 3*K, DWORK,
     $                      LDWORK, IERR )
               IF ( IERR.NE.0 )  THEN
C
C                 Error return:  The matrix is not positive definite.
C
                  INFO = 1
                  RETURN
               END IF
C
               MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
               IF ( N.GT.I ) THEN
                  CALL MB02CY( 'Row', 'NoStructure', K, K, (N-I)*K, K,
     $                         R(STARTR,STARTR+K), LDR, T(1,STARTR+K),
     $                         LDT, T(1,STARTR), LDT, CS(STARTT), 3*K,
     $                         DWORK, LDWORK, IERR )
                  MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
C
                  CALL DLACPY( 'Upper', K, (N-I)*K, R(STARTR,STARTR),
     $                          LDR, R(STARTR+K,STARTR+K), LDR )
               END IF
   20       CONTINUE
C
         END IF
C
      ELSE
C
C        T is the first block column of a block Toeplitz matrix.
C        Bring T to proper form by triangularizing its first block.
C
         CALL DPOTRF( 'Lower', K, T, LDT, IERR )
         IF ( IERR.NE.0 )  THEN
C
C           Error return:  The matrix is not positive definite.
C
            INFO = 1
            RETURN
         END IF
C
         IF ( N.GT.1 )
     $      CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit',
     $                  (N-1)*K, K, ONE, T, LDT, T(K+1,1), LDT )
C
C        Initialize the output matrices.
C
         IF ( COMPG ) THEN
            CALL DLASET( 'All', N*K, 2*K, ZERO, ZERO, G, LDG )
            CALL DLASET( 'All', 1, K, ONE, ONE, G(1,K+1), LDG+1 )
            CALL DTRSM(  'Right', 'Lower', 'Transpose', 'NonUnit', K, K,
     $                   ONE, T, LDT, G(1,K+1), LDG )
            IF ( N.GT.1 )
     $         CALL DLACPY( 'Lower', (N-1)*K, K, T, LDT, G(K+1,K+1),
     $                      LDG )
            CALL DLACPY( 'Upper', K, K, G(1,K+1), LDG, G, LDG )
         END IF
C
         IF ( COMPL ) THEN
            CALL DLACPY( 'Upper', K, K, G(1,K+1), LDG, L, LDL )
         END IF
C
         IF ( COMPR ) THEN
            CALL DLACPY( 'Lower', N*K, K, T, LDT, R, LDR )
         END IF
C
C        Processing the generator.
C
         IF ( COMPG ) THEN
C
C           Here we use G as working array for holding the generator.
C           T contains the second column of the generator.
C           G contains in its first block column the second column of
C           the inverse generator.
C           The second block column of G is partitioned as follows:
C
C           [ First block of the inverse generator; ...
C             First column of the generator; ...
C             The rest of the blocks of the inverse generator ]
C
C           The reason for the odd partitioning is that the first block
C           of the inverse generator will be thrown out at the end and
C           we want to avoid reordering.
C
C           (N-1)*K locations of DWORK are used by SLICOT Library
C           routine MB02CY.
C
            DO 30  I = 2, N
               STARTR = ( I - 1 )*K + 1
               STARTI = ( N - I + 1 )*K + 1
               STARTT = 3*( I - 2 )*K + 1
C
C              Transformations acting on the generator:
C
               CALL MB02CX( 'Column', K, K, K, G(K+1,K+1), LDG,
     $                      T(STARTR,1), LDT, CS(STARTT), 3*K, DWORK,
     $                      LDWORK, IERR )
C
               IF ( IERR.NE.0 )  THEN
C
C                 Error return:  The matrix is not positive definite.
C
                  INFO = 1
                  RETURN
               END IF
C
               MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
               IF ( N.GT.I ) THEN
                  CALL MB02CY( 'Column', 'NoStructure', K, K, (N-I)*K,
     $                         K, G(2*K+1,K+1), LDG, T(STARTR+K,1), LDT,
     $                         T(STARTR,1), LDT, CS(STARTT), 3*K, DWORK,
     $                         LDWORK, IERR )
                  MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
               END IF
C
               IF ( COMPR ) THEN
                  CALL DLACPY( 'Lower', (N-I+1)*K, K, G(K+1,K+1), LDG,
     $                         R(STARTR,STARTR), LDR)
               END IF
C
C              Transformations acting on the inverse generator:
C
               CALL DLASET( 'All', K, K, ZERO, ZERO, G(STARTI,K+1),
     $                      LDG )
               CALL MB02CY( 'Column', 'Triangular', K, K, K, K,
     $                      G(1,K+1), LDG, G(STARTR,1), LDG,
     $                      T(STARTR,1), LDT, CS(STARTT), 3*K, DWORK,
     $                      LDWORK, IERR )
               MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
C
               CALL MB02CY( 'Column', 'NoStructure', K, K, (I-1)*K, K,
     $                      G(STARTI,K+1), LDG, G, LDG, T(STARTR,1),
     $                      LDT, CS(STARTT), 3*K, DWORK, LDWORK, IERR )
               MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
C
               IF ( COMPL ) THEN
                  CALL DLACPY( 'All', (I-1)*K, K, G(STARTI,K+1), LDG,
     $                         L(1,STARTR), LDL )
                  CALL DLACPY( 'Upper', K, K, G(1,K+1), LDG,
     $                         L((I-1)*K+1,STARTR), LDL )
               END IF
   30       CONTINUE
C
         ELSE
C
C           Here R is used as working array for holding the generator.
C           Again, T contains the second column of the generator.
C           The current column of R contains the first column of the
C           generator.
C
            IF ( N.GT.1 )
     $         CALL DLACPY( 'Lower', (N-1)*K, K, T, LDT, R(K+1,K+1),
     $                      LDR )
C
            DO 40  I = 2, N
               STARTR = ( I - 1 )*K + 1
               STARTT = 3*( I - 2 )*K + 1
               CALL MB02CX( 'Column', K, K, K, R(STARTR,STARTR), LDR,
     $                      T(STARTR,1), LDT, CS(STARTT), 3*K, DWORK,
     $                      LDWORK, IERR )
               IF ( IERR.NE.0 )  THEN
C
C                 Error return:  The matrix is not positive definite.
C
                  INFO = 1
                  RETURN
               END IF
C
               MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
               IF ( N.GT.I ) THEN
                  CALL MB02CY( 'Column', 'NoStructure', K, K, (N-I)*K,
     $                         K, R(STARTR+K,STARTR), LDR,
     $                         T(STARTR+K,1), LDT, T(STARTR,1), LDT,
     $                         CS(STARTT), 3*K, DWORK, LDWORK, IERR )
                  MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
C
                  CALL DLACPY( 'Lower', (N-I)*K, K, R(STARTR,STARTR),
     $                         LDR, R(STARTR+K,STARTR+K), LDR )
               END IF
   40       CONTINUE
C
         END IF
      END IF
C
      DWORK(1) = MAXWRK
C
      RETURN
C
C *** Last line of MB02CD ***
      END


\ Stack debugging example for sectorforth, a 512-byte, bootable x86 Forth.
\ Copyright (c) 2020 Cesar Blum
\ Distributed under the MIT license. See LICENSE for details.
\ Depends on definitions built up to the variables examples.

\ make a few more basic operators
: ?dup dup ?branch [ 4 , ] dup ;
: -rot ( x y z -- z x y ) rot rot ;
: xor ( x y -- x^y) 2dup and invert -rot or and ;
: 8000h lit [ 0 c, 80h c, ] ; \ little endian
: >= ( x y -- flag ) - 8000h and 0= ;
: < ( x y -- flag ) >= invert ;
: <= ( x y -- flag ) 2dup < -rot = or ;
: 0< ( x -- flag ) 0 < ;

\ divison and modulo
: /mod ( x y -- x%y x/y )
    over 0< -rot                \ remainder negative if dividend is negative
    2dup xor 0< -rot            \ quotient negative if operand signs differ
    dup 0< if negate then       \ make divisor positive if negative
    swap dup 0< if negate then  \ make dividend positive if negative
    0 >r begin                  \ hold quotient in return stack
        over 2dup >=            \ while divisor greater than dividend
    while
        -                       \ subtract divisor from dividend
        r> 1 + >r               \ increment quotient
    repeat
    drop nip                    \ leave sign flags and remainder on stack
    rot if negate then          \ set remainder sign
    r> rot                      \ get quotient from return stack
    if negate then ;            \ set quotient sign
: / /mod nip ;
: mod /mod drop ;

\ constants for decimal and hexadecimal 10 (i.e. 10 and 16)
: 10 lit [ 4 4 2 + + , ] ;
: 10h lit [ 4 4 4 4 + + + , ] ;

variable base
10 base !

\ switch to common bases
: hex 10h base ! ;
: decimal 10 base ! ;

\ convert number to ASCII digit
: digit ( x -- c )
    dup 10 < if [char] 0 + else 10 - [char] A + then ;

\ print space
: space bl emit ;

\ print number at the top of the stack in current base
: . ( x -- )
    -1 swap                                     \ put sentinel on stack
    dup 0< if negate -1 else 0 then             \ make positive if negative
    >r                                          \ save sign on return stack
    begin base @ /mod ?dup 0= until             \ convert to base 10 digits
    r> if [char] - emit then                    \ print sign
    begin digit emit dup -1 = until drop        \ print digits
    space ;                                     \ print space

\ base of data stack
: sp0 lit [ sp@ , ] ;

\ print backspace
: backspace lit [ 4 4 + , ] emit ;

\ print stack
: .s
    sp@ 0 swap begin
        dup sp0 <
    while
        2 +
        swap 1 + swap
    repeat swap
    [char] < emit dup . backspace [char] > emit space
    ?dup if
        0 do 2 - dup @ . loop
    then drop ;


module fedata
    use types
    implicit none
    save

    !! This module is used to define global values and matrices

    integer :: ne
        !! Total number of elements
    integer :: nn
        !! Total number of nodes
    integer :: nb
        !! Number of boundary conditions
    integer :: np
        !! Number of loads
    integer :: nm
        !! Number of materials
    integer :: neqn
        !! Number of equations
    integer :: bw
        !! Bandwidth of system matrix

    real(wp), dimension(:,:), allocatable :: x
        !! Nodal coordinates:
        !! * _i_-th row: coordinates for node _i_
        !! * column 1: \(x\)-coordinate
        !! * column 2: \(y\)-coordinate

    type element_def
        !! The "element" data type, which is used to
        !! describe a single element of a structure
        integer, dimension(4) :: ix
            !! Node list
        integer :: id
            !! Element id:
            !! * 1: truss element
            !! * 2: continuum element
        integer :: mat
            !! Identification number for material used by this element
        integer :: numnode
            !! Number of nodes on this element
    end type element_def
    type(element_def), dimension(:), allocatable :: element
        !! The elements of a structure

    type matprop
        !! The "material" data type, which is used to
        !! describe a material. Note that a given material
        !! might not use all of the properties defined below
        real(wp) :: young
            !! Young's Modulus
        real(wp) :: nu
            !! Poisson's Ratio
        real(wp) :: thk
            !! The thickness of the structure where this material is used
        real(wp) :: area
            !! The cross-sectional area of the structure where this material is used
        real(wp) :: dens
            !! Density
        real(wp) :: youngy
            !! Young's Modulus in the transverse direction (used for orthotropic materials)
        real(wp) :: shear
            !! Shear Modulus (used for orthotropic materials)
    end type matprop
    type(matprop), dimension(:), allocatable :: mprop
        !! The materials of a structure

    ! Boundary conditions
    real(wp), dimension(:,:), allocatable :: bound
        !! Boundary conditions
        !!
        !! * _i_-th row: boundary condition number _i_
        !! * column 1: index of node where boundary condition is applied
        !! * column 2: degree of freedom _i_ affected by boundary condition
        !!     * _i_ = 1: \(x\)-component
        !!     * _i_ = 2: \(y\)-component
        !! * column 3: prescribed value for the displacement
    real(wp), dimension(:,:), allocatable :: loads
        !! External loading
        !!
        !! * _i_-th row: external load number _i_
        !! * column 1: type _j_ of external loading
        !!     * _j_ = 1: point load
        !!     * _j_ = 2: pressure load
        !!
        !! The meaning of columns 2 - 4 depend on the type of external loading:
        !!
        !! * For point loads:
        !!     * column 2: index of node where load is applied
        !!     * column 3: degree of freedom _k_ affected by load
        !!         - _k_ = 1: \(x\)-component
        !!         - _k_ = 2: \(y\)-component
        !!      * column 4: value of applied force
        !!
        !! * For surface loads:
        !!     * column 2: index of element where pressure load is applied
        !!     * column 3: index of element face where pressure is applied
        !!     * column 4: value of applied pressure (always normal to surface)
    real(wp) :: accel(2)
        !! Acceleration forces
        !!
        !! * index 1: acceleration along \(x\)-component
        !! * index 2: acceleration along \(y\)-component

    ! Working arrays:
    real(wp), dimension(:,:), allocatable :: kmatrix
        !! Stiffness matrix
    real(wp), dimension(:,:), allocatable :: strain
        !! Strains at different places in the structure
        !!
        !! * _i_-th row: strain in element _i_
        !! * column 1: \(\epsilon_{11}\)
        !! * column 2: \(\epsilon_{22}\)
        !! * column 3: \(\epsilon_{12}\)
    real(wp), dimension(:,:), allocatable :: stress
        !! Stresses at different places in the structure
        !!
        !! * _i_-th row: stress in element _i_
        !! * column 1: \(\sigma_{11}\)
        !! * column 2: \(\sigma_{22}\)
        !! * column 3: \(\sigma_{12}\)
    real(wp), dimension(:),   allocatable :: p
        !! Force vector
    real(wp), dimension(:),   allocatable :: d
        !! Displacement vector
    real(wp), dimension(:,:),   allocatable :: d_eig
    	!! Eigenvector
    real(wp), dimension(:,:),   allocatable :: d_all
    	!! History of displacements
    real(wp), dimension(:), allocatable :: vm_stress
    real(wp), dimension(:), allocatable :: psi
    	!! Von mises Stress and direction (psi)

    ! Input/Output
    character(len=50) :: filename
        !! Name of input file
!    character(len=5), parameter :: plotdevice = '/XWIN'
    character(len=3), parameter :: plotdevice = '/SS'
!    character(len=3), parameter :: plotdevice = '/GW'
        !! Platform (or graphics package) dependent parameter for plotting
        !!
        !! * Linux               : '/XWIN'
        !! * Windows/Plato       : '/SS'
        !! * Windows/Code::Blocks: '/GW'

    ! Analysis type
    character(len=20) :: antype
        !! The type of analysis to be carried out
        !!
        !! STATIC
        !! : Static linear analysis (default)
        !!
        !! STATIC_NL
        !! : Static geometrically nonlinear analysis (HINT: not implemented yet)
        !!
        !! MODAL
        !! : Analysis of eigenfrequencies and mode shapes (HINT: not implemented yet)
        !!
        !! ANGLE
        !! : Optimization of fiber orientation of anisotropic material (HINT: not implemented yet)
        !!
        !! TRANS
        !! : Transient analysis (HINT: not implemented yet)

    ! Parameters
    integer, parameter :: mdim = 8
        !! Maximum number of element degrees-of-freedom
    integer, parameter :: no_gauss_points_k = 2
    	!! Number of points for gauss numeric integration of stiffness
    integer, parameter :: no_gauss_points_s = 1
    	!! Number of points for gauss numeric integration of strain
    integer, parameter :: no_eigenvalues = 5
    	!! Number of eigenvalues to be found

    real(wp), parameter :: scale_def = 1.0_wp
        !! Scale deformations when plotting
    real(wp), parameter :: scale_vec = 1.0_wp
        !! Scale length of vectors for plotting
	logical, parameter :: plot_stress = .false.
    	!! Plot regular stress
    logical, parameter :: plot_vmstress = .true.
    	!! Plot Von Mises Stress

    real(wp), parameter :: scale_thk = 0.1_wp
        !! Scale thickness of lines
    real(wp), parameter :: element_evaluation_x = 0.0_wp
    real(wp), parameter :: element_evaluation_y = 0.0_wp
    	!! Set point of evaluation for continuum elements (only used for rectangular elements)
    real(wp), parameter :: estop = 10e-12_wp
		!! Set presicion for for inverse iteration in modal analysis

    logical, parameter :: isoparametric = .true.
    	!! Indicate whether the  element is rectangular (false) or isoparametric (true)
	logical, parameter :: banded = .false.
        !! Indicate whether the system matrix is in banded form or not (full matrix)
    logical, parameter :: penalty = .false.
        !! Indicate whether boundary conditions are imposed by the penalty method or not (zero-one method)
    real(wp), parameter :: penalty_fac = 1.0e10_wp
        !! Scaling factor for boundary conditions imposed by the penalty method

end module fedata


C**************************************************************************
C************************* SUBROUTINE SPERHO ******************************
C**************************************************************************

       SUBROUTINE SPERHO (XF, NTOT, RHO, PROB)

C
C     *     THIS SUBROUTINE COMPUTES THE SPEARMAN'S RHO STATISTIC AND   *
C     *     ITS PROBABILITY UNDER THE NULL HYPOTHESIS.                  *
C     *                                                                 *
C     *   INPUT                                                         *
C     *      XF(J, I) : RANKS OF TWO VARIABLES J = 1, 2                 *
C     *      NTOT     : NUMBER OF DATA POINTS                           *
C     *                                                                 *
C     *   OUTPUT                                                        *
C     *       RHO     : SPEARMAN'S RHO                                  *
C     *       PROB    : PROBABILITY                                     *
C     *                                                                 *
C     *   SUBROUTINE AGAUSS                                             *
C
C
       IMPLICIT REAL*8 (A-H, O-Z), INTEGER (I-N)
       DIMENSION XF(2, NTOT)

       XSUM = 0.0
       X2SUM = 0.0
       YSUM = 0.0
       Y2SUM = 0.0
       XYSUM = 0.0
       RN = NTOT

       DO 100 I = 1, NTOT
          XSUM = XSUM + XF(1,I)
          X2SUM = X2SUM + XF(1,I) ** 2
          YSUM = YSUM + XF(2,I)
          Y2SUM = Y2SUM + XF(2,I) ** 2
          XYSUM = XYSUM + XF(1,I) * XF(2,I)
  100  CONTINUE

       XBAR = XSUM / RN
       YBAR = YSUM / RN

       SXX = X2SUM - RN * XBAR ** 2
       SYY = Y2SUM - RN * YBAR ** 2
       SXY = XYSUM - RN * XBAR * YBAR

       RHO = SXY / SQRT (SXX * SYY)
C
C******  THE NEXT APPROXIMATION IS GOOD ONLY WHEN N IS LARGE (E.G. >30)  *
C

       Z   = RHO * SQRT (RN - 1.0)

       PROB = 1.0 - AGAUSS (Z)

       RETURN
       END


module mod_hash_set
  implicit none
  integer, parameter :: int_max_value = 2147483647
  integer, parameter :: default_initial_capacity = 16
  integer, parameter :: maximum_capacity = lshift(1, 30)
  real, parameter :: default_load_factor = 0.75

  type t_element
    integer :: key
    type(t_element), pointer :: next => null()
    integer :: hash
  end type

  type t_element_ptr
    type(t_element), pointer :: ref => null()
  end type

  type t_hash_set
    type(t_element_ptr), private, allocatable :: table(:)
    integer :: size = 0
    integer, private :: threshold = int(default_initial_capacity * default_load_factor)
    real, private :: load_factor = default_load_factor
  contains
    procedure :: is_empty => is_empty
    procedure :: is_not_empty => is_not_empty
    procedure :: add => add
    procedure :: add_all => add_all
    procedure :: remove => remove
    procedure :: clear => clear
    procedure :: contains => contains_key
    procedure :: get_keys => get_keys
  end type

  interface hash_set
    module procedure :: newhs0, newhs1, newhs2
  end interface

contains

  function new_element(key, h) result(res)
    integer, intent(in) :: key
    integer, intent(in) :: h
    type(t_element), pointer :: res
    allocate(res)
    res%key = key
    res%hash = h
  end

  integer function hash_code(i) result(res)
    integer, intent(in) :: i
    res = i
  end

  type(t_hash_set) function newhs0() result(res)
    allocate(res%table(default_initial_capacity))
  end

  type(t_hash_set) function newhs1(initial_capacity) result(res)
    integer, intent(in) :: initial_capacity
    res = newhs2(initial_capacity, default_load_factor)
  end

  type(t_hash_set) function newhs2(initial_capacity, load_factor) result(res)
    integer, intent(in) :: initial_capacity
    real, intent(in) :: load_factor
    integer :: capacity
    if (initial_capacity < 0) then
      capacity = default_initial_capacity
    else
      capacity = 1
      do while (capacity < min(initial_capacity, maximum_capacity))
        capacity = lshift(capacity, 1)
      end do
    end if

    if (load_factor <= 0 .or. load_factor /= load_factor) then
      res%load_factor = default_load_factor
    else
      res%load_factor = load_factor
    end if

    res%threshold = int(capacity * res%load_factor)
    allocate(res%table(capacity))
  end

  integer function shr(i, n) result(res)
    integer, intent(in) :: i, n
    if (n == 0) then
      res = i
    else
      res = rshift(ibclr(rshift(i, 1), 31), n-1)
    end if
  end

  integer function hash(i) result(res)
    integer, intent(in) :: i
    integer :: h
    h = i
    h = xor(h, xor(shr(h, 20), shr(h, 12)))
    res = xor(h, xor(shr(h, 7), shr(h, 4)))
  end

  integer function index_for(h, length) result(res)
    integer, intent(in) :: h, length
    res = and(h, length - 1) + 1
  end

  logical function is_empty(this) result(res)
    class(t_hash_set), intent(in) :: this
    res = this%size == 0
  end

  logical function is_not_empty(this) result(res)
    class(t_hash_set), intent(in) :: this
    res = this%size /= 0
  end

  logical function contains_key(this, key) result(res)
    class(t_hash_set), intent(in) :: this
    integer, intent(in) :: key
    type(t_element), pointer :: e
    e => get_element(this, key)
    res = associated(e)
  end

  function get_element(this, key) result(res)
    class(t_hash_set), intent(in) :: this
    integer, intent(in) :: key
    integer :: h
    type(t_element), pointer :: e
    type(t_element), pointer :: res
    h = hash(hash_code(key))
    e => this%table(index_for(h, size(this%table)))%ref
    do while (associated(e))
      if (e%hash == h .and. e%key == key) then
        res => e
        return
      end if
      e => e%next
    end do
    res => null()
  end

  subroutine add(this, key)
    class(t_hash_set), intent(inout) :: this
    integer, intent(in) :: key
    integer :: h, i
    type(t_element), pointer :: e
    h = hash(hash_code(key))
    i = index_for(h, size(this%table))
    e => this%table(i)%ref
    do while (associated(e))
      if (e%hash == h .and. e%key == key) return
      e => e%next
    end do
    call add_element(this, key, h, i)
  end

  subroutine add_element(this, key, h, idx)
    class(t_hash_set), intent(inout) :: this
    integer, intent(in) :: key
    integer, intent(in) :: h, idx
    type(t_element), pointer :: e
    e => this%table(idx)%ref
    this%table(idx)%ref => new_element(key, h)
    this%table(idx)%ref%next => e
    this%size = this%size + 1
    if (this%size >= this%threshold) call resize(this, 2 * size(this%table))
  end

  subroutine add_all(this, keys)
    class(t_hash_set), intent(inout) :: this
    integer, intent(in) :: keys(:)
    integer :: i
    do i = 1, size(keys)
      call add(this, keys(i))
    end do
  end

  subroutine resize(this, new_capacity)
    class(t_hash_set), intent(inout) :: this
    integer, intent(in) :: new_capacity
    integer :: capacity, i, j
    type(t_element), pointer :: e, next
    type(t_element_ptr) :: table(new_capacity)
    capacity = size(this%table)
    if (capacity == maximum_capacity) then
      this%threshold = int_max_value
      return
    end if

    do j = 1, capacity
      e => this%table(j)%ref
      if (associated(e)) then
        this%table(j)%ref => null()
        do
          next => e%next
          i = index_for(e%hash, new_capacity)
          e%next => table(i)%ref
          table(i)%ref => e
          e => next
          if (.not.associated(e)) exit
        end do
      end if
    end do

    deallocate(this%table)
    allocate(this%table(new_capacity))
    do j = 1, new_capacity
      this%table(j)%ref => table(j)%ref
    end do
    this%threshold = int(new_capacity * this%load_factor)
  end

  subroutine remove(this, key)
    class(t_hash_set), intent(inout) :: this
    integer, intent(in) :: key
    integer :: h, i
    type(t_element), pointer :: e, prev, next
    h = hash(hash_code(key))
    i = index_for(h, size(this%table))
    prev => this%table(i)%ref
    e => prev
    do while (associated(e))
      next => e%next
      if (e%hash == h .and. e%key == key) then
        this%size = this%size - 1
        if (associated(prev, e)) then
          this%table(i)%ref => next
        else
          prev%next => next
        end if
        return
      end if
      prev => e
      e => next
    end do
  end

  subroutine clear(this)
    class(t_hash_set), intent(inout) :: this
    deallocate(this%table)
    allocate(this%table(default_initial_capacity))
    this%size = 0
  end

  function get_keys(this) result(res)
    class(t_hash_set), intent(in) :: this
    integer :: res(this%size)
    integer :: i, k
    type(t_element), pointer :: e
    k = 0
    do i = 1, size(this%table)
      e => this%table(i)%ref
      do while (associated(e))
        k = k + 1
        res(k) = e%key
        e => e%next
      end do
    end do
  end
end module mod_hash_set


!===============================================================================
! One of Andy Nowacki's Fortran utility modules for dealing with seismic
! anisotropy and other problems.
!
! Andy Nowacki <andy.nowacki@bristol.ac.uk>
!
! See the file LICENCE for licence details.
!===============================================================================
program project_to_gcp_prog
!===============================================================================
!  Wrapper program for sg_project_to_gcp.  This reads the coordinates of the pole
!  to a great circle on the unit sphere and another point and projects that point
!  onto the great circle.
!  Input is in geographic coordinates in degrees.

   use spherical_geometry, only: sg_project_to_gcp

   implicit none
   real(8) :: long, latg, lonp, latp, lon, lat
   integer :: iostat

   if (command_argument_count() /= 0) call usage

   ! Loop over lines of stdin
   iostat = 0
   do while (iostat == 0)
      read(*,*,iostat=iostat) long,latg,lonp,latp
      if (iostat > 0) then
         write(0,'(a)') 'project_to_gcp: Error: problem reading lon,lat,lon,lat from stdin'
         stop
      endif
      if (iostat < 0) exit
      call sg_project_to_gcp(long,latg,lonp,latp,lon,lat,degrees=.true.)
      write(*,'(f11.6,1x,f10.6)') lon,lat
   enddo

contains
   !============================================================================
   subroutine usage()
   !============================================================================
      implicit none
      write(0,'(a)') 'Usage: project_to_gcp < [lon pole] [lat pole] [lon point] [lat point]',&
                     '   Project a point onto a great circle',&
                     '   First two coordinates are the pole to the great circle, second two are',&
                     '   coordinates of the point to be projected onto the great circle'
      stop
   end subroutine usage
   !----------------------------------------------------------------------------

end program project_to_gcp_prog
!-------------------------------------------------------------------------------