subroutine pressure

    use m_parameters
    use m_fields
    use m_work
    use x_fftw

    implicit none

    integer :: i, j, k, n
    real*8  :: div1, div2, lapl1, lapl2, p1, p2

    ! pressure poisson equation
    do k = 1, nz
        do j = 1, ny
            do i = 1, nx + 1, 2

                ! getting the divergence (i*k*\hat(u))
                ! remember that in the Fourier space indicies go as (ix,iz,iy)

                ! getting divergence
                div2 = akx(i)*fields(i, j, k, 1) + aky(k)*fields(i, j, k, 2) + akz(j)*fields(i, j, k, 3)
                div1 = -(akx(i + 1)*fields(i + 1, j, k, 1) + aky(k)*fields(i + 1, j, k, 2) + akz(j)*fields(i + 1, j, k, 3))

                ! inverse laplace operator
                lapl1 = akx(i)**2 + aky(k)**2 + akz(j)**2
                lapl2 = akx(i + 1)**2 + aky(k)**2 + akz(j)**2

                if (lapl1 .eq. 0.d0) lapl1 = 9e20
                if (lapl2 .eq. 0.d0) lapl2 = 9e20

                ! calculating pressure
                p1 = -div1/lapl1
                p2 = -div2/lapl2

                ! Taking derivatives of the pressure and subtracting from the corresponding velocities
                fields(i, j, k, 1) = fields(i, j, k, 1) + p2*akx(i + 1)
                fields(i + 1, j, k, 1) = fields(i + 1, j, k, 1) - p1*akx(i)

                fields(i, j, k, 2) = fields(i, j, k, 2) + p2*aky(k)
                fields(i + 1, j, k, 2) = fields(i + 1, j, k, 2) - p1*aky(k)

                fields(i, j, k, 3) = fields(i, j, k, 3) + p2*akz(j)
                fields(i + 1, j, k, 3) = fields(i + 1, j, k, 3) - p1*akz(j)

                ! store the pressures in a new array dedicated to the pressures
                pressure_field(i, j, k, 1) = p2 + akx(i + 1)
                pressure_field(i + 1, j, k, 1) = -p1 + akx(i)

                pressure_field(i, j, k, 2) = p2 + aky(k)
                pressure_field(i + 1, j, k, 2) = -p1 + aky(k)

                pressure_field(i, j, k, 3) = p2 + akz(j)
                pressure_field(i + 1, j, k, 3) = -p1 + akz(j)

            end do
        end do
    end do

    return
end subroutine pressure

subroutine divergence

    use m_openmpi
    use m_parameters
    use m_fields
    use m_work
    use x_fftw

    implicit none

    integer :: i, j, k
    real*8 :: dmin, dmax, d1

    wrk(:, :, :, 1:3) = fields(:, :, :, 1:3)

    call x_derivative(1, 'x', 4)
    call x_derivative(2, 'y', 5)
    call x_derivative(3, 'z', 6)

    call xFFT3d(-1, 4)
    call xFFT3d(-1, 5)
    call xFFT3d(-1, 6)

    wrk(:, :, :, 0) = wrk(:, :, :, 4) + wrk(:, :, :, 5) + wrk(:, :, :, 6)

    d1 = minval(wrk(1:nx, :, :, 0))
    call MPI_REDUCE(d1, dmin, 1, MPI_REAL8, MPI_MIN, 0, MPI_COMM_TASK, mpi_err)
    d1 = maxval(wrk(1:nx, :, :, 0))
    call MPI_REDUCE(d1, dmax, 1, MPI_REAL8, MPI_MAX, 0, MPI_COMM_TASK, mpi_err)

    if (myid .eq. 0) then
        write (out, *) 'divergence:', dmin, dmax
!!$    print *, 'divergence:',dmin,dmax
        call flush (out)
    end if

    return
end subroutine divergence


PROGRAM Triangle
IMPLICIT NONE
REAL :: a, b, c, Area
PRINT *, 'Welcome, please enter the&
          &lengths of the 3 sides.'
READ *, a, b, c
PRINT *, 'Triangle''s area:  ', Area(a,b,c)
END PROGRAM Triangle
FUNCTION Area(x,y,z)
IMPLICIT NONE
REAL :: Area            ! function type
REAL, INTENT( IN ) :: x, y, z
REAL :: theta, height
theta = ACOS((x**2+y**2-z**2)/(2.0*x*y))
height = x*SIN(theta); Area = 0.5*y*height
END FUNCTION Area


    Program ztrsen_example

!     ZTRSEN Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use blas_interfaces, Only: zgemm
      Use lapack_example_aux, Only: nagf_file_print_matrix_complex_gen_comp
      Use lapack_interfaces, Only: zlange, ztrsen
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Complex (Kind=dp) :: alpha, beta
      Real (Kind=dp) :: norm, s, sep
      Integer :: i, ifail, info, lda, ldc, ldq, ldt, lwork, m, n
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: a(:, :), c(:, :), q(:, :), t(:, :), &
        w(:), work(:)
      Real (Kind=dp) :: rwork(1)
      Logical, Allocatable :: select(:)
      Character (1) :: clabs(1), rlabs(1)
!     .. Intrinsic Procedures ..
      Intrinsic :: cmplx, epsilon
!     .. Executable Statements ..
      Write (nout, *) 'ZTRSEN Example Program Results'
      Write (nout, *)
      Flush (nout)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      ldc = n
      lda = n
      ldq = n
      ldt = n
      lwork = (n*n)/2
      Allocate (a(lda,n), c(ldc,n), q(ldq,n), t(ldt,n), w(n), work(lwork), &
        select(n))

!     Read T, Q and the logical array SELECT from data file

      Read (nin, *)(t(i,1:n), i=1, n)
      Read (nin, *)
      Read (nin, *)(q(i,1:n), i=1, n)
      Read (nin, *)
      Read (nin, *) select(1:n)

!     Compute Q * T * Q**T to find  A
      alpha = cmplx(1, kind=dp)
      beta = cmplx(0, kind=dp)
      Call zgemm('N', 'N', n, n, n, alpha, q, ldq, t, ldt, beta, c, ldc)
      Call zgemm('N', 'C', n, n, n, alpha, c, ldc, q, ldq, beta, a, lda)

!     Print Matrix A, as computed from Q * T * Q**T
!     ifail: behaviour on error exit
!            =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
      ifail = 0
      Call nagf_file_print_matrix_complex_gen_comp('General', ' ', n, n, a, &
        lda, 'Bracketed', 'F7.4', 'Matrix A created from Q*T*Q^T', 'Integer', &
        rlabs, 'Integer', clabs, 80, 0, ifail)

      Write (nout, *)
      Flush (nout)

!     Reorder the Schur factor T and update the matrix Q to obtain TT and QT

      Call ztrsen('Both', 'Vectors', select, n, t, ldt, q, ldq, w, m, s, sep, &
        work, lwork, info)

!     Compute (Q * T * Q^H) - (QT * TT * QT^H) and store in A,
!     i.e. the difference between reconstructed A using Schur and reordered
!          Schur decompositions.
      alpha = cmplx(1, kind=dp)
      beta = cmplx(0, kind=dp)
      Call zgemm('N', 'N', n, n, n, alpha, q, ldq, t, ldt, beta, c, ldc)
      alpha = cmplx(-1, kind=dp)
      beta = cmplx(1, kind=dp)
      Call zgemm('N', 'C', n, n, n, alpha, c, ldc, q, ldq, beta, a, lda)

!     Find norm of difference matrix and print warning if it is too large
      norm = zlange('O', lda, n, a, lda, rwork)
      If (norm>epsilon(1.0E0_dp)**0.5_dp) Then
        Write (nout, *) 'Norm of A - (QT * TT * QT^H) is much greater than 0.'
        Write (nout, *) 'Schur factorization has failed.'
      Else
!       Print condition estimates
        Write (nout, 100) 'Condition number estimate', &
          ' of the selected cluster of eigenvalues = ', 1.0_dp/s
        Write (nout, *)
        Write (nout, 100) 'Condition number estimate of the specified ', &
          'invariant subspace    = ', 1.0_dp/sep
      End If

100   Format (1X, A, A, 1P, E10.2)
    End Program


! This source file is part of GAME-DA, which is released under the MIT license.
! Github repository: https://github.com/OpenNWP/GAME-DA

! This module contains linear algebra functions.

module lin_algebra

  use iso_c_binding

  implicit none

  ! precision of doubles
  integer, parameter        :: wp = c_double

  contains

  subroutine gauss(to_be_inverted, inv, matrix_size) &
  bind(c, name = "gauss")

    ! This subroutine computes the inverse inv of the matrix to_be_inverted, using the Gauss scheme.
    ! CAUTION: in the process, to_be_inverted will be modified.

    real(wp), intent(inout) :: to_be_inverted(matrix_size,matrix_size)
    real(wp), intent(inout) :: inv           (matrix_size,matrix_size)
    integer,  intent(in)    :: matrix_size

    ! local variables
    integer                 :: permute_index_found, permute_index_counter
    real(wp)                :: factor
    ! loop indices
    integer                 :: i, j, k

    ! firstly, the inverse is initialized with the unity matrix
    !$omp parallel
    !$omp do private(i)
    do i = 1,matrix_size
      inv(i,i) = 1._wp
    enddo
    !$omp end do
    !$omp end parallel

    ! Gaussian downwards
    ! ------------------
    ! we will start to modify to_be_inverted now (misuse of name)
    do i = 1,matrix_size-1
      ! checking if a permutation is necessary
      ! Firstly, the permutation index has to be found.
      permute_index_found = 0
      permute_index_counter = i
      do while (permute_index_found == 0)
        if (to_be_inverted(permute_index_counter,i) /= 0._wp) then
          permute_index_found = 1
        else
          permute_index_counter = permute_index_counter + 1
        endif
      enddo
      ! actually performing the permutation
      if (permute_index_counter > i) then
        call permute_lines(to_be_inverted, i, permute_index_counter, matrix_size)
        call permute_lines(inv, i, permute_index_counter, matrix_size)
      endif

      ! permutation is done, now comes the actual calculation
      ! dividing the line by to_be_inverted(i,i)
      factor = 1._wp/to_be_inverted(i,i)
      !$omp parallel
      !$omp do private(j)
      do j=i,matrix_size
        to_be_inverted(i,j) = factor*to_be_inverted(i,j)
      enddo
      !$omp end do
      !$omp end parallel
      inv(i,:) = factor*inv(i,:)
      ! loop over all the lines that are below the current line
      !$omp parallel
      !$omp do private(factor,j,k)
      do j=i+1,matrix_size
        factor = -to_be_inverted(j,i)
        do k=i,matrix_size
          to_be_inverted(j,k) = to_be_inverted(j,k) + factor*to_be_inverted(i,k)
        enddo
        inv(j,:) = inv(j,:) + factor*inv(i,:)
      enddo
      !$omp end do
      !$omp end parallel
    enddo

    inv(matrix_size,:) = inv(matrix_size,:)/to_be_inverted(matrix_size,matrix_size)
    to_be_inverted(matrix_size,matrix_size) = 1._wp

    ! Gaussian upwards
    ! ----------------
    do i = matrix_size,2,-1
      !$omp parallel
      !$omp do private(j)
      do j = i-1,1,-1
        inv(j,:) = inv(j,:) - to_be_inverted(j,i)*inv(i,:)
      enddo
      !$omp end do
      !$omp end parallel
    enddo

  end subroutine gauss

  subroutine permute_lines(matrix, line_a, line_b, matrix_size)

    ! This subroutine permutes line_a with line_b of matrix.

    ! arguments
    real(wp), intent(inout) :: matrix(matrix_size,matrix_size)
    integer,  intent(in)    :: line_a
    integer,  intent(in)    :: line_b
    integer,  intent(in)    :: matrix_size

    ! local variables
    real(wp)                :: line_a_pre(matrix_size)

    line_a_pre(:) = matrix(line_a,:)
    matrix(line_a,:) = matrix(line_b,:)
    matrix(line_b,:) = line_a_pre(:)

  end subroutine permute_lines

end module lin_algebra


    Program dbdsdc_example

!     DBDSDC Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_interfaces, Only: dbdsdc
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Integer :: info, ldb, ldu, ldvt, n
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: b(:, :), d(:), e(:), u(:, :), vt(:, :), &
        work(:)
      Real (Kind=dp) :: q(1)
      Integer :: iq(1)
      Integer, Allocatable :: iwork(:)
!     .. Executable Statements ..
      Write (nout, *) 'DBDSDC Example Program Results'
      Write (nout, *)
      Flush (nout)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      ldb = n
      ldu = n
      ldvt = n
      Allocate (b(ldb,n), d(n), e(n-1), u(ldu,n), vt(ldvt,n), work(n*(3*n+ &
        4)), iwork(8*n))

!     Read the bidiagonal matrix B from data file, first
!     the diagonal elements, and then the off diagonal elements

      Read (nin, *) d(1:n)
      Read (nin, *) e(1:n-1)

