    module layer1_m
        use kind_m
        use mpg_m
        implicit none
        private
        public :: isubband_normalization, bit_allocation, iquantization
        integer, private :: i_
        ! ISO Table B.1 -- Layer I,II scalefactors
        real(kd), parameter :: scale_factor(0:63) = &
                              [(1.0e-14_kd * anint(1.0e14_kd * 2.0_kd * 2.0_kd**(-real(i_, kd) / 3.0_kd )), i_ = 0, 63)]

        ! ISO Table C.2 -- Layer I  Signal-to-Noise Ratios
        real(kd), parameter :: snr(0:*) =[ 0.00_kd,  7.00_kd, 16.00_kd, 25.28_kd, 31.59_kd, 37.75_kd, 43.84_kd, &
                                        49.89_kd, 55.93_kd, 61.96_kd, 67.98_kd, 74.01_kd, 80.03_kd, 86.05_kd, 92.01_kd]
        ! empirically better SNR = 20 * log(2^n)
        !real(kd), parameter :: snr(0:14) = [(20.0_kd * log10(2.0_kd) * i_, i_ = 0, 14)]

        ! ISO Table C.3 -- Layer I Quantization Coefficients
        real(kd), parameter :: tmp(14) = [( 1.0_kd / 2.0_kd**real(i_ + 1, kd), i_ = 1, 14)]
        real(kd), parameter :: a(14) = [ 1.0e-9_kd * anint(1.0e9_kd * (1.0e0_kd - tmp))]
        real(kd), parameter :: b(14) = [-1.0e-9_kd * anint(1.0e9_kd * tmp)]
    contains
        pure function isubband_normalization(subband) result(iscale_factor)
            real(kd), intent(in) :: subband(0:, 0:, 0:)
            integer :: iscale_factor(0:31, 0:size(subband, 3))
            integer :: ichannel, iband
            forall(iband = 0:31, ichannel = 0:size(subband, 3))
                iscale_factor(iband, ichannel) = iscale_fac_sub(subband(iband, :, ichannel))
            end forall
        contains
            pure integer function iscale_fac_sub(x) result(ires)
                real(kd), intent(in) :: x(0:)
                do ires = 62, 0, -1
                    if (maxval(abs(x), dim = 1) < scale_factor(ires)) exit
                end do
            end function iscale_fac_sub
        end function isubband_normalization

        function bit_allocation(mpg, smr, max_bits) result(ialloc_bits)
            type(mpg_t), intent(in) :: mpg
            real(kd), intent(in) :: smr(:, :)
            integer , intent(in) :: max_bits
            integer :: ialloc_bits(32, size(smr, 2))
            integer  :: max_pos(2), itot_bits, k
            real(kd) :: rmnr(32, size(smr, 2)) ! size(smr, 2) = no. of channel

            itot_bits = 32 + 4 * 32 * size(smr, 2) ! 32bits for header + 4*32*nch bits required for the scale factor bits :
            if (mpg%icrc == 0) itot_bits = itot_bits + 16 ! 16bits required for the crc
            ialloc_bits = 0
            rmnr = smr - snr(0)
            do
                select case (max_bits - itot_bits)
                case (0:11) ! no more bits left
                    exit
                case (12:29) ! cannot allocate to new place
                    max_pos = maxloc(rmnr, mask = ialloc_bits < 13 .AND. ialloc_bits /= 0)
                case (30:)   !
                    max_pos = maxloc(rmnr, mask = ialloc_bits < 13)
                    if (rmnr( max_pos(1), max_pos(2) ) < -0.44d0) then ! threshold margin 10% -0.46 20% -1.0
                        max_pos = maxloc(rmnr, mask = ialloc_bits == 0)
                        if (max_pos(1) == 0) max_pos = maxloc(rmnr, mask = ialloc_bits < 13)
                    end if
                case default
                     stop 'impossible!: bit_allocation'
                end select
                k = ialloc_bits( max_pos(1), max_pos(2) )
                if (k == 13) exit
                if (k == 0) then
                    itot_bits = itot_bits + 6 + 12 * 2 ! first time: scalefactor 6 bits + 12 * 2 bits
                else
                    itot_bits = itot_bits + 12         ! 12 * 1 bit
                end if
                ialloc_bits( max_pos(1), max_pos(2) ) = k + 1
                rmnr       ( max_pos(1), max_pos(2) ) = smr( max_pos(1), max_pos(2) ) - snr(k + 1)
            end do
        end function bit_allocation

        pure function iquantization(ialloc_bits, subband, iscale_factor) result(isubband)
            integer , intent(in) :: ialloc_bits(0:, 0:), iscale_factor(0:, 0:)
            real(kd), intent(in) :: subband(0:, 0:, 0:)
            integer :: isubband(0:31, 0:11, 0:ubound(subband, 3))
            integer :: ichannel, iband, k, m
            real(kd) :: s(12)
            do ichannel = 0, ubound(subband, 3)
                do iband = 0, 31
                    k = ialloc_bits(iband, ichannel)
                    m = iscale_factor(iband, ichannel)
                    if (k /= 0) then
                         s = a(k) * subband(iband, :, ichannel)  / scale_factor(m) + b(k)
                         isubband(iband, :, ichannel) = floor( (s + 1.0_kd) * 2**k )
                    else
                         isubband(iband, :, ichannel) = 0
                    end if
                end do
            end do
        end function iquantization
    end module layer1_m


!=======================================================================
  SUBROUTINE vhwf(n, l, z, nr, r, vh, ierr)
!=======================================================================
!
!   This program returns the vector of values, vh(i), of a normalized
!   hydrogenic function with nuclear charge z and quantum numbers (n,l)
!   at values of the radius, r(i),  i=1,nr.
!
!   SUBROUTINE contained:  hnorm
!
!-----------------------------------------------------------------------
!
!   on entry
!   --------
!
!       n     principal quantum number
!       l     angular quantum number
!       z     Nuclear charge
!       nr    number of points in the vector
!       r     values at which radial function is to be evaluated, in
!             increasing order
!
!   on exit
!   -------
!
!       vh    values of the hydrogenic radial functions
!       ierr  error condition; 0 for normal return; 1 otherwise
!
!-----------------------------------------------------------------------
!
     IMPLICIT NONE
     INTEGER, INTENT(IN) :: n, l, nr
     INTEGER, INTENT(OUT) :: ierr
     REAL(KIND=8), INTENT(IN) :: z
     REAL(KIND=8), DIMENSION(nr), INTENT(IN) :: r
     REAL(KIND=8), DIMENSION(nr), INTENT(OUT) :: vh

     ! .. Local variables

     INTEGER :: k, i, nm
     REAL(KIND=8) :: a, b, c, factor
     REAL(KIND=8), DIMENSION(nr) :: w, p

     CALL hnorm       ! .. gets the normalization factor
     k = n - l - 1

     ! .. store the argument of the exponential factor

     w = -2.D0*z*r/n

     ! .. to avoid underlow, determine point at which function will be zero
     ! .. Note that exp(-150) = 0.7175 10**-65

     nm = nr
     do
        if (w(nm) < -150.D0 .AND. nm /= -1) then
           vh(nm) = 0.D0
           nm = nm - 1
        else
           EXIT
        end if
     end do

     ! .. Initialize the recurrence relation for each value of r(i)

     p(1:nm) = 1.D0

     a = 1.D0
     b = k
     c = n + l
     ierr = 0

     SELECT CASE (k)

     CASE (:-1)      ! .. all values below 0
        ierr = 1
        RETURN

     CASE (1:)      ! .. all values above 0

        ! .. Apply the recurrence relation when k is positive

        do I = 1, k
           p(1:nm) = 1.D0 + a/b*p(1:nm)/c*w(1:nm)
           a = a + 1.D0
           b = b - 1.D0
           c = c - 1.D0
        end do
     END SELECT

     ! .. Multiply the factor by the exponential

     vh(1:nm) = factor*p(1:nm)*EXP(w(1:nm)/2.D0)*(-w(1:nm))**(l + 1)

  CONTAINS

     !====================================================================
     SUBROUTINE hnorm
        !====================================================================
        !
        !   returns the value of the normalization constant for an
        !   hydrogenic function with nuclear charge z, and orbital
        !   quantum numbers (n,l)
        !
        !--------------------------------------------------------------------
        !
        IMPLICIT NONE

        ! .. local variables
        INTEGER :: m, i
        REAL(KIND=8) :: a, b, d, t

        m = l + l + 1
        a = n + l
        b = m
        t = a
        d = b
        m = m - 1

        if (m > 0) then
           do i = 1, m
              a = a - 1.d0
              b = b - 1.d0
              t = t*a
              d = d*b
           end do
        end if
        factor = SQRT(z*t)/(n*d)
     END SUBROUTINE hnorm

  END SUBROUTINE vhwf


!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

      module m_eulerrot
c************************************
c     Perform Euler rotations.
c     Y. Mokrousov
c
c     tidied up version
c     Frank Freimuth
c************************************
      contains
      subroutine eulerrot(
     >               nwfs,alpha,beta,gamma,
     <               amx)
c************************************************************************
c..Perform "nwfs" Euler rotations.
c..Input: Set of "nwfs" Euler angles: alpha(i),beta(i),gamma(i); i=1,nwfs
c..Output: "nwfs" rotation matrices: amx(:,:,i); i=1,nwfs
c************************************************************************

      implicit none

      integer, intent (in)  :: nwfs
      real,    intent (in)  :: alpha(nwfs),beta(nwfs),gamma(nwfs)
      real,    intent (out) :: amx(3,3,nwfs)

      integer :: nwf

      do nwf = 1,nwfs
         call eulerrot1(
     >                  alpha(nwf),beta(nwf),gamma(nwf),
     <                  amx(1,1,nwf) )
      enddo

      end subroutine eulerrot

      subroutine eulerrot1(
     >               alpha,beta,gamma,
     <               amx)
c***********************************************************************
c..Perform one Euler rotation.
c..Input: Euler angles: alpha, beta, gamma
c..Output: Rotation matrix: amx(:,:)
c
c..Given the Euler angles, the following procedure is
c..performed:
c..1. Rotation around the z-axis by alpha (matrix D)
c..2. Rotation around the x-axis by beta  (matrix C)
c..3. Rotation around the z-axis by gamma again. (matrix B)
c..The overall rotation is given by the matrix A = B*C*D
c***********************************************************************

      implicit none

      real,    intent (in)  :: alpha,beta,gamma
      real,    intent (out) :: amx(3,3)

      real    :: bmx(3,3),cmx(3,3),dmx(3,3),hmx(3,3)

      dmx(1,1) = cos(alpha) ; dmx(1,2) = sin(alpha) ; dmx(1,3) = 0.
      dmx(2,1) =-sin(alpha) ; dmx(2,2) = cos(alpha) ; dmx(2,3) = 0.
      dmx(3,1) = 0.         ; dmx(3,2) = 0.         ; dmx(3,3) = 1.

      cmx(1,1) = 1.  ; cmx(1,2) = 0.         ; cmx(1,3) = 0.
      cmx(2,1) = 0.  ; cmx(2,2) = cos(beta)  ; cmx(2,3) = sin(beta)
      cmx(3,1) = 0.  ; cmx(3,2) =-sin(beta)  ; cmx(3,3) = cos(beta)

      bmx(1,1) = cos(gamma) ; bmx(1,2) = sin(gamma) ; bmx(1,3) = 0.
      bmx(2,1) =-sin(gamma) ; bmx(2,2) = cos(gamma) ; bmx(2,3) = 0.
      bmx(3,1) = 0.         ; bmx(3,2) = 0.         ; bmx(3,3) = 1.

      hmx = matmul(cmx,dmx)
      amx = matmul(bmx,hmx)

      end subroutine eulerrot1

      end module m_eulerrot


      SUBROUTINE SMOOFT(Y,N,PTS)
      PARAMETER(MMAX=1024)
      DIMENSION Y(MMAX)
      M=2
      NMIN=N+2.*PTS
