! Module containing functions useful to construct and calculate
! interpolation functions based on a stellar model.
module interpolate
   use real_kind

   type interpolate_t
      integer :: n
      real(double), pointer :: x(:), y(:), b(:), c(:), d(:)
   end type interpolate_t

contains

   ! ------------------------------------------------------------------------------
   !  SPLINE_INIT
   !   Taken from Make Me A Star, because the spline code already in the evolution
   !   code is too integrated into the opacity table (sigh...)
   !   This routine is a very slightly modified version of one from the book
   !   Computer Methods for Mathematical Computations, by George Forsythe, Mike
   !   Malcolm, and Cleve Moler. The original copy was obtained from the Netlib
   !   mathematical software file server
   !   (see http://www2.ucsc.edu/cats/sc/software/netlib/) with the command
   !   "send spline from fmm".
   !
   !  the coefficients b(i), c(i), and d(i), i=1,2,...,n are computed
   !  for a cubic interpolating mmas_spline
   !
   !    s(x) = y(i) + b(i)*(x-x(i)) + c(i)*(x-x(i))**2 + d(i)*(x-x(i))**3
   !
   !  input..
   !
   !    n = the number of data points or knots (n.ge.2)
   !    x = the abscissas of the knots in strictly increasing order
   !    y = the ordinates of the knots
   !
   !  output..
   !
   !    b, c, d  = arrays of spline coefficients as defined above.
   !
   !  using  p  to denote differentiation,
   !
   !    y(i) = s(x(i))
   !    b(i) = sp(x(i))
   !    c(i) = spp(x(i))/2
   !    d(i) = sppp(x(i))/6  (derivative from the right)
   !
   !  the accompanying function subprogram  seval  can be used
   !  to evaluate the mmas_spline.
   ! ------------------------------------------------------------------------------
   !  Input:
   !        N  - The number of grid points (>=2)
   !        X  - The independent variable (usually the mass coordinate)
   !        Y  - The dependent variable
   !  Output:
   !        B  - Linear term in the interpolation function
   !        C  - Quadratic term in the interpolation function
   !        D  - Cubic term in the interpolation function
   ! ------------------------------------------------------------------------------
   subroutine spline_init (n, x, y, b, c, d)
      use real_kind

      implicit none
      integer, intent (in) ::  n
      real(double), intent(in) :: x(n), y(n)
      real(double), intent(out) :: b(n), c(n), d(n)
      integer :: nm1, ib, i
      real(double) :: t
      !
      nm1 = n-1
      if ( n < 2 ) return
      if ( n < 3 ) then
         b(1) = (y(2)-y(1))/(x(2)-x(1))
         c(1) = 0.d0
         d(1) = 0.d0
         b(2) = b(1)
         c(2) = 0.d0
         d(2) = 0.d0
         return
      end if
      !
      !  set up tridiagonal system
      !
      !  b = diagonal, d = offdiagonal, c = right hand side.
      !
      d(1) = x(2) - x(1)
      c(2) = (y(2) - y(1))/d(1)
      do i = 2, nm1
         d(i) = x(i+1) - x(i)
         b(i) = 2.d0*(d(i-1) + d(i))
         c(i+1) = (y(i+1) - y(i))/d(i)
         c(i) = c(i+1) - c(i)
      end do
      !
      !  end conditions.  third derivatives at  x(1)  and  x(n)
      !  obtained from divided differences
      !
      b(1) = -d(1)
      b(n) = -d(n-1)
      c(1) = 0.d0
      c(n) = 0.d0
      if ( .not. ( n .eq. 3 ) ) then
         c(1) = c(3)/(x(4)-x(2)) - c(2)/(x(3)-x(1))
         c(n) = c(n-1)/(x(n)-x(n-2)) - c(n-2)/(x(n-1)-x(n-3))
         c(1) = c(1)*d(1)**2/(x(4)-x(1))
         c(n) = -c(n)*d(n-1)**2/(x(n)-x(n-3))
      end if
      !
      !  forward elimination
      !
      do i = 2, n
         t = d(i-1)/b(i-1)
         b(i) = b(i) - t*d(i-1)
         c(i) = c(i) - t*c(i-1)
      end do
      !
      !  back substitution
      !
      c(n) = c(n)/b(n)
      do ib = 1, nm1
         i = n-ib
         c(i) = (c(i) - d(i)*c(i+1))/b(i)
      end do
      !
      !  c(i) is now the sigma(i) of the text
      !
      !  compute polynomial coefficients
      !
      b(n) = (y(n) - y(nm1))/d(nm1) + d(nm1)*(c(nm1) + 2.d0*c(n))
      do i = 1, nm1
         b(i) = (y(i+1) - y(i))/d(i) - d(i)*(c(i+1) + 2.d0*c(i))
         d(i) = (c(i+1) - c(i))/d(i)
         c(i) = 3.d0*c(i)
      end do
      c(n) = 3.d0*c(n)
      d(n) = d(n-1)
   end subroutine spline_init

   ! ------------------------------------------------------------------------------
   ! LINEAR_INIT
   ! Set up linear interpolation tables in a way that is compatible with
   ! iptable_eval.
   !  the coefficients b(i), c(i), and d(i), i=1,2,...,n are computed
   !  for a cubic interpolating mmas_spline
   !
   !    s(x) = y(i) + b(i)*(x-x(i))
   !    c(i) = d(i) = 0.0
   !
   ! ------------------------------------------------------------------------------
   !  Input:
   !        N  - The number of grid points (>=2)
   !        X  - The independent variable (usually the mass coordinate)
   !        Y  - The dependent variable
   !  Output:
   !        B  - Linear term in the interpolation function
   !        C  - Quadratic term in the interpolation function (0)
   !        D  - Cubic term in the interpolation function (0)
   ! ------------------------------------------------------------------------------
   subroutine linear_init (n, x, y, b, c, d)
      use real_kind

      implicit none
      integer, intent (in) ::  n
      real(double), intent(in) :: x(n), y(n)
      real(double), intent(out) :: b(n), c(n), d(n)
      integer :: nm1, i

      nm1 = n-1
      if ( n .lt. 2 ) return

      b(:) = 0
      c(:) = 0
      d(:) = 0

      do i=2, nm1
         ! Average forward and backward derivatives
         !b(i) = 0.5 * ( (y(i-1) - y(i)) / (x(i-1) - x(i)) +  (y(i) - y(i+1)) / (x(i) - x(i+1)))
         b(i) = (y(i) - y(i+1)) / (x(i) - x(i+1))
      end do
      b(1) = (y(1) - y(2)) / (x(1) - x(2))
      b(n) = (y(n-1) - y(n)) / (x(n-1) - x(n))
   end subroutine linear_init

   ! ------------------------------------------------------------------------------
   ! MONO_INIT
   ! Set up monotonic cubic interpolation tables in a way that is compatible with
   ! iptable_eval.
   ! Based on the algorithm of Steffen (1990).
   !
   !    s(x) = y(i) + b(i)*(x-x(i)) + c(i)*(x-x(i))**2 + d(i)*(x-x(i))**3
   !
   ! ------------------------------------------------------------------------------
   !  Input:
   !        N  - The number of grid points (>=2)
   !        X  - The independent variable (usually the mass coordinate)
   !        Y  - The dependent variable
   !  Output:
   !        B  - Linear term in the interpolation function
   !        C  - Quadratic term in the interpolation function
   !        D  - Cubic term in the interpolation function
   ! ------------------------------------------------------------------------------
   subroutine mono_init (n, x, y, b, c, d)
      use real_kind

      implicit none
      integer, intent (in) ::  n
      real(double), intent(in) :: x(n), y(n)
      real(double), intent(out) :: b(n), c(n), d(n)
      real(double) :: h(n), s(n), p(n), yp(n+1)
      integer :: i

      if ( n < 2 ) return

      h = 0
      s = 0
      p = 0
      yp = 0

      ! Calculate intervals h and the secant slopes
      h(1:n-1) = x(2:n) - x(1:n-1)
      s(1:n-1) = y(2:n) - y(1:n-1)
      s(1:n-1) = s(1:n-1) / h(1:n-1)

      ! Estimate the slope of the function y(x) at the data points
      do i=2, n-1
         p(i) = (s(i-1)*h(i) + s(i)*h(i-1)) / (h(i-1) + h(i))
      end do

      ! Adjust the slope as needed
      forall (i=2:n-1)
         yp(i) = (sign(1.d0,s(i-1))+sign(1.d0,s(i))) * min(abs(s(i-1)), abs(s(i)), 0.5d0*abs(p(i)))
      end forall

      ! Calculate the coefficients for the interpolating polynomial
      b(:) = 0
      c(:) = 0
      d(:) = 0

      do i=1, n
         d(i) = (yp(i) + yp(i+1) - 2.d0*s(i)) / h(i)**2
         c(i) = (3.d0 * s(i) - 2.d0*yp(i) - yp(i+1)) / h(i)
         b(i) = yp(i)
      end do
   end subroutine mono_init

   ! ------------------------------------------------------------------------------
   ! IPTABLE_EVAL
   !  Again taken from Make Me A Star.
   ! This routine is from the book Computer Methods for Mathematical
   ! Computations, by George Forsythe, Mike Malcolm, and Cleve Moler.
   ! This copy was obtained from the Netlib mathematical software file server
   ! (see http://www2.ucsc.edu/cats/sc/software/netlib/) with the command
   ! "send seval from fmm".
   !
   !  this subroutine evaluates the cubic mmas_spline function
   !
   !    seval = y(i) + b(i)*(u-x(i)) + c(i)*(u-x(i))**2 + d(i)*(u-x(i))**3
   !
   !  if  u .lt. x(1) then  i = 1  is used.
   !  if  u .ge. x(n) then  i = n  is used.
   !
   !  input..
   !
   !    n = the number of data points
   !    u = the abscissa at which the mmas_spline is to be evaluated
   !    x,y = the arrays of data abscissas and ordinates
   !    b,c,d = arrays of mmas_spline coefficients computed by mmas_spline
   !
   !  if  u  is not in the same interval as the previous call, then a
   !  binary search is performed to determine the proper interval.
   !
   !  This code will also accept the linear interpolation tables calculated by
   !  linear_init() in this module.
   ! ------------------------------------------------------------------------------
   !  Input:
   !        N  - The number of grid points (>=2)
   !        U  - Wanted value for the independent variable
   !        X  - The independent variable (usually the mass coordinate)
   !        Y  - The dependent variable
   !        B  - Linear term in the interpolation function
   !        C  - Quadratic term in the interpolation function (0)
   !        D  - Cubic term in the interpolation function (0)
   !  Return value:
   !        The interpolated value of Y for X = U
   ! ------------------------------------------------------------------------------
   function iptable_eval(n, u, x, y, b, c, d)
      use real_kind

      implicit none
      real(double)  :: iptable_eval
      integer, intent(in) :: n
      real(double) , intent(in) :: u, x(n), y(n), b(n), c(n), d(n)
      integer :: i
      integer :: j, k
      real(double) :: dx

      !
      !  binary search - NB: Assumes that the array x is stored largest-smallest
      !
      i = 1;
      j = n+1
      if (x(1) > x(n)) then
         do while (j > i+1)
            k = (i+j)/2
            if ( u < x(k) ) then
               i = k
            else
               j = k
            end if
         end do
      else
         do while (j > i+1)
            k = (i+j)/2
            if ( u > x(k) ) then
               i = k
            else
               j = k
            end if
         end do
      end if
      !
      !  evaluate mmas_spline
      !
      dx = u - x(i)
      iptable_eval = y(i) + dx*(b(i) + dx*(c(i) + dx*d(i)))
   end function iptable_eval

   ! ------------------------------------------------------------------------------
   ! IPTABLE_INIT
   !  Prepare data structures for either linear or cubic spline
   !  interpolation, depending on settings.
   ! ------------------------------------------------------------------------------
   !  Input:
   !        N  - The number of grid points (>=2)
   !        X  - The independent variable (usually the mass coordinate)
   !        Y  - The dependent variable
   !  Output:
   !        B  - Linear term in the interpolation function
   !        C  - Quadratic term in the interpolation function (or 0)
   !        D  - Cubic term in the interpolation function (or 0)
   ! ------------------------------------------------------------------------------
   subroutine iptable_init (n, x, y, b, c, d)
      use real_kind

      implicit none
      integer, intent (in) ::  n
      real(double), intent(in) :: x(n), y(n)
      real(double), intent(out) :: b(n), c(n), d(n)

      call mono_init (n, x, y, b, c, d)
      !if (use_spline_interpolation) then
      !   call spline_init (n, x, y, b, c, d)
      !else
      !   call linear_init (n, x, y, b, c, d)
      !end if
   end subroutine iptable_init

   subroutine make_interpolation_table(n, x, y, ip)
      use real_kind
      implicit none
      integer, intent(in) :: n
      real(double), intent(in) :: x(n), y(n)
      type(interpolate_t), intent(out) :: ip

      ip%n = n;
      allocate(ip%x(n), ip%y(n), ip%b(n), ip%c(n), ip%d(n))
      ip%x(1:n) = x(1:n)
      ip%y(1:n) = y(1:n)

      call iptable_init(n, x, y, ip%b, ip%c, ip%d)
   end subroutine make_interpolation_table

   subroutine update_interpolation_table(n, x, y, ip)
      use real_kind
      implicit none
      integer, intent(in) :: n
      real(double), intent(in) :: x(n), y(n)
      type(interpolate_t), intent(inout) :: ip

      ! Can't update if the table sizes don't match
      if (ip%n /= n) return

      ! Recalculate table coefficients
      ip%x(1:n) = x(1:n)
      ip%y(1:n) = y(1:n)

      call iptable_init(n, x, y, ip%b, ip%c, ip%d)
   end subroutine update_interpolation_table

   function evaluate_interpolation_table(x, ip)
      use real_kind
      implicit none
      real(double), intent(in) :: x
      type(interpolate_t), intent(in) :: ip
      real(double) :: evaluate_interpolation_table

      evaluate_interpolation_table = iptable_eval(ip%n, x, ip%x, ip%y, ip%b, ip%c, ip%d)
   end function evaluate_interpolation_table

   subroutine destroy_interpolation_table(ip)
      implicit none
      type(interpolate_t), intent(inout) :: ip

      deallocate(ip%x, ip%y, ip%b, ip%c, ip%d)
   end subroutine destroy_interpolation_table

end module interpolate


    Program zunmtr_example

!     ZUNMTR 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: zscal
      Use lapack_example_aux, Only: nagf_file_print_matrix_complex_gen_comp
      Use lapack_interfaces, Only: dstebz, zhetrd, zstein, zunmtr
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Real (Kind=dp), Parameter :: zero = 0.0E0_dp
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: vl, vu
      Integer :: i, ifail, info, k, lda, ldc, lwork, m, n, nsplit
      Character (1) :: uplo
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: a(:, :), c(:, :), tau(:), work(:)
      Real (Kind=dp), Allocatable :: d(:), e(:), rwork(:), w(:)
      Integer, Allocatable :: iblock(:), ifailv(:), isplit(:), iwork(:)
      Character (1) :: clabs(1), rlabs(1)
!     .. Intrinsic Procedures ..
      Intrinsic :: abs, cmplx, conjg, maxloc
!     .. Executable Statements ..
      Write (nout, *) 'ZUNMTR Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      lda = n
      ldc = n
      lwork = 64*n
      Allocate (a(lda,n), c(ldc,n), tau(n), work(lwork), d(n), e(n), &
        rwork(5*n), w(n), iblock(n), ifailv(n), isplit(n), iwork(3*n))

!     Read A from data file

      Read (nin, *) uplo
      If (uplo=='U') Then
        Read (nin, *)(a(i,i:n), i=1, n)
      Else If (uplo=='L') Then
        Read (nin, *)(a(i,1:i), i=1, n)
      End If

!     Reduce A to tridiagonal form T = (Q**H)*A*Q
      Call zhetrd(uplo, n, a, lda, d, e, tau, work, lwork, info)

!     Calculate the two smallest eigenvalues of T (same as A)

      Call dstebz('I', 'B', n, vl, vu, 1, 2, zero, d, e, m, nsplit, w, iblock, &
        isplit, rwork, iwork, info)

      Write (nout, *)
      If (info>0) Then
        Write (nout, *) 'Failure to converge.'
      Else
        Write (nout, *) 'Eigenvalues'
        Write (nout, 100) w(1:m)

!       Calculate the eigenvectors of T, storing the result in C
        Call zstein(n, d, e, m, w, iblock, isplit, c, ldc, rwork, iwork, &
          ifailv, info)

        If (info>0) Then
          Write (nout, *) 'Failure to converge.'
        Else

!         Calculate the eigenvectors of A = Q * (eigenvectors of T)
          Call zunmtr('Left', uplo, 'No transpose', n, m, a, lda, tau, c, ldc, &
            work, lwork, info)

!         Print eigenvectors
          Write (nout, *)
          Flush (nout)

!         Normalize the eigenvectors so that the element of largest absolute
!         value is real.
          Do i = 1, m
            rwork(1:n) = abs(c(1:n,i))
            k = maxloc(rwork(1:n), 1)
            Call zscal(n, conjg(c(k,i))/cmplx(abs(c(k,i)),kind=dp), c(1,i), 1)
          End Do

!         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, m, &
            c, ldc, 'Bracketed', 'F7.4', 'Eigenvectors', 'Integer', rlabs, &
            'Integer', clabs, 80, 0, ifail)

        End If
      End If

100   Format (8X, 4(F7.4,11X,:))
    End Program


! NCLFORTSTART
SUBROUTINE DCOMPUTEWSPD(wspd, u, v, nx, ny)

    IMPLICIT NONE

    !f2py threadsafe
    !f2py intent(in,out) :: wspd

    INTEGER, INTENT(IN) :: nx, ny
    REAL(KIND=8), DIMENSION(nx,ny), INTENT(OUT) :: wspd
    REAL(KIND=8), DIMENSION(nx,ny), INTENT(IN) :: u, v
! NCLEND

    INTEGER i, j

    !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(runtime)
    DO j = 1,ny
        DO i = 1,nx
            wspd(i,j) = SQRT(u(i,j)*u(i,j) + v(i,j)*v(i,j))
        END DO
    END DO
    !$OMP END PARALLEL DO

END SUBROUTINE DCOMPUTEWSPD

! NCLFORTSTART
SUBROUTINE DCOMPUTEWDIR(wdir, u, v, nx, ny)
    USE wrf_constants, ONLY : DEG_PER_RAD

    IMPLICIT NONE

    !f2py threadsafe
    !f2py intent(in,out) :: wdir

    INTEGER, INTENT(IN) :: nx, ny
    REAL(KIND=8), DIMENSION(nx,ny), INTENT(OUT) :: wdir
    REAL(KIND=8), DIMENSION(nx,ny), INTENT(IN) :: u, v
! NCLEND

    INTEGER i, j

    !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(runtime)
    DO j = 1,ny
        DO i = 1,nx
            wdir(i,j) = MOD(270.0 - ATAN2(v(i,j), u(i,j)) * DEG_PER_RAD, 360.)
        END DO
    END DO
    !$OMP END PARALLEL DO

END SUBROUTINE DCOMPUTEWDIR


      program example2
!  normally we use atan() intrinsic, this is just for example.
!
! page 29
      use funcs, only: arctan
      use funcs58, only: arctanII
      ! should always put function and subroutine in modules

      !-----------------------------------------------------------------------
      ! this is obsolete Fortran 66 and should not be done
      !dimension a(5)
      !data a /3.,3.5,1.57, 3.14, -1/
      !--------------------------------------------
      ! this is modern
      real :: a(5) = [3., 3.5, 1.57, 3.14, -1.]
      !---------------------------------------------

      ! old Fortran II way
      do 10 i = 1,5
10    write (*,*) arctanII(a(i))

      ! modern Fortran way
      print *, arctan(a)

      ! range of arctan
      print *, atan(-huge(0.)), atan(huge(0.))

      end program


program tarefab1
    implicit real(8) (a-h,o-z)

    g = 9.8d0
    a_l = 9.8d0
    a_m = 1d0
    dt = 1d-4
    tmax = 120d0
    e = 1e-7

    open(10, file='saida-b1-10407962.dat')

    do j = 1, 30
        omega_i = 0d0
        theta_0 = rand()
        theta_i = theta_0
        i = 0
        t0 = 0d0
        n = 0
        sumT = 0d0
        gama = 0d0
        F0 = 0d0
        Omega = 0d0

        do while ( i*dt.le.tmax )

            omega_j = omega_i +dw(g, a_l, theta_i, gama, omega_i, F0, Omega, dt*i)*dt
            theta_j = theta_i +omega_j*dt

            if (omega_i*omega_j.lt.0) then
                if (t0.ge.0d0) then
                    sumT = sumT + i*dt-t0
                    n = n + 1
                end if
                t0 = i*dt
            end if

            theta_i = theta_j
            omega_i = omega_j

            i = i+1
        end do
        sumT = 2*sumT/n
        solucaoNum = simpson(f, -theta_0+e, theta_0-e, i, theta_0)
        solucaoAna = 2*analitico(theta_0, a_l, g, e)

        write(10,'(F0.8,2(" ",F0.8))') theta_0, sumT, solucaoNum + solucaoAna
    end do

    close(10)

contains
    function dw(g, a_l, theta, gama, dTheta, F0, Omega, t)
        implicit real(8) (a-h,o-z)
        dw = -(g/a_l)*sin(theta) -gama*dTheta +F0*sin(Omega*t)
        return
    end function

    function f(theta, theta_0)
        implicit real(8) (a-h,o-z)
        g = 9.8d0
        a_l = 9.8d0
        f = sqrt(2*a_l/g)/sqrt(cos(theta)-cos(theta_0))
        return
    end function

    function analitico(theta_0, a_l, g, e)
        implicit real(8) (a-h,o-z)
        analitico = 2*sqrt(2*a_l/g)*sqrt(e)/sqrt(theta_0)
        return
    end function

    function simpson(f, a, b, n, y)
        implicit real(8) (a-h,o-z)
        h = (b-a)/n
        simpson = 0d0

        do i = 1, n-1, 2
            x = a + i*h
            simpson = simpson + ( f(x -h, y) +4*f(x, y) +f(x +h, y) ) * h/3
        end do

        return
    end function simpson

end program tarefab1


FUNCTION betai(a,b,x)
REAL*8 betai,a,b,x
!CU    USES betacf,gammln
REAL*8 bt,betacf,gammln
if(x.lt.0..or.x.gt.1.)pause 'bad argument x in betai'
if(x.eq.0..or.x.eq.1.)then
  bt=0.
else
  bt=exp(gammln(a+b)-gammln(a)-gammln(b)+a*log(x)+b*log(1.-x))
endif
if(x.lt.(a+1.)/(a+b+2.))then
  betai=bt*betacf(a,b,x)/a
  return
else
  betai=1.-bt*betacf(b,a,1.-x)/b
  return
endif
END


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! This file is dedicated to the public domain.  If your jurisdiction requires a        !
! specific license:                                                                    !
!                                                                                !
! Copyright (c) Stephen McDowell, 2017-2019                                            !
! License:      CC0 1.0 Universal                                                      !
! License Text: https://creativecommons.org/publicdomain/zero/1.0/legalcode            !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!---------------------------------------------------------------------------------------
! MODULE: conversions
!> \author Thomas E. Kurtz
!
!> \file
!
!> \brief A fortran module for converting between degrees and radians.
!
!> Conversions may be done using either single or double precision.  This file is mostly
!> an adaptation of the excellent crash-course slides presented in Fall 2010:
!> https://pages.mtu.edu/~shene/COURSES/cs201/NOTES/F90-Subprograms.pdf
!---------------------------------------------------------------------------------------
module conversions
  use iso_c_binding, only : c_float, c_double
  implicit none

  !> The single precision representation of \f$\Pi\f$.
  real(c_float),  parameter :: pi_s  = 3.14159265358979323846
  !> The double precision representation of \f$\Pi\f$.
  real(c_double), parameter :: pi_d  = 3.14159265358979323846264338327950288
  !> The single precision representation of ``180.0``.
  real(c_float),  parameter :: s_180 = 180.0
  !> The double precision representation of ``180.0``.
  real(c_double), parameter :: d_180 = 180.0

contains
  !-------------------------------------------------------------------------------------
  !> \brief
  !>     Convert degrees into radians using single precision floating point numbers.
  !>
  !> \param degrees_s
  !>     The input single precision number representing degrees to be converted.
  !>
  !> \return
  !>     The input ``degrees_s`` converted to radians.  Return type is single precision.
  !-------------------------------------------------------------------------------------
  function degrees_to_radians_s(degrees_s) result(radians_s)
    real(c_float), intent(in) :: degrees_s
    real(c_float)             :: radians_s
    radians_s = degrees_s * pi_s / s_180
  end function degrees_to_radians_s

  !-------------------------------------------------------------------------------------
  !> \brief
  !>     Convert radians into degrees using single precision floating point numbers.
  !>
  !> \param radians_s
  !>     The input single precision number representing radians to be converted.
  !>
  !> \return
  !>     The input ``radians_s`` converted to degrees.  Return type is single precision.
  !-------------------------------------------------------------------------------------
  function radians_to_degrees_s(radians_s) result(degrees_s)
    real(c_float), intent(in) :: radians_s
    real(c_float)             :: degrees_s
    degrees_s = radians_s * s_180 / pi_s
  end function radians_to_degrees_s

  !-------------------------------------------------------------------------------------
  !> \brief
  !>     Convert degrees into radians using double precision floating point numbers.
  !>
  !> \param degrees_d
  !>     The input double precision number representing degrees to be converted.
  !>
  !> \return
  !>     The input ``degrees_d`` converted to radians.  Return type is double precision.
  !-------------------------------------------------------------------------------------
  function degrees_to_radians_d(degrees_d) result(radians_d)
    real(c_double), intent(in) :: degrees_d
    real(c_double)             :: radians_d
    radians_d = degrees_d * pi_d / d_180
  end function degrees_to_radians_d

  !-------------------------------------------------------------------------------------
  !> \brief
  !>     Convert radians into degrees using double precision floating point numbers.
  !>
  !> \param radians_d
  !>     The input double precision number representing radians to be converted.
  !>
  !> \return
  !>     The input ``radians_d`` converted to degrees.  Return type is double precision.
  !-------------------------------------------------------------------------------------
  function radians_to_degrees_d(radians_d) result(degrees_d)
    real(c_double), intent(in) :: radians_d
    real(c_double)             :: degrees_d
    degrees_d = radians_d * d_180 / pi_d
  end function radians_to_degrees_d
end module conversions


MODULE SpecFuns

! Module for spectral differentiation and integration

IMPLICIT NONE

DOUBLE PRECISION, PARAMETER :: pi=3.1415926535897932385d0

CONTAINS

  SUBROUTINE fft(a,b,nd,id)
!
! Cooley-Tukey FFT as copied from Fornberg Appendix F except
! stride 1 is assumed
!
! Replaces a+ib with sum_k=0^(nd-1) (a_k+ib_k)*exp(2*pi*i*id*j*k/nd)
!
  INTEGER, INTENT(IN) :: nd
  DOUBLE PRECISION, INTENT(IN) :: id
  DOUBLE PRECISION, DIMENSION(0:nd-1), INTENT(INOUT) :: a,b
  INTEGER :: j,i,k,l,lh,ip
  DOUBLE PRECISION :: tr,ti,s,c,ur,ui
!
  j=0
  DO i=0,nd-2
    IF (i < j) THEN
      tr=a(j)
      a(j)=a(i)
      a(i)=tr
      ti=b(j)
      b(j)=b(i)
      b(i)=ti
    END IF
    k=nd/2
    DO WHILE (k <= j)
      j=j-k
      k=k/2
    END DO
    j=j+k
  END DO
!
  s=0.d0
  c=-1.d0
  l=1
  DO WHILE (l < nd)
    lh=l
    l=l+l
    ur=1.d0
    ui=0.d0
    DO j=0,lh-1
      DO i=j,nd-1,l
        ip=i+lh
        tr=a(ip)*ur-b(ip)*ui
        ti=a(ip)*ui+b(ip)*ur
        a(ip)=a(i)-tr
        b(ip)=b(i)-ti
        a(i)=a(i)+tr
        b(i)=b(i)+ti
      END DO
      ti=ur*s+ui*c
      ur=ur*c-ui*s
      ui=ti
    END DO
    s=SQRT(.5d0*(1.d0-c))*id
    c=SQRT(.5d0*(1.d0+c))
  END DO
!
  END SUBROUTINE fft

  SUBROUTINE tofour(a,b,nd)
!
! Use complex FFT to transform the real periodic pair a,b
! to ahat bhat - Copied from Fornberg Appendix F
!
  INTEGER, INTENT(IN) :: nd
  DOUBLE PRECISION, DIMENSION(0:nd-1), INTENT(INOUT) :: a,b
  INTEGER :: j
  DOUBLE PRECISION :: scl
!
  scl=1.d0/DBLE(nd)
  CALL fft(a,b,nd,-1.d0)
  DO j=0,nd-1
    a(j)=a(j)*scl
    b(j)=b(j)*scl
  END DO
!
  END SUBROUTINE tofour

  SUBROUTINE diffour(a,b,nd)
!
! Differentiate in Fourier space
! Copied from Fornberg Appendix F
!
  INTEGER, INTENT(IN) :: nd
  DOUBLE PRECISION, DIMENSION(0:nd-1), INTENT(INOUT) :: a,b
  INTEGER :: i,j,nh
  DOUBLE PRECISION :: a1,f
!
  nh=nd/2
  a(0)=0.d0
  b(0)=0.d0
  a(nh)=0.d0
  b(nh)=0.d0
  DO i=1,nh-1
    j=nd-i
    f=DBLE(i)
    a1=a(i)*f
    a(i)=-b(i)*f
    b(i)=a1
    a1=a(j)*f
    a(j)=b(j)*f
    b(j)=-a1
  END DO
!
  END SUBROUTINE diffour

  SUBROUTINE LaplaceBeltrami(Lw,w,theta,M,N)
!
! Use Fourier PS to approximate the Laplace-Beltrami operator on the
! sphere. Here we use Fornberg's filtered doubly periodic PS approximation.
! See Chapter 6
!
  INTEGER, INTENT(IN) :: M,N
  DOUBLE PRECISION, DIMENSION(M,0:N-1), INTENT(IN) :: w
  DOUBLE PRECISION, DIMENSION(M,0:N-1), INTENT(OUT) :: Lw
  DOUBLE PRECISION, DIMENSION(M), INTENT(IN) :: theta
  DOUBLE PRECISION, DIMENSION(0:N-1) :: ah,bh,ap,bp
  DOUBLE PRECISION, DIMENSION(M) :: sint,cott
  INTEGER :: j,k,j1,j2,j3,j4,k1,k2
  LOGICAL, SAVE :: first_call=.TRUE.
!
  IF (first_call) THEN
    DO k=1,m
      sint(k)=SIN(theta(k))
      cott(k)=1.d0/TAN(theta(k))
    END DO
    first_call=.FALSE.
  END IF
!
  Lw=0.d0
!
! First compute theta derivatives - extend data periodically
!
  DO j=0,N/2-1
    j1=2*j
    j2=2*j+1
    j3=j1+(N/2)
    IF (j3 > N-1) THEN
      j3=j3-N
    END IF
    j4=j2+(N/2)
    IF (j4 > N-1) THEN
      j4=j4-N
    END IF
    DO k=1,M
      ah(k-1)=w(k,j1)
      bh(k-1)=w(k,j2)
      ah(2*M-k)=w(k,j3)
      bh(2*M-k)=w(k,j4)
    END DO
!
    CALL tofour(ah,bh,N)
    ap=ah
    bp=bh
    CALL diffour(ap,bp,N)
    ah=ap
    bh=bp
    CALL fft(ah,bh,N,1.d0)
    CALL diffour(ap,bp,N)
    CALL fft(ap,bp,N,1.d0)
    DO k=1,M
      Lw(k,j1)=Lw(k,j1)+cott(k)*ah(k-1)+ap(k-1)
      Lw(k,j2)=Lw(k,j2)+cott(k)*bh(k-1)+bp(k-1)
    END DO
  END DO
!
! Now phi derivatives
!
  DO k=1,M/2
    k1=2*k-1
    k2=2*k
    DO j=0,N-1
      ah(j)=w(k1,j)
      bh(j)=w(k2,j)
    END DO
    CALL tofour(ah,bh,N)
!
! Now filter out the high modes according to sin(theta) - 10
! was chosen based on experiments with TestLB.f90
!
    DO j=1,(N/2)-1
      IF (DBLE(j) > 10.d0*sint(k1)*DBLE(N/2)) THEN
        ah(j)=0.d0
        ah(N-j)=0.d0
      END IF
      IF (DBLE(j) > 10.d0*sint(k2)*DBLE(N/2)) THEN
        bh(j)=0.d0
        bh(N-j)=0.d0
      END IF
    END DO
!
    CALL diffour(ah,bh,N)
    CALL diffour(ah,bh,N)
    CALL fft(ah,bh,N,1.d0)
    DO j=0,N-1
      Lw(k1,j)=Lw(k1,j)+ah(j)/(sint(k1)*sint(k1))
      Lw(k2,j)=Lw(k2,j)+bh(j)/(sint(k2)*sint(k2))
    END DO
  END DO
!
  END SUBROUTINE LaplaceBeltrami

  SUBROUTINE Shift(a,b,nd)
!
! Shift periodic arrays a,b to their midpoints
!
  INTEGER, INTENT(IN) :: nd
  DOUBLE PRECISION, DIMENSION(0:nd-1), INTENT(INOUT) :: a,b
  INTEGER :: i,nh
  DOUBLE PRECISION :: a1,fr,fi
!
  nh=nd/2
  CALL tofour(a,b,nd)
  DO i=0,nd-1
    fr=COS(pi*DBLE(i)/DBLE(nd))
    fi=SIN(pi*DBLE(i)/DBLE(nd))
    IF (i > nh) THEN
      fr=-fr
      fi=-fi
    END IF
    a1=a(i)*fr-b(i)*fi
    b(i)=b(i)*fr+a(i)*fi
    a(i)=a1
  END DO
  CALL fft(a,b,nd,1.d0)
!
  END SUBROUTINE Shift

  SUBROUTINE DCT2(a,b,nd)
!
! Type II DCT according to Makhoul - IEEE Transactions on Acoustics, Speech
! and Signal Processing 1 1980 - Use Fornberg's real and imaginary trick
!
  INTEGER, INTENT(IN) :: nd
  DOUBLE PRECISION, DIMENSION(0:nd-1), INTENT(INOUT) :: a,b
  DOUBLE PRECISION, DIMENSION(0:nd-1) :: ah,bh
  INTEGER :: k,j,nh
  DOUBLE PRECISION :: scl,a1,b1,c,s
!
  scl=1.d0/DBLE(nd)
  nh=nd/2
  DO j=0,nh-1
    ah(j)=a(2*j)
    bh(j)=b(2*j)
    k=nd-j-1
    ah(k)=a(2*(nd-k)-1)
    bh(k)=b(2*(nd-k)-1)
  END DO
  CALL fft(ah,bh,nd,-1.d0)
  DO j=0,nd-1
    c=COS(pi*DBLE(j)/DBLE(2*nd))
    s=SIN(pi*DBLE(j)/DBLE(2*nd))
    a(j)=(c*ah(j)+s*bh(j))*scl
    b(j)=(c*bh(j)-s*ah(j))*scl
  END DO
  DO j=1,nh
    k=nd-j
    a1=(a(j)-b(k))
    b1=(a(k)+b(j))
    a(k)=(a(k)-b(j))
    b(k)=(a(j)+b(k))
    a(j)=a1
    b(j)=b1
  END DO
!
  END SUBROUTINE DCT2

  SUBROUTINE IDCT2(a,b,nd)
!
! Inverse DCT according to Makhoul - IEEE Transactions on Acoustics, Speech
! and Signal Processing 1 1980 - Use Fornberg's real and imaginary trick
!
  INTEGER, INTENT(IN) :: nd
  DOUBLE PRECISION, DIMENSION(0:nd-1), INTENT(INOUT) :: a,b
  DOUBLE PRECISION, DIMENSION(0:nd-1) :: ah,bh
  INTEGER :: k,j,nh
  DOUBLE PRECISION :: a1,b1,c,s
!
  nh=nd/2
  ah(0)=a(0)
  bh(0)=b(0)
  DO j=1,nd-1
    ah(j)=a(j)+b(nd-j)
    bh(j)=b(j)-a(nd-j)
  END DO
  DO j=1,nd-1
    c=COS(pi*DBLE(j)/DBLE(2*nd))
    s=SIN(pi*DBLE(j)/DBLE(2*nd))
    a(j)=(c*ah(j)-s*bh(j))/2.d0
    b(j)=(c*bh(j)+s*ah(j))/2.d0
  END DO
  CALL fft(a,b,nd,1.d0)
  ah=a
  bh=b
  DO j=0,nh-1
    a(2*j)=ah(j)
    b(2*j)=bh(j)
    k=nd-j-1
    a(2*(nd-k)-1)=ah(k)
    b(2*(nd-k)-1)=bh(k)
  END DO
!
  END SUBROUTINE IDCT2

  SUBROUTINE filter(ah,bh,nd,ifil)
!
! ifil=1 exponential filter
! ifil=2 2/3 rule
!
! assume modes 0, ... ,(nd/2)-1,-(nd/2), ... ,-1
!
  INTEGER, INTENT(IN) :: nd,ifil
  DOUBLE PRECISION, DIMENSION(0:nd-1), INTENT(INOUT) :: ah,bh
!
  INTEGER :: j,k,nh,m
  DOUBLE PRECISION :: alpha,dN
!
  nh=nd/2
!
  IF (ifil==1) THEN
    m=36
    alpha=36.d0 ! parameters from Hou Acta Numerica 2009
    dN=1.d0/DBLE(nh)
    DO k=0,nh-1
      ah(k)=EXP(-alpha*(DBLE(k)*dN)**m)*ah(k)
      bh(k)=EXP(-alpha*(DBLE(k)*dN)**m)*bh(k)
      j=nh-k
      ah(k+nh)=EXP(-alpha*(DBLE(j)*dN)**m)*ah(k+nh)
      bh(k+nh)=EXP(-alpha*(DBLE(j)*dN)**m)*bh(k+nh)
    END DO
  ELSE IF (ifil==0) THEN
    DO k=0,nh-1
      IF (k > (2*nd)/3) THEN
        ah(k)=0.d0
        bh(k)=0.d0
      END IF
      j=nh-k
      IF (j > (2*nd)/3) THEN
        ah(k+nh)=0.d0
        bh(k+nh)=0.d0
      END IF
    END DO
  END IF
!
  END SUBROUTINE filter

  SUBROUTINE Poisson2d(f,u,nx,ny)
!
! Solve -lap u = f for doubly 2pi-periodic functions
!
! Use fft without the real and imaginary trick
! for simplicity - harder than necessary
!
! Assume without checking that f has mean 0
!
!
  INTEGER, INTENT(IN) :: nx,ny
  DOUBLE PRECISION, DIMENSION(0:nx-1,0:ny-1), INTENT(IN) :: f
  DOUBLE PRECISION, DIMENSION(0:nx-1,0:ny-1), INTENT(OUT) :: u
!
  DOUBLE PRECISION, DIMENSION(0:nx-1,0:ny-1) :: fhr,fhi
  DOUBLE PRECISION, DIMENSION(0:nx-1) :: ah,bh
  DOUBLE PRECISION, DIMENSION(0:ny-1) :: ch,dh
  INTEGER :: jx,jy,kx,ky,nhx,nhy
  DOUBLE PRECISION :: den
!
  nhx=nx/2
  nhy=ny/2
!
  DO jy=0,ny-1
    DO jx=0,nx-1
      ah(jx)=f(jx,jy)
      bh(jx)=0.d0
    END DO
    CALL tofour(ah,bh,nx)
    DO jx=0,nx-1
      fhr(jx,jy)=ah(jx)
      fhi(jx,jy)=bh(jx)
    END DO
  END DO
!
  DO jx=0,nx-1
    DO jy=0,ny-1
      ch(jy)=fhr(jx,jy)
      dh(jy)=fhi(jx,jy)
    END DO
    CALL tofour(ch,dh,ny)
    DO jy=0,ny-1
      fhr(jx,jy)=ch(jy)
      fhi(jx,jy)=dh(jy)
    END DO
  END DO
!
! Solve
!
  DO jx=0,nhx-1
    kx=jx-nhx
    DO jy=0,nhy-1
      ky=jy-nhy
      den=DBLE(jx**2+jy**2)
      IF (den > 0.d0) THEN
        fhr(jx,jy)=fhr(jx,jy)/den
        fhi(jx,jy)=fhi(jx,jy)/den
      END IF
      den=DBLE(kx**2+jy**2)
      fhr(jx+nhx,jy)=fhr(jx+nhx,jy)/den
      fhi(jx+nhx,jy)=fhi(jx+nhx,jy)/den
      den=DBLE(jx**2+ky**2)
      fhr(jx,jy+nhy)=fhr(jx,jy+nhy)/den
      fhi(jx,jy+nhy)=fhi(jx,jy+nhy)/den
      den=DBLE(kx**2+ky**2)
      fhr(jx+nhx,jy+nhy)=fhr(jx+nhx,jy+nhy)/den
      fhi(jx+nhx,jy+nhy)=fhi(jx+nhx,jy+nhy)/den
    END DO
  END DO
!
  DO jx=0,nx-1
    DO jy=0,ny-1
      ch(jy)=fhr(jx,jy)
      dh(jy)=fhi(jx,jy)
    END DO
    CALL fft(ch,dh,ny,1.d0)
    DO jy=0,ny-1
      fhr(jx,jy)=ch(jy)
      fhi(jx,jy)=dh(jy)
    END DO
  END DO
!
  DO jy=0,ny-1
    DO jx=0,nx-1
      ah(jx)=fhr(jx,jy)
      bh(jx)=fhi(jx,jy)
    END DO
    CALL fft(ah,bh,nx,1.d0)
    DO jx=0,nx-1
      u(jx,jy)=ah(jx)
    END DO
  END DO
!
  END SUBROUTINE Poisson2d

  SUBROUTINE ChebyInt(ya,yb,a,b,nd)
!
! Use a Chebyshev expansion to compute int_-1^1 f(x)dx
!                                    = int_0^pi f(cos(g)) sin(g)dg
! Assume a,b data on the Chebyshev nodes x_j=cos((j+1/2)*pi/nd), j=0,..,nd-1
! Use int_0^pi cos(ng)*sin(g) dg = 0, n odd; = -2/(n^2-1) n even
!
  INTEGER, INTENT(IN) :: nd
  DOUBLE PRECISION, DIMENSION(0:nd-1), INTENT(IN) :: a,b
  DOUBLE PRECISION, INTENT(OUT) :: ya,yb
  DOUBLE PRECISION, DIMENSION(0:nd-1) :: ah,bh
  INTEGER :: k,nh
!
  nh=nd/2
  ah=a
  bh=b
  CALL DCT2(ah,bh,nd)
  ya=0.d0
  yb=0.d0
  DO k=0,nh-1
    ya=ya-2.d0*ah(2*k)/(DBLE(4*k*k)-1.d0)
    yb=yb-2.d0*bh(2*k)/(DBLE(4*k*k)-1.d0)
  END DO
!
  END SUBROUTINE ChebyInt

  SUBROUTINE ChebyDiff(a,da,nd)
!
! Differentiate in Chebyshev space using the recursion
!
! T_{n+1}'   T_{n-1}'
! -------  - -------    = 2T_n
!  n+1         n-1
!
  INTEGER, INTENT(IN) :: nd
  DOUBLE PRECISION, DIMENSION(0:nd-1), INTENT(IN) :: a
  DOUBLE PRECISION, DIMENSION(0:nd-1), INTENT(OUT) :: da
  INTEGER :: k
!
  da=0.d0
  da(nd-2)=DBLE(2*(nd-1))*a(nd-1)
  DO k=nd-3,1,-1
    da(k)=DBLE(2*(k+1))*a(k+1)+da(k+2)
  END DO
  da(0)=a(1)+da(2)/2.d0
!
  END SUBROUTINE ChebyDiff

  SUBROUTINE ChebyPR(x,w,nd)
!
! Return the rational Chebyshev points x_j=cot((2j+1)*pi/(2*nd))
! and the integration weights 1/sin^2((2j+1)*pi/(2*nd))
!
! Note that now integration will simply be the midpoint rule
!
  INTEGER, INTENT(IN) :: nd
  DOUBLE PRECISION, DIMENSION(0:nd-1), INTENT(OUT) :: x,w
!
  INTEGER :: j
  DOUBLE PRECISION :: theta
!
  DO j=0,nd-1
    theta=DBLE(2*j+1)*pi/DBLE(2*nd)
    x(j)=1.d0/TAN(theta)
    w(j)=1.d0/(SIN(theta)**2)
  END DO
!
  END SUBROUTINE ChebyPR

  SUBROUTINE I3dC(f,intf,ns,nu,nv)
!
! Integrate in s,u,v - trapezoid in s,u and Chebyshev in v
!
  INTEGER, INTENT(IN) :: ns,nu,nv
  DOUBLE PRECISION, DIMENSION(0:ns-1,0:nu-1,0:nv-1), INTENT(IN) :: f
  DOUBLE PRECISION, INTENT(OUT) :: intf
  DOUBLE PRECISION, DIMENSION(0:nv-1) :: a,b
  DOUBLE PRECISION :: hs,hu,ya,yb
  INTEGER :: ks,ku,nuh,kv
!
  nuh=nu/2
  hs=2.d0*pi/DBLE(ns)
  hu=2.d0*pi/DBLE(nu)
  intf=0.d0
  DO ks=0,ns-1
    DO ku=0,nuh-1
      DO kv=0,nv-1
        a(kv)=f(ks,2*ku,kv)
        b(kv)=f(ks,2*ku+1,kv)
      END DO
      CALL ChebyInt(ya,yb,a,b,nv)
      intf=intf+ya+yb
    END DO
  END DO
!
  intf=intf*hs*hu
!
  END SUBROUTINE I3dC

  SUBROUTINE I3dA(f,intf,wq,ns,nu,nv)
!
! Integrate in s,u,v - trapezoid in s,u and a quadrature rule with
! weights wq in v
!
  INTEGER, INTENT(IN) :: ns,nu,nv
  DOUBLE PRECISION, DIMENSION(0:ns-1,0:nu-1,0:nv), INTENT(IN) :: f
  DOUBLE PRECISION, INTENT(OUT) :: intf
  DOUBLE PRECISION, DIMENSION(0:nv), INTENT(IN) :: wq
  DOUBLE PRECISION :: hs,hu
  INTEGER :: ks,ku,kv
!
  hs=2.d0*pi/DBLE(ns)
  hu=2.d0*pi/DBLE(nu)
  intf=0.d0
  DO kv=0,nv
    DO ku=0,nu-1
      DO ks=0,ns-1
        intf=intf+wq(kv)*f(ks,ku,kv)
      END DO
    END DO
  END DO
!
  intf=intf*hs*hu
!
  END SUBROUTINE I3dA

  SUBROUTINE GaussQCofs(x,w,q)
!
! Compute nodes and weights for Gauss-Legendre quadrature
!
  INTEGER, INTENT(IN) :: q
  DOUBLE PRECISION, DIMENSION(0:q), INTENT(OUT) :: x,w
!
  DOUBLE PRECISION, DIMENSION(0:q) :: dg
  DOUBLE PRECISION, DIMENSION(q) :: bg
  DOUBLE PRECISION, DIMENSION(0:q,0:q) :: V
  DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: wrk
  INTEGER, DIMENSION(:), ALLOCATABLE :: iwrk
!
  INTEGER :: j,info,lwrk,liwrk
!
  lwrk=1+4*(q+1)+(q+1)**2
  ALLOCATE(wrk(lwrk))
  liwrk=3+5*(q+1)
  ALLOCATE(iwrk(liwrk))
!
  dg=0.d0
  DO j=1,q
    bg(j)=DBLE(j)/SQRT(4.d0*DBLE(j**2)-1.d0)
  END DO
!
  CALL dstedc('I',q+1,dg,bg,V,q+1,wrk,lwrk,iwrk,liwrk,info)
  IF (info /= 0) THEN
    PRINT *,'Trouble from dstedc in GaussQCofs: info=',info
    STOP
  END IF
!
  DO j=0,q
    x(j)=dg(j)
    w(j)=2.d0*V(0,j)*V(0,j)
  END DO
!
  END SUBROUTINE GaussQCofs

  SUBROUTINE LegendreP(p,x,n,m)
!
! Evaluate the standard Legendre polynomial of degrees 0:n
!
  INTEGER, INTENT(IN) :: n,m
  DOUBLE PRECISION, DIMENSION(m), INTENT(IN) :: x
  DOUBLE PRECISION, DIMENSION(m,0:n), INTENT(OUT) :: p
  INTEGER :: k,j
!
  DO j=1,m
    p(j,0)=1.d0
  END DO
!
  IF (n > 0) THEN
!
  DO j=1,m
    p(j,1)=x(j)
  END DO
!
  IF (n > 1) THEN
!
  DO k=2,n
    DO j=1,m
      p(j,k)=(DBLE(2*k-1)*x(j)*p(j,k-1)-DBLE(k-1)*p(j,k-2))/DBLE(k)
    END DO
  END DO
!
  END IF
!
  END IF
!
  END SUBROUTINE LegendreP

  SUBROUTINE Romberg(f,fnew,RB,errest,nvar,itmax,it)
!
! Build and evaluate a Romberg acceleration table
! assuming mesh halving and an even error function
!
  INTEGER, INTENT(IN) :: nvar,itmax,it
  DOUBLE PRECISION, DIMENSION(nvar), INTENT(IN) :: fnew
  DOUBLE PRECISION, DIMENSION(itmax,itmax,nvar), INTENT(INOUT) :: RB
  DOUBLE PRECISION, INTENT(OUT) :: errest
  DOUBLE PRECISION, DIMENSION(nvar), INTENT(OUT) :: f
!
  DOUBLE PRECISION :: err,errtab,fac
  INTEGER :: q,k
!
  IF (it==1) THEN
    errest=0.d0
    DO k=1,nvar
      RB(1,1,k)=fnew(k)
      f(k)=fnew(k)
      errest=errest+f(k)**2
    END DO
    errest=SQRT(errest)
  ELSE
    IF (it > itmax) THEN
      PRINT *,'Error from Romberg - maximum iterations exceeded'
      RETURN
    END IF
    errtab=0.d0
    DO k=1,nvar
      RB(it,1,k)=fnew(k)
      errtab=errtab+(RB(it,1,k)-RB(it-1,1,k))**2
      f(k)=fnew(k)
    END DO
    errtab=SQRT(errtab)
    DO q=1,it-1
      fac=2.d0**(2*q)
      err=0.d0
      DO k=1,nvar
        RB(it,q+1,k)=(fac*RB(it,q,k)-RB(it-1,q,k))/(fac-1.d0)
        IF (q < it-1) THEN
          err=err+(RB(it,q+1,k)-RB(it-1,q+1,k))**2
        END IF
      END DO
      IF (q < it-1) THEN
        err=SQRT(err)
        IF (err < errtab) THEN
          DO k=1,nvar
            f(k)=RB(it,q+1,k)
          END DO
          errtab=err
        END IF
      END IF
    END DO
    errest=errtab
!    PRINT *,it,errtab
  END IF
!
  END SUBROUTINE Romberg

END MODULE SpecFuns


*DECK RATQR
      SUBROUTINE RATQR (N, EPS1, D, E, E2, M, W, IND, BD, TYPE, IDEF,
     +   IERR)
C***BEGIN PROLOGUE  RATQR
C***PURPOSE  Compute the largest or smallest eigenvalues of a symmetric
C            tridiagonal matrix using the rational QR method with Newton
C            correction.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4A5, D4C2A
C***TYPE      SINGLE PRECISION (RATQR-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure RATQR,
C     NUM. MATH. 11, 264-272(1968) by REINSCH and BAUER.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 257-265(1971).
C
C     This subroutine finds the algebraically smallest or largest
C     eigenvalues of a SYMMETRIC TRIDIAGONAL matrix by the
C     rational QR method with Newton corrections.
C
C     On Input
C
C        N is the order of the matrix.  N is an INTEGER variable.
C
C        EPS1 is a theoretical absolute error tolerance for the
C          computed eigenvalues.  If the input EPS1 is non-positive, or
C          indeed smaller than its default value, it is reset at each
C          iteration to the respective default value, namely, the
C          product of the relative machine precision and the magnitude
C          of the current eigenvalue iterate.  The theoretical absolute
C          error in the K-th eigenvalue is usually not greater than
C          K times EPS1.  EPS1 is a REAL variable.
C
C        D contains the diagonal elements of the symmetric tridiagonal
C          matrix.  D is a one-dimensional REAL array, dimensioned D(N).
C
C        E contains the subdiagonal elements of the symmetric
C          tridiagonal matrix in its last N-1 positions.  E(1) is
C          arbitrary.  E is a one-dimensional REAL array, dimensioned
C          E(N).
C
C        E2 contains the squares of the corresponding elements of E in
C          its last N-1 positions.  E2(1) is arbitrary.  E2 is a one-
C          dimensional REAL array, dimensioned E2(N).
C
C        M is the number of eigenvalues to be found.  M is an INTEGER
C          variable.
C
C        IDEF should be set to 1 if the input matrix is known to be
C          positive definite, to -1 if the input matrix is known to
C          be negative definite, and to 0 otherwise.  IDEF is an
C          INTEGER variable.
C
C        TYPE should be set to .TRUE. if the smallest eigenvalues are
C          to be found, and to .FALSE. if the largest eigenvalues are
C          to be found.  TYPE is a LOGICAL variable.
C
C     On Output
C
C        EPS1 is unaltered unless it has been reset to its
C          (last) default value.
C
C        D and E are unaltered (unless W overwrites D).
C
C        Elements of E2, corresponding to elements of E regarded as
C          negligible, have been replaced by zero causing the matrix
C          to split into a direct sum of submatrices.  E2(1) is set
C          to 0.0e0 if the smallest eigenvalues have been found, and
C          to 2.0e0 if the largest eigenvalues have been found.  E2
C          is otherwise unaltered (unless overwritten by BD).
C
C        W contains the M algebraically smallest eigenvalues in
C          ascending order, or the M largest eigenvalues in descending
C          order.  If an error exit is made because of an incorrect
C          specification of IDEF, no eigenvalues are found.  If the
C          Newton iterates for a particular eigenvalue are not monotone,
C          the best estimate obtained is returned and IERR is set.
C          W is a one-dimensional REAL array, dimensioned W(N).  W need
C          not be distinct from D.
C
C        IND contains in its first M positions the submatrix indices
C          associated with the corresponding eigenvalues in W --
C          1 for eigenvalues belonging to the first submatrix from
C          the top, 2 for those belonging to the second submatrix, etc.
C          IND is an one-dimensional INTEGER array, dimensioned IND(N).
C
C        BD contains refined bounds for the theoretical errors of the
C          corresponding eigenvalues in W.  These bounds are usually
C          within the tolerance specified by EPS1.  BD is a one-
C          dimensional REAL array, dimensioned BD(N).  BD need not be
C          distinct from E2.
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          6*N+1      if  IDEF  is set to 1 and  TYPE  to .TRUE.
C                     when the matrix is NOT positive definite, or
C                     if  IDEF  is set to -1 and  TYPE  to .FALSE.
C                     when the matrix is NOT negative definite,
C                     no eigenvalues are computed, or
C                     M is greater than N,
C          5*N+K      if successive iterates to the K-th eigenvalue
C                     are NOT monotone increasing, where K refers
C                     to the last such occurrence.
C
C     Note that subroutine TRIDIB is generally faster and more
C     accurate than RATQR if the eigenvalues are clustered.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  R1MACH
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  RATQR
C
      INTEGER I,J,K,M,N,II,JJ,K1,IDEF,IERR,JDEF
      REAL D(*),E(*),E2(*),W(*),BD(*)
      REAL F,P,Q,R,S,EP,QP,ERR,TOT,EPS1,DELTA,MACHEP
      INTEGER IND(*)
      LOGICAL FIRST, TYPE
C
      SAVE FIRST, MACHEP
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  RATQR
      IF (FIRST) THEN
         MACHEP = R1MACH(4)
      ENDIF
      FIRST = .FALSE.
C
      IERR = 0
      JDEF = IDEF
C     .......... COPY D ARRAY INTO W ..........
      DO 20 I = 1, N
   20 W(I) = D(I)
C
      IF (TYPE) GO TO 40
      J = 1
      GO TO 400
   40 ERR = 0.0E0
      S = 0.0E0
C     .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES AND DEFINE
C                INITIAL SHIFT FROM LOWER GERSCHGORIN BOUND.
C                COPY E2 ARRAY INTO BD ..........
      TOT = W(1)
      Q = 0.0E0
      J = 0
C
      DO 100 I = 1, N
         P = Q
         IF (I .EQ. 1) GO TO 60
         IF (P .GT. MACHEP * (ABS(D(I)) + ABS(D(I-1)))) GO TO 80
   60    E2(I) = 0.0E0
   80    BD(I) = E2(I)
C     .......... COUNT ALSO IF ELEMENT OF E2 HAS UNDERFLOWED ..........
         IF (E2(I) .EQ. 0.0E0) J = J + 1
         IND(I) = J
         Q = 0.0E0
         IF (I .NE. N) Q = ABS(E(I+1))
         TOT = MIN(W(I)-P-Q,TOT)
  100 CONTINUE
C
      IF (JDEF .EQ. 1 .AND. TOT .LT. 0.0E0) GO TO 140
C
      DO 110 I = 1, N
  110 W(I) = W(I) - TOT
C
      GO TO 160
  140 TOT = 0.0E0
C
  160 DO 360 K = 1, M
C     .......... NEXT QR TRANSFORMATION ..........
  180    TOT = TOT + S
         DELTA = W(N) - S
         I = N
         F = ABS(MACHEP*TOT)
         IF (EPS1 .LT. F) EPS1 = F
         IF (DELTA .GT. EPS1) GO TO 190
         IF (DELTA .LT. (-EPS1)) GO TO 1000
         GO TO 300
C     .......... REPLACE SMALL SUB-DIAGONAL SQUARES BY ZERO
C                TO REDUCE THE INCIDENCE OF UNDERFLOWS ..........
  190    IF (K .EQ. N) GO TO 210
         K1 = K + 1
         DO 200 J = K1, N
            IF (BD(J) .LE. (MACHEP*(W(J)+W(J-1))) ** 2) BD(J) = 0.0E0
  200    CONTINUE
C
  210    F = BD(N) / DELTA
         QP = DELTA + F
         P = 1.0E0
         IF (K .EQ. N) GO TO 260
         K1 = N - K
C     .......... FOR I=N-1 STEP -1 UNTIL K DO -- ..........
         DO 240 II = 1, K1
            I = N - II
            Q = W(I) - S - F
            R = Q / QP
            P = P * R + 1.0E0
            EP = F * R
            W(I+1) = QP + EP
            DELTA = Q - EP
            IF (DELTA .GT. EPS1) GO TO 220
            IF (DELTA .LT. (-EPS1)) GO TO 1000
            GO TO 300
  220       F = BD(I) / Q
            QP = DELTA + F
            BD(I+1) = QP * EP
  240    CONTINUE
C
  260    W(K) = QP
         S = QP / P
         IF (TOT + S .GT. TOT) GO TO 180
C     .......... SET ERROR -- IRREGULAR END OF ITERATION.
C                DEFLATE MINIMUM DIAGONAL ELEMENT ..........
         IERR = 5 * N + K
         S = 0.0E0
         DELTA = QP
C
         DO 280 J = K, N
            IF (W(J) .GT. DELTA) GO TO 280
            I = J
            DELTA = W(J)
  280    CONTINUE
C     .......... CONVERGENCE ..........
  300    IF (I .LT. N) BD(I+1) = BD(I) * F / QP
         II = IND(I)
         IF (I .EQ. K) GO TO 340
         K1 = I - K
C     .......... FOR J=I-1 STEP -1 UNTIL K DO -- ..........
         DO 320 JJ = 1, K1
            J = I - JJ
            W(J+1) = W(J) - S
            BD(J+1) = BD(J)
            IND(J+1) = IND(J)
  320    CONTINUE
C
  340    W(K) = TOT
         ERR = ERR + ABS(DELTA)
         BD(K) = ERR
         IND(K) = II
  360 CONTINUE
C
      IF (TYPE) GO TO 1001
      F = BD(1)
      E2(1) = 2.0E0
      BD(1) = F
      J = 2
C     .......... NEGATE ELEMENTS OF W FOR LARGEST VALUES ..........
  400 DO 500 I = 1, N
  500 W(I) = -W(I)
C
      JDEF = -JDEF
      GO TO (40,1001), J
C     .......... SET ERROR -- IDEF SPECIFIED INCORRECTLY ..........
 1000 IERR = 6 * N + 1
 1001 RETURN
      END


      SUBROUTINE ZHPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY)
*     .. Scalar Arguments ..
      DOUBLE COMPLEX ALPHA,BETA
      INTEGER INCX,INCY,N
      CHARACTER UPLO
*     ..
*     .. Array Arguments ..
      DOUBLE COMPLEX AP(*),X(*),Y(*)
*     ..
*
*  Purpose
*  =======
*
*  ZHPMV  performs the matrix-vector operation
*
*     y := alpha*A*x + beta*y,
*
*  where alpha and beta are scalars, x and y are n element vectors and
*  A is an n by n hermitian matrix, supplied in packed form.
*
*  Arguments
*  ==========
*
*  UPLO   - CHARACTER*1.
*           On entry, UPLO specifies whether the upper or lower
*           triangular part of the matrix A is supplied in the packed
*           array AP as follows:
*
*              UPLO = 'U' or 'u'   The upper triangular part of A is
*                                  supplied in AP.
*
*              UPLO = 'L' or 'l'   The lower triangular part of A is
*                                  supplied in AP.
*
*           Unchanged on exit.
*
*  N      - INTEGER.
*           On entry, N specifies the order of the matrix A.
*           N must be at least zero.
*           Unchanged on exit.
*
*  ALPHA  - COMPLEX*16      .
*           On entry, ALPHA specifies the scalar alpha.
*           Unchanged on exit.
*
*  AP     - COMPLEX*16       array of DIMENSION at least
*           ( ( n*( n + 1 ) )/2 ).
*           Before entry with UPLO = 'U' or 'u', the array AP must
*           contain the upper triangular part of the hermitian matrix
*           packed sequentially, column by column, so that AP( 1 )
*           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
*           and a( 2, 2 ) respectively, and so on.
*           Before entry with UPLO = 'L' or 'l', the array AP must
*           contain the lower triangular part of the hermitian matrix
*           packed sequentially, column by column, so that AP( 1 )
*           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
*           and a( 3, 1 ) respectively, and so on.
*           Note that the imaginary parts of the diagonal elements need
*           not be set and are assumed to be zero.
*           Unchanged on exit.
*
*  X      - COMPLEX*16       array of dimension at least
*           ( 1 + ( n - 1 )*abs( INCX ) ).
*           Before entry, the incremented array X must contain the n
*           element vector x.
*           Unchanged on exit.
*
*  INCX   - INTEGER.
*           On entry, INCX specifies the increment for the elements of
*           X. INCX must not be zero.
*           Unchanged on exit.
*
*  BETA   - COMPLEX*16      .
*           On entry, BETA specifies the scalar beta. When BETA is
*           supplied as zero then Y need not be set on input.
*           Unchanged on exit.
*
*  Y      - COMPLEX*16       array of dimension at least
*           ( 1 + ( n - 1 )*abs( INCY ) ).
*           Before entry, the incremented array Y must contain the n
*           element vector y. On exit, Y is overwritten by the updated
*           vector y.
*
*  INCY   - INTEGER.
*           On entry, INCY specifies the increment for the elements of
*           Y. INCY must not be zero.
*           Unchanged on exit.
*
*
*  Level 2 Blas routine.
*
*  -- Written on 22-October-1986.
*     Jack Dongarra, Argonne National Lab.
*     Jeremy Du Croz, Nag Central Office.
*     Sven Hammarling, Nag Central Office.
*     Richard Hanson, Sandia National Labs.
*
*
*     .. Parameters ..
      DOUBLE COMPLEX ONE
      PARAMETER (ONE= (1.0D+0,0.0D+0))
      DOUBLE COMPLEX ZERO
      PARAMETER (ZERO= (0.0D+0,0.0D+0))
*     ..
*     .. Local Scalars ..
      DOUBLE COMPLEX TEMP1,TEMP2
      INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY
*     ..
*     .. External Functions ..
      LOGICAL LSAME
      EXTERNAL LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC DBLE,DCONJG
*     ..
*
*     Test the input parameters.
*
      INFO = 0
      IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
          INFO = 1
      ELSE IF (N.LT.0) THEN
          INFO = 2
      ELSE IF (INCX.EQ.0) THEN
          INFO = 6
      ELSE IF (INCY.EQ.0) THEN
          INFO = 9
      END IF
      IF (INFO.NE.0) THEN
          CALL XERBLA('ZHPMV ',INFO)
          RETURN
      END IF
*
*     Quick return if possible.
*
      IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
*
*     Set up the start points in  X  and  Y.
*
      IF (INCX.GT.0) THEN
          KX = 1
      ELSE
          KX = 1 - (N-1)*INCX
      END IF
      IF (INCY.GT.0) THEN
          KY = 1
      ELSE
          KY = 1 - (N-1)*INCY
      END IF
*
*     Start the operations. In this version the elements of the array AP
*     are accessed sequentially with one pass through AP.
*
*     First form  y := beta*y.
*
      IF (BETA.NE.ONE) THEN
          IF (INCY.EQ.1) THEN
              IF (BETA.EQ.ZERO) THEN
                  DO 10 I = 1,N
                      Y(I) = ZERO
   10             CONTINUE
              ELSE
                  DO 20 I = 1,N
                      Y(I) = BETA*Y(I)
   20             CONTINUE
              END IF
          ELSE
              IY = KY
              IF (BETA.EQ.ZERO) THEN
                  DO 30 I = 1,N
                      Y(IY) = ZERO
                      IY = IY + INCY
   30             CONTINUE
              ELSE
                  DO 40 I = 1,N
                      Y(IY) = BETA*Y(IY)
                      IY = IY + INCY
   40             CONTINUE
              END IF
          END IF
      END IF
      IF (ALPHA.EQ.ZERO) RETURN
      KK = 1
      IF (LSAME(UPLO,'U')) THEN
*
*        Form  y  when AP contains the upper triangle.
*
          IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
              DO 60 J = 1,N
                  TEMP1 = ALPHA*X(J)
                  TEMP2 = ZERO
                  K = KK
                  DO 50 I = 1,J - 1
                      Y(I) = Y(I) + TEMP1*AP(K)
                      TEMP2 = TEMP2 + DCONJG(AP(K))*X(I)
                      K = K + 1
   50             CONTINUE
                  Y(J) = Y(J) + TEMP1*DBLE(AP(KK+J-1)) + ALPHA*TEMP2
                  KK = KK + J
   60         CONTINUE
          ELSE
              JX = KX
              JY = KY
              DO 80 J = 1,N
                  TEMP1 = ALPHA*X(JX)
                  TEMP2 = ZERO
                  IX = KX
                  IY = KY
                  DO 70 K = KK,KK + J - 2
                      Y(IY) = Y(IY) + TEMP1*AP(K)
                      TEMP2 = TEMP2 + DCONJG(AP(K))*X(IX)
                      IX = IX + INCX
                      IY = IY + INCY
   70             CONTINUE
                  Y(JY) = Y(JY) + TEMP1*DBLE(AP(KK+J-1)) + ALPHA*TEMP2
                  JX = JX + INCX
                  JY = JY + INCY
                  KK = KK + J
   80         CONTINUE
          END IF
      ELSE
*
*        Form  y  when AP contains the lower triangle.
*
          IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
              DO 100 J = 1,N
                  TEMP1 = ALPHA*X(J)
                  TEMP2 = ZERO
                  Y(J) = Y(J) + TEMP1*DBLE(AP(KK))
                  K = KK + 1
                  DO 90 I = J + 1,N
                      Y(I) = Y(I) + TEMP1*AP(K)
                      TEMP2 = TEMP2 + DCONJG(AP(K))*X(I)
                      K = K + 1
   90             CONTINUE
                  Y(J) = Y(J) + ALPHA*TEMP2
                  KK = KK + (N-J+1)
  100         CONTINUE
          ELSE
              JX = KX
              JY = KY
              DO 120 J = 1,N
                  TEMP1 = ALPHA*X(JX)
                  TEMP2 = ZERO
                  Y(JY) = Y(JY) + TEMP1*DBLE(AP(KK))
                  IX = JX
                  IY = JY
                  DO 110 K = KK + 1,KK + N - J
                      IX = IX + INCX
                      IY = IY + INCY
                      Y(IY) = Y(IY) + TEMP1*AP(K)
                      TEMP2 = TEMP2 + DCONJG(AP(K))*X(IX)
  110             CONTINUE
                  Y(JY) = Y(JY) + ALPHA*TEMP2
                  JX = JX + INCX
                  JY = JY + INCY
                  KK = KK + (N-J+1)
  120         CONTINUE
          END IF
      END IF
*
      RETURN
*
*     End of ZHPMV .
*
      END


module class_Circle
    implicit none
    private
    public :: Circle, circle_area, circle_print

    real :: pi=3.1415926535897931d0 ! Class-wide private constant

    type Circle
        real :: radius
    end type Circle
contains
    function circle_area(this) result(area)
        type(Circle), intent(in) :: this
        real :: area
        area = pi * this%radius**2
    end function circle_area

    subroutine circle_print
        type(Circle), intent(in) :: this
        real :: area
        area = circle_area(this)  ! Call the circle_area function
        print*, 'Circle: r = ', this%radius, 'area = ', area
    end subroutine circle_print
end module class_Circle


!********************************************************************************
!   CONVG: Test the convergence rate of FPML
!   Author: Thomas R. Cameron, Davidson College
!   Last Modified: 1 November 2018
!********************************************************************************
! Tests the convergence rate of FPML on polynomials with random complex roots
! in the unit circle.
!********************************************************************************
program convg
    use fpml
    use mpmodule
    implicit none
    ! testing variables
    integer                                     :: deg, j
    integer, parameter                          :: itmax = 10
    real(kind=dp), parameter                    :: pi = 3.141592653589793d0
    real(kind=dp), dimension(:), allocatable    :: coeffs, xr, xi
    real(kind=dp), dimension(:,:), allocatable  :: error
    complex(kind=dp), dimension(:), allocatable :: exact_roots
    ! FPML variables
    integer, dimension(:), allocatable          :: conv
    real(kind=dp), dimension(:), allocatable    :: berr, cond
    complex(kind=dp), dimension(:), allocatable :: p, roots

    call mpinit

    ! Testing: convergence
    call init_random_seed()
    open(unit=1,file="data_files/convg.dat")
    write(1,'(A)') 'Iteration, Error-1, Error-2, Error-3, Error-4, Error-5, Error-6'
    allocate(error(itmax,6))
    deg = 4;
    j=1;
    do while(deg<=24)
        ! allocate
        allocate(exact_roots(deg), p(deg+1), roots(deg), berr(deg), cond(deg), conv(deg), xr(deg), xi(deg), coeffs(deg))
        ! roots
        call rand_unitcmplx(exact_roots,deg)
        xr = dble(exact_roots)
        xi = aimag(exact_roots)
        ! polynomial
        call rootstocoeffs(deg,xr,xi,coeffs)
        p(1:deg) = (/ (cmplx(coeffs(j),0,kind=dp), j=1,deg)/)
        p(deg+1) = cmplx(1,0,kind=dp)
        ! error
        error(:,j)=0d0
        ! solve
        call conv_main(p, deg, roots, berr, cond, conv, itmax, error(:,j), exact_roots)
        ! deallocate
        deallocate(exact_roots, p, roots, berr, cond, conv, xr, xi, coeffs)
        ! update deg and j
        deg = deg+4
        j = j+1
    end do

    ! write results to file
    do j=1,itmax
        write(1,'(I10)', advance='no') j
        write(1,'(A)', advance='no') ','
        write(1,'(ES15.2)',advance='no') error(j,1)
        write(1,'(A)',advance='no') ','
        write(1,'(ES15.2)',advance='no') error(j,2)
        write(1,'(A)',advance='no') ','
        write(1,'(ES15.2)',advance='no') error(j,3)
        write(1,'(A)',advance='no') ','
        write(1,'(ES15.2)',advance='no') error(j,4)
        write(1,'(A)',advance='no') ','
        write(1,'(ES15.2)',advance='no') error(j,5)
        write(1,'(A)',advance='no') ','
        write(1,'(ES15.2)') error(j,6)
    end do
    deallocate(error)
    ! close file
    close(1)
contains
    !************************************************
    !                       conv_main               *
    !************************************************
    ! Modified FPML for storing the convergence rate
    ! of the root approximations. Before each
    ! iteration, the roots and check array are
    ! sorted with respect to exact roots. Then the
    ! max relative forward error is stored in err.
    !************************************************
    subroutine conv_main(p, deg, roots, berr, cond, conv, itmax, err, exact_roots)
        implicit none
        ! argument variables
        integer, intent(in)             :: deg, itmax
        integer, intent(out)            :: conv(:)
        real(kind=dp), intent(out)      :: berr(:), cond(:), err(:)
        complex(kind=dp), intent(in)    :: p(:)
        complex(kind=dp), intent(out)   :: roots(:), exact_roots(:)
        ! local variables
        integer                         :: i, j, nz
        real(kind=dp), dimension(deg+1) :: alpha
        real(kind=dp)                   :: r
        complex(kind=dp)                :: b, c, z

        ! initial estimates
        alpha = abs(p)
        conv = 0
        nz = 0
        call estimates(alpha, deg, roots, conv, nz)
        ! main loop
        alpha = (/ (alpha(i)*(3.8*(i-1)+1),i=1,deg+1)/)
        do i=1,itmax
            err(i) = maxrel_fwderr(roots, exact_roots, deg)
            do j=1,deg
                if(conv(j)==0) then
                    z = roots(j)
                    r = abs(z)
                    if(r > 1) then
                        call rcheck_lag(p, alpha, deg, b, c, z, r, conv(j), berr(j), cond(j))
                    else
                        call check_lag(p, alpha, deg, b, c, z, r, conv(j), berr(j), cond(j))
                    end if
                    if(conv(j)==0) then
                        call modify_lag(deg, b, c, z, j, roots)
                        roots(j) = roots(j) - c
                    else
                        nz = nz + 1
                        if(nz==deg) return
                    end if
                end if
            end do
        end do
    end subroutine conv_main
    !************************************************
    !                   init_random_seed            *
    !************************************************
    ! Initiate random seed using system_clock. This
    ! seed is then available for the random number
    ! generator in random_number for the life of
    ! the program.
    !************************************************
    subroutine init_random_seed()
        implicit none
        ! local variables
        integer                             :: i, n , clock
        integer, dimension(:), allocatable  :: seed
        ! intrinsic subroutines
        intrinsic                           :: random_seed, system_clock

        ! main
        call random_seed(size = n)
        allocate(seed(n))

        call system_clock(count = clock)
        seed = clock + 37 * (/ (i - 1, i = 1,n) /)
        call random_seed(put = seed)

        deallocate(seed)
    end subroutine init_random_seed
    !************************************************
    !                       maxrel_fwderr           *
    !************************************************
    ! Compute the maximum relative forward error
    ! in the approximation roots to exact_roots.
    !************************************************
    function maxrel_fwderr(roots, exact_roots, deg) result(res)
        implicit none
        ! argument variables
        integer, intent(in)             :: deg
        complex(kind=dp), intent(in)    :: exact_roots(:)
        complex(kind=dp), intent(inout) :: roots(:)
        ! local variables
        integer                         :: i, j, k
        real(kind=dp)                   :: hd, res

        ! main
        res = 0d0
        do i=1,deg
            hd = abs(roots(i)-exact_roots(1))
            j = 1
            do k = 2,deg
                if (hd>abs(roots(i)-exact_roots(k))) then
                    hd = abs(roots(i)-exact_roots(k))
                    j = k
                end if
            end do
            if (res<hd/abs(exact_roots(j))) then
                res = hd/abs(exact_roots(j))
            end if
        end do
        return
    end function maxrel_fwderr
    !************************************************
    !                       rand_unitcmplx          *
    !************************************************
    ! creates a random array of unitary complex numbers.
    ! Complex numbers come in conjugate pairs, thus
    ! array should have size divisible by 2.
    !************************************************
    subroutine rand_unitcmplx(array,size)
        implicit none
        ! argument variables
        integer, intent(in)             :: size
        complex(kind=dp), intent(out)   :: array(:)
        ! local variables
        integer                         :: k
        real(kind=dp)                   :: theta1, theta2, r

        ! main
        do k=1,size,2
            call random_number(theta1)
            call random_number(theta2)
            call random_number(r)
            theta1 = -1 + 2*theta1
            theta2 = -1 + 2*theta2
            array(k) = r*cmplx(cos(theta1*pi),sin(theta2*pi),kind=dp)
            array(k+1) = conjg(array(k))
        end do
    end subroutine rand_unitcmplx
end program convg


c     ============================================
      subroutine clawpack46_b4step2(maxmx,maxmy,mbc,
     &            mx,my,meqn,q,
     &            xlower,ylower,dx,dy,t,dt,maux,aux)
c     ============================================
c
c     # called from claw2 before each call to step2.
c     # use to set time-dependent aux arrays or perform other tasks
c     # which must be done every time step.

c
c     # dummy routine

      implicit double precision (a-h,o-z)
      dimension q(1-mbc:maxmx+mbc,1-mbc:maxmy+mbc, meqn)
      dimension aux(1-mbc:maxmx+mbc,1-mbc:maxmy+mbc, maux)
      double precision fp(-1:1,-1:1), qavg(-1:1,-1:1)
      double precision qp, qlap, flap

      integer i,j,ii,jj
c
c     computes point values of the conserved quantities
      do i=2-mbc, mx+mbc-1
         do j=2-mbc, my+mbc-1
            do ii = -1,1
                do jj = -1,1
                  qavg(ii,jj) = q(i+ii,j+jj,1)
                end do
            end do
            qlap = (qavg(-1,0) + qavg(1,0) + qavg(0,-1) +
     &                    qavg(0,1) - 4*qavg(0,0))

c           # Compute pointwise from average values
            aux(i,j,1) = qavg(0,0) - qlap/24.
        end do
      end do

c     # Use cell-averaged values instead of pointwise values at
c     # last layers of ghost cells (where we cannot compute the
c     # Laplacian.)
c     #
c     # Instead, use :
c     # (2, -5, 4, -1) for second order one-sided derivative
c     # approximation to second derivative
      do j = 1-mbc,my+mbc
          aux(1-mbc,j,1) = q(1-mbc,j,1)
          aux(mx+mbc,j,1) = q(mx+mbc,j,1)
      enddo

      do i = 1-mbc,mx+mbc
          aux(i,1-mbc,1) = q(i,1-mbc,1)
          aux(i,my+mbc,1) = q(i,my+mbc,1)
      enddo

      do i=2-mbc, mx+mbc-1
         do j=2-mbc, my+mbc-1
            do ii = -1,1
                do jj = -1,1
                  qp = aux(i+ii,j+jj,1)
                  fp(ii,jj) = 0.5*qp**2
                end do
            end do
c           # Compute the average flux from pointwise values
            flap = (fp(-1,0) + fp(1,0) + fp(0,-1) +
     &                  fp(0,1) - 4*fp(0,0))
            aux(i,j,2) = fp(0,0) + flap/24.
        end do
      end do

      return
      end


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

    Module dgees_example_mod

!     DGEES Example Program Module:
!            Parameters and User-defined Routines

!     .. Use Statements ..
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Accessibility Statements ..
      Private
      Public :: select
!     .. Parameters ..
      Integer, Parameter, Public :: nb = 64, nin = 5, nout = 6
    Contains
      Function select(wr, wi)

!       Logical function select for use with DGEES (DGEES)
!       Returns the value .TRUE. if the eigenvalue is real and positive

!       .. Function Return Value ..
        Logical :: select
!       .. Scalar Arguments ..
        Real (Kind=dp), Intent (In) :: wi, wr
!       .. Executable Statements ..
        select = (wr>0._dp .And. wi==0._dp)
        Return
      End Function
    End Module
    Program dgees_example

!     DGEES Example Main Program

!     .. Use Statements ..
      Use blas_interfaces, Only: dgemm
      Use dgees_example_mod, Only: nb, nin, nout, select
      Use lapack_example_aux, Only: nagf_file_print_matrix_real_gen
      Use lapack_interfaces, Only: dgees, dlange
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Local Scalars ..
      Real (Kind=dp) :: alpha, beta, norm
      Integer :: i, ifail, info, lda, ldc, ldd, ldvs, lwork, n, sdim
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: a(:, :), c(:, :), d(:, :), vs(:, :), &
        wi(:), work(:), wr(:)
      Real (Kind=dp) :: dummy(1), rwork(1)
      Logical, Allocatable :: bwork(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: epsilon, max, nint
!     .. Executable Statements ..
      Write (nout, *) 'DGEES Example Program Results'
      Write (nout, *)
      Flush (nout)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      lda = n
      ldc = n
      ldd = n
      ldvs = n
      Allocate (a(lda,n), c(ldc,n), d(ldd,n), vs(ldvs,n), wi(n), wr(n), &
        bwork(n))

!     Use routine workspace query to get optimal workspace.
      lwork = -1
      Call dgees('Vectors (Schur)', 'Sort', select, n, a, lda, sdim, wr, wi, &
        vs, ldvs, dummy, lwork, bwork, info)

!     Make sure that there is enough workspace for block size nb.
      lwork = max((nb+2)*n, nint(dummy(1)))
      Allocate (work(lwork))

!     Read in the matrix A
      Read (nin, *)(a(i,1:n), i=1, n)

!     Copy A into D
      d(1:n, 1:n) = a(1:n, 1:n)

!     Print matrix A
!     ifail: behaviour on error exit
!            =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
      ifail = 0
      Call nagf_file_print_matrix_real_gen('General', ' ', n, n, a, lda, &
        'Matrix A', ifail)

      Write (nout, *)
      Flush (nout)

!     Find the Schur factorization of A
      Call dgees('Vectors (Schur)', 'Sort', select, n, a, lda, sdim, wr, wi, &
        vs, ldvs, work, lwork, bwork, info)

      If (info==0 .Or. info==(n+2)) Then

!       Compute A - Z*T*Z^T from the factorization of A and store in matrix D
        alpha = 1.0_dp
        beta = 0.0_dp
        Call dgemm('N', 'N', n, n, n, alpha, vs, ldvs, a, lda, beta, c, ldc)
        alpha = -1.0_dp
        beta = 1.0_dp
        Call dgemm('N', 'T', n, n, n, alpha, c, ldc, vs, ldvs, beta, d, ldd)

!       Find norm of matrix D and print warning if it is too large
        norm = dlange('O', ldd, n, d, ldd, rwork)
        If (norm>epsilon(1.0E0_dp)**0.8_dp) Then
          Write (nout, *) 'Norm of A-(Z*T*Z^T) is much greater than 0.'
          Write (nout, *) 'Schur factorization has failed.'
        Else

!         Print solution
          Write (nout, 100) &
            'Number of eigenvalues for which SELECT is true = ', sdim, &
            '(dimension of invariant subspace)'

          Write (nout, *)
!         Print eigenvalues.
          Write (nout, *) 'Selected eigenvalues'
          Write (nout, 120)(' (', wr(i), ',', wi(i), ')', i=1, sdim)
          Write (nout, *)

          If (info==(n+2)) Then
            Write (nout, 130) '***Note that rounding errors mean ', &
              'that leading eigenvalues in the Schur form', &
              'no longer satisfy SELECT = .TRUE.'
            Write (nout, *)
          End If

        End If

      Else
        Write (nout, 110) 'Failure in DGEES. INFO = ', info
      End If

100   Format (1X, A, I4, /, 1X, A)
110   Format (1X, A, I4)
120   Format (1X, A, F8.4, A, F8.4, A)
130   Format (1X, 2A, /, 1X, A)
    End Program


      DOUBLE PRECISION FUNCTION slDPAV ( V1, V2 )
*+
*     - - - - -
*      D P A V
*     - - - - -
*
*  Position angle of one celestial direction with respect to another.
*
*  (double precision)
*
*  Given:
*     V1    d(3)    direction cosines of one point
*     V2    d(3)    direction cosines of the other point
*
*  (The coordinate frames correspond to RA,Dec, Long,Lat etc.)
*
*  The result is the bearing (position angle), in radians, of point
*  V2 with respect to point V1.  It is in the range +/- pi.  The
*  sense is such that if V2 is a small distance east of V1, the
*  bearing is about +pi/2.  Zero is returned if the two points
*  are coincident.
*
*  V1 and V2 need not be unit vectors.
*
*  The routine slDBER performs an equivalent function except
*  that the points are specified in the form of spherical
*  coordinates.
*
*  Last revision:   16 March 2005
*
*  Copyright P.T.Wallace.  All rights reserved.
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program 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 General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      DOUBLE PRECISION V1(3),V2(3)

      DOUBLE PRECISION X1,Y1,Z1,W,X2,Y2,Z2,SQ,CQ

*  The unit vector to point 1.
      X1 = V1(1)
      Y1 = V1(2)
      Z1 = V1(3)
      W = SQRT(X1*X1+Y1*Y1+Z1*Z1)
      IF (W.NE.0D0) THEN
         X1 = X1/W
         Y1 = Y1/W
         Z1 = Z1/W
      END IF

*  The vector to point 2.
      X2 = V2(1)
      Y2 = V2(2)
      Z2 = V2(3)

*  Position angle.
      SQ = Y2*X1-X2*Y1
      CQ = Z2*(X1*X1+Y1*Y1)-Z1*(X2*X1+Y2*Y1)
      IF (SQ.EQ.0D0.AND.CQ.EQ.0D0) CQ=1D0
      slDPAV = ATAN2(SQ,CQ)

      END