!     Calculate the singular values and left and right singular
!     vectors of B.

      Call dbdsdc('Upper', 'I', n, d, e, u, ldu, vt, ldvt, q, iq, work, iwork, &
        info)

      If (info==0) Then
!       Print the singular values of B.

        Write (nout, *) 'Singular values of B:'
        Write (nout, 100) d(1:n)
      Else
        Write (nout, 110) '** DBDSDC failed with INFO = ', info
      End If

100   Format (1X, 4(3X,F11.4))
110   Format (1X, A, I10)
    End Program


subroutine SHReturnTapersM(theta0, lmax, m, tapers, eigenvalues, shannon, &
                           degrees, ntapers, exitstatus)
!------------------------------------------------------------------------------
!
!   This subroutine will return all the eigenvalues and eigenfunctions for the
!   space-concentration problem of a spherical cap of angular radius theta0.
!   The returned eigenfunctions correspond to "geodesy" normalized spherical
!   harmonic coefficients, and the eigenfunctions are further normalized such
!   that they have unit power (i.e., the integral of the function squared over
!   the sphere divided by 4 pi is 1, and the sum of the squares of their
!   coefficients is 1). If the optional vector DEGREES is specified, then the
!   eigenfunctions will be computed using only those degrees where DEGREES(l+1)
!   is not zero.
!
!   When possible, the eigenfunctions are calculated using the kernel of
!   Grunbaum et al. 1982 and the eigenvalues are then calculated by integration
!   using the definition of the space-concentration problem. Use of the
!   Grunbaum et al. kernel is prefered over the space-concentration kernel as
!   the eigenfunctions of the later are unreliable when there are several
!   eigenvalues identical (within machine precision) to either 1 or zero. If,
!   the optional parameter DEGREES is specified, and at least one element is
!   zero for degrees greater or equal to abs(m), then the eigenfunctions and
!   eigenvalues will instead be computed directly using the space-concentration
!   kernel.
!
!   Calling Parameters
!
!       IN
!           theta0          Angular radius of spherical cap in RADIANS.
!           lmax            Maximum spherical harmonic degree
!                           for the concentration problem.
!           m               Angular order of the concentration
!                           problem (m=0 corresponds to isotropic case).
!
!       OUT
!           tapers          An (lmax+1) by (lmax+1-abs(m)) array containing
!                           all the eigenfunctions of the space-
!                           concentration kernel. Eigenfunctions
!                           are listed by columns in decreasing order
!                           corresponding to value of their eigenvalue.
!                           Only the first ntapers columns are non-zero.
!           eigenvalues     A vector of length lmax+1-abs(m) containing the
!                           eigenvalued corresponding to the individual
!                           eigenfunctions.
!
!       OPTIONAL (IN)
!           degrees     Specify those degrees of the coupling matrix to
!                       compute. If degrees(l+1) is zero, degree l will not
!                       be computed.
!
!       OPTIONAL (OUT)
!           shannon     Shannon number as calculated from the trace of the
!                       kernel.
!           ntapers     The number of non-zero tapers.
!           exitstatus  If present, instead of executing a STOP when an error
!                       is encountered, the variable exitstatus will be
!                       returned describing the error.
!                       0 = No errors;
!                       1 = Improper dimensions of input array;
!                       2 = Improper bounds for input variable;
!                       3 = Error allocating memory;
!                       4 = File IO error.
!
!   Copyright (c) 2005-2019, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use SHTOOLS, only: ComputeDG82, ComputeDm, EigValVecSymTri, EigValVecSym, &
                       PreGLQ, PlmBar, PlmIndex
    use ftypes

    implicit none

    real(dp), intent(in) :: theta0
    integer, intent(in) :: lmax, m
    real(dp), intent(out) :: tapers(:,:), eigenvalues(:)
    real(dp), intent(out), optional :: shannon
    integer, intent(in), optional :: degrees(:)
    integer, intent(out), optional :: ntapers
    integer, intent(out), optional :: exitstatus
    integer :: l, n, n_int, j, i, astat(3), ind(lmax+1), use_dg82
    real(dp) :: eval(lmax+1), pi, upper, lower, zero(lmax+1), w(lmax+1), h
    real(dp), allocatable :: evec(:,:), dllmtri(:,:), p(:), dllm(:,:)

    use_dg82 = 1

    if (present(exitstatus)) exitstatus = 0

    if (size(tapers(:,1)) < (lmax+1) .or. &
            size(tapers(1,:)) < (lmax+1-abs(m)) ) then
        print*, "Error --- SHReturnTapersM"
        print*, "TAPERS must be dimensioned as (LMAX+1, LMAX+1-ABS(M)) " // &
                "where LMAX is ", lmax
        print*, "Input array is dimensioned as ", size(tapers(:,1)), &
                size(tapers(1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if(size(eigenvalues) < (lmax+1-abs(m)) ) then
        print*, "Error --- SHReturnTapersM"
        print*, "EIGENVALUES must be dimensioned as (LMAX+1-ABS(m)) " // &
                "where LMAX is ", lmax
        print*, "Input array is dimensioned as ", size(eigenvalues)
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (m > lmax) then
        print*, "Error --- SHReturnTapersM"
        print*, "M must be less than or equal to LMAX."
        print*, "M = ", m
        print*, "LMAX = ", lmax
        if (present(exitstatus)) then
            exitstatus = 2
            return
        else
            stop
        end if

    end if

    if (present(degrees)) then
        if (size(degrees) < lmax+1) then
            print*, "Error --- SHReturnTapersM"
            print*, "DEGREES must have dimension LMAX+1, where LMAX is ", lmax
            print*, "Input array is dimensioned as ", size(degrees)
            if (present(exitstatus)) then
                exitstatus = 1
                return
            else
                stop
            end if
        end if
    end if

    if (present(degrees)) then
        if (sum(degrees(1+abs(m):lmax+1)) /= lmax + 1 - abs(m)) use_dg82 = 0
    end if

    allocate (evec(lmax+1, lmax+1-abs(m)), stat = astat(1))
    allocate (dllmtri(lmax+1, lmax+1), stat = astat(2))
    allocate (p((lmax+1)*(lmax+2)/2), stat = astat(3))

    if (astat(1) /= 0 .or. astat(2) /= 0 .or. astat(3) /= 0) then
        print*, "Error --- SHReturnTapersM"
        print*, "Problem allocating arrays EVEC, DLLMTRI, and P", &
            astat(1), astat(2), astat(3)
        if (present(exitstatus)) then
            exitstatus = 3
            return
        else
            stop
        end if

    end if

    pi = acos(-1.0_dp)

    tapers = 0.0_dp
    eigenvalues = 0.0_dp
    eval = 0.0_dp
    evec = 0.0_dp

    if (use_dg82 == 1) then
        !----------------------------------------------------------------------
        !
        !   Calculate space-concentration kernel and the corresponding
        !   eigenfunctions of the Grunbaum et al. kernel.
        !
        !----------------------------------------------------------------------
        n = lmax + 1 - abs(m)

        if (present(exitstatus)) then
            call ComputeDG82(dllmtri(1:n,1:n), lmax, m, theta0, &
                             exitstatus = exitstatus)
        if (exitstatus /= 0) return
            call EigValVecSymTri(dllmtri(1:n,1:n), n, eval(1:n), &
                                 tapers(1+abs(m):lmax+1,1:n), &
                                 exitstatus = exitstatus)
            if (exitstatus /= 0) return
        else
            call ComputeDG82(dllmtri(1:n,1:n), lmax, m, theta0)
            call EigValVecSymTri(dllmtri(1:n,1:n), n, eval(1:n), &
                                 tapers(1+abs(m):lmax+1,1:n))
        end if

        !----------------------------------------------------------------------
        !
        !   Calculate true eigenvalues
        !
        !----------------------------------------------------------------------
        upper = 1.0_dp
        lower = cos(theta0)
        n_int = lmax + 1

        if (present(exitstatus)) then
            call PreGLQ(lower, upper, n_int, zero, w, exitstatus = exitstatus)
            if (exitstatus /= 0) return
        else
            call PreGLQ(lower, upper, n_int, zero, w)
        end if

        do i=1, n_int
            if (present(exitstatus)) then
                call PlmBar(p, lmax, zero(i), exitstatus = exitstatus)
                if (exitstatus /= 0) return
            else
                call PlmBar(p, lmax, zero(i))
            end if

            do j = 1, n
                h = 0.0_dp

                do l = abs(m), lmax
                    h = h + p(PlmIndex(l, abs(m))) * tapers(l+1, j)

                end do

                eigenvalues(j) = eigenvalues(j) + w(i) * h**2

            end do
        end do

        if (m == 0) then
            eigenvalues(1:n) = eigenvalues(1:n) / 2.0_dp

        else
            eigenvalues(1:n) = eigenvalues(1:n) / 4.0_dp

        end if

    else
        !----------------------------------------------------------------------
        !
        !   Calculate space-concentration kernel and the corresponding
        !   eigenfunctions.
        !
        !----------------------------------------------------------------------
        ind = 0
        i = 0

        do l=abs(m), lmax, 1
            if (degrees(l+1) /= 0) then
                i = i + 1
                ind(i) = l + 1
            end if
        end do

        n = i

        if (n /= 0) then

            allocate (dllm(n, n), stat = astat(1))
            if (astat(1) /= 0) then
                print*, "Error --- SHReturnTapersM"
                print*, "Problem allocating array DLLM ", astat(1)
                if (present(exitstatus)) then
                    exitstatus = 3
                    return
                else
                    stop
                end if
            end if

            dllm = 0.0_dp

            if (present(exitstatus)) then
                call ComputeDm(dllmtri, lmax, m, theta0, degrees=degrees, &
                               exitstatus=exitstatus)
                if (exitstatus /= 0) return
            else
                call ComputeDm(dllmtri, lmax, m, theta0, degrees=degrees)
            end if

            do i=1, n
                do j=1, n
                    dllm(i, j) = dllmtri(ind(i), ind(j))
                end do
            end do

            if (present(exitstatus)) then
                call EigValVecSym(dllm(1:n, 1:n), n, &
                                  eval(1:n), evec(1:n,1:n), &
                                exitstatus = exitstatus)
                if (exitstatus /= 0) return
            else
                call EigValVecSym(dllm, n, eval(1:n),&
                                  evec(1:n,1:n))
            end if

            do i=1, n
                tapers(ind(i), 1:n) = evec(i, 1:n)
            end do

            eigenvalues(1:n) = eval(1:n)

        end if

    end if

    if (present(shannon)) then
        shannon = sum(eigenvalues(1:lmax+1-abs(m)))
    end if

    if (present(ntapers)) then
        ntapers = n
    end if

    ! deallocate memory
    call PlmBar (p, -1, zero(1))
    deallocate (evec)
    deallocate (dllmtri)
    deallocate (p)
    if (use_dg82 == 0 .and. n /= 0) deallocate (dllm)

end subroutine SHReturnTapersM


!
!     file hwsplr.f90
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 2005 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Fishpack                              *
!     *                                                               *
!     *                      A Package of Fortran                     *
!     *                                                               *
!     *                Subroutines and Example Programs               *
!     *                                                               *
!     *               for Modeling Geophysical Processes              *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *        John Adams, Paul Swarztrauber and Roland Sweet         *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!     SUBROUTINE hwsplr(a, b, m, mbdcnd, bda, bdb, c, d, n, nbdcnd, bdc, bdd,
!                       elmbda, f, idimf, pertrb, ierror)
!
!
! DIMENSION OF           bda(n), bdb(n), bdc(m), bdd(m), f(idimf, n+1)
! ARGUMENTS
!
! LATEST REVISION        May 2016
!
! PURPOSE                Solves a finite difference approximation to
!                        the helmholtz equation in polar coordinates.
!                        the equation is
!
!                            (1/r)(d/dr)(r(du/dr)) +
!                            (1/r**2)(d/dtheta)(du/dtheta) +
!                            lambda*u = f(r, theta).
!
! USAGE                  call hwsplr(a, b, m, mbdcnd, bda, bdb, c, d, n,
!                                     nbdcnd, bdc, bdd, elmbda, f, idimf,
!                                     pertrb, ierror, w)
!
! ARGUMENTS
! ON INPUT               a, b
!                          the range of r, i.e., a <= r <= b.
!                          a must be less than b and a must be
!                          non-negative.
!
!                        m
!                          the number of panels into which the
!                          interval (a, b) is subdivided.  hence,
!                          there will be m+1 grid points in the
!                          r-direction given by r(i) = a+(i-1)dr,
!                          for i = 1, 2, ..., m+1,
!                          where dr = (b-a)/m is the panel width.
!                          m must be greater than 3.
!
!                        mbdcnd
!                          indicates the type of boundary condition
!                          at r = a and r = b.
!
!                          = 1  if the solution is specified at
!                               r = a and r = b.
!                          = 2  if the solution is specified at
!                               r = a and the derivative of
!                               the solution with respect to r is
!                               specified at r = b.
!                          = 3  if the derivative of the solution
!                               with respect to r is specified at
!                               r = a (see note below) and r = b.
!                          = 4  if the derivative of the solution
!                               with respect to r is specified at
!                               r = a (see note below) and the
!                               solution is specified at r = b.
!                          = 5  if the solution is unspecified at
!                               r = a = 0 and the solution is
!                               specified at r = b.
!                          = 6  if the solution is unspecified at
!                               r = a = 0 and the derivative of the
!                               solution with respect to r is specified
!                               at r = b.
!
!                          note:
!                          if a = 0, do not use mbdcnd = 3 or 4, but
!                          instead use mbdcnd = 1, 2, 5, or 6  .
!
!                        bda
!                          a one-dimensional array of length n+1 that
!                          specifies the values of the derivative of
!                          the solution with respect to r at r = a.
!
!                          when mbdcnd = 3 or 4,
!                            bda(j) = (d/dr)u(a, theta(j)),
!                            j = 1, 2, ..., n+1  .
!
!                          when mbdcnd has any other value, bda is
!                          a dummy variable.
!
!                        bdb
!                          a one-dimensional array of length n+1 that
!                          specifies the values of the derivative of
!                          the solution with respect to r at r = b.
!
!                          when mbdcnd = 2, 3, or 6,
!                            bdb(j) = (d/dr)u(b, theta(j)),
!                            j = 1, 2, ..., n+1  .
!
!                          when mbdcnd has any other value, bdb is
!                          a dummy variable.
!
!                        c, d
!                          the range of theta, i.e., c <=
!                          theta <= d.  c must be less than d.
!
!                        n
!                          the number of panels into which the
!                          interval (c, d) is subdivided.  hence,
!                          there will be n+1 grid points in the
!                          theta-direction given by
!                          theta(j) = c+(j-1)dtheta for
!                          j = 1, 2, ..., n+1, where
!                          dtheta = (d-c)/n is the panel width.
!                          n must be greater than 3.
!
!                        nbdcnd
!                          indicates the type of boundary conditions
!                          at theta = c and at theta = d.
!
!                          = 0  if the solution is periodic in theta,
!                               i.e., u(i, j) = u(i, n+j).
!                          = 1  if the solution is specified at
!                               theta = c and theta = d
!                               (see note below).
!                          = 2  if the solution is specified at
!                               theta = c and the derivative of the
!                               solution with respect to theta is
!                               specified at theta = d
!                               (see note below).
!                          = 4  if the derivative of the solution
!                               with respect to theta is specified
!                               at theta = c and the solution is
!                               specified at theta = d
!                               (see note below).
!
!                          note:
!                          when nbdcnd = 1, 2, or 4, do not use
!                          mbdcnd = 5 or 6
!                          (the former indicates that the solution
!                          is specified at r = 0, the latter indicates
!                          the solution is unspecified at r = 0).
!                          use instead mbdcnd = 1 or 2  .
!
!                        bdc
!                          a one-dimensional array of length m+1 that
!                          specifies the values of the derivative
!                          of the solution with respect to theta at
!                          theta = c.  when nbdcnd = 3 or 4,
!
!                            bdc(i) = (d/dtheta)u(r(i), c),
!                            i = 1, 2, ..., m+1  .
!
!                          when nbdcnd has any other value, bdc is
!                          a dummy variable.
!
!                        bdd
!                          a one-dimensional array of length m+1 that
!                          specifies the values of the derivative
!                          of the solution with respect to theta at
!                          theta = d.  when nbdcnd = 2 or 3,
!
!                            bdd(i) = (d/dtheta)u(r(i), d),
!                            i = 1, 2, ..., m+1  .
!
!                          when nbdcnd has any other value, bdd is
!                          a dummy variable.
!
!                        elmbda
!                          the constant lambda in the helmholtz
!                          equation.  if lambda < 0, a solution
!                          may not exist.  however, hwsplr will
!                          attempt to find a solution.
!
!                        f
!                          a two-dimensional array, of dimension at
!                          least (m+1)*(n+1), specifying values
!                          of the right side of the helmholtz
!                          equation and boundary data (if any).
!
!                          on the interior, f is defined as follows:
!                          for i = 2, 3, ..., m and j = 2, 3, ..., n
!                          f(i, j) = f(r(i), theta(j)).
!
!                          on the boundaries f is defined as follows:
!                          for j = 1, 2, ..., n+1 and i = 1, 2, ..., m+1
!
!                          mbdcnd   f(1, j)            f(m+1, j)
!                          ------   -------------     -------------
!
!                            1      u(a, theta(j))     u(b, theta(j))
!                            2      u(a, theta(j))     f(b, theta(j))
!                            3      f(a, theta(j))     f(b, theta(j))
!                            4      f(a, theta(j))     u(b, theta(j))
!                            5      f(0, 0)            u(b, theta(j))
!                            6      f(0, 0)            f(b, theta(j))
!
!                          nbdcnd   f(i, 1)            f(i, n+1)
!                          ------   ---------         ---------
!
!                            0      f(r(i), c)         f(r(i), c)
!                            1      u(r(i), c)         u(r(i), d)
!                            2      u(r(i), c)         f(r(i), d)
!                            3      f(r(i), c)         f(r(i), d)
!                            4      f(r(i), c)         u(r(i), d)
!
!                          note:
!                          if the table calls for both the solution
!                          u and the right side f at a corner then
!                          then the solution must be specified.
!
!                        idimf
!                          the row (or first) dimension of the array
!                          f as it appears in the program calling
!                          hwsplr.  this parameter is used to specify
!                          the variable dimension of f.  idimf must
!                          be at least m+1.
!
! ON OUTPUT              f
!                          contains the solution u(i, j) of the finite
!                          difference approximation for the grid point
!                          (r(i), theta(j)),
!                          i = 1, 2, ..., m+1, j = 1, 2, ..., n+1  .
!
!                        pertrb
!                          if a combination of periodic, derivative,
!                          or unspecified boundary conditions is
!                          specified for a poisson equation
!                          (lambda = 0), a solution may not exist.
!                          pertrb is a constant, calculated and
!                          subtracted from f, which ensures that a
!                          solution exists.  hwsplr then computes
!                          this solution, which is a least squares
!                          solution to the original approximation.
!                          this solution plus any constant is also
!                          a solution.  hence, the solution is not
!                          unique.  pertrb should be small compared
!                          to the right side. otherwise, a solution
!                          is obtained to an essentially different
!                          problem.  this comparison should always
!                          be made to insure that a meaningful
!                          solution has been obtained.
!
!                        ierror
!                          An error flag that indicates invalid input
!                          parameters. Except for numbers 0 and 11,
!                          a solution is not attempted.
!
!                          =  0  no error.
!                          =  1  a < 0  .
!                          =  2  a >= b.
!                          =  3  mbdcnd < 1 or mbdcnd > 6  .
!                          =  4  c >= d.
!                          =  5  n <= 3
!                          =  6  nbdcnd < 0 or > 4  .
!                          =  7  a = 0, mbdcnd = 3 or 4  .
!                          =  8  a > 0, mbdcnd >= 5  .
!                          =  9  mbdcnd >= 5, nbdcnd /= 0
!                                and nbdcnd /= 3  .
!                          = 10  idimf < m+1  .
!                          = 11  lambda > 0  .
!                          = 12  m <= 3
!                          = 20 If the dynamic allocation of real and
!                               complex workspace required for solution
!                               fails (for example if n, m are too large
!                               for your computer)
!
!                          Since this is the only means of indicating
!                          a possibly incorrect call to hwsplr, the
!                          user should test ierror after the call.
!
! SPECIAL CONDITIONS     None
!
! I/O                    None
!
! PRECISION              64-bit double precision
!
! REQUIRED files         type_FishpackWorkspace.f90, genbun.f90, type_CyclicReductionUtility.f9090
!
! STANDARD               Fortran 2008
!
! HISTORY                * Written by Roland Sweet at NCAR in the late
!                          1970's. Released on NCAR's public software
!                          libraries in January 1980.
!                        * Revised in June 2004 by John Adams using
!                          Fortran 90 dynamically allocated workspace.
!
! ALGORITHM              The routine defines the finite difference
!                        equations, incorporates boundary data, and
!                        adjusts the right side of singular systems
!                        and then calls genbun to solve the system.
!
! TIMING                 For large m and n, the operation count
!                        is roughly proportional to
!
!                          m*n*log2(n)
!
!                        but also depends on input parameters nbdcnd
!                        and mbdcnd.
!
! ACCURACY               The solution process employed results in a loss
!                        of no more than three significant digits for n
!                        and m as large as 64. More details about
!                        accuracy can be found in the documentation for
!                        subroutine genbun which is the routine that
!                        solves the finite difference equations.
!
! REFERENCES             Swarztrauber, P. and R. Sweet, "Efficient
!                        FORTRAN subprograms for the solution of
!                        elliptic equations"
!                          NCAR TN/IA-109, July, 1975, 138 pp.
!
submodule (centered_helmholtz_solvers) centered_polar_solver

contains

    module subroutine hwsplr(a, b, m, mbdcnd, bda, bdb, c, d, n, nbdcnd, bdc, &
        bdd, elmbda, f, idimf, pertrb, ierror)

        ! Dummy arguments
        integer(ip), intent(in)     :: m
        integer(ip), intent(in)     :: mbdcnd
        integer(ip), intent(in)     :: n
        integer(ip), intent(in)     :: nbdcnd
        integer(ip), intent(in)     :: idimf
        integer(ip), intent(out)    :: ierror
        real(wp),    intent(in)     :: a
        real(wp),    intent(in)     :: b
        real(wp),    intent(in)     :: c
        real(wp),    intent(in)     :: d
        real(wp),    intent(in)     :: elmbda
        real(wp),    intent(out)    :: pertrb
        real(wp),    intent(in)     :: bda(:)
        real(wp),    intent(in)     :: bdb(:)
        real(wp),    intent(in)     :: bdc(:)
        real(wp),    intent(in)     :: bdd(:)
        real(wp),    intent(inout) :: f(:,:)

        ! Local variables
        type(FishpackWorkspace) workspace

        ! Check input arguments
        call hwsplr_check_input_arguments(a, b, m, mbdcnd, c, d, n, nbdcnd, idimf, ierror)

        ! Check error flag
        if (ierror /= 0) return

        ! Allocate memory
        call workspace%initialize_centered_workspace(n, m)

        ! Solve system
        associate( rew => workspace%real_workspace )
            call hwsplr_lower_routine(a, b, m, mbdcnd, bda, bdb, c, d, n, &
                nbdcnd, bdc, bdd, elmbda, f, idimf, pertrb, ierror, rew)
        end associate

        ! Release memory
        call workspace%destroy()

    end subroutine hwsplr

    pure subroutine hwsplr_check_input_arguments(a, b, m, mbdcnd, c, d, n, nbdcnd, idimf, ierror)

        ! Dummy arguments
        integer(ip), intent(in)     :: m
        integer(ip), intent(in)     :: mbdcnd
        integer(ip), intent(in)     :: n
        integer(ip), intent(in)     :: nbdcnd
        integer(ip), intent(in)     :: idimf
        integer(ip), intent(out)    :: ierror
        real(wp),    intent(in)     :: a
        real(wp),    intent(in)     :: b
        real(wp),    intent(in)     :: c
        real(wp),    intent(in)     :: d

        if (a < ZERO) then
            ierror = 1
        else if (a >= b) then
            ierror = 2
        else if (mbdcnd <= 0 .or. mbdcnd >= 7) then
            ierror = 3
        else if (d <= c) then
            ierror = 4
        else if (n <= 3) then
            ierror = 5
        else if (nbdcnd <= -1 .or. 5 <= nbdcnd) then
            ierror = 6
        else if (a == ZERO .and. (mbdcnd==3 .or. mbdcnd==4)) then
            ierror = 7
        else if (a > ZERO .and. 5 <= mbdcnd) then
            ierror = 8
        else if (5 <= mbdcnd .and. nbdcnd /= 0 .and. nbdcnd /= 3) then
            ierror = 9
        else if (idimf < m + 1) then
            ierror = 10
        else if (m <= 3) then
            ierror = 12
        else
            ierror = 0
        end if

    end subroutine hwsplr_check_input_arguments

    subroutine hwsplr_lower_routine(a, b, m, mbdcnd, bda, bdb, c, d, n, nbdcnd, bdc, &
        bdd, elmbda, f, idimf, pertrb, ierror, w)

        ! Dummy arguments
        integer(ip), intent(in)     :: m
        integer(ip), intent(in)     :: mbdcnd
        integer(ip), intent(in)     :: n
        integer(ip), intent(in)     :: nbdcnd
        integer(ip), intent(in)     :: idimf
        integer(ip), intent(out)    :: ierror
        real(wp),    intent(in)     :: a
        real(wp),    intent(in)     :: b
        real(wp),    intent(in)     :: c
        real(wp),    intent(in)     :: d
        real(wp),    intent(in)     :: elmbda
        real(wp),    intent(out)    :: pertrb
        real(wp),    intent(in)     :: bda(:)
        real(wp),    intent(in)     :: bdb(:)
        real(wp),    intent(in)     :: bdc(:)
        real(wp),    intent(in)     :: bdd(:)
        real(wp),    intent(inout)  :: f(:,:)
        real(wp),    intent(inout)  :: w(:)

        ! Local variables
        integer(ip) :: mp1, np1, np, mstart, mstop, munk, nstart, nstop, nunk
        integer(ip) :: id2, id3, id4, id5, id6, ij, i
        integer(ip) :: j, l, lp, k, i1, local_error_flag, iip
        real(wp)    :: dr, half_dr, dr2, dt, dt2
        real(wp)    :: a1, r, s2, a2, s, s1, ypole
        type(CenteredCyclicReductionUtility) :: util

        mp1 = m + 1
        dr = (b - a)/m
        half_dr = dr/2
        dr2 = dr**2
        np1 = n + 1
        dt = (d - c)/n
        dt2 = dt**2
        np = nbdcnd + 1
        !
        ! Define range of indices i and j for unknowns u(i, j).
        !
        mstart = 2
        mstop = mp1

        select case (mbdcnd)
            case (1)
                mstop = m
            case (3)
                mstart = 1
            case (4)
                mstart = 1
                mstop = m
            case (5)
                mstop = m
        end select

        munk = mstop - mstart + 1
        nstart = 1
        nstop = n

        select case (np)
            case (2)
                nstart = 2
            case (3)
                nstart = 2
                nstop = np1
            case (4)
                nstop = np1
        end select

        nunk = nstop - nstart + 1
        !
        ! Define a, b, c coefficients in w-array.
        !
        id2 = munk
        id3 = id2 + munk
        id4 = id3 + munk
        id5 = id4 + munk
        id6 = id5 + munk
        a1 = TWO/dr2
        ij = 0

        if (mbdcnd == 3 .or. mbdcnd == 4) ij = 1

        do i = 1, munk
            r = a + real(i - ij, kind=wp)*dr
            j = id5 + i
            w(j) = r
            j = id6 + i
            w(j) = ONE/r**2
            w(i) = (r - half_dr)/(r*dr2)
            j = id3 + i
            w(j) = (r + half_dr)/(r*dr2)
            j = id2 + i
            w(j) = (-a1) + elmbda
        end do

        select case (mbdcnd)
            case (2, 6)
                w(id2) = a1
            case (3)
                w(id2) = a1
                w(id3+1) = a1
            case (4)
                w(id3+1) = a1
        end select

        select case (mbdcnd)
            case (1:2)
                a1 = w(1)
                f(2, nstart:nstop) = f(2, nstart:nstop) - a1*f(1, nstart:nstop)
            case (3:4)
                a1 = TWO * dr*w(1)
                f(1, nstart:nstop) = f(1, nstart:nstop) + a1*bda(nstart:nstop)
        end select

        select case (mbdcnd)
            case (1, 4:5)
                a1 = w(id4)
                f(m, nstart:nstop) = f(m, nstart:nstop) - a1*f(mp1, nstart:nstop)
            case (2:3, 6)
                a1 = TWO * dr*w(id4)
                f(mp1, nstart:nstop) = f(mp1, nstart:nstop) - a1*bdb(nstart:nstop)
        end select

        !
        ! Enter boundary data for theta-boundaries.
        !
        a1 = ONE/dt2
        l = id5 - mstart + 1
        lp = id6 - mstart + 1

        if (np /= 1) then
            select case (np)
                case (2:3)
                    f(mstart:mstop, 2) = f(mstart:mstop, 2) - a1*w(mstart+lp:mstop+lp)*f &
                        (mstart:mstop, 1)
                case (4:5)
                    a1 = TWO/dt
                    f(mstart:mstop, 1) = f(mstart:mstop, 1) + a1*w(mstart+lp:mstop+lp)* &
                        bdc(mstart:mstop)
            end select

            a1 = ONE/dt2

            select case (np)
                case (2, 5)
                    f(mstart:mstop, n) = f(mstart:mstop, n) &
                        - a1*w(mstart+lp:mstop+lp) * f(mstart:mstop, np1)
                case (3:4)
                    a1 = TWO/dt
                    f(mstart:mstop, np1) = f(mstart:mstop, np1) &
                        - a1 * w(mstart+lp:mstop+lp) * bdd(mstart:mstop)
            end select
        end if

        if ((mbdcnd >= 5) .and. (nbdcnd == 3)) then
            f(1, 1) = f(1, 1) - (bdd(2)-bdc(2))* 4.0_wp/(real(n, kind=wp)*dt*dr2)
        end if
        !
        !     adjust right side of singular problems to insure existence of a
        !     solution.
        !
        pertrb = ZERO

        if_construct: if (elmbda >= ZERO) then
            if (elmbda /= ZERO) then
                ierror = 11
                return
            else
                if (nbdcnd == 0 .or. nbdcnd == 3) then
                    s2 = ZERO
                    select case (mbdcnd)
                        case (1:2, 4:5)
                            exit if_construct
                        case (3)
                            w(id5+1) = HALF * (w(id5+2)-half_dr)
                            s2 = 0.25_wp * dr
                    end select

                    if (nbdcnd == 0) then
                        a2 = ONE
                    else
                        a2 = TWO
                    end if

                    j = id5 + munk
                    w(j) = HALF * (w(j-1)+half_dr)
                    s = ZERO

                    do i = mstart, mstop
                        s1 = ZERO
                        ij = nstart + 1
                        k = nstop - 1
                        s1 = sum(f(i, ij:k))
                        j = i + l
                        s = s + (a2*s1 + f(i, nstart)+f(i, nstop))*w(j)
                    end do

                    s2=real(m, kind=wp)*a+dr*(real((m-1)*(m+1), kind=wp)*HALF+0.25_wp)+s2
                    s1 = (TWO + a2*real(nunk - 2, kind=wp))*s2

                    if (mbdcnd /= 3) then
                        s2 = (real(n, kind=wp)*a2*dr)/8
                        s = s + f(1, 1)*s2
                        s1 = s1 + s2
                    end if

                    pertrb = s/s1
                    f(mstart:mstop, nstart:nstop) = &
                        f(mstart:mstop, nstart:nstop) - pertrb
                end if
            end if
        end if if_construct

        do i = mstart, mstop
            k = i - mstart + 1
            j = i + lp
            a1 = dt2/w(j)
            w(k) = a1*w(k)
            j = id2 + k
            w(j) = a1*w(j)
            j = id3 + k
            w(j) = a1*w(j)
            f(i, nstart:nstop) = a1*f(i, nstart:nstop)
        end do

        w(1) = ZERO
        w(id4) = ZERO
        !
        ! Solve the system of equations.
        !
        i1 = 1
        local_error_flag = 0
        associate( &
            a_arg => w(1:munk), &
            b_arg => w(id2+1:id2+1+munk), &
            c_arg => w(id3+1:id3+1+munk), &
            y_arg => f(mstart:,nstart:nstart+nunk), &
            w_arg => w(id4+1:) &
            )
            call util%genbun_lower_routine(nbdcnd, nunk, i1, munk, a_arg, b_arg, c_arg, &
                idimf, y_arg, local_error_flag, w_arg)
        end associate

        ! Check error flag
        if (local_error_flag /= 0) then
            error stop 'fishpack library: genbun_lower_routine call failed in hwsplr_lower_routine'
        end if

        select case (mbdcnd)
            case (1:4)
                if (nbdcnd == 0) f(mstart:mstop, np1) = f(mstart:mstop, 1)
            case (5)
                j = id5 + munk
                w(j) = w(id2)/w(id3)

                do iip = 3, munk
                    i = munk - iip + 2
                    j = id5 + i
                    lp = id2 + i
                    k = id3 + i
                    w(j) = w(i)/(w(lp)-w(k)*w(j+1))
                end do

                w(id5+1) = -HALF * dt2/(w(id2+1)-w(id3+1)*w(id5+2))

                do i = 2, munk
                    j = id5 + i
                    w(j) = -w(j)*w(j-1)
                end do

                s = ZERO
                s = sum(f(2, nstart:nstop))
                a2 = nunk

                if (nbdcnd /= 0) then
                    s = s - HALF * (f(2, nstart)+f(2, nstop))
                    a2 = a2 - ONE
                end if

                ypole = (0.25_wp *dr2*f(1, 1)-s/a2)/(w(id5+1)-ONE + elmbda*dr2* 0.25_wp)

                do i = mstart, mstop
                    k = l + i
                    f(i, nstart:nstop) = f(i, nstart:nstop) + ypole*w(k)
                end do

                f(1, :np1) = ypole

                if (nbdcnd == 0) f(mstart:mstop, np1) = f(mstart:mstop, 1)

            case (6)
                !
                ! Adjust the solution as necessary for the problems where a = 0.
                !
                if (elmbda == ZERO) then
                    ypole = ZERO
                    f(1, :np1) = ypole
                    if (nbdcnd == 0) f(mstart:mstop, np1) = f(mstart:mstop, 1)
                end if
        end select

    end subroutine hwsplr_lower_routine

end submodule centered_polar_solver
!
! REVISION HISTORY
!
! September 1973    Version 1
! April     1976    Version 2
! January   1978    Version 3
! December  1979    Version 3.1
! February  1985    Documentation upgrade
! November  1988    Version 3.2, FORTRAN 77 changes
! June      2004    Version 5.0, Fortran 90 changes
! May       2016    Fortran 2008 changes
!


! { dg-do run }
! { dg-options "" }
! Test various exponentations
! initially designed for patch to PR31120

program test
  call run_me (1.0, 1, (1.0,0.0))
  call run_me (-1.1, -1, (0.0,-1.0))
  call run_me (42.0, 12, (1.0,7.0))
end program test

! This subroutine is for runtime tests
subroutine run_me(a, i, z)
  implicit none

  real, intent(in) :: a
  integer, intent(in) :: i
  complex, intent(in) :: z

  call check_equal_i (i**0, 1)
  call check_equal_i (i**1, i)
  call check_equal_i (i**2, i*i)
  call check_equal_i (i**3, i*(i**2))

  ! i has default integer kind.
  call check_equal_i (int(i**0_8,kind=kind(i)), 1)
  call check_equal_i (int(i**1_8,kind=kind(i)), i)
  call check_equal_i (int(i**2_8,kind=kind(i)), i*i)
  call check_equal_i (int(i**3_8,kind=kind(i)), i*i*i)

  call check_equal_r (a**0.0, 1.0)
  call check_equal_r (a**1.0, a)
  call check_equal_r (a**2.0, a*a)
  call check_equal_r (a**3.0, a*(a**2))
  call check_equal_r (a**(-1.0), 1/a)
  call check_equal_r (a**(-2.0), (1/a)*(1/a))

  call check_equal_r (a**0, 1.0)
  call check_equal_r (a**1, a)
  call check_equal_r (a**2, a*a)
  call check_equal_r (a**3, a*(a**2))
  call check_equal_r (a**(-1), 1/a)
  call check_equal_r (a**(-2), (1/a)*(1/a))

  call check_equal_r (a**0_8, 1.0)
  call check_equal_r (a**1_8, a)
  call check_equal_r (a**2_8, a*a)
  call check_equal_r (a**3_8, a*(a**2))
  call check_equal_r (a**(-1_8), 1/a)
  call check_equal_r (a**(-2_8), (1/a)*(1/a))

  call check_equal_c (z**0.0, (1.0,0.0))
  call check_equal_c (z**1.0, z)
  call check_equal_c (z**2.0, z*z)
  call check_equal_c (z**3.0, z*(z**2))
  call check_equal_c (z**(-1.0), 1/z)
  call check_equal_c (z**(-2.0), (1/z)*(1/z))

  call check_equal_c (z**(0.0,0.0), (1.0,0.0))
  call check_equal_c (z**(1.0,0.0), z)
  call check_equal_c (z**(2.0,0.0), z*z)
  call check_equal_c (z**(3.0,0.0), z*(z**2))
  call check_equal_c (z**(-1.0,0.0), 1/z)
  call check_equal_c (z**(-2.0,0.0), (1/z)*(1/z))

  call check_equal_c (z**0, (1.0,0.0))
  call check_equal_c (z**1, z)
  call check_equal_c (z**2, z*z)
  call check_equal_c (z**3, z*(z**2))
  call check_equal_c (z**(-1), 1/z)
  call check_equal_c (z**(-2), (1/z)*(1/z))

  call check_equal_c (z**0_8, (1.0,0.0))
  call check_equal_c (z**1_8, z)
  call check_equal_c (z**2_8, z*z)
  call check_equal_c (z**3_8, z*(z**2))
  call check_equal_c (z**(-1_8), 1/z)
  call check_equal_c (z**(-2_8), (1/z)*(1/z))

contains

  subroutine check_equal_r (a, b)
    real, intent(in) :: a, b
    if (abs(a - b) > 1.e-5 * abs(b)) call abort
  end subroutine check_equal_r

  subroutine check_equal_c (a, b)
    complex, intent(in) :: a, b
    if (abs(a - b) > 1.e-5 * abs(b)) call abort
  end subroutine check_equal_c

  subroutine check_equal_i (a, b)
    integer, intent(in) :: a, b
    if (a /= b) call abort
  end subroutine check_equal_i

end subroutine run_me

! subroutine foo is used for compilation test only
subroutine foo(a)
  implicit none

  real, intent(in) :: a
  integer :: i
  complex :: z

  ! Integer
  call gee_i(i**0_1)
  call gee_i(i**1_1)
  call gee_i(i**2_1)
  call gee_i(i**3_1)
  call gee_i(i**(-1_1))
  call gee_i(i**(-2_1))
  call gee_i(i**(-3_1))
  call gee_i(i**huge(0_1))
  call gee_i(i**(-huge(0_1)))
  call gee_i(i**(-huge(0_1)-1_1))

  call gee_i(i**0_2)
  call gee_i(i**1_2)
  call gee_i(i**2_2)
  call gee_i(i**3_2)
  call gee_i(i**(-1_2))
  call gee_i(i**(-2_2))
  call gee_i(i**(-3_2))
  call gee_i(i**huge(0_2))
  call gee_i(i**(-huge(0_2)))
  call gee_i(i**(-huge(0_2)-1_2))

  call gee_i(i**0_4)
  call gee_i(i**1_4)
  call gee_i(i**2_4)
  call gee_i(i**3_4)
  call gee_i(i**(-1_4))
  call gee_i(i**(-2_4))
  call gee_i(i**(-3_4))
  call gee_i(i**huge(0_4))
  call gee_i(i**(-huge(0_4)))
  call gee_i(i**(-huge(0_4)-1_4))

  call gee_i(i**0_8) ! { dg-warning "Type mismatch in argument" }
  call gee_i(i**1_8) ! { dg-warning "Type mismatch in argument" }
  call gee_i(i**2_8) ! { dg-warning "Type mismatch in argument" }
  call gee_i(i**3_8) ! { dg-warning "Type mismatch in argument" }
  call gee_i(i**(-1_8)) ! { dg-warning "Type mismatch in argument" }
  call gee_i(i**(-2_8)) ! { dg-warning "Type mismatch in argument" }
  call gee_i(i**(-3_8)) ! { dg-warning "Type mismatch in argument" }
  call gee_i(i**huge(0_8)) ! { dg-warning "Type mismatch in argument" }
  call gee_i(i**(-huge(0_8))) ! { dg-warning "Type mismatch in argument" }
  call gee_i(i**(-huge(0_8)-1_8)) ! { dg-warning "Type mismatch in argument" }

  ! Real
  call gee_r(a**0_1)
  call gee_r(a**1_1)
  call gee_r(a**2_1)
  call gee_r(a**3_1)
  call gee_r(a**(-1_1))
  call gee_r(a**(-2_1))
  call gee_r(a**(-3_1))
  call gee_r(a**huge(0_1))
  call gee_r(a**(-huge(0_1)))
  call gee_r(a**(-huge(0_1)-1_1))

  call gee_r(a**0_2)
  call gee_r(a**1_2)
  call gee_r(a**2_2)
  call gee_r(a**3_2)
  call gee_r(a**(-1_2))
  call gee_r(a**(-2_2))
  call gee_r(a**(-3_2))
  call gee_r(a**huge(0_2))
  call gee_r(a**(-huge(0_2)))
  call gee_r(a**(-huge(0_2)-1_2))

  call gee_r(a**0_4)
  call gee_r(a**1_4)
  call gee_r(a**2_4)
  call gee_r(a**3_4)
  call gee_r(a**(-1_4))
  call gee_r(a**(-2_4))
  call gee_r(a**(-3_4))
  call gee_r(a**huge(0_4))
  call gee_r(a**(-huge(0_4)))
  call gee_r(a**(-huge(0_4)-1_4))

  call gee_r(a**0_8)
  call gee_r(a**1_8)
  call gee_r(a**2_8)
  call gee_r(a**3_8)
  call gee_r(a**(-1_8))
  call gee_r(a**(-2_8))
  call gee_r(a**(-3_8))
  call gee_r(a**huge(0_8))
  call gee_r(a**(-huge(0_8)))
  call gee_r(a**(-huge(0_8)-1_8))

  ! Complex
  call gee_z(z**0_1)
  call gee_z(z**1_1)
  call gee_z(z**2_1)
  call gee_z(z**3_1)
  call gee_z(z**(-1_1))
  call gee_z(z**(-2_1))
  call gee_z(z**(-3_1))
  call gee_z(z**huge(0_1))
  call gee_z(z**(-huge(0_1)))
  call gee_z(z**(-huge(0_1)-1_1))

  call gee_z(z**0_2)
  call gee_z(z**1_2)
  call gee_z(z**2_2)
  call gee_z(z**3_2)
  call gee_z(z**(-1_2))
  call gee_z(z**(-2_2))
  call gee_z(z**(-3_2))
  call gee_z(z**huge(0_2))
  call gee_z(z**(-huge(0_2)))
  call gee_z(z**(-huge(0_2)-1_2))

  call gee_z(z**0_4)
  call gee_z(z**1_4)
  call gee_z(z**2_4)
  call gee_z(z**3_4)
  call gee_z(z**(-1_4))
  call gee_z(z**(-2_4))
  call gee_z(z**(-3_4))
  call gee_z(z**huge(0_4))
  call gee_z(z**(-huge(0_4)))
  call gee_z(z**(-huge(0_4)-1_4))

  call gee_z(z**0_8)
  call gee_z(z**1_8)
  call gee_z(z**2_8)
  call gee_z(z**3_8)
  call gee_z(z**(-1_8))
  call gee_z(z**(-2_8))
  call gee_z(z**(-3_8))
  call gee_z(z**huge(0_8))
  call gee_z(z**(-huge(0_8)))
  call gee_z(z**(-huge(0_8)-1_8))
end subroutine foo

subroutine gee_i(i)
  integer :: i
end subroutine gee_i

subroutine gee_r(r)
  real :: r
end subroutine gee_r

subroutine gee_z(c)
  complex :: c
end subroutine gee_z


! { dg-do run }
! Test fix for PR fortran/38823.
program power

   implicit none

   integer, parameter :: &
   &  s = kind(1.e0), &
   &  d = kind(1.d0), &
   &  e = max(selected_real_kind(precision(1.d0)+1), d)

  real(s),    parameter :: ris = 2.e0_s**2
  real(d),    parameter :: rid = 2.e0_d**2
  real(e),    parameter :: rie = 2.e0_e**2
  complex(s), parameter :: cis = (2.e0_s,1.e0_s)**2
  complex(d), parameter :: cid = (2.e0_d,1.e0_d)**2
  complex(e), parameter :: cie = (2.e0_e,1.e0_e)**2

  real(s),    parameter :: rrs = 2.e0_s**2.e0
  real(d),    parameter :: rrd = 2.e0_d**2.e0
  real(e),    parameter :: rre = 2.e0_e**2.e0
  complex(s), parameter :: crs = (2.e0_s,1.e0_s)**2.e0
  complex(d), parameter :: crd = (2.e0_d,1.e0_d)**2.e0
  complex(e), parameter :: cre = (2.e0_e,1.e0_e)**2.e0

  real(s),    parameter :: rds = 2.e0_s**2.e0_d
  real(d),    parameter :: rdd = 2.e0_d**2.e0_d
  real(e),    parameter :: rde = 2.e0_e**2.e0_d
  complex(s), parameter :: cds = (2.e0_s,1.e0_s)**2.e0_d
  complex(d), parameter :: cdd = (2.e0_d,1.e0_d)**2.e0_d
  complex(e), parameter :: cde = (2.e0_e,1.e0_e)**2.e0_d

  real(s), parameter :: eps_s = 1.e-5_s
  real(d), parameter :: eps_d = 1.e-10_d
  real(e), parameter :: eps_e = 1.e-10_e

  if (abs(ris - 4) > eps_s) call abort
  if (abs(rid - 4) > eps_d) call abort
  if (abs(rie - 4) > eps_e) call abort
  if (abs(real(cis, s) - 3) > eps_s .or. abs(aimag(cis) - 4) > eps_s) call abort
  if (abs(real(cid, d) - 3) > eps_d .or. abs(aimag(cid) - 4) > eps_d) call abort
  if (abs(real(cie, e) - 3) > eps_e .or. abs(aimag(cie) - 4) > eps_e) call abort

  if (abs(rrs - 4) > eps_s) call abort
  if (abs(rrd - 4) > eps_d) call abort
  if (abs(rre - 4) > eps_e) call abort
  if (abs(real(crs, s) - 3) > eps_s .or. abs(aimag(crs) - 4) > eps_s) call abort
  if (abs(real(crd, d) - 3) > eps_d .or. abs(aimag(crd) - 4) > eps_d) call abort
  if (abs(real(cre, e) - 3) > eps_e .or. abs(aimag(cre) - 4) > eps_e) call abort

  if (abs(rds - 4) > eps_s) call abort
  if (abs(rdd - 4) > eps_d) call abort
  if (abs(rde - 4) > eps_e) call abort
  if (abs(real(cds, s) - 3) > eps_s .or. abs(aimag(cds) - 4) > eps_s) call abort
  if (abs(real(cdd, d) - 3) > eps_d .or. abs(aimag(cdd) - 4) > eps_d) call abort
  if (abs(real(cde, e) - 3) > eps_e .or. abs(aimag(cde) - 4) > eps_e) call abort

end program power


program fexample
  use fftwpp ! access the wrapper for FFTW++
  use, intrinsic :: ISO_C_Binding
  implicit NONE
  include 'fftw3.f03'

  integer(c_int) :: nthreads
  integer(c_int) :: mx, my, mz
  integer(c_int) :: mxp, myp
  integer(c_int) ::  i, j, k

  integer :: returnflag

  complex(C_DOUBLE_COMPLEX), pointer :: f(:), g(:)
  complex(C_DOUBLE_COMPLEX), pointer :: ff(:,:), gg(:,:)
  complex(C_DOUBLE_COMPLEX), pointer :: fff(:,:,:), ggg(:,:,:)

  type(C_PTR) :: pf, pg, pconv
  !type(C_PTR) :: pu, pv, pw, pu2, pv2, pu1, pv1, pw1, pu3, pv3

  returnflag=0 ! return value for tests

  write(*,*) "Example of calling fftw++ convolutions from Fortran:"

  nthreads = 2 ! specify number of threads

  call set_fftwpp_maxthreads(nthreads);

!!! cconv
  write(*,*) "1d non-centered complex convolution:"

  mx = 8 ! problem size

  ! Allocate the memory using FFTW.
  pf = fftw_alloc_complex(int(mx, C_SIZE_T))
  pg = fftw_alloc_complex(int(mx, C_SIZE_T))

  ! Create the pointer to the convolution
  pconv = cconv1d_create(mx)

  ! Make the FORTRAN pointer pf point to the same memory as f, and
  ! give it the correct shape.
  call c_f_pointer(pf, f, [mx])
  call c_f_pointer(pg, g, [mx])

  call init(f, g, mx)
  write(*,*) "Input f:"
  call output(f, mx)
  write(*,*) "Input g:"
  call output(g, mx)

  call cconv1d_convolve(pconv, pf, pg)

  write(*,*) "Output:"
  call output(f, mx)

  call delete_cconv1d(pconv)
  call fftw_free(pf)
  call fftw_free(pg)

  write(*,*)

!!! hconv
  write(*,*) "1d centered Hermitian-symmetric complex convolution:"

  mx = 8 ! problem size

  pf = fftw_alloc_complex(int(mx, C_SIZE_T))
  pg = fftw_alloc_complex(int(mx, C_SIZE_T))
  pconv = hconv1d_create(mx)

   call c_f_pointer(pf, f, [mx])
   call c_f_pointer(pg, g, [mx])

   call init(f, g, mx)
   write(*,*) "Input f:"
   call output(f, mx)
   write(*,*) "Input g:"
   call output(g, mx)

   call hconv1d_convolve(pconv, pf, pg)

   write(*,*) "Output:"
   call output(f, mx)

   call fftw_free(pf)
   call fftw_free(pg)
   call delete_hconv1d(pconv)

   write(*,*)

!!! cconv2
   write(*,*) "2d non-centered complex convolution:"
   mx = 4
   my = 4

   pf = fftw_alloc_complex(int(mx * my, C_SIZE_T))
   pg = fftw_alloc_complex(int(mx * my, C_SIZE_T))
   pconv = cconv2d_create(mx, my)

   call c_f_pointer(pf, ff, [my, mx])
   call c_f_pointer(pg, gg, [my, mx])
   call init2(ff, gg, my, mx)

   write(*,*) "Input f:"
   call output2(ff, my, mx)
   write(*,*) "Input g:"
   call output2(gg, my, mx)

   call cconv2d_convolve(pconv, pf, pg)

   write(*,*) "Output:"
   call output2(ff, mx, my)

   call delete_cconv2d(pconv)
   call fftw_free(pf)
   call fftw_free(pg)

!!! hconv2
   write(*,*) "2d centered complex convolution:"
   mx = 4
   my = 4
   mxp = 2 * mx - 1

   pf = fftw_alloc_complex(int(mxp * my, C_SIZE_T))
   pg = fftw_alloc_complex(int(mxp * my, C_SIZE_T))
   pconv = hconv2d_create(mx, my)

   call c_f_pointer(pf, ff, [my, mxp])
   call c_f_pointer(pg, gg, [my, mxp])

   call init2(ff, gg, my, mxp)

   write(*,*) "Input f:"
   call output2(ff, my, mxp)
   write(*,*) "Input g:"
   call output2(gg, my, mxp)

   call hconv2d_convolve(pconv, pf, pg)

   write(*,*) "Output:"
   call output2(ff, my, mxp)

   call delete_hconv2d(pconv)
   call fftw_free(pf)
   call fftw_free(pg)

!!! cconv3
   write(*,*) "3d non-centered complex convolution:"
   mx = 4
   my = 4
   mz = 4

   pf = fftw_alloc_complex(int(mx * my * mz, C_SIZE_T))
   pg = fftw_alloc_complex(int(mx * my * mz, C_SIZE_T))
   pconv = cconv3d_create(mx, my, mz)

   call c_f_pointer(pf, fff, [mz, my, mx])
   call c_f_pointer(pg, ggg, [mz, my, mx])
   call init3(fff, ggg, mz, my, mx)

   write(*,*) "Input f:"
   call output3(fff, mz, my, mx)
   write(*,*) "Input g:"
   call output3(ggg, mz, my, mx)

   call cconv3d_convolve(pconv, pf, pg)

   write(*,*) "Output:"
   call output3(fff, mz, my, mx)

   call delete_cconv3d(pconv)
   call fftw_free(pf)
   call fftw_free(pg)

   !!! hconv2
   write(*,*) "2d centered complex convolution:"
   mx = 4
   my = 4
   mz = 4
   mxp = 2 * mx - 1
   myp = 2 * my - 1

   pf = fftw_alloc_complex(int(mxp * myp * mz, C_SIZE_T))
   pg = fftw_alloc_complex(int(mxp * myp * mz, C_SIZE_T))
   pconv = hconv3d_create(mx, my, mz)

   call c_f_pointer(pf, fff, [mz, myp, mxp])
   call c_f_pointer(pg, ggg, [mz, myp, mxp])

   call init3(fff, ggg, mz, myp, mxp)

   write(*,*) "Input f:"
   call output3(fff, mz, myp, mxp)
   write(*,*) "Input g:"
   call output3(ggg, mz, myp, mxp)

   call hconv3d_convolve(pconv, pf, pg)

   write(*,*) "Output:"
   call output3(fff, mz, myp, mxp)

   call delete_hconv3d(pconv)
   call fftw_free(pf)
   call fftw_free(pg)

   call EXIT(returnflag)

contains
  subroutine init(f, g, m)
    use,intrinsic :: ISO_C_Binding
    implicit NONE
    integer :: i
    integer(c_int), intent(in) :: m
    complex(C_DOUBLE_COMPLEX), pointer, intent(inout) :: f(:), g(:)
    do i = 0 ,m - 1
       f(i + 1) = cmplx(i, i + 1)
       g(i + 1) = cmplx(i, 2 * i + 1)
    end do
  end subroutine init

  subroutine init2(f, g, my, mx)
    use,intrinsic :: ISO_C_Binding
    implicit NONE
    integer :: i,j
    integer(c_int),intent(in) :: my, mx
    complex(C_DOUBLE_COMPLEX), pointer, intent(inout) :: f(:,:), g(:,:)
    do j = 0, my - 1
       do i = 0, mx - 1
          f(j + 1, i + 1) = cmplx(i, j)
          g(j + 1, i + 1) = cmplx(2 * i, j + 1)
       end do
    end do
  end subroutine init2

  subroutine init3(f, g, mz, my, mx)
    use,intrinsic :: ISO_C_Binding
    implicit NONE
    integer :: i,j
    integer(c_int),intent(in) :: mz, my, mx
    complex(C_DOUBLE_COMPLEX), pointer, intent(inout) :: f(:,:,:), g(:,:,:)
    do k = 0, mz - 1
       do j = 0, my - 1
          do i = 0, mx - 1
             f(k + 1, j + 1, i + 1) = cmplx(i + k, j + k)
             g(k + 1, j + 1, i + 1) = cmplx(2 * i + k, j + 1 + k)
          end do
       end do
    end do
  end subroutine init3

  subroutine output(f, m)
    use,intrinsic :: ISO_C_Binding
    implicit NONE
    integer :: i
    integer(c_int),intent(in) :: m
    complex(C_DOUBLE_COMPLEX),pointer,intent(inout) :: f(:)
    do i=1,m
       print*,f(i)
    end do
  end subroutine output

  subroutine output2(f, my, mx)
    use,intrinsic :: ISO_C_Binding
    implicit NONE
    integer :: j, i
    integer(c_int), intent(in) :: my, mx
    complex(C_DOUBLE_COMPLEX), pointer, intent(in) :: f(:,:)
    do j = 1, my
       do i = 1, mx
          print*,f(j,i)
       end do
       write(*,*)
    end do
  end subroutine output2

  subroutine output3(f, mz, my, mx)
    use,intrinsic :: ISO_C_Binding
    implicit NONE
    integer :: i,j
    integer(c_int),intent(in) :: mz, my, mx
    complex(C_DOUBLE_COMPLEX),pointer,intent(inout) :: f(:,:,:)
    do k=1,mz
       do j=1,my
          do i=1,mx
             print*,f(k,j,i)
          end do
          write(*,*)
       end do
       write(*,*)
    end do
  end subroutine output3

end program fexample


!*********************************************************************
! This file is part of Polylogarithm.
!
! Polylogarithm is licenced under the MIT License.
!*********************************************************************

!*********************************************************************
!> @brief Clausen function \f$\operatorname{Cl}_6(\theta) = \operatorname{Im}(\operatorname{Li}_6(e^{i\theta}))\f$
!> @param x real angle
!> @return \f$\operatorname{Cl}_6(\theta)\f$
!> @author Alexander Voigt
!> Implemented as rational function approximation.
!*********************************************************************

double precision function dcl6(x)
  implicit none
  double precision :: x, y, z, z2, z4, p, q, p0, p1, h, sgn
  double precision, parameter :: PI = 3.14159265358979324D0
  double precision, parameter :: PI2 = 2*PI, PIH = PI/2, PI28 = PI*PI/8
  double precision, parameter :: zeta3 = 1.2020569031595943D0
  double precision, parameter :: cp(4) = (/ &
      1.0369277551433699D+0,                &
     -2.0871954441071750D-1,                &
      2.0652251045312954D-2,                &
     -1.3834381382568400D-4                 /)
  double precision, parameter :: cq(4) = (/ &
      1.0000000000000000D+0,                &
     -8.0784096827362542D-3,                &
      5.8074568862993102D-6,                &
     -5.1960620033050114D-10                /)
  double precision, parameter :: cr(5) = (/ &
      7.9544504578027050D-1,                &
     -1.9255025309738589D-1,                &
      1.5805208288846591D-2,                &
     -5.4175380521534706D-4,                &
      6.7577493541009068D-6                 /)
  double precision, parameter :: cs(6) = (/ &
      1.0000000000000000D+0,                &
     -7.0798422394109274D-2,                &
      7.1744189715634762D-4,                &
      3.9098747334347093D-6,                &
      3.5669441618295266D-8,                &
      2.5315391843409925D-10                /)

  sgn = 1

  if (x .lt. 0) then
     x = -x
     sgn = -1
  endif

  if (x .ge. PI2) then
     x = mod(x, PI2)
  endif

  if (x .gt. PI) then
     p0 = 6.28125D0
     p1 = 0.0019353071795864769253D0
     x = (p0 - x) + p1
     sgn = -sgn
  endif

  if (x .eq. 0 .or. x .eq. PI) then
     dcl6 = 0
     return
  endif

  if (x .lt. PIH) then
    y = x*x
    z = y*y
    p = cp(1) + y * cp(2) + z * (cp(3) + y * cp(4))
    q = cq(1) + y * cq(2) + z * (cq(3) + y * cq(4))
    h = x*(p/q - 1.0D0/120*z*log(x))
  else
    y = PI - x
    z = y*y - PI28
    z2 = z*z
    z4 = z2*z2
    p = cr(1) + z * cr(2) + z2 * (cr(3) + z * cr(4)) + &
        z4 * cr(5)
    q = cs(1) + z * cs(2) + z2 * (cs(3) + z * cs(4)) + &
        z4 * (cs(5) + z * cs(6))
    h = y*p/q
  endif

  dcl6 = sgn*h

end function dcl6


!    Copyright (C) 2012 The SPEED FOUNDATION
!    Author: Ilario Mazzieri
!
!    This file is part of SPEED.
!
!    SPEED is free software; you can redistribute it and/or modify it
!    under the terms of the GNU Affero General Public License as
!    published by the Free Software Foundation, either version 3 of the
!    License, or (at your option) any later version.
!
!    SPEED is distributed in the hope that it will be useful, but
!    WITHOUT ANY WARRANTY; without even the implied warranty of
!    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!    Affero General Public License for more details.
!
!    You should have received a copy of the GNU Affero General Public License
!    along with SPEED.  If not, see <http://www.gnu.org/licenses/>.

!> @brief Compute the Rayleigh damping matrix C = A0 M + A1 K,
!! M = mass matrix, K= stiffness matrix
!! @author Ilario Mazzieri
!> @date November, 2014
!> @version 1.0
!> @param[in] nn polynomial degree + 1
!> @param[in] ct LGL nodes
!> @param[in] ww LGL weights
!> @param[in] dd matrix of spectral derivates
!> @param[in] rho mass density
!> @param[in] A11,...,DD3 coefficients for the bilinear map
!> @param[out] mc_el Rayleigh damping matrix

      subroutine MAKE_RAYLEIGH_DAMPING_MATRIX(nn,ct,ww,dd,rho,&
                           A11,A12,A13,A21,A22,A23,&
                           A31,A32,A33,B11,B12,B13,&
                           B21,B22,B23,B31,B32,B33,&
                           GG1,GG2,GG3,DD1,DD2,DD3,&
                           mc_el)

      implicit none

      integer*4 :: nn
      integer*4 :: i,j,k

      real*8 :: A11,A12,A13,A21,A22,A23,A31,A32,A33
      real*8 :: B11,B12,B13,B21,B22,B23,B31,B32,B33
      real*8 :: GG1,GG2,GG3,DD1,DD2,DD3
      real*8 :: dxdx,dxdy,dxdz,dydx,dydy,dydz,dzdx,dzdy,dzdz,det_j

      real*8, dimension(nn) :: ct,ww

      real*8, dimension(nn,nn) :: dd

      real*8, dimension(nn,nn,nn) :: rho,gamma
      real*8, dimension(nn,nn,nn) :: mc_el,mck_el

      do k = 1,nn
         do j = 1,nn
            do i = 1,nn
               dxdx = A11 +B12*ct(k) +B13*ct(j) &
                    + GG1*ct(j)*ct(k)
               dydx = A21 +B22*ct(k) +B23*ct(j) &
                    + GG2*ct(j)*ct(k)
               dzdx = A31 +B32*ct(k) +B33*ct(j) &
                    + GG3*ct(j)*ct(k)

               dxdy = A12 +B11*ct(k) +B13*ct(i) &
                    + GG1*ct(k)*ct(i)
               dydy = A22 +B21*ct(k) +B23*ct(i) &
                    + GG2*ct(k)*ct(i)
               dzdy = A32 +B31*ct(k) +B33*ct(i) &
                    + GG3*ct(k)*ct(i)

               dxdz = A13 +B11*ct(j) +B12*ct(i) &
                    + GG1*ct(i)*ct(j)
               dydz = A23 +B21*ct(j) +B22*ct(i) &
                    + GG2*ct(i)*ct(j)
               dzdz = A33 +B31*ct(j) +B32*ct(i) &
                    + GG3*ct(i)*ct(j)

               det_j = dxdz * (dydx*dzdy - dzdx*dydy) &
                     - dydz * (dxdx*dzdy - dzdx*dxdy) &
                     + dzdz * (dxdx*dydy - dydx*dxdy)

                    mc_el(i,j,k) = rho(i,j,k) &
                                 * det_j * ww(i) * ww(j) * ww(k)

            enddo
         enddo
      enddo

      return

      end subroutine MAKE_RAYLEIGH_DAMPING_MATRIX


program gen_crc14

  character m77*77,c14*14

  integer mc(96),r(15),p(15),ncrc
! polynomial for 14-bit CRC 0x6757
  data p/1,1,0,0,1,1,1,0,1,0,1,0,1,1,1/

  nargs=iargc()
  if(nargs.ne.1) then
     print*,'Usage:   gen_crc14 <77-bit message>'
     print*,'Example: gen_crc14 "00000000000000000000000000100000010011011111110011011100100010100001010000001"'
     go to 999
  endif

! pad the 77bit message out to 96 bits
  call getarg(1,m77)
  read(m77,'(77i1)') mc(1:77)
  mc(78:96)=0

! divide by polynomial
  r=mc(1:15)
  do i=0,81
    r(15)=mc(i+15)
    r=mod(r+r(1)*p,2)
    r=cshift(r,1)
  enddo

! the crc is in r(1:14) - print it in various ways:
  write(c14,'(14b1)') r(1:14)
  write(*,'(a40,1x,a14)') 'crc14 as a string: ',c14
  read(c14,'(b14.14)') ncrc
  write(*,'(a40,i6)') 'crc14 as an integer: ',ncrc
  write(*,'(a40,1x,b14.14)') 'binary representation of the integer: ',ncrc

999 end program gen_crc14


      SUBROUTINE MB05OD( BALANC, N, NDIAG, DELTA, A, LDA, MDIG, IDIG,
     $                   IWORK, DWORK, LDWORK, IWARN, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute exp(A*delta) where A is a real N-by-N matrix and delta
C     is a scalar value. The routine also returns the minimal number of
C     accurate digits in the 1-norm of exp(A*delta) and the number of
C     accurate digits in the 1-norm of exp(A*delta) at 95% confidence
C     level.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     BALANC  CHARACTER*1
C             Specifies whether or not a balancing transformation (done
C             by SLICOT Library routine MB04MD) is required, as follows:
C             = 'N', do not use balancing;
C             = 'S', use balancing (scaling).
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A.  N >= 0.
C
C     NDIAG   (input) INTEGER
C             The specified order of the diagonal Pade approximant.
C             In the absence of further information NDIAG should
C             be set to 9.  NDIAG should not exceed 15.  NDIAG >= 1.
C
C     DELTA   (input) DOUBLE PRECISION
C             The scalar value delta of the problem.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On input, the leading N-by-N part of this array must
C             contain the matrix A of the problem. (This is not needed
C             if DELTA = 0.)
C             On exit, if INFO = 0, the leading N-by-N part of this
C             array contains the solution matrix exp(A*delta).
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     MDIG    (output) INTEGER
C             The minimal number of accurate digits in the 1-norm of
C             exp(A*delta).
C
C     IDIG    (output) INTEGER
C             The number of accurate digits in the 1-norm of
C             exp(A*delta) at 95% confidence level.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (N)
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= N*(2*N+NDIAG+1)+NDIAG, if N >  1.
C             LDWORK >= 1,                     if N <= 1.
C
C     Warning Indicator
C
C     IWARN   INTEGER
C             = 0:  no warning;
C             = 1:  if MDIG = 0 and IDIG > 0, warning for possible
C                   inaccuracy (the exponential has been computed);
C             = 2:  if MDIG = 0 and IDIG = 0, warning for severe
C                   inaccuracy (the exponential has been computed);
C             = 3:  if balancing has been requested, but it failed to
C                   reduce the matrix norm and was not actually used.
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:  if the norm of matrix A*delta (after a possible
C                   balancing) is too large to obtain an accurate
C                   result;
C             = 2:  if the coefficient matrix (the denominator of the
C                   Pade approximant) is exactly singular; try a
C                   different value of NDIAG;
C             = 3:  if the solution exponential would overflow, possibly
C                   due to a too large value DELTA; the calculations
C                   stopped prematurely. This error is not likely to
C                   appear.
C
C     METHOD
C
C     The exponential of the matrix A is evaluated from a diagonal Pade
C     approximant. This routine is a modification of the subroutine
C     PADE, described in reference [1]. The routine implements an
C     algorithm which exploits the identity
C
C         (exp[(2**-m)*A]) ** (2**m) = exp(A),
C
C     where m is an integer determined by the algorithm, to improve the
C     accuracy for matrices with large norms.
C
C     REFERENCES
C
C     [1] Ward, R.C.
C         Numerical computation of the matrix exponential with accuracy
C         estimate.
C         SIAM J. Numer. Anal., 14, pp. 600-610, 1977.
C
C     NUMERICAL ASPECTS
C                               3
C     The algorithm requires 0(N ) operations.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997.
C     Supersedes Release 2.0 routine MB05CD by T.W.C. Williams, Kingston
C     Polytechnic, March 1982.
C
C     REVISIONS
C
C     June 14, 1997, April 25, 2003, December 12, 2004.
C
C     KEYWORDS
C
C     Continuous-time system, matrix algebra, matrix exponential,
C     matrix operations, Pade approximation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, HALF, ONE, TWO, FOUR, EIGHT, TEN, TWELVE,
     $                  NINTEN, TWO4, FOUR7, TWOHND
      PARAMETER         ( ZERO = 0.0D0,    HALF = 0.5D0,   ONE = 1.0D0,
     $                    TWO  = 2.0D0,    FOUR = 4.0D0, EIGHT = 8.0D0,
     $                    TEN  = 10.0D0, TWELVE = 12.0D0,
     $                    NINTEN = 19.0D0, TWO4 = 24.0D0,
     $                    FOUR7  = 47.0D0, TWOHND = 200.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         BALANC
      INTEGER           IDIG, INFO, IWARN, LDA, LDWORK, MDIG, N,
     $                  NDIAG
      DOUBLE PRECISION  DELTA
C     .. Array Arguments ..
      INTEGER           IWORK(*)
      DOUBLE PRECISION  A(LDA,*), DWORK(*)
C     .. Local Scalars ..
      LOGICAL           LBALS
      CHARACTER         ACTBAL
      INTEGER           BASE, I, IFAIL, IJ, IK, IM1, J, JWORA1, JWORA2,
     $                  JWORA3, JWORV1, JWORV2, K, M, MPOWER, NDAGM1,
     $                  NDAGM2, NDEC, NDECM1
      DOUBLE PRECISION  ANORM, AVGEV, BD, BIG, EABS, EAVGEV, EMNORM,
     $                  EPS, FACTOR, FN, GN, MAXRED, OVRTH2, OVRTHR, P,
     $                  RERL, RERR, S, SD2, SIZE, SMALL, SS, SUM2D,
     $                  TEMP, TMP1, TR, U, UNDERF, VAR, VAREPS, XN
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DASUM, DLAMCH, DLANGE, DNRM2
      EXTERNAL          DASUM, DLAMCH, DLANGE, DNRM2, LSAME
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DGEMM, DGEMV, DGETRF, DGETRS, DLACPY,
     $                  DLASCL, DLASET, DSCAL, MB04MD, MB05OY, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, EXP, INT, LOG, LOG10, MAX, MIN, MOD, SQRT
C     .. Executable Statements ..
C
      IWARN = 0
      INFO  = 0
      LBALS = LSAME( BALANC, 'S' )
C
C     Test the input scalar arguments.
C
      IF( .NOT.( LSAME( BALANC, 'N' ) .OR. LBALS ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NDIAG.LT.1 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDWORK.LT.1 .OR.
     $       ( LDWORK.LT.N*( 2*N + NDIAG + 1 ) + NDIAG .AND. N.GT.1 )
     $       ) THEN
         INFO = -11
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB05OD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      EPS  = DLAMCH( 'Epsilon' )
      NDEC = INT( LOG10( ONE/EPS ) + ONE )
C
      IF ( N.EQ.0 ) THEN
         MDIG = NDEC
         IDIG = NDEC
         RETURN
      END IF
C
C     Set some machine parameters.
C
      BASE = DLAMCH( 'Base' )
      NDECM1 = NDEC - 1
      UNDERF = DLAMCH( 'Underflow' )
      OVRTHR = DLAMCH( 'Overflow' )
      OVRTH2 = SQRT( OVRTHR )
C
      IF ( DELTA.EQ.ZERO ) THEN
C
C        The DELTA = 0 case.
C
         CALL DLASET( 'Full', N, N, ZERO, ONE, A, LDA )
         MDIG = NDECM1
         IDIG = NDECM1
         RETURN
      END IF
C
      IF ( N.EQ.1 ) THEN
C
C        The 1-by-1 case.
C
         A(1,1) = EXP( A(1,1)*DELTA )
         MDIG = NDECM1
         IDIG = NDECM1
         RETURN
      END IF
C
C     Set pointers for the workspace.
C
      JWORA1 = 1
      JWORA2 = JWORA1 + N*N
      JWORA3 = JWORA2 + N*NDIAG
      JWORV1 = JWORA3 + N*N
      JWORV2 = JWORV1 + N
C
C     Compute Pade coefficients in DWORK(JWORV2:JWORV2+NDIAG-1).
C
      DWORK(JWORV2) = HALF
C
      DO 20 I = 2, NDIAG
         IM1 = I - 1
         DWORK(JWORV2+IM1) = DWORK(JWORV2+I-2)*DBLE( NDIAG - IM1 )/
     $                                   DBLE( I*( 2*NDIAG - IM1 ) )
   20 CONTINUE
C
      VAREPS = EPS**2*( ( DBLE( BASE )**2 - ONE )/
     $        ( TWO4*LOG( DBLE( BASE ) ) ) )
      XN = DBLE( N )
      TR = ZERO
C
C     Apply a translation with the mean of the eigenvalues of A*DELTA.
C
      DO 40 I = 1, N
         CALL DSCAL( N, DELTA, A(1,I), 1 )
         TR = TR + A(I,I)
   40 CONTINUE
C
      AVGEV = TR/XN
      IF ( AVGEV.GT.LOG( OVRTHR ) .OR. AVGEV.LT.LOG( UNDERF ) )
     $   AVGEV = ZERO
      IF ( AVGEV.NE.ZERO ) THEN
         ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK(JWORA1) )
C
         DO 60 I = 1, N
            A(I,I) = A(I,I) - AVGEV
   60    CONTINUE
C
         TEMP = DLANGE( '1-norm', N, N, A, LDA, DWORK(JWORA1) )
         IF ( TEMP.GT.HALF*ANORM ) THEN
C
            DO 80 I = 1, N
               A(I,I) = A(I,I) + AVGEV
   80       CONTINUE
C
            AVGEV = ZERO
         END IF
      END IF
      ACTBAL = BALANC
      IF ( LBALS ) THEN
C
C        Balancing (scaling) has been requested.  First, save A.
C
         CALL DLACPY( 'Full', N, N, A, LDA, DWORK(JWORA1), N )
         MAXRED = TWOHND
         CALL MB04MD( N, MAXRED, A, LDA, DWORK(JWORV1), INFO )
         IF ( MAXRED.LT.ONE ) THEN
C
C           Recover the matrix and reset DWORK(JWORV1,...,JWORV1+N-1)
C           to 1, as no reduction of the norm occured (unlikely event).
C
            CALL DLACPY( 'Full', N, N, DWORK(JWORA1), N, A, LDA )
            ACTBAL = 'N'
            DWORK(JWORV1) = ONE
            CALL DCOPY( N-1, DWORK(JWORV1), 0, DWORK(JWORV1+1), 1 )
            IWARN = 3
         END IF
      END IF
C
C     Scale the matrix by 2**(-M), where M is the minimum integer
C     so that the resulted matrix has the 1-norm less than 0.5.
C
      ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK(JWORA1) )
      M = 0
      IF ( ANORM.GE.HALF ) THEN
         MPOWER = INT( LOG( OVRTHR )/LOG( TWO ) )
         M = INT( LOG( ANORM )/LOG( TWO ) ) + 1
         IF ( M.GT.MPOWER ) THEN
C
C           Error return: The norm of A*DELTA is too large.
C
            INFO = 1
            RETURN
         END IF
         FACTOR = TWO**M
         IF ( M+1.LT.MPOWER ) THEN
            M = M + 1
            FACTOR = FACTOR*TWO
         END IF
C
         DO 120 I = 1, N
            CALL DSCAL( N, ONE/FACTOR, A(1,I), 1 )
  120    CONTINUE
C
      END IF
      NDAGM1 = NDIAG - 1
      NDAGM2 = NDAGM1 - 1
      IJ = 0
C
C     Compute the factors of the diagonal Pade approximant.
C     The loop 200 takes the accuracy requirements into account:
C     Pade coefficients decrease with K, so the calculations should
C     be performed in backward order, one column at a time.
C     (A BLAS 3 implementation in forward order, using DGEMM, could
C     possibly be less accurate.)
C
      DO 200 J = 1, N
         CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, A(1,J), 1, ZERO,
     $               DWORK(JWORA2), 1 )
         IK = 0
C
         DO 140 K = 1, NDAGM2
            CALL DGEMV( 'No transpose', N, N, ONE, A, LDA,
     $                  DWORK(JWORA2+IK), 1, ZERO, DWORK(JWORA2+IK+N),
     $                  1 )
            IK = IK + N
  140    CONTINUE
C
         DO 180 I = 1, N
            S = ZERO
            U = ZERO
            IK = NDAGM2*N + I - 1
C
            DO 160 K = NDAGM1, 1, -1
               P = DWORK(JWORV2+K)*DWORK(JWORA2+IK)
               IK = IK - N
               S = S + P
               IF ( MOD( K+1, 2 ).EQ.0 ) THEN
                  U = U + P
               ELSE
                  U = U - P
               END IF
  160       CONTINUE
C
            P = DWORK(JWORV2)*A(I,J)
            S = S + P
            U = U - P
            IF ( I.EQ.J ) THEN
               S = S + ONE
               U = U + ONE
            END IF
            DWORK(JWORA3+IJ) = S
            DWORK(JWORA1+IJ) = U
            IJ = IJ + 1
  180    CONTINUE
C
  200 CONTINUE
C
C     Compute the exponential of the scaled matrix, using diagonal Pade
C     approximants.  As, in theory [1], the denominator of the Pade
C     approximant should be very well conditioned, no condition estimate
C     is computed.
C
      CALL DGETRF( N, N, DWORK(JWORA1), N, IWORK, IFAIL )
      IF ( IFAIL.GT.0 ) THEN
C
C        Error return: The matrix is exactly singular.
C
         INFO = 2
         RETURN
      END IF
C
      CALL DLACPY( 'Full', N, N, DWORK(JWORA3), N, A, LDA )
      CALL DGETRS( 'No transpose', N, N, DWORK(JWORA1), N, IWORK, A,
     $             LDA, IFAIL )
C
C     Prepare for the calculation of the accuracy estimates.
C     Note that ANORM here is in the range [1, e].
C
      ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK(JWORA1) )
      IF ( ANORM.GE.ONE ) THEN
         EABS = ( NINTEN*XN + FOUR7 )*( EPS*ANORM )
      ELSE
         EABS = ( ( NINTEN*XN + FOUR7 )*EPS )*ANORM
      END IF
      IF ( M.NE.0 ) THEN
         VAR = XN*VAREPS
         FN = ( FOUR*XN )/( ( XN + TWO )*( XN + ONE ) )
         GN = ( ( TWO*XN + TEN )*XN - FOUR )/( ( ( XN + TWO )**2 )
     $                                        *( ( XN + ONE )**2 ) )
C
C        Square-up the computed exponential matrix M times, with caution
C        for avoiding overflows.
C
         DO 220 K = 1, M
            IF ( ANORM.GT.OVRTH2 ) THEN
C
C              The solution could overflow.
C
               CALL DGEMM( 'No transpose', 'No transpose', N, N, N,
     $                     ONE/ANORM, A, LDA, A, LDA, ZERO,
     $                     DWORK(JWORA1), N )
               S = DLANGE( '1-norm', N, N, DWORK(JWORA1), N,
     $                     DWORK(JWORA1) )
               IF ( ANORM.LE.OVRTHR/S ) THEN
                  CALL DLASCL( 'General', N, N, ONE, ANORM, N, N,
     $                         DWORK(JWORA1), N, INFO )
                  TEMP = OVRTHR
               ELSE
C
C                 Error return: The solution would overflow.
C                 This will not happen on most machines, due to the
C                 selection of M.
C
                  INFO = 3
                  RETURN
               END IF
            ELSE
               CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE,
     $                     A, LDA, A, LDA, ZERO, DWORK(JWORA1), N )
               TEMP = ANORM**2
            END IF
            IF ( EABS.LT.ONE ) THEN
               EABS = ( TWO*ANORM + EABS )*EABS  + XN*( EPS*TEMP )
            ELSE IF ( EABS.LT.SQRT( ONE - XN*EPS + OVRTHR/TEMP )*ANORM -
     $                        ANORM ) THEN
               EABS = XN*( EPS*TEMP ) + TWO*( ANORM*EABS ) + EABS**2
            ELSE
               EABS = OVRTHR
            END IF