1     IF(M.LT.NMIN)THEN
        M=2*M
      GO TO 1
      ENDIF
      IF(M.GT.MMAX) PAUSE 'MMAX too small'
      CONST=(PTS/M)**2
      Y1=Y(1)
      YN=Y(N)
      RN1=1./(N-1.)
      DO 11 J=1,N
        Y(J)=Y(J)-RN1*(Y1*(N-J)+YN*(J-1))
11    CONTINUE
      IF(N+1.LE.M)THEN
        DO 12 J=N+1,M
          Y(J)=0.
12      CONTINUE
      ENDIF
      MO2=M/2
      CALL REALFT(Y,MO2,1)
      Y(1)=Y(1)/MO2
      FAC=1.
      DO 13 J=1,MO2-1
        K=2*J+1
        IF(FAC.NE.0.)THEN
          FAC=AMAX1(0.,(1.-CONST*J**2)/MO2)
          Y(K)=FAC*Y(K)
          Y(K+1)=FAC*Y(K+1)
        ELSE
          Y(K)=0.
          Y(K+1)=0.
        ENDIF
13    CONTINUE
      FAC=AMAX1(0.,(1.-0.25*PTS**2)/MO2)
      Y(2)=FAC*Y(2)
      CALL REALFT(Y,MO2,-1)
      DO 14 J=1,N
        Y(J)=RN1*(Y1*(N-J)+YN*(J-1))+Y(J)
14    CONTINUE
      RETURN
      END


* -------------------------- BEGIN SMOOTH_interpolate --------------------------
      subroutine Smooth_interpolate (x_in, y_in, npts_in,
     :                               x_out, y_out, npts_out,
     :                   itype, ipow, df_smooth, smooth_param,
     :                   freq_param, m_start,m_stop)