C
            TMP1 = FN*VAR + GN*( TEMP*VAREPS )
            IF ( TMP1.GT.OVRTHR/TEMP ) THEN
               VAR = OVRTHR
            ELSE
               VAR = TMP1*TEMP
            END IF
C
            CALL DLACPY( 'Full', N, N, DWORK(JWORA1), N, A, LDA )
            ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK(JWORA1) )
  220    CONTINUE
C
      ELSE
         VAR = ( TWELVE*XN )*VAREPS
      END IF
C
C     Apply back transformations, if balancing was effectively used.
C
      CALL MB05OY( ACTBAL, N, 1, N, A, LDA, DWORK(JWORV1), INFO )
      EAVGEV = EXP( AVGEV )
      EMNORM = DLANGE( '1-norm', N, N, A, LDA, DWORK(JWORA1) )
C
C     Compute auxiliary quantities needed for the accuracy estimates.
C
      BIG = ONE
      SMALL = ONE
      IF ( LBALS ) THEN
C
C        Compute norms of the diagonal scaling matrix and its inverse.
C
         DO 240 I = 1, N
            U = DWORK(JWORV1+I-1)
            IF (   BIG.LT.U )   BIG = U
            IF ( SMALL.GT.U ) SMALL = U
  240    CONTINUE
C
         SUM2D = DNRM2( N, DWORK(JWORV1), 1 )
      ELSE
         SUM2D = SQRT( XN )
      END IF
C
C     Update the exponential for the initial translation, and update the
C     auxiliary quantities needed for the accuracy estimates.
C
      SD2 = SQRT( EIGHT*XN*VAREPS )*ANORM
      BD  = SQRT( VAR )
      SS  = MAX( BD, SD2 )
      BD  = MIN( BD, SD2 )
      SD2 = SS*SQRT( ONE + ( BD/SS )**2 )
      IF ( SD2.LE.ONE ) THEN
         SD2 = ( TWO/XN )*SUM2D*SD2
      ELSE IF ( SUM2D/XN.LT.OVRTHR/TWO/SD2 ) THEN
         SD2 = ( TWO/XN )*SUM2D*SD2
      ELSE
         SD2 = OVRTHR
      END IF
      IF ( LBALS ) THEN
         SIZE = ZERO
      ELSE
         IF ( SD2.LT.OVRTHR - EMNORM ) THEN
            SIZE = EMNORM + SD2
         ELSE
            SIZE = OVRTHR
         END IF
      END IF
C
      DO 260 J = 1, N
         SS = DASUM( N, A(1,J), 1 )
         CALL DSCAL( N, EAVGEV, A(1,J), 1 )
         IF ( LBALS ) THEN
            BD = DWORK(JWORV1+J-1)
            SIZE = MAX( SIZE, SS + SD2/BD )
         END IF
  260 CONTINUE