! Meaning of smoothing input parameters
!
! NO SMOOTHING
! itype = 0
! SMOOTHING OVER EQUALLY SPACED FREQUENCIES
! itype = 1: box weighting function
!   smooth_param = width of box weighting function (Hz)
! itype = 2: triangular weighting function
!   smooth_param = width of triangular weighting function (Hz)
! SMOOTHING OVER LOGARITHMICALLY SPACED FREQUENCIES
! itype = 3: box weighting function
!   smooth_param = xi, which is the fraction of a decade for the
!                  box weighting function
! itype = 4: triangular weighting function
!   smooth_param = xi, which is the fraction of a decade for the
!                  triangular weighting function
! itype = 5: Konno and Ohmachi weighting function (see BSSA 88, 228-241)
!   smooth_param = xi, which is the fraction of a decade for which
!                  the Konno and Ohmachi weighting function is greater
!                  than 0.043.(it is related to
!                  their smoothing parameter b by the equation
!                  b = 4.0/smooth_param, so we have this correspondence between
!                  b and smooth_param
!                         b smooth_param
!                        10         0.40
!                        20         0.20
!                        40         0.10
!
!                  b = 40 seems to be commonly used, but I do not think that it gives
!                  enough smoothing; I prefer smooth_param = 0.2, corresponding to
!                  b = 20.
!
! ipow = power of FAS to be smoothed (2 = smoothing energy spectrum)
!
! df_smooth: Note: need df_smooth for linearly-spaced smoothers,
! and generally it should be the df from the fft.  For general x data, it is
! the spacing between x values, assumed to be constant,  The reason for
! including it as an input parameter is to "fool" the
! program to do smoothing over a specified number of points by
! setting df_smooth = 1 and smooth_param = number of points (including
! points with zero weight at ends; e.g., smooth_param = 5 will
! give a smoother with weights 0, 1/4, 2/4, 1/4, 0; smooth_param
! should be odd).
!

* Dates:  03/27/08 - Written by D. Boore, patterned after smooth.for
*         06/26/09 - Restrict i/ic so that w>=0.1 (rather than go to
*                    first zero crossing of sin X/X).
*         07/11/09 - With this definition (w>=0.1), redefine the meaning of smooth_param
*                    so that it is closer to the fraction of a decade over which the
*                    smoothing takes place.  The width in log frequency corresponding
*                    to the weighting function being greater than 0.1
*                    is related to b by Delta logf = (1/b)*3.5.  Thus
*                    if smooth_param = Delta logf, we have b=3.5/smooth_param
*                    instead of b=2*pi/smooth_param.
*         07/11/09 - I decided to let the smoothing width be determined by
*                    wmin = 0.043 (as a compromise between 0.01 and 0.1, and because
*                    this corresponds to log(arg)=+-2, a nice round number),
*                    which means that b=4.0/smooth_param.
!         03/15/10 - Correct error for the case of smoothing and fft frequencies
!                    starting at a frequency greater than 0.0
!        03/16/10 - Change df_intrp to freq_param in input argument list (because
!                   freq_param is not always the frequency spacing, it may be
!                   less confusing to use freq_param than df_intrp).

      real x_in(*), y_in(*), x_out(*), y_out(*)
      real work(:)
      allocatable :: work

      pi = 4.0*atan(1.0)

      allocate(work(npts_in))

      if (itype == 1 .or. itype == 2) then  ! calculate range of indices to use in average
        ic1 = int(aint(0.5*smooth_param/df_smooth))
        ic2 = npts_in - ic1
        b = 0.0
      else if (itype == 5) then  ! convert smoothing parameter to K&O parameters
!        b = 2.0*pi/smooth_param  ! corresponds to zero crossings of K&O weighting function
!        b = 4.6370/smooth_param      ! corresponds to K&O weighting function = 0.01
        b = 4.0/smooth_param      ! corresponds to K&O weighting function = 0.043
!        b = 3.4996/smooth_param      ! corresponds to K&O weighting function = 0.1
        ic1 = 0
        ic2 = 0
      end if

      do i = 1, npts_in
        work(i) = y_in(i)**float(ipow)
      end do

      if (itype == 0 .and. freq_param == 0.0) then  ! no smoothing, no interpolation
        do j = 1, m_stop - m_start + 1
          y_out(j) = y_in(j+m_start - 1)
        end do
        return
      else if (itype == 0 .and. freq_param /= 0.0) then ! no smoothing, interpolation
        do j = 1, npts_out
          y_out(j) = yintrf(x_out(j), x_in, y_in,
     :                 npts_in)
        end do
        return
      else if (itype /= 0 .and. freq_param == 0.0) then ! smoothing, no interpolation
!        do j = 1, npts_in
        do j = 1, m_stop - m_start + 1
          j4smooth = j + m_start - 1
          y_out(j) = smooth_f(work, npts_in, j4smooth, ic1, ic2,
     :                        b, itype, smooth_param)
          y_out(j) = y_out(j)**(1.0/float(ipow))  ! undo power
        end do
        return
      end if

* What's left?  Smoothing and interpolation

      do iy = 1, npts_out

* For each x_out, calculate indices of x_in:

        call locate(x_in, npts_in, x_out(iy), j)  ! x_out(ic) will be between x_in(j) and x_in(j+1)
                                                  ! so need to compute smoothed value of y at
                                                  ! these two points and then interpolate.

* Compute smoothed values at these bracketing values of x:

        y_smooth_j =
     :   smooth_f(work, npts_in, j, ic1, ic2, b, itype, smooth_param)
        y_smooth_jp1 =
     :   smooth_f(work, npts_in, j+1, ic1, ic2, b, itype, smooth_param)

* And interpolate the smoothed values

        y_out(iy) = y_smooth_j +
     :             (x_out(iy)-x_in(j))*(y_smooth_jp1 - y_smooth_j)/
     :             (x_in(j+1)-x_in(j))

        y_out(iy) = y_out(iy)**(1.0/float(ipow))  ! undo power

      end do

      deallocate(work)

      return
      end
* -------------------------- END Smooth_interpolate --------------------------

* -------------------------- BEGIN smooth_f --------------------------
      real function smooth_f(work, npts_in, ic, ic1, ic2, b,
     :                  itype, smooth_param)

      implicit none

      real, intent(in) :: b, smooth_param, work(*)
      integer, intent(in) :: npts_in, ic, ic1, ic2, itype

      real :: sum, wavg, weight, f_fc
      real :: w_triangular, w_logtriangular, w_konno_ohmachi
      integer :: iz1, iz2, j

      if (itype == 1 .or. itype == 2) then
          iz1 = ic - ic1
          iz2 = ic + ic1
      else if (itype == 5) then
!          f_fc = 0.00480**(1.0/b)    ! corresponds to K&O weighting function = 0.01
          f_fc = 0.0100**(1.0/b)    ! corresponds to K&O weighting function = 0.043
!          f_fc = 0.01779**(1.0/b)    ! corresponds to K&O weighting function = 0.1
          iz1 = nint(float(ic)*f_fc)
          iz2 = nint(float(ic)/f_fc)

      else
          iz1 = nint(float(ic)*10.0**(-0.5*smooth_param))
          iz2 = nint(float(ic)*10.0**(0.5*smooth_param))
      end if

        if (iz1 < 1) then
          iz1 = 1
        end if
        if (iz2 > npts_in) then
          iz2 = npts_in
        end if

        sum = 0.0
        wavg = 0.0

        do j = iz1, iz2
          if (itype == 1) then
            weight = 1.0
          else if (itype == 2) then
            weight = w_triangular(j, ic, iz1, iz2, smooth_param)
          else if (itype == 3) then
            weight = 1.0
          else if (itype == 4) then
            weight = w_logtriangular(j, ic, iz1, iz2, smooth_param)
          else if (itype == 5) then
            weight = w_konno_ohmachi(j, ic, b)
          else
            print *, ' error, invalid itype = ', itype, '; quitting'
            stop
          end if

          wavg = wavg + weight
          sum = sum + weight * work(j)
        end do

        smooth_f = (sum/wavg)

        end function smooth_f
* -------------------------- END smooth_f --------------------------

* -------------------------- BEGIN w_triangular --------------------------
      function w_triangular(j, ic, iz1, iz2, smooth_param)

      if (j .eq. ic) then
        w_triangular = 1.0
      else if (j .lt. ic) then
        w_triangular =
     :      (float(j) - float(iz1))/(float(ic) - float(iz1))
      else
        w_triangular = 1 -
     :      (float(j) - float(ic))/(float(iz2) - float(ic))
      end if

      return

      end
* -------------------------- END w_triangular --------------------------

* -------------------------- BEGIN w_logtriangular --------------------------
      function w_logtriangular(j, ic, iz1, iz2, smooth_param)

      if (j .eq. ic) then
        w_logtriangular = 1.0
      else if (j .lt. ic) then
        w_logtriangular =
     :      alog10(float(j)/float(iz1))/alog10(float(ic)/float(iz1))
      else
        w_logtriangular = 1 -
     :      alog10(float(j)/float(ic))/alog10(float(iz2)/float(ic))
      end if

      return

      end
* -------------------------- END w_logtriangular --------------------------

* -------------------------- BEGIN w_konno_ohmachi --------------------------
      function w_konno_ohmachi(j,ic,b)

      if (j .eq. ic) then
        w_konno_ohmachi = 1.0
      else
        arg = b*alog10(float(j)/float(ic))
        w_konno_ohmachi = (sin(arg)/arg)**4.0
      end if

      return

      end
* -------------------------- END w_konno_ohmachi --------------------------


c     Stencil spec inference expectation
c     a : centered depth=1 dim=0,1
c     b : backward depth=1{a} dim=t
c
c     [or possibly  a : backward depth=1{b} dim=t]

      program procs
      implicit none

      integer i, j, t, imax, jmax, tmax
      parameter (imax = 3, jmax = 3, tmax = 3)

      real a(0:imax,0:jmax), b(0:imax,0:jmax)

c     some kind of setup
      do 1 i = 0, imax
         do 2 j = 0, jmax
            a(i,j) = i*j
            b(i,j) = 0
 2       continue
 1    continue

c     main part
      do 3 t = 0, tmax

c     output routine
         write (*,*) 'A = '
         do 4 i = 0, imax
            do 5 j = 0, jmax
               write (*,'(" ",f0.2," ",$)') a(i,j)
 5          continue
            write (*,'(/)')
 4       continue
         call stencl(a, b, imax, jmax)
         a = b

 3    continue
      end

c     subroutine to do the actual stencil part (flow depenency b <- a)
      subroutine stencl(a, b, imax, jmax)
      integer i, j
      real a(0:imax,0:jmax), b(0:imax,0:jmax)
      do 1 i = 1, (imax-1)
         do 2 j = 1, (jmax-1)
c= stencil readOnce, pointed(dim=1)*centered(depth=1, dim=2) + centered(depth=1, dim=1)*pointed(dim=2) :: a
            b(i,j) = (a(i,j) + a(i+1,j)
     &           + a(i-1,j) + a(i,j+1) + a(i,j-1))/4.0
 2       continue
 1    continue
      end


! { dg-options "-O2 -fgraphite-identity -fno-loop-block -fno-loop-interchange -fno-loop-strip-mine" }

MODULE beta_gamma_psi
  INTEGER, PARAMETER :: dp=KIND(0.0D0)
CONTAINS
  FUNCTION basym (a, b, lambda, eps) RESULT(fn_val)
    REAL(dp) :: a0(21), b0(21), bsum, c(21), d(21), dsum, &
         j0, j1, r, r0, r1, s, sum, t, t0, t1, &
         u, w, w0, z, z0, z2, zn, znm1
    DO n = 2, num, 2
       DO i = n, np1
          b0(1) = r*a0(1)
          DO m = 2, i
             bsum = 0.0e0_dp
             mm1 = m - 1
             DO j = 1, mm1
                mmj = m - j
                bsum = bsum + (j*r - mmj)*a0(j)*b0(mmj)
             END DO
             b0(m) = r*a0(m) + bsum/m
          END DO
          c(i) = b0(i)/(i + 1.0e0_dp)
          d(i) = -(dsum + c(i))
       END DO
       t0 = d(n)*w*j0
       sum = sum + (t0 + t1)
    END DO
    fn_val = e0*t*u*sum
  END FUNCTION basym
END MODULE beta_gamma_psi
! { dg-final { cleanup-modules "beta_gamma_psi" } }


submodule(euler_interface_m) euler_prob_0028_m
    implicit none

contains

    module character(len=20) function euler0028()
        write (euler0028, "(i20)") ans()
    end function euler0028

    integer function ans()
        integer :: i, k, ur, bl, br, ul, tmp

        tmp = 1
        do i = 2, 501
            k = 2*i - 1
            ur = k**2
            bl = ur - 2*k + 2
            br = bl - (k - 1)
            ul = bl + (k - 1)
            tmp = tmp + ur + bl + br + ul
        end do
        ans = tmp
    end function ans

end submodule euler_prob_0028_m


      SUBROUTINE proma4(a,b,c,n1,n2,n3)
!********************************************************************
!
!***this routine evaluates a matrix product
!                                            t
!           a(i,j) = b(k,i) * c(k,j)    a = b * c
!
!********************************************************************
      IMPLICIT NONE

      INTEGER (kind=4),INTENT(IN) :: n1,n2,n3
      REAL (kind=8),INTENT(IN) :: b(1:n3,1:n1), c(1:n3,1:n3)
      REAL (kind=8),INTENT(OUT) :: a(1:n1,1:n3)

      a(1:n1,1:n2) = MATMUL( TRANSPOSE(b(1:n3,1:n1)), c(1:n3,1:n2) )
      RETURN

      END SUBROUTINE proma4


! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download

program sampling_error

use      types_mod, only : r8, digits12
use random_seq_mod, only : random_seq_type, init_random_seq, twod_gaussians

implicit none

integer, parameter :: sample_size = 1000000
type (random_seq_type) :: ran_id
real(r8) :: zero_2(2) = 0.0, cov(2, 2)
real(r8) :: t_correl, correl_mean, sample_correl, ratio_mean, correl_mean2, correl_sd
real(r8), allocatable :: pairs(:, :), obs_inc(:), unobs_inc(:), new_unobs(:)
real(r8) :: s_mean(2), s_var(2)
real(r8) :: reg_sum, reg_mean, reg_sum_2, reg_sd, t_sd1, t_sd2, alpha, beta
integer i, j, k, lji, ens_size

call init_random_seq(ran_id)

! Loop through a range of ensemble sizes
do lji = 2, 2
   ens_size = 10 * 2**(lji - 1)

   ens_size = 10

   allocate(pairs(2, ens_size), obs_inc(ens_size), unobs_inc(ens_size), new_unobs(ens_size))
   write(*, *) 'stats for ensemble size ', ens_size

   ! Loop through real correlations every 0.02
   do j = 0, 50
   !do j = 0, 0

      ! Loop through a large number of samples to get mean
      correl_mean  = 0.0_r8
      correl_mean2 = 0.0_r8
      ratio_mean   = 0.0_r8
      reg_sum      = 0.0_r8
      reg_sum_2    = 0.0_r8

      do k = 1, sample_size
         t_correl = j * 0.02_r8

         ! NOTE: RESULTS DO NOT DEPEND ON SDs of the two priors, just on correl
         t_sd1 = 1.0_r8
         t_sd2 = 1.0_r8

         ! Generate the covariance matrix for this correlation
         cov(1, 1) = t_sd1**2;    cov(2, 2) = t_sd2**2
         cov(1, 2) = t_correl * t_sd1 * t_sd2; cov(2, 1) = cov(1, 2)

         ! Loop to generate an ensemble size sample from this correl
         ! Generate a random sample of size ens_size from something with this correlation
         do i = 1, ens_size
            call twod_gaussians(ran_id, zero_2, cov, pairs(:, i))
         enddo

         ! Compute the sample correlation
         call comp_correl(pairs, ens_size, sample_correl)

         ! Keep a sum of the sample_correl
         correl_mean = correl_mean + abs(sample_correl)
         correl_mean2 = correl_mean2 + sample_correl**2

         !-----------------
         ! Also interested in finding out what the spurious variance reduction factor is
         ! First need to compute sample s.d. for the obs and unobs variable
         do i = 1, 2
            call sample_mean_var(pairs(i, :), ens_size, s_mean(i), s_var(i))
         enddo

         !-----------------
         ! Also compute statistics for regression coefficient
         reg_sum = reg_sum + sample_correl * sqrt(s_var(2) / s_var(1))
         reg_sum_2 = reg_sum_2 + (sample_correl * sqrt(s_var(2) / s_var(1)))**2

      enddo
      correl_mean = correl_mean / sample_size
      correl_sd = sqrt((correl_mean2 - sample_size * correl_mean**2) / (sample_size - 1))
      ratio_mean = ratio_mean / sample_size
      !write(*, *) 'ratio mean ', ratio_mean

      ! Do regression stats, too
      reg_mean = reg_sum / sample_size
      reg_sd = sqrt((reg_sum_2 - sample_size * reg_mean**2) / (sample_size - 1))
      if(reg_sd <= 0.0_r8) then
         alpha = 1.0_r8
      else
         beta = reg_mean**2 / reg_sd**2
         alpha = beta / (1.0_r8 + beta)
      endif
      write(*, 11) t_correl, correl_mean, t_correl / correl_mean, alpha
      11 format(1x, 4(e10.4, 1x))

   enddo
   deallocate(pairs)

enddo

!-----------------------------------------------------
contains
!-----------------------------------------------------

subroutine comp_correl(ens, n, correl)

integer,        intent(in) :: n
real(digits12), intent(in) :: ens(2, n)
real(digits12), intent(out) :: correl

real(digits12) :: sum_x, sum_y, sum_xy, sum_x2, sum_y2

sum_x  = sum(ens(2, :))
sum_y  = sum(ens(1, :))
sum_xy = sum(ens(2, :) * ens(1, :))
sum_x2 = sum(ens(2, :) * ens(2, :))

! Computation of correlation
sum_y2 = sum(ens(1, :) * ens(1, :))

correl = (n * sum_xy - sum_x * sum_y) / &
   sqrt((n * sum_x2 - sum_x**2) * (n * sum_y2 - sum_y**2))

end subroutine comp_correl

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

subroutine sample_mean_var(x, n, mean, var)

integer,        intent(in) :: n
real(digits12), intent(in) :: x(n)
real(digits12), intent(out) :: mean, var

real(digits12) :: sx, s_x2

sx   = sum(x)
s_x2 = sum(x * x)
mean = sx / n
var  = (s_x2 - sx**2 / n) / (n - 1)

end subroutine sample_mean_var

end program sampling_error


subroutine integrate_2d(img,img_err,solid_angle,rad,chi,rad_val,chi_val,integ,integ_err,M,N,rad_npt,chi_npt)
!**********************************************************************************
!Subroutine to perform cacking of a two dimensional SAXS/WAXS image
![M,N]=dimensions of the image
!img=image array
!img=image error array
!rad=array of radial values with similar dimensions as img
!chi=array of azimuthal values with similar dimensions as img!
!solid_angle= array of solid angle of the pixes of the detector
!rad_npt=Maximum number of points between which the radial part will be divided
!chi_npt=Maximum number of points between which the azimuthal part will be divided
!rad_val=Radial values
!chi_val=azimuthal values
!integ=integrated two dimensional caking data
!integ_err
!**********************************************************************************
implicit none
integer (8):: M,N,rad_npt,chi_npt
double precision, dimension(0:M-1,0:N-1):: img,img_err,solid_angle,rad,chi
double precision, dimension(0:rad_npt-1,0:chi_npt-1):: integ,integ_err,counts
double precision, dimension(0:rad_npt-1):: rad_val
double precision, dimension(0:chi_npt-1):: chi_val
double precision :: rad_step,chi_step
integer (8):: i,j,irad,ichi

integ(:,:)=0.0d0
integ_err(:,:)=0.0d0
counts(:,:)=0.0d0

rad_step=dabs(rad_val(1)-rad_val(0))
chi_step=dabs(chi_val(1)-chi_val(0))

do i =0,M-1
	do j=0,N-1
		irad=idint((rad(i,j)-rad_val(0))/rad_step)
		ichi=idint((chi(i,j)-chi_val(0))/chi_step)
		if ((img(i,j)>0.0d0) .and. (irad>=0) .and. (ichi>=0) .and. (irad<=rad_npt-1) .and. (ichi<=chi_npt-1))  then
			integ(irad,ichi)=integ(irad,ichi)+img(i,j)/solid_angle(i,j)
			integ_err(irad,ichi)=integ_err(irad,ichi)+img_err(i,j)**2/solid_angle(i,j)**2
			counts(irad,ichi)=counts(irad,ichi)+1.0d0
		endif
	enddo
enddo

do i =0,rad_npt-1
	do j=0,chi_npt-1
		if (counts(i,j)>1.0d0) then
			integ(i,j)=integ(i,j)/counts(i,j)
			integ_err(i,j)=dsqrt(integ_err(i,j))/counts(i,j)
		else
			integ(i,j)=0.0d0
			integ_err(i,j)=0.0d0
		endif
	enddo
enddo

end subroutine integrate_2d


FUNCTION bnc(N,P,rank)

!-------------------------------------------------------------
!
!  Compute the number of cells for the subdomain, one
!   dimension at a time.
!  Take in the number of cells total for a dimension, N, the
!   number of processes P in that dimension, and the rank.
!  Return the integer number of cells for that sub-domain, bnc.
!
!  When not evenly divided, keeps all but one even, then puts
!   remainder in with final sub-domain
!
!-------------------------------------------------------------

USE invar
IMPLICIT NONE
INTEGER, INTENT(IN) :: N, P, rank
INTEGER :: bnc, tmpi1, tmpi2

tmpi1 = MOD(N,P)
tmpi2 = N/P

! If it's evenly divisible, just use the division
IF (tmpi1 == 0) THEN
   bnc = tmpi2

! If not, then set all but the last process equal to division
! Last process set to remainder
ELSE
   IF (rank == 0) THEN
      warn = warn + 1
      WRITE (8,'(/,A,/)') "WARNING: Number of cells not evenly divided by processes."
   END IF
   IF (rank < tmpi1) THEN
      bnc = tmpi2 + 1
   ELSE
      bnc = tmpi2
   END IF
END IF

END FUNCTION bnc


c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1998  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  function invbeta  --  inverse Beta distribution function  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "invbeta" computes the inverse Beta distribution function
c     via a combination of Newton iteration and bisection search
c
c     literature reference:
c
c     K. L. Majumder and G. P. Bhattacharjee, "Inverse of the
c     Incomplete Beta Function Ratio", Applied Statistics, 22,
c     411-414 (1973)
c
c
      function invbeta (a,b,y)
      implicit none
      real*8 eps
      parameter (eps=1.0d-5)
      real*8 invbeta,a,b,y
      real*8 x,x0,x1
      real*8 aexp,bexp,beta
      real*8 mean,stdev
      real*8 betai,gammln
      real*8 slope,error
      logical done
c
c
c     use limiting values when input argument is out of range
c
      done = .false.
      if (y .le. 0.0d0) then
         x = 0.0d0
         done = .true.
      else if (y .ge. 1.0d0) then
         x = 1.0d0
         done = .true.
      end if
c
c     initial guess from mean and variance of probability function
c
      if (.not. done) then
         aexp = a - 1.0d0
         bexp = b - 1.0d0
         beta = exp(gammln(a) + gammln(b) - gammln(a+b))
         mean = a / (a+b)
         stdev = sqrt(a*b/((a+b+1.0d0)*(a+b)**2))
         if (y.gt.0.0d0 .and. y.le.0.167d0) then
            x = mean + (y/0.167d0-2.0d0)*stdev
         else if (y.gt.0.167d0 .and. y.lt.0.833d0) then
            x = mean + (y/0.333d0-1.5d0)*stdev
         else if (y.ge.0.833d0 .and. y.lt.1.0d0) then
            x = mean + (y/0.167d0-4.0d0)*stdev
         end if
         x = max(eps,min(1.0d0-eps,x))
      end if
c
c     refine inverse distribution value via Newton iteration
c
      do while (.not. done)
         slope = (x**aexp * (1.0d0-x)**bexp) / beta
         error = betai(a,b,x) - y
         x = x - error/slope
         if (abs(error) .lt. eps)  done = .true.
         if (x.lt.0.0d0 .or. x.gt.1.0d0)  done = .true.
      end do
c
c     try bisection search if Newton iteration moved out of range
c
      if (x.lt.0.0d0 .or. x.gt.1.0d0) then
         x0 = 0.0d0
         x1 = 1.0d0
         done = .false.
      end if
c
c     refine inverse distribution value via bisection search
c
      do while (.not. done)
         x = 0.5d0 * (x0+x1)
         error = betai(a,b,x) - y
         if (error .gt. 0.0d0)  x1 = x
         if (error .lt. 0.0d0)  x0 = x
         if (abs(error) .lt. eps)  done = .true.
      end do
c
c     return best estimate of the inverse beta distribution value
c
      invbeta = x
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  function betai  --  cumulative Beta distribution function  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "betai" evaluates the cumulative Beta distribution function
c     as the probability that a random variable from a distribution
c     with Beta parameters "a" and "b" will be less than "x"
c
c
      function betai (a,b,x)
      implicit none
      real*8 betai,a,b,x
      real*8 bt,betacf,gammln
c
c
c     get cumulative distribution directly or via reflection
c
      if (x .le. 0.0d0) then
         betai = 0.0d0
      else if (x .ge. 1.0d0) then
         betai = 1.0d0
      else
         bt = exp(gammln(a+b) - gammln(a) - gammln(b)
     &               + a*log(x) + b*log(1.0d0-x))
         if (x .lt. (a+1.0d0)/(a+b+2.0d0)) then
            betai = (bt/a) * betacf (a,b,x)
         else
            betai = 1.0d0 - (bt/b) * betacf (b,a,1.0d0-x)
         end if
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  function betacf  --  continued fraction routine for betai  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "betacf" computes a rapidly convergent continued fraction needed
c     by routine "betai" to evaluate the cumulative Beta distribution
c
c
      function betacf (a,b,x)
      implicit none
      integer maxiter
      real*8 eps,delta
      parameter (maxiter=100)
      parameter (eps=1.0d-10)
      parameter (delta=1.0d-30)
      integer i
      real*8 betacf,a,b,x
      real*8 m,m2,aa
      real*8 c,d,del,h
      real*8 qab,qam,qap
c
c
c     establish an initial guess for the Beta continued fraction
c
      qab = a + b
      qap = a + 1.0d0
      qam = a - 1.0d0
      c = 1.0d0
      d = 1.0d0 - qab*x/qap
      if (abs(d) .lt. delta)  d = delta
      d = 1.0d0 / d
      h = d
c
c     iteratively improve the continued fraction to convergence
c
      do i = 1, maxiter
         m = dble(i)
         m2 = 2.0d0 * m
         aa = m * (b-m) * x / ((qam+m2)*(a+m2))
         d = 1.0d0 + aa*d
         if (abs(d) .lt. delta)  d = delta
         c = 1.0d0 + aa/c
         if (abs(c) .lt. delta)  c = delta
         d = 1.0d0 / d
         h = h * d * c
         aa = -(a+m) * (qab+m) * x / ((a+m2)*(qap+m2))
         d = 1.0d0 + aa*d
         if (abs(d) .lt. delta)  d = delta
         c = 1.0d0 + aa/c
         if (abs(c) .lt. delta)  c = delta
         d = 1.0d0 / d
         del = d * c
         h = h * del
         if (abs(del-1.0d0) .lt. eps)  goto 10
      end do
   10 continue
      betacf = h
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  function gammln  --  natural log of the Gamma function  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "gammln" uses a series expansion due to Lanczos to compute
c     the natural logarithm of the Gamma function at "x" in [0,1]
c
c
      function gammln (x)
      implicit none
      real*8 step,c0,c1,c2,c3,c4,c5,c6
      parameter (step=2.5066282746310005d0)
      parameter (c0=1.000000000190015d0)
      parameter (c1=7.618009172947146d1)
      parameter (c2=-8.650532032941677d1)
      parameter (c3=2.401409824083091d1)
      parameter (c4=-1.231739572450155d0)
      parameter (c5=1.208650973866179d-3)
      parameter (c6=-5.395239384953d-6)
      real*8 gammln,x
      real*8 series,temp
c
c
c     get the natural log of Gamma via a series expansion
c
      temp = x + 5.5d0
      temp = (x+0.5d0)*log(temp) - temp
      series = c0 + c1/(x+1.0d0) + c2/(x+2.0d0) + c3/(x+3.0d0)
     &            + c4/(x+4.0d0) + c5/(x+5.0d0) + c6/(x+6.0d0)
      gammln = temp + log(step*series/x)
      return
      end


SUBROUTINE mutate(pop, pops, NP, gen, gens, mutRate, lb, ub)
	IMPLICIT NONE
	INTEGER, INTENT(IN):: NP, gen, pops, gens
	REAL, INTENT(IN):: mutRate, lb(NP), ub(NP)
	REAL, INTENT(INOUT):: pop(pops*NP)

	INTEGER:: i, dm
	REAL::rang, chance, inf, sup
	REAL::RAND
	INTEGER:: IRAND

	DO i = 1, pops
		chance = (1.0 - gen/(gens*mutRate))**1.5
		IF (RAND(0) <= chance) THEN
			dm = MOD(IRAND(0),NP)+1
			rang = (ub(dm)-lb(dm))*chance/2
			inf  = pop((i-1)*NP+dm) - rang
			IF (inf < lb(dm)) inf = lb(dm)
			sup = pop((i-1)*NP+dm) + rang
			IF (sup > ub(dm)) sup = ub(dm)
			pop((i-1)*NP+dm) = RAND(0)*(sup-inf)+sup
		END IF
	END DO

END SUBROUTINE mutate


SUBROUTINE brdc_qc_gps(EPHNEW, AVE_A, STD_A)

! ----------------------------------------------------------------------
! PROGRAM: brdc_qc_gps.f90
! ----------------------------------------------------------------------
! Purpose: Compute statistic information of broadcast parameters for quality control
!
! ----------------------------------------------------------------------
! Author :      Dr. Tzupang Tseng
!
! Copyright: GEOSCIENCE AUSTRALIA, AUSTRALIA
!
! Created:   13-08-2019
!
! ----------------------------------------------------------------------
      USE mdl_precision
      USE m_meanstd
      IMPLICIT NONE
      REAL (KIND = prec_q) :: EPHNEW(15)
      REAL (KIND = prec_q), ALLOCATABLE, DIMENSION(:) :: EPHQC
      REAL (KIND = prec_q) :: A
      REAL (KIND = prec_q) :: A_SumSQR
      REAL (KIND = prec_q) :: AVE_A
      REAL (KIND = prec_q) :: STD_A
      INTEGER (KIND=4) :: SZ1, NUM, I, JJ
      INTEGER (KIND = prec_int2) :: AllocateStatus

SZ1 = SIZE(EPHNEW,DIM =1)
NUM = 0
DO I= 1, SZ1
IF(EPHNEW(3) /= 0.d0)THEN
NUM = NUM + 1
END IF
END DO
ALLOCATE (EPHQC(NUM), STAT=AllocateStatus)

EPHQC = 0.d0
NUM = 0
DO I= 1, SZ1
IF(EPHNEW(3) /= 0.d0)THEN
NUM = NUM + 1
EPHQC(NUM) = EPHNEW(I)
END IF
END DO

A = 0.d0
A_SumSQR    = 0.d0

DO JJ=1,NUM
A = A     + EPHQC(JJ)
A_SumSQR    = A_SumSQR     + EPHQC(JJ)*EPHQC(JJ)
END DO

CALL meanstd(A, A_SumSQR, NUM, AVE_A, STD_A)

END SUBROUTINE


!(LICENSE:PD)
!
! makesphere
!
!        make a sphere object
!
        subroutine makesphere
      use M_draw

        integer SPHERE
        integer ii
        real i, r, z, a, RADIUS, PI
        parameter (PI = 3.1415926535, RADIUS = 10.0, SPHERE = 1)

        call makeobj(SPHERE)

!
! create the latitudinal rings
!
            do 10 ii = 0, 180, 20
                call pushmatrix
                    i=real(ii)
                    call rotate(i, 'y')
                    call circle(0.0, 0.0, RADIUS)
                call popmatrix
10          continue

!
! create the longitudinal rings
!
            call pushmatrix
                call rotate(90.0, 'x')
                do 20 ia = -90, 90, 20
                    a=ia
                    r = RADIUS * cos(a * PI / 180.0)
                    z = RADIUS * sin(a * PI / 180.0)
                    call pushmatrix
                        call translate(0.0, 0.0, -z)
                        call circle(0.0, 0.0, r)
                    call popmatrix
20              continue
            call popmatrix

        call closeobj

        end

!
!@(#)  a demonstration of objects
!
        program fballs
      use M_draw

        integer SPHERE
        integer BLACK, RED, GREEN, YELLOW, BLUE, MAGENTA, CYAN, WHITE
        real RADIUS
        parameter (RADIUS = 10.0)
        parameter(SPHERE = 1)
        parameter(BLACK = 0)
        parameter(RED = 1)
        parameter(GREEN = 2)
        parameter(YELLOW = 3)
        parameter(BLUE = 4)
        parameter(MAGENTA = 5)
        parameter(CYAN = 6)
        parameter(WHITE = 7)
        character(len=50) :: device

        print*,'Enter output device:'
        read(*,'(a)') device

        call vinit(device)

        call vsetflush(.false.)

!
! set up our viewing transformation
!
        call perspective(90.0, 1.0, 0.001, 500.0)
        call lookat(13.0, 13.0, 8.0, 0.0, 0.0, 0.0, 0.0)

        call color(BLACK)
        call clear

!
! Call a routine to make the sphere object
!
        call makesphere

!
! Now draw the sphere object scaled down. We use the pushmatrix
! and the popmatrix to preserve the transformation matrix so
! that only this sphere is drawn scaled. The callobj then enables
! us to draw the sphere we generated with makeobj in makesphere.
!
        call color(CYAN)

        call pushmatrix
            call scale(0.5, 0.5, 0.5)
            call callobj(SPHERE)
        call popmatrix

!
! now we draw the same sphere translated, with a different
! scale and color.
!
        call color(WHITE)

        call pushmatrix
            call translate(0.0, (-1.4) * RADIUS, 1.4 * RADIUS)
            call scale(0.3, 0.3, 0.3)
            call callobj(SPHERE)
        call popmatrix

!
! and maybe a few more times....
!

        call color(RED)

        call pushmatrix
            call translate(0.0, RADIUS, 0.7 * RADIUS)
            call scale(0.2, 0.2, 0.2)
            call callobj(SPHERE)
        call popmatrix

        call color(GREEN)

        call pushmatrix
            call translate(0.0, 1.5 * RADIUS, -RADIUS)
            call scale(0.15, 0.15, 0.15)
            call callobj(SPHERE)
        call popmatrix

        call color(YELLOW)

        call pushmatrix
            call translate(0.0, -RADIUS, -RADIUS)
            call scale(0.12, 0.12, 0.12)
            call callobj(SPHERE)
        call popmatrix

        call color(BLUE)

        call pushmatrix
            call translate(0.0, (-2.0)*RADIUS, -RADIUS)
            call scale(0.3, 0.3, 0.3)
            call callobj(SPHERE)
        call popmatrix

        idum=getkey()

        call vexit

        end


module m_spline
use, intrinsic :: iso_fortran_env, only: REAL32, REAL64
implicit none
private
public :: spline
public :: ispline
interface spline
   module procedure spline_
   module procedure spline_interp_r4_
   module procedure spline_interp_r8_
end interface
contains
  subroutine spline_interp_r8_ ( xi, xo, yi, yo )

  implicit none

  real(kind=REAL64),intent(in)    :: xi(:)
  real(kind=REAL64),intent(in)    :: xo(:)
  real(kind=REAL64),intent(in)    :: yi(:)
  real(kind=REAL64),intent(inout) :: yo(:)

  real(kind=REAL64), allocatable :: b(:), c(:), d(:)
  real(kind=REAL64), allocatable :: xxi(:)
  real(kind=REAL64), allocatable :: yyi(:)
  real(kind=REAL64), allocatable :: xxo(:)

  integer k,ni,no
  logical reverse_

  ni=size(xi)
  no=size(xo)

  allocate(b(ni),c(ni),d(ni))
  allocate(xxi(ni))
  allocate(yyi(ni))
  allocate(xxo(no))

  reverse_=xi(1)>xi(ni)
  if (reverse_) then
     xxi=xi(ni:1:-1)
     yyi=yi(ni:1:-1)
     xxo=xo(no:1:-1)
  else
     xxi=xi
     yyi=yi
     xxo=xo
  endif

! Derive spline coefficients
  call spline_ ( xxi, yyi, b, c, d, ni )

! Apply spline coefficients
  yo(1)=yyi(1)
  do k=2,no-1
     yo(k) = ispline( xxo(k), xxi, yyi, b, c, d, ni)
  enddo
  yo(no)=yyi(ni)
  if (reverse_) then
     yo=yo(no:1:-1)
  endif

  deallocate(xxo)
  deallocate(yyi)
  deallocate(xxi)
  deallocate(b,c,d)

  end subroutine spline_interp_r8_

  subroutine spline_interp_r4_ ( xi, xo, yi, yo )

  implicit none

  real(kind=REAL32) :: xi(:)
  real(kind=REAL32) :: xo(:)
  real(kind=REAL32) :: yi(:)
  real(kind=REAL32) :: yo(:)

  real(kind=REAL64), allocatable, dimension(:) :: b(:), c(:), d(:)
  real(kind=REAL64), allocatable, dimension(:) :: xxi(:)
  real(kind=REAL64), allocatable, dimension(:) :: yyi(:)
  real(kind=REAL64), allocatable, dimension(:) :: xxo(:)

  integer k,ni,no
  logical reverse_

  ni=size(xi)
  no=size(xo)

  allocate(b(ni),c(ni),d(ni))
  allocate(xxi(ni))
  allocate(yyi(ni))
  allocate(xxo(no))

  reverse_=xi(1)>xi(ni)
  if (reverse_) then
     xxi=xi(ni:1:-1)
     yyi=yi(ni:1:-1)
     xxo=xo(no:1:-1)
  else
     xxi=xi
     yyi=yi
     xxo=xo
  endif

! Derive spline coefficients
  call spline_ ( xxi, yyi, b, c, d, ni )

! Apply spline coefficients
  yo(1)=yyi(1)
  do k=2,no-1
     yo(k) = ispline( xxo(k), xxi, yyi, b, c, d, ni)
  enddo
  yo(no)=yyi(ni)
  if (reverse_) then
     yo=yo(no:1:-1)
  endif

  deallocate(xxo)
  deallocate(yyi)
  deallocate(xxi)
  deallocate(b,c,d)

  end subroutine spline_interp_r4_

   subroutine spline_ (x, y, b, c, d, n)
!======================================================================
!  Calculate the coefficients b(i), c(i), and d(i), i=1,2,...,n
!  for cubic spline interpolation
!  s(x) = y(i) + b(i)*(x-x(i)) + c(i)*(x-x(i))**2 + d(i)*(x-x(i))**3
!  for  x(i) <= x <= x(i+1)
!  Alex G: January 2010
!----------------------------------------------------------------------
!  input..
!  x = the arrays of data abscissas (in strictly increasing order)
!  y = the arrays of data ordinates
!  n = size of the arrays xi() and yi() (n>=2)
!  output..
!  b, c, d  = arrays of spline coefficients
!  comments ...
!  spline.f90 program is based on fortran version of program spline.f
!  the accompanying function fspline can be used for interpolation
!======================================================================
implicit none
integer n
real(kind=REAL64) :: x(n), y(n), b(n), c(n), d(n)
integer i, j, gap
real(kind=REAL64) :: h

gap = n-1
! check input
if ( n < 2 ) return
if ( n < 3 ) then
  b(1) = (y(2)-y(1))/(x(2)-x(1))   ! linear interpolation
  c(1) = 0.
  d(1) = 0.
  b(2) = b(1)
  c(2) = 0.
  d(2) = 0.
  return
end if
!
! step 1: preparation
!
d(1) = x(2) - x(1)
c(2) = (y(2) - y(1))/d(1)
do i = 2, gap
  d(i) = x(i+1) - x(i)
  b(i) = 2.0*(d(i-1) + d(i))
  c(i+1) = (y(i+1) - y(i))/d(i)
  c(i) = c(i+1) - c(i)
end do
!
! step 2: end conditions
!
b(1) = -d(1)
b(n) = -d(n-1)
c(1) = 0.0
c(n) = 0.0
if(n /= 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
!
! step 3: forward elimination
!
do i = 2, n
  h = d(i-1)/b(i-1)
  b(i) = b(i) - h*d(i-1)
  c(i) = c(i) - h*c(i-1)
end do
!
! step 4: back substitution
!
c(n) = c(n)/b(n)
do j = 1, gap
  i = n-j
  c(i) = (c(i) - d(i)*c(i+1))/b(i)
end do
!
! step 5: compute spline coefficients
!
b(n) = (y(n) - y(gap))/d(gap) + d(gap)*(c(gap) + 2.0*c(n))
do i = 1, gap
  b(i) = (y(i+1) - y(i))/d(i) - d(i)*(c(i+1) + 2.0*c(i))
  d(i) = (c(i+1) - c(i))/d(i)
  c(i) = 3.*c(i)
end do
c(n) = 3.0*c(n)
d(n) = d(n-1)
end subroutine spline_

  function ispline(u, x, y, b, c, d, n)
!======================================================================
! function ispline evaluates the cubic spline interpolation at point z
! ispline = y(i)+b(i)*(u-x(i))+c(i)*(u-x(i))**2+d(i)*(u-x(i))**3
! where  x(i) <= u <= x(i+1)
!----------------------------------------------------------------------
! input..
! u       = the abscissa at which the spline is to be evaluated
! x, y    = the arrays of given data points
! b, c, d = arrays of spline coefficients computed by spline
! n       = the number of data points
! output:
! ispline = interpolated value at point u
!=======================================================================
implicit none
real(kind=REAL64) :: ispline
integer n
real(kind=REAL64) :: u, x(n), y(n), b(n), c(n), d(n)
integer i, j, k
real(kind=REAL64) :: dx

! if u is ouside the x() interval take a boundary value (left or right)
if(u <= x(1)) then
  ispline = y(1)
  return
end if
if(u >= x(n)) then
  ispline = y(n)
  return
end if

!*
!  binary search for for i, such that x(i) <= u <= x(i+1)
!*
i = 1
j = n+1
do while (j > i+1)
  k = (i+j)/2
  if(u < x(k)) then
    j=k
    else
    i=k
   end if
end do
!*
!  evaluate spline interpolation
!*
dx = u - x(i)
ispline = y(i) + dx*(b(i) + dx*(c(i) + dx*d(i)))
end function ispline

end module m_spline


    Program dsygvx_example

!     DSYGVX 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_example_aux, Only: nagf_blas_damax_val, &
        nagf_file_print_matrix_real_gen
      Use lapack_interfaces, Only: dsygvx
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Real (Kind=dp), Parameter :: zero = 0.0_dp
      Integer, Parameter :: nb = 64, nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: abstol, r, vl, vu
      Integer :: i, ifail, il, info, iu, k, lda, ldb, ldz, lwork, m, n
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: a(:, :), b(:, :), w(:), work(:), z(:, :)
      Real (Kind=dp) :: dummy(1)
      Integer, Allocatable :: iwork(:), jfail(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: max, nint
!     .. Executable Statements ..
      Write (nout, *) 'DSYGVX Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      lda = n
      ldb = n
      ldz = n
      m = n
      Allocate (a(lda,n), b(ldb,n), w(n), z(ldz,m), iwork(5*n), jfail(n))

!     Read the lower and upper bounds of the interval to be searched.
      Read (nin, *) vl, vu

!     Use routine workspace query to get optimal workspace.
      lwork = -1
      Call dsygvx(1, 'Vectors', 'Values in range', 'Upper', n, a, lda, b, ldb, &
        vl, vu, il, iu, abstol, m, w, z, ldz, dummy, lwork, iwork, jfail, &
        info)

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

!     Read the upper triangular parts of the matrices A and B

      Read (nin, *)(a(i,i:n), i=1, n)
      Read (nin, *)(b(i,i:n), i=1, n)

!     Set the absolute error tolerance for eigenvalues.  With ABSTOL
!     set to zero, the default value is used instead

      abstol = zero

!     Solve the generalized symmetric eigenvalue problem
!     A*x = lambda*B*x (ITYPE = 1)

      Call dsygvx(1, 'Vectors', 'Values in range', 'Upper', n, a, lda, b, ldb, &
        vl, vu, il, iu, abstol, m, w, z, ldz, work, lwork, iwork, jfail, info)

      If (info>=0 .And. info<=n) Then

!       Print solution

        Write (nout, 100) 'Number of eigenvalues found =', m
        Write (nout, *)
        Write (nout, *) 'Eigenvalues'
        Write (nout, 110) w(1:m)
        Flush (nout)

!       Normalize the eigenvectors, largest positive
        Do i = 1, m
          Call nagf_blas_damax_val(n, z(1,i), 1, k, r)
          If (z(k,i)<zero) Then
            z(1:n, i) = -z(1:n, i)
          End If
        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_real_gen('General', ' ', n, m, z, ldz, &
          'Selected eigenvectors', ifail)

        If (info>0) Then
          Write (nout, 100) 'INFO eigenvectors failed to converge, INFO =', &
            info
          Write (nout, *) 'Indices of eigenvectors that did not converge'
          Write (nout, 120) jfail(1:m)
        End If
      Else If (info>n .And. info<=2*n) Then
        i = info - n
        Write (nout, 130) 'The leading minor of order ', i, &
          ' of B is not positive definite'
      Else
        Write (nout, 100) 'Failure in DSYGVX. INFO =', info
      End If

100   Format (1X, A, I5)
110   Format (3X, (8F8.4))
120   Format (3X, (8I8))
130   Format (1X, A, I4, A)
    End Program


! =============================================================================
subroutine rp1(maxmx,meqn,mwaves,maux,mbc,mx,ql,qr,auxl,auxr,wave,s,amdq,apdq)
! =============================================================================
!
! Riemann problems for the 1D Burgers' equation with entropy fix for
! transonic rarefaction. See "Finite Volume Method for Hyperbolic Problems",
! R. J. LeVeque.

! waves: 1
! equations: 1

! Conserved quantities:
!       1 q

    implicit none

    integer, intent(in) :: maxmx, meqn, mwaves, maux, mbc, mx
    real(kind=8), intent(in), dimension(meqn,1-mbc:maxmx+mbc) :: ql, qr
    real(kind=8), intent(in), dimension(maux,1-mbc:maxmx+mbc) :: auxl, auxr
    real(kind=8), intent(out) :: s(mwaves, 1-mbc:maxmx+mbc)
    real(kind=8), intent(out) :: wave(meqn, mwaves, 1-mbc:maxmx+mbc)
    real(kind=8), intent(out), dimension(meqn,1-mbc:maxmx+mbc) :: amdq,apdq

    ! local variables:
    real(kind=8) :: qs,fs,qi,qim,fi,fim
    integer :: i

    logical :: efix
    common /comrp/ efix

    qs = 0.d0 ! sonic point
    fs = 0.d0 ! flux at sonic point

    do i=2-mbc,mx+mbc

        qim = qr(1,i-1)  ! left state for Riemann problem at i-1/2
        qi = ql(1,i)     ! right state for Riemann problem at i-1/2

        wave(1,1,i) = qi - qim

        if (qi == qim) then
            s(1,i) = qi   ! f'(q)
          else
            fim = 0.5d0*qim**2
            fi = 0.5d0*qi**2
            s(1,i) = (fi - fim) / (qi - qim)
          endif

        amdq(1,i) = dmin1(s(1,i), 0.d0) * wave(1,1,i)
        apdq(1,i) = dmax1(s(1,i), 0.d0) * wave(1,1,i)

	    if (efix) then
            if (qim < qs .and. qi > qs) then
                amdq(1,i) = fs - fim
                apdq(1,i) = fi - fs
            endif
        endif
    enddo

    end subroutine


module chebyshev

implicit none
public
save

contains

subroutine build_cheb_zder_matrix(dor,d,d2)
    use dim, only: nzp
    use grid, only: gf, gf2
    use flags, only: debug
    use mpicom, only: myid
    use formatstrings
    ! i/o
    real, dimension(nzp,nzp), intent(out) :: dor, d, d2
    ! vars
    integer :: i,j
    ! allocate derivative matrix
!     allocate(dor(nzp,nzp),d(nzp,nzp),d2(nzp,nzp))
    ! compute first derivative matrix
    do j=1,nzp
        do i=1,nzp
            dor(i,j) = del(i,j,nzp)
            d(i,j) = del(i,j,nzp)*gf(i)
        end do
    end do
    ! compute second derivative matrix
    d2 = matmul(d,d)
!     d2 = matmul(dor,dor)
!     do i=1,nzp
!         d2(:,i) = d2(:,i)*gf2(:)
!     end do
!     do i=1,nzp
!         do j=1,nzp
!             d2(i,j) = 0.0
!             do k=1,nzp
!                 d2(i,j) = d2(i,j) + d(i,k)*d(k,j)
!             end do
!         end do
!     end do
    ! debug: print out derivative matrix for visual inspection
    if (debug>=2 .and. myid==0) then
        write(*,*) 'dor(1:nzp,1:nzp)'
        write(*,fm3) dor(1:nzp,1:nzp)
    end if

end subroutine build_cheb_zder_matrix

real function del(k,j,n)
    ! returns Chebyshev a single derivative coefficient
    ! of d/d(xi) matrix given the desired index (k,j)
    ! where xi = cos(pi*(k-1)/nz) = [-1,1]
    use grid, only: xl
    integer, intent(in) :: k,j,n
    integer :: kr,jr,nr
    real :: fac
    kr = k - 1
    jr = j - 1
    nr = n - 1
    fac = 1.
    if( kr .eq. nr ) then
        ! take care of boundary condition k=nz (bottom row),
        ! make it the same as first row by setting kr = 0
        kr = 0
        ! but reverse order of bottom row,
        ! and change its sign (compared to top row)
        jr = nr - jr
        fac = -1.
    end if
    del = fac*xnum(kr,jr,nr)/den(kr,jr,nr)
    ! scale the d/d(xi) entry to reflect
    ! xi = xl/2*cos(pi*(k-1)/nz) = [-xl/2,xl/2]
    del = del*(2.0/xl)

end function del

real function den(kr,jr,nr)
    ! returns denominator of single Chebyshev derivative coefficient
    ! of d/d(xi) matrix given the desired index (k-1,j-1)
    integer, intent(in) :: kr,jr,nr
    real :: pi
    pi = 4.*atan(1.)
    ! den = nz*sin(pi(k-1)/nz) except first and last row
    den = nr*sin(pi*kr/nr)
    ! and at first or last column, den is double
    if(jr .eq. 0 .or. jr .eq. nr) den = den*2.0

    ! this section targets first and last row of matrix
    if (kr==0) then
        ! for first and last row, den = nz/2 for even (j-1)
        den = .5*nr
        ! for odd (j-1), den = -nz/2
        if(mod(jr,2) .eq. 1) den = - den
        ! except at four corners of matrix, where den = 1
        if(jr .eq. 0 .or. jr .eq. nr) den = 1.
    end if

end function den

real function xnum(kr,jr,nr)
    ! returns numerator of single Chebyshev derivative coefficient
    ! of d/d(xi) matrix given the desired index (k-1,j-1)
    integer, intent(in) :: kr,jr,nr
    real :: pi
    pi = 4.*atan(1.)

    ! nominally, except at first & last row,
    ! xnum = +/- (nz/2)/tan(pi*(k+j-2)/(2*nz)) +/- (nz/2)/tan(pi*(k-j)/(2*nz))
    xnum = ff(kr+jr,nr) + ff(kr-jr,nr)

    if (kr==0) then
        ! for interior points of first and last row
        xnum = .5*(nr+.5)*((nr+.5) &
            & + (1./tan(pi*jr/(2.0*nr)))**2) &
            & + 1./8. - .25/(sin(pi*jr/(2.0*nr))**2.0) &
            & - .5*nr*nr

        ! for the 2 right corners (jr=nz,kr=0) and (jr=nz,kr=nz)
        ! xnum = 0.5
        if(jr .eq. nr) then
            xnum = .5
            ! if nz is not divisible by 2, xnum = -0.5 for same 2 corners
            if( mod(nr,2) .eq. 1 ) xnum = - xnum
        end if
        ! for 2 left corners (kr=0,jr=0) and (kr=nz,jr=0),
        ! xnum = (nz^2)/3 + 1/6
        if(jr.eq.0) xnum = (1./3.)*nr*nr + 1./6.

    end if

end function xnum

real function ff(i,nr)
    ! computes half of the numerator for
    ! a single Chebyshev derivative coefficient
    ! of d/d(xi) matrix given the desired index i = (k+j-2) or i = (k-j)
    integer, intent(in) :: i, nr
    real :: pi
    pi = 4.*atan(1.)
    ! ff = nz/2 / tan(pi*(k-j)/(2*nz)) OR ff = nz/2 / tan(pi*(k+j-2)/(2*nz))
    ff = nr*.5/tan(pi*i/(2.0*nr))

    ! for even (k+j-2) and (k-j), ff is negative
    if (mod(i,2) .eq. 0) ff = -ff

    ! zero diagonal component (k=j) from i=(k-j),
    ! and from (k+j-2) when k=1,j=1
    ! because tan(0) = 0 and 1/tan(0) would go to infinity otherwise
    ! hence why boundaries are handled in xnum
    if(i .eq. 0) then
        ff = 0.0
    end if

end function ff

! subroutine dct_diff(dydx, y, half_interval, n)
!     include 'fftw3.f'
!     ! use the discrete cosine transform from fftw to calculate the derivative
!     integer, intent(in) :: n ! number of data points
!     real, intent(in), dimension(n) :: y ! function values
!     real, intent(out), dimension(n) :: dydx ! derivative values
!     real, intent(in) :: half_interval ! half the interval length
!     real, dimension(n) :: beta ! derivative coefficients
!     real, dimension(n) :: alpha ! function coefficients
!     integer(kind=8) :: plan1, plan2
!     integer :: i, n_logical ! the logical size of the transform, size of
!     ! the corresponding real symmetric DFT

!     ! the logical size depends on the type of transform, check the docs:
!     ! http://www.fftw.org/doc/1d-real_002deven-DFTs-_0028DCTs_0029.html
!     n_logical = 2*(n-1)

!     ! forward DCT:
!     call dfftw_plan_r2r_1d(plan1, n, y, alpha, FFTW_REDFT00, FFTW_ESTIMATE)
!     call dfftw_execute_r2r(plan1, y, alpha)
!     call dfftw_destroy_plan(plan1)
!     alpha = alpha / half_interval

!     ! recurrence for the derivative coefficients:
!     beta(n) = 0
!     beta(n-1) = 2 * real(n-1) * alpha(n)
!     do i = n-1, 2, -1
!     beta(i-1) = beta(i+1) + 2 * real(i-1) * alpha(i)
!     end do
! !     beta = - beta ! this makes it work, but not sure why!

!     ! inverse DCT:
!     call dfftw_plan_r2r_1d(plan2, n, beta, dydx, FFTW_REDFT00, FFTW_ESTIMATE)
!     call dfftw_execute_r2r(plan2, beta, dydx)
!     call dfftw_destroy_plan(plan2)

!     ! FFTW computes the un-normalized transforms, normalize by logical size
!     dydx = dydx / real(n_logical)

! end subroutine dct_diff

subroutine dct_diff(n1, n2, n, y, dydx, p)
    ! use the discrete cosine transform from fftw to calculate the derivative
    ! taken from: variousconsequences.com/2009/05/fftw-discrete-cosine-transform.html
!     use dim
    use grid, only: xl, gf
!     include 'fftw3.f'
    use, intrinsic :: iso_c_binding
    include 'fftw3.f03'
    integer, intent(in) :: n1, n2, n, p ! p = 1 : first derivative; p = 2 : second derivative
    real, intent(in), dimension(n1,n2,n) :: y ! function values
    real, intent(out), dimension(n1,n2,n) :: dydx ! derivative values
    real :: half_interval ! half the interval length
    real, allocatable, dimension(:) :: alpha, beta ! work arrays
!     real, dimension(n) :: beta ! derivative coefficients
!     real, dimension(n) :: alpha ! function coefficients
    integer(kind=8) :: plan1, plan2
    integer :: i,j,k, l, n_logical, err ! the logical size of the transform, size of
    ! the corresponding real symmetric DFT

    half_interval = 0.5*xl

    ! the logical size depends on the type of transform, check the docs:
    ! http://www.fftw.org/doc/1d-real_002deven-DFTs-_0028DCTs_0029.html
    n_logical = 2*(n-1)

    if (.not. allocated(alpha)) allocate(alpha(n), beta(n), stat=err)
    if (err /= 0) print *, "array: Allocation request denied"

    call dfftw_plan_r2r_1d(plan1, n, beta, alpha, FFTW_REDFT00, FFTW_ESTIMATE)
    call dfftw_plan_r2r_1d(plan2, n, beta, alpha, FFTW_REDFT00, FFTW_ESTIMATE)

    do j=1,n2
        do i=1,n1
            beta = y(i,j,:) ! copy vertical data into beta
            do l=1,p ! loop to calculate higher derivatives
                ! forward DCT:
                call dfftw_execute_r2r(plan1, beta, alpha)
                ! divide by half interval (because domain is not from -1 to 1)
                alpha(2:n-1) = alpha(2:n-1) / half_interval

                beta = 0.0! re-zero beta
                ! recurrence for the derivative coefficients:
                beta(n) = 0.0
                beta(n-1) = 2.0 * (n - 1.) * alpha(n) ! 2.0*n*alpha(n)
                do k = n-1, 2, -1
                    beta(k-1) = beta(k+1) + 2.0 * (k - 1.) * alpha(k) !2.0*k*alpha(k)
                end do

                alpha = 0.0! re-zero alpha
                ! inverse DCT:
                call dfftw_execute_r2r(plan2, beta, alpha)
                ! FFTW computes the un-normalized transforms
                ! normalize by logical size
                ! and apply mapping (chain rule)
                beta = alpha*gf / n_logical
            end do
            dydx(i,j,:) = beta
        end do
    end do

    call dfftw_destroy_plan(plan1)
    call dfftw_destroy_plan(plan2)

    if (allocated(alpha)) deallocate(alpha, beta, stat=err)
    if (err /= 0) print *, "array: Deallocation request denied"

end subroutine dct_diff

! subroutine cheb_fft_diff(uf, dudzf)
!     ! use the discrete cosine transform from fftw to calculate the derivative
!     ! taken from: variousconsequences.com/2009/05/fftw-discrete-cosine-transform.html
!     use dim
!     use grid, only: xl, gf
! !     include 'fftw3.f'
!     use, intrinsic :: iso_c_binding
!     include 'fftw3.f03'
! !     integer, intent(in) :: n ! number of data points
!     real, intent(in), dimension(nxpl,ny,nl) :: uf ! function values
!     real, intent(out), dimension(nxpl,ny,nzpl) :: dudzf ! derivative values
!     real :: half_interval, pi ! half the interval length
! !     real, allocatable, dimension(:) :: u, uhat, what, w, t
!     complex*16, allocatable, dimension(:) :: u, uhat, what, w, t
!     integer :: plan1, plan2
!     integer :: i,j,k, n, err, wavz

!     half_interval = 0.5*xl

!     pi = 4.*atan(1.)

!     n = 2*(nzp-1)

!     allocate(u(n), uhat(n), what(n), w(n), t(nzp), stat=err)
!     if (err /= 0) print *, "cheb_fft_diff: Allocation request denied"

!     call dfftw_plan_dft_1d(plan1, n, u, uhat, FFTW_FORWARD, FFTW_ESTIMATE)
!     call dfftw_plan_dft_1d(plan2, n, what, w, FFTW_BACKWARD, FFTW_ESTIMATE)

!     do j=1,ny
!         do i=1,nxpl !,2
!             ! extend data to 2*(nzp-1): u_0, u_1,...,u_n, u_n-1,...,u_1
!             u(1:nzp) = uf(i,j,:) ! + (0.0,1.)*uf(i+1,j,:)
!             do k=2,nz
!                 u(nzp+k-1) = uf(i,j,nzp-k+1) ! + (0.0,1.)*uf(i+1,j,nzp-k+1)
!             end do

!             ! forward fourier transform:
!             call dfftw_execute(plan1, u, uhat)
!             ! normalize by number of actual grid points
! !             uhat = uhat / nzp
!             uhat = real( uhat )

!             ! calculate derivative: what(kz) = i kz uhat, where kz = -nzp+1,...,nzp
!             do k = 1,n
!                 wavz = -nzp+k
!                 what(k) = -(0.0,1.)*wavz*uhat(k)
!             end do
!             what(nzp) = 0.0! for first derivative

!             ! inverse fourier transform:
!             call dfftw_execute(plan2, what, w)

!             w = w / real(n) !nzp

!             ! Chebyshev derivatives
!             t = 0.0
!             do k = 1,nz
! !                 t(k) = -w(k)/sqrt( 1. - cos((nz-k+1)*pi/real(nz)) )
!                 t(k) = - real( w(k) )/sqrt( 1. - cos((nz-k+1)*pi/real(nz)) )
!             end do
!             ! derivatives for end points
!             t(1) = 0.5*nzp*uhat(nzp+1)
!             t(nzp) = 0.5*nzp*uhat(nzp+1)
!             do k=1,nzp
!                 t(1) = t(1) + real(k-1)**2*uhat(k)/real(nzp)
!                 t(nzp) = t(nzp) + real((-1)**(k-1)*(k-1))**2*uhat(k)/real(nzp)
!             end do

!             ! apply mapping (chain rule)
!             dudzf(i,j,:) = t*gf
! !             dudzf(i,j,:) = real(t)*gf
! !             dudzf(i+1,j,:) = aimag(t)*gf
!         end do
!     end do

!     call dfftw_destroy_plan(plan1)
!     call dfftw_destroy_plan(plan2)

!     if (allocated(uhat)) deallocate(u, uhat, what, w, t, stat=err)
!     if (err /= 0) print *, "cheb_fft_diff: Deallocation request denied"

! end subroutine cheb_fft_diff

end module chebyshev


program main

    use tide_module

    implicit none
    integer :: i, wl_size
    real(kind=8), dimension (:), allocatable :: time_input, water_level
    real(kind=8) :: time, y

    call setup_tide(time_input, water_level, wl_size)

    time = (time_input(1) + time_input(2)) * 0.5

    do i = 2, wl_size
        if ((time > time_input(i-1)) .and. (time < time_input(i))) then
            call parabola_val2(wl_size, time_input, water_level, i, time, y)
            !call linear_val2(y, time, &
            !                & water_level(i-1), water_level(i), &
            !                & time_input(i-1), time_input(i))
            exit
        end if
    end do

    write(*,*) time, y, water_level(1), water_level(2)

    call setup_tide(time_input, water_level, wl_size)

    time = (time_input(3) + time_input(4)) * 0.5

    do i = 2, wl_size
        if ((time > time_input(i-1)) .and. (time < time_input(i))) then
            call parabola_val2(wl_size, time_input, water_level, i, time, y)
            !call linear_val2(y, time, &
            !                & water_level(i-1), water_level(i), &
            !                & time_input(i-1), time_input(i))
            exit
        end if
    end do

    write(*,*) time, y, water_level(3), water_level(4)

    deallocate(time_input)
    deallocate(water_level)

end program main


! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download
!
! $Id$

program system_simulation

! See notes from first two weeks of December, 2001.
! This program begins attempts to analyze the value of particular
! observations. Here, we begin by trying to determine the value of
! observations with a given correlation to a state variable using an
! N member ensemble to compute the correlations.

use      types_mod, only : r8
use random_seq_mod, only : random_seq_type, init_random_seq, &
                           random_gaussian, twod_gaussians

implicit none

! version controlled file description for error handling, do not edit
character(len=256), parameter :: source   = &
   "$URL$"
character(len=32 ), parameter :: revision = "$Revision$"
character(len=128), parameter :: revdate  = "$Date$"

type (random_seq_type) :: r
real(r8), allocatable :: rnum(:, :)
real(r8) :: c(2, 2), sum_err_var, sigma_y_p, sigma_y_o, sigma_x_p
real(r8) :: y_truth, y_o, sample_correl, reg_coef, sample_reg_coef
real(r8) :: sigma_y_u, y_u, sigma_x_u, x_u, sample_x_u, x_error
real(r8) :: x_error_var, total_err_var, mean(2), correl, est_err_var
real(r8) :: temp_sum, pe_2_sum
integer :: n, i, j, n_samples

! Initialize repeatable random sequence
call init_random_seq(r)

! Initialize error accumulation for averaging
sum_err_var = 0.0_r8
mean        = 0.0_r8
temp_sum    = 0.0_r8
pe_2_sum    = 0.0_r8

! For now have a set of free parameters that may be too large
write(*, *) 'Input prior variance of observation variable'
read(*, *) sigma_y_p
write(*, *) 'Input variance of observing instrument'
read(*, *) sigma_y_o
write(*, *) 'Input prior variance of state variable'
read(*, *) sigma_x_p
write(*, *) 'Input ensemble size'
read(*, *) n
write(*, *) 'input an expected correlation'
read(*, *) correl

! Set up covariance matrix for computing the sample correlation
c(1, 1) = 1.0; c(2, 2) = 1.0; c(1, 2) = correl; c(2, 1) = correl

! Allocate storage for doing the correlation
allocate(rnum(2, n))

write(*, *) 'Input number of samples for statistics'
read(*, *) n_samples

! Loop through the number of samples
do i = 1, n_samples

! Produce a sample of an observation yo by getting truth from prior
! and adding on sample from observatoinal error distribution
   y_truth = random_gaussian(r, dble(0.0), sqrt(sigma_y_p))
   y_o = y_truth + random_gaussian(r, dble(0.0), sqrt(sigma_y_o))

! Use random sample to generate erroneous sample correlation
! Generate n pairs of numbers from this distribution
   do j = 1, n
      call twod_gaussians(r, mean, c, rnum(:, j))
   enddo

! Compute the sample correlation
   call comp_correl(rnum, n, sample_correl)

! Compute temporary sum to evaluate partial analytic solution
   temp_sum = temp_sum + (sample_correl - correl)**2 * y_o**2
   pe_2_sum = pe_2_sum + (sample_correl - correl)**2

! Compute regression coefficient, erroneous regression coefficient
   reg_coef = correl * sqrt(sigma_x_p) / sqrt(sigma_y_p)
   sample_reg_coef = sample_correl * sqrt(sigma_x_p) / sqrt(sigma_y_p)

! Compute the updated covariance and mean for y given this observation
   sigma_y_u = 1.0 / (1.0 / sigma_y_p + 1.0 / sigma_y_o)
   y_u = sigma_y_u * (0.0 + y_o / sigma_y_o)

! Compute updated covariance for x
! See notes from 11 Dec. for sigma_x_u computation
   sigma_x_u = sigma_x_p - correl**2 * sigma_x_p * sigma_y_p &
      / (sigma_y_o + sigma_y_p)

! Compute correct x_u and sample x_u
   x_u = reg_coef * y_u
   sample_x_u = sample_reg_coef * y_u

! Compute error in x
   x_error = sample_x_u - x_u
   x_error_var = x_error **2

! Total expected variance for this one is x_error_var plus sigma_x_u
   total_err_var = x_error_var + sigma_x_u

! Accumulate this for averaging
   sum_err_var = sum_err_var + total_err_var

enddo

! Output the mean total_err_var
write(*, *) '----------'
write(*, *) 'Large N Mean total_err_var is ', sigma_x_u
write(*, *) 'Expected sample x variance is ', sum_err_var / n_samples
write(*, *) '----------'

! Using sample for product of correlation and y_0_2
write(*, *) 'Expected error variance is                  ', &
   (temp_sum / n_samples )*(sigma_x_p / sigma_y_p) * (sigma_y_u / sigma_y_o)**2

! Estimate using sample only for correlation
write(*, *) 'Expected error variance, only sample correl ', &
   sigma_x_p * sigma_y_p * (pe_2_sum / n_samples) / (sigma_y_p + sigma_y_o)

est_err_var = ((1.0 - correl**2)**2 / (n - 1.)) * sigma_x_p * sigma_y_p / &
   (sigma_y_p + sigma_y_o)
write(*, *) 'Estimated correl expected variance is       ', est_err_var
write(*, *) '----------'

write(*, *) 'pe_2_mean                   ', pe_2_sum / n_samples
write(*, *) 'expected value of pe_2_mean ', (1.0 - correl**2)**2 / (n - 1.)

write(*, *) '----------'
write(*, *) 'net improvement ', (sigma_x_p - sum_err_var / n_samples) / &
   (sigma_x_p - sigma_x_u)
write(*, *) 'Computed net improvement ', 1. - (pe_2_sum / n_samples) / correl**2

!-----------------------------------------------------
contains
!-----------------------------------------------------

subroutine comp_correl(ens, n, correl)

integer,  intent(in) :: n
real(r8), intent(in) :: ens(2, n)
real(r8), intent(out) :: correl

real(r8) :: sum_x, sum_y, sum_xy, sum_x2, sum_y2

sum_x  = sum(ens(2, :))
sum_y  = sum(ens(1, :))
sum_xy = sum(ens(2, :) * ens(1, :))
sum_x2 = sum(ens(2, :) * ens(2, :))

! Computation of correlation
sum_y2 = sum(ens(1, :) * ens(1, :))

correl = (n * sum_xy - sum_x * sum_y) / &
   sqrt((n * sum_x2 - sum_x**2) * (n * sum_y2 - sum_y**2))

end subroutine comp_correl

end program system_simulation


c      program DRSXRK8
c>> 2008-02-24 DRSXRK8  Krogh -- Change dimenstions for new usage.
c>> 2001-05-25 DRSXRK8  Krogh -- Added comma to format.
c>> 1997-12-18 DRSXRK8  Krogh   Initial code
c--S replaces "?": DR?XRK8, ?XRK8, ?XRK8F, ?XRK8O
c Sample driver for SXRK8 --  Set up to solve simple two body problem
c with circular motion.
c
      integer NEQ, LIDAT, LDAT, LWORK
      parameter (NEQ=4, LIDAT=49+2, LDAT=32+2*NEQ+2+2, LWORK=9*4+6+8*4)
      integer IDAT(LIDAT)
      real             DAT(LDAT), TS(3), TOL, Y(NEQ), WORK(LWORK)
      real             OPT(6)
c++S Default SETTOL = 'TOL = 1.E-4'
c++  Default SETTOL = 'TOL = 1.D-10'
c++  Replace 'TOL = 1.E-4 ' = SETTOL
      parameter (TOL = 1.E-4 )
      real             XRKEND, XRKAE, XRKTDT
      parameter (XRKEND=0.E0, XRKAE=2.E0, XRKTDT=24.E0)
c            Abs. Err. tol.   Output at intervals of 2 Pi       End opt.
      data  OPT /XRKAE,TOL, XRKTDT,0.E0,6.283185307179586477E0, XRKEND/
      data   IDAT(4), IDAT(5), IDAT(6), IDAT(7) /
     1           NEQ,   LIDAT,    LDAT,   LWORK /
c      Starting:  T     H;  Final T.
      data  TS / 0.E0, 0.E0, 20.E0 /
c      Initial Y
      data Y / 1.E0, 0.E0, 0.E0, 1.E0 /
c
c Do the integration
      IDAT(1) = 0
  100 continue
         call SXRK8(TS, Y, OPT, IDAT, DAT, WORK)
         if (IDAT(1) .NE. 3) go to 100
      stop
      end

      subroutine SXRK8F(T, Y, F, IDAT)
c Sample derivative subroutine for use with SXRK8
c This evaluates derivatives for a simple two body problem.
c
      integer          IDAT(*)
      real             T, Y(*), F(*), RQBI
c
c Evaluate the derivatives
      RQBI = 1.E0 / ((sqrt(Y(1)**2+Y(3)**2))**3)
      F(1) = Y(2)
      F(2) = -Y(1)*RQBI
      F(3) = Y(4)
      F(4) = -Y(3)*RQBI
      return
      end

      subroutine SXRK8O(TS, Y, IDAT, DAT)
c Sample output subroutine for use with SXRK8.
c This subroutine gives output for a simple two body problem.
c
      integer          IDAT(*)
      real             TS(*), Y(*), DAT(*)
 1000 format (6X, 'RESULTS FOR A SIMPLE 2-BODY PROBLEM'//
     1   8X, 'T', 13X, 'U/V', 11X, 'UP/VP'/' ')
 1001 format (1P,3E15.6 / 15X, 2E15.6/' ')
c
c Do the output
      if (TS(1) .eq. 0.E0) then
        write (*, 1000)
      end if
      write (*, 1001) TS(1), Y(1), Y(2), Y(3), Y(4)
      return
      end


program ratio

   implicit none

   integer, parameter :: n = 40
   real, parameter :: pi = 3.14159265359

   integer :: i, cube_side
   real :: area_to_volume_S(n), area_to_volume_P(n), surface_sphere, volume_cube, diameter

   do i = 1, n
      cube_side = i
      diameter = sqrt(3*real(cube_side)**2)
      surface_sphere = pi*diameter**2
      volume_cube = real(cube_side)**3
      area_to_volume_S(i) = surface_sphere/volume_cube
   end do

!$OMP PARALLEL DO default(none)
   do i = 1, n
      cube_side = i
      diameter = sqrt(3*real(cube_side)**2)
      print *, i, cube_side
      surface_sphere = pi*diameter**2
      volume_cube = real(cube_side)**3
      area_to_volume_P(i) = surface_sphere/volume_cube
   end do
!$OMP END PARALLEL DO

   do i = 1, n
      if (abs(area_to_volume_S(i) - area_to_volume_P(i)) > 1e-2) then
         print *, "Wrong value for i=", i, area_to_volume_S(i), area_to_volume_P(i)
      end if
   end do

end program ratio