C
C     Set the accuracy estimates and warning errors, if any.
C
      RERR = LOG10( BIG ) + LOG10( EABS ) - LOG10( SMALL ) -
     $       LOG10( EMNORM ) - LOG10( EPS )
      IF ( SIZE.GT.EMNORM ) THEN
         RERL = LOG10( ( SIZE/EMNORM - ONE )/EPS )
      ELSE
         RERL = ZERO
      END IF
      MDIG = MIN( NDEC - INT( RERR + HALF ), NDECM1 )
      IDIG = MIN( NDEC - INT( RERL + HALF ), NDECM1 )
C
      IF ( MDIG.LE.0 ) THEN
         MDIG = 0
         IWARN = 1
      END IF
      IF ( IDIG.LE.0 ) THEN
         IDIG = 0
         IWARN = 2
      END IF
C
      RETURN
C *** Last line of MB05OD ***
      END


! PR tree-optimization/65450
! { dg-do run }
! { dg-additional-options "-mtune=amdfam10" { target x86_64-*-* i?86-*-* } }

program pr65450
  integer :: n, m, o, i, k
  double precision :: u(500,60,3), h(500,60,3)
  double precision :: v(500,60)
  u = 0
  h = 0
  o = 1
  m = 2
  n = 3
  do k = 1, 50
    v = foo (u(:,:,m))
    u(2:499,1:60,n) = u(2:499,1:60,o)+16.d0
    h(1:500,2:59,n) = h(1:500,2:59,o)-4.d0*v(1:500,2:59)-32.0d0
    i = o
    o = m
    m = n
    n = i
  end do
  if (abs (v(17, 23) + h(17, 23, 2) + 768.0d0) > 0.5d0) STOP 1
contains
  function foo(a)
    double precision :: a(:,:)
    double precision :: foo(size(a,dim=1),size(a,dim=2))
    integer :: i, j
    i = size(a,dim=1)
    j = size(a,dim=2)
    foo(2:i-1,1:j) = a(3:i,1:j)-a(1:i-2,1:j)
    foo(1,1:j) = 2*(a(2,1:j)-a(1,1:j))
    foo(i,1:j) = 2*(a(i,1:j)-a(i-1,1:j))
  end function foo
end program pr65450


!program:
!this program is based on Conjugate Gradient.
!it's purpose is to get x from Ax=b with a positive definite and symmetrical mat!rix A
!history:
!2012/3/2(finished)	don 	first release

module sub1
	contains
!The following subroutine is the to get x from Ax=b by Conjugate Gradient
!N is the N_max ,this method is come from "矩阵计算的理论与方法"北大徐树方p154
!with a little change
	subroutine cg(A,b,x,N)
	!variable	meaning
	!A		a matrix,from main program,is coefficient matrix of Ax=b
	!b		a vector,from main program,is righthand of Ax=b
	!x		a vector,the answer of Ax=b,is what we need,our goal
	!r		a vector,minus grads of 0.5xAx-bx at x point,says b-Ax
	!p		a vector,the direction of iteration better than r
	!w		a vector,value is A*p,is useful to simplify the process
	!q0		a number,value is r0*r0,is standard of loop times
	!q1		a number,value is rk-1*rk-1
	!q2		a number, value is rk*rk
	!ba,ar		a number,named by their pronounciation
	!e		a number,standard of loop times,input by client
	!test		a number,value is matmul(r,w)
	!pw		a number,value is matmul(p,w)
	!i		a number,count variable
	!N		a number,the degree of A
		real*8 A(N,N)
		real*8 b(N),x(N),r(N),p(N),w(N)
		!real*8 A(2,2),b(2),x(2),r(2),p(2),w(2)
		real*8 q0,q1,q2,ba,ar,e,test,pw
		integer i,N
		write(*,*)"you want the x_error less than"
		read(*,*)e
		x=0.0
		r=b
		call onedimenmul(r,r,N,q0)
		q2=q0
		p=r

	!	w=matmul(A,p)
	!	call onedimenmul(r,w,2,test)
	!	ar=q2/test
	!	x=x+ar*p
	!	r=r-ar*w
	!	q1=q2;call onedimenmul(r,r,2,q2)
	!	!r=r-a*w
		i=1
		do while(q2>=q0*e)
		q1=q2
	!	ba=q2/q1
	!	p=r+ba*p

		w=matmul(A,p)
		call onedimenmul(p,w,N,pw)!pw is p*w
		ar=q1/pw
		x=x+ar*p
		r=r-ar*w
		call onedimenmul(r,r,N,q2)
		!r=r-a*w
		ba=q2/q1
		i=i+1
		p=r+ba*p
		end do
	write(*,*)"x",x
	write(*,*)"i",i
	end subroutine cg

	!This subroutine is to solve one dimention's multiplication
	subroutine onedimenmul(m1,m2,n,ans)
	integer n
	real*8 m1(n),m2(n),ans
	ans=0
	do i=1,n
		ans=m1(i)*m2(i)+ans
	end do

	end subroutine onedimenmul
end module sub1


      SUBROUTINE JuLDATE(IC,MONTH,DAY,YEAR,DATE)
C
C     PURPOSE
C     TO CONVERT GREGORIAN DATES TO MODIFIED JULIAN DATES AND
C     MODIFIED JULIAN DATES (MJD = JD - 2440000.) TO GREGORIAN
C
C     FORTRAN USAGE
C     CALL JLDATE(IC,MONTH,DAY,YEAR,DATE)
C     IC   -=0 IF CONVERSION IS GREGORIAN TO JULIAN
C           =1 IF CONVERSION IS JULIAN TO GREGORIAN
C     MONTH- MONTH(INTEGER)
C     DAY  - DAY(INTEGER)
C     YEAR - YEAR(INTEGER)
C     DATE - JULIAN DATE(FLOATING POINT)
C
c     IMPLICIT UNDEFINED(A-Z)
      INTEGER MTHDAY(12)
      INTEGER DAY,YEAR,IC,ND,MONTH,I
      REAL*8 DATE
      DATA MTHDAY/31,28,31,30,31,30,31,31,30,31,30,31/
      IF(IC)1,1,6
    1 ND=DAY+365.25*YEAR
      IF(YEAR/4*4-YEAR)4,2,4
    2 IF(MONTH.LE.2)ND=ND-1
    4 DO 5 I=2,MONTH
    5 ND=ND+MTHDAY(I-1)
      DATE=ND-718955.5
      RETURN
C  THE NEXT LINE INSERTED OCT 78 TO IMPROVE PRECISION TO A FEW MS
C     DATE=IDINT(DATE)+0.5
    6 ND=DATE+718955.5
      YEAR=ND/365.25
      ND = ND - INT(365.25*YEAR)
      IF(YEAR/4*4-YEAR)10,7,10
7     IF(ND-59)9,8,10
8     MONTH = 2
      DAY = 29
      RETURN
9     ND = ND + 1
10    DO 11 I = 1,12
      IF(ND.LE.MTHDAY(I)) GO TO 12
11    ND = ND - MTHDAY(I)
      I = 12
12    MONTH = I
      DAY = ND
      RETURN
      END