c***********************************************************************
c Find the Gauss-Lobatto collocation points xGL(i) and the
c corresponding weights.
c***********************************************************************
C NCL:  gau = gausLobat (npts)
C NCLFORTSTART
      subroutine   GausLobat(xGL,weight,npts)
      implicit     none
c                             INPUT
      integer      npts
c                             OUTPUT [return like NCL 'gaus']
      double precision weight(npts), xGL(npts)
C NCLEND
      integer      n
c                            return G-L wgts and 'lat'
      call   GaussLobatto(xGL,weight,npts)
c                            switch sign: make -1 to +1 [symmetric]
      if (xGL(1).gt.xGL(2)) then
          do n=1,npts
             xGL(n) = -xGL(n)
          end do
      end if
c                            make range [-90,90]
      do n=1,npts
         xGL(n) = xGL(n)*90.d0
      end do

      return
      end
c *********************************************************************
c ....Find the Gauss-Lobatto weights associated with the GL latitudes
c ....Requested by Erik Kluzek
c *********************************************************************
C NCL:  gauLat = gausLobatWgt (xGLAT)
C NCLFORTSTART
      subroutine findglw (xGLAT, weight, npts)
      implicit   none
c                             INPUT  [xGLAT are [+90 to -90]
      integer    npts
      double precision     xGLAT(npts)
c                             OUTPUT [1D array: double]
      double precision     weight(npts)
C NCLEND
      integer    N, m
      double precision     dt, func0, func1, func2, temp

      N  = npts-1
      dt = 2.d0/(N*(N+1.d0))

      do m = 1,N+1
        temp = xGLAT(m)/90.d0
        call jacobf(func0,func1,func2,temp,N)
        weight(m) = dt / (func0**2)
c c c   write(6,"('FINDGLW:',i4,4f12.5)") m,func0,xGLAT(m),weight(m)
      enddo

      return
      end
c *************** COMPUTATIONAL ROUTINES **********************
      subroutine   GaussLobatto(xGL,weight,npts)
      implicit     none
      integer      npts
      double precision       weight(npts), xGL(npts)

      integer      N, nh, nr, m
      double precision       pi,dt, xh,xl, func0,func1,func2
      data         pi/3.1415926535897932384d0/

      N = npts-1

c.....Find 1st half of the roots by direct solution

      nh = N/2
      dt = pi/(2.d0*N+1.d0)

      do m = 1,nh
        xh = cos( (2.d0*m-1.d0)*dt)
        xl = cos( 2.d0*m*dt)
        call NewtonRaphson1(xl,xh,weight(m),N)
      enddo

      nr = N-2*nh

      if (nr.ne.0) then
c.......N is odd
        weight(nh+1) = 0.d0
      endif

c.....Find 2nd half of the roots by symmetry

      do m = nh+nr+1,N
        weight(m) =-weight(N-m+1)
      enddo

c.....Find 1st half of the roots by direct solution

      xGL(1) = 1.d0
      nh = (N-1)/2

      do m = 1,nh
        xh = weight(m)
        xl = weight(m+1)
        call NewtonRaphson2(xl,xh,xGL(m+1),N)
      enddo

      nr = N-1-2*nh

      if (nr.ne.0) then
c.......N is odd
        xGL(nh+2) = 0.d0
      endif

c.....Find 2nd half of the roots by symmetry

      do m = nh+nr+2,N+1
        xGL(m) =-xGL(N+2-m)
      enddo

c.....Find the Gauss-Lobatto weights

      N  = npts-1
      dt = 2.d0/(N*(N+1.d0))

      do m = 1,N+1
        call jacobf(func0,func1,func2,xGL(m),N)
        weight(m) = dt / (func0**2)
      enddo

      return
      end

c**********************************************************************
c Combination of Newton-Raphson iterations and Bisection method.
c xl and xh are the initial bracketing of the root xm.
c**********************************************************************

      subroutine   NewtonRaphson1(xl,xh,xm,N)
      implicit     none

      integer      k,ITERMAX,N
      double precision  xl,xh,xm,xn, func0,func1,func2, error, TOLERANCE
      parameter   (ITERMAX=100, TOLERANCE=1.d-15)

c.....Find function values at bracketing points

      call jacobf(xm,func1,func2,xl,N)
      call jacobf(xn,func1,func2,xh,N)

      if (xm*xn.gt.0.d0) then
         write(6,*)' root is not bracketed'
         return
      endif

c.....Rearrange xl and xh so that f(xl)< 0.d0 < f(xh)

      if (xm.gt.0.d0) then
         xm = xl
         xl = xh
         xh = xm
      endif

c.....Initial width of bracketed interval

      error = abs(xh-xl)

c.....Initialize guess for root

      xm = 0.5d0*(xl+xh)

      k = 0

      do while (error.gt.TOLERANCE .and. k.lt.ITERMAX)
         k = k+1
         call jacobf(func0,func1,func2,xm,N)

c........Adjust the bracketing of the root
         if (func0.gt.0.d0) then
            xh = xm
         else
            xl = xm
         endif

c........Tentative newton-Raphson step

         xn = xm - func0/func1

         if ((xn-xl)*(xn-xh).gt.0.d0) then
c...........Bisection step
            xm = 0.5d0* (xh+xl)
            error = abs(xh-xl)
         else
c...........Newton-Raphson step successfull
            error = abs(xn-xm)
            xm = xn
         endif
      enddo

c.....Check if solution converged

      if (error.gt.TOLERANCE) then
         write(6,*) 'solution did not converge'
      endif

      return
      end

c**********************************************************************
c Combination of Newton-Raphson iterations and Bisection method.
c xl and xh are the initial bracketing of the root xm.
c**********************************************************************

      subroutine   NewtonRaphson2(xl,xh,xm,N)
      implicit     none

      integer      k,ITERMAX,N
      double precision xl,xh,xm,xn, func0,func1,func2, error, TOLERANCE
      parameter   (ITERMAX=100, TOLERANCE=1.d-15)

c.....Find function values at bracketing points

      call jacobf(func0,xm,func2,xl,N)
      call jacobf(func0,xn,func2,xh,N)

      if (xm*xn.gt.0.d0) then
         write(6,*)' root is not bracketed'
         return
      endif

c.....Rearrange xl and xh so that f(xl)< 0.d0 < f(xh)

      if (xm.gt.0.d0) then
         xm = xl
         xl = xh
         xh = xm
      endif

c.....Initial width of bracketed interval

      error = abs(xh-xl)

c.....Initialize guess for root

      xm = 0.5d0*(xl+xh)

      k = 0

      do while (error.gt.TOLERANCE .and. k.lt.ITERMAX)
         k = k+1
         call jacobf(func0,func1,func2,xm,N)

c........Adjust the bracketing of the root
         if (func1.gt.0.d0) then
            xh = xm
         else
            xl = xm
         endif

c........Tentative newton-Raphson step

         xn = xm - func1/func2

         if ((xn-xl)*(xn-xh).gt.0.d0) then
c...........Bisection step
            xm = 0.5d0* (xh+xl)
            error = abs(xh-xl)
         else
c...........Newton-Raphson step successfull
            error = abs(xn-xm)
            xm = xn
         endif
      enddo

c.....Check if solution converged

      if (error.gt.TOLERANCE) then
         write(6,*) 'solution did not converge'
      endif

      return
      end

c**********************************************************************
c Compute the Jacobi polynomials and their derivatives using
c the recurrence relationship.
c p0_3 = Legendre polynomial of degree N
c p1_3 = 1st derivative of Legendre polynomial of degree N at x
c p2_3 = 2nd derivative of Legendre polynomial of degree N at x
c**********************************************************************

      subroutine   jacobf(p0_3,p1_3,p2_3,x,N)
      implicit     none

      integer      N, k
      double precision p0_1, p0_2, p0_3, p1_1, p1_2
     *               , p1_3, p2_1, p2_2, p2_3, a1, a2, x

      p0_3 = 1.d0
      p1_3 = 0.d0
      p2_3 = 0.d0

      if (N.ne.0) then
        p0_2 = p0_3
        p1_2 = p1_3
        p2_2 = p2_3
        p0_3 = x
        p1_3 = 1.d0
        p2_3 = 0.d0

        do k = 2,N
          p0_1 = p0_2
          p1_1 = p1_2
          p2_1 = p2_2
          p0_2 = p0_3
          p1_2 = p1_3
          p2_2 = p2_3

          a1 = (2.d0*k-1.d0) / k
          a2 = (k-1.d0) / k

          p0_3 = a1*x*p0_2 - a2*p0_1
          p1_3 = a1*x*p1_2 - a2*p1_1 + a1*p0_2
          p2_3 = a1*x*p2_2 - a2*p2_1 + 2.d0*a1*p1_2
        enddo
      endif

      return
      end

c**********************************************************************
c Compute the Jacobi polynomials using c the recurrence relationship.
c p_3 = Legendre polynomial of degree N
c p_2 = Legendre polynomial of degree N-1 at x
c p_1 = Legendre polynomial of degree N-2 at x
c**********************************************************************

      function     Legendre(x,N)
      implicit     none

      integer      N, k
      double precision p_1, p_2, p_3, x, Legendre

      p_3 = 1.d0

      if (N.ne.0) then
        p_2 = p_3
        p_3 = x
        do k = 2,N
          p_1 = p_2
          p_2 = p_3
          p_3 = ( (2.d0*k-1.d0)*x*p_2 - (k-1.d0)*p_1 ) / k
        enddo
      endif

      Legendre = p_3

      return
      end

c***********************************************************************
c Compute the matrix giving the first derivative to the Cardinal
c Legendre functions. To compute the first derivative just form the
c matrix product [dcpdxv]{u}={u_ksi}. Reapply previous formula for
c higher order derivative.

c npts:number of collocation points 1<=i<=npts
c dcpdxv(i,j): derivative of pressure cardinal function i evaluated at
c 		velocity node j
c***********************************************************************

      subroutine   CoefPgOnVg(dcpdxv,xvg,xpg,legep,npts,nptp)
      implicit     none

      integer      npts,nptp,N,i,j
      double precision
     *             Legendre,fact,f1,f2,func0,func1,func2,dis,
     *             xvg(npts),xpg(nptp),legep(nptp),dcpdxv(nptp,npts)

      N = nptp-1

      do i = 1,nptp
        legep(i) = Legendre(xpg(i),N)
      enddo

      fact = N*(N+1)

      do j = 1,npts
        call jacobf(func0,func1,func2,xvg(j),N)
        f1 = fact*func0
        f2 = (1.d0-xvg(j)**2) * func1

        do i = 1,nptp
          if (xvg(j).ne.xpg(i)) then
            dis = xvg(j) - xpg(i)
            dcpdxv(i,j) = (f1*dis+f2) / (fact*legep(i)*dis*dis)
          else
            dcpdxv(i,j) = 0.d0
          endif
        enddo
      enddo

      dcpdxv(nptp,npts) =-0.25d0*fact
      dcpdxv(1,1) = 0.25d0*fact

      return
      end


      real             function SCOS1 (X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>>   1994-10-20 SCOS1 Krogh  Changes to use M77CON
c>>   1993-07-21 SCOS1 WV Snyder JPL Original code
c
c     compute (1 - cos(x)) / x**2.
c
c--S replaces "?": ?COS1
c
      real             X
      real             C, SINC
c
      if (x .eq. 0.0e0) then
         scos1 = 0.5e0
      else
         c = cos(x)
         if (c .le. 0.0) then
            scos1 = (1.0e0 - c ) / x*x
         else
            sinc = sin(x) / x
            scos1 = sinc**2 / (1.0e0 + c)
         end if
      end if
      return
      end


! { dg-do compile }
!
! PR fortran/36153
! Contributed by Jonathan Hogg
!
program test_64
   implicit none

   integer, parameter :: long = selected_int_kind(18)
   integer, parameter :: short = kind(0)

   integer(long), parameter :: big_sz = huge(0_short)+1000_long
   integer(long), parameter :: max_32 = huge(0_short)
   integer, dimension(:), allocatable :: array

   integer(long) :: i

   print *, "2**31  = ", 2_long**31
   print *, "max_32 = ", max_32
   print *, "big_sz = ", big_sz

! Disabled as it overflows on 32bit systems (at compile time)
! (conversion of integer(8) to integer(4))
!   allocate(array(big_sz))
   print *, "sz = ", size(array)
   print *, "sz = ", size(array, kind=long)
end program


*     Fortran 77 Syntax Test File
*     Some Comments about this file

*     Hello World

      PROGRAM HELLOW
        PRINT '(A)', 'Hello, world'
        STOP
      END

*     euclid.f (FORTRAN 77)
*     Find greatest common divisor using the Euclidean algorithm

      PROGRAM EUCLID
        PRINT *, 'A?'
        READ *, NA
        IF (NA.LE.0) THEN
          PRINT *, 'A must be a positive integer.'
          STOP
        END IF
        PRINT *, 'B?'
        READ *, NB
        IF (NB.LE.0) THEN
          PRINT *, 'B must be a positive integer.'
          STOP
        END IF
        PRINT *, 'The GCD of', NA, ' and', NB, ' is', NGCD(NA, NB), '.'
        STOP
      END

      FUNCTION NGCD(NA, NB)
        IA = NA
        IB = NB
    1   IF (IB.NE.0) THEN
          ITEMP = IA
          IA = IB
          IB = MOD(ITEMP, IB)
          GOTO 1
        END IF
        NGCD = IA
        RETURN
      END


subroutine gaussj(a,n,npp,b,m,mp)
  implicit none

  integer :: n,npp,m,mp
  integer,parameter :: nmax = 10000
  real(8) ::  a(npp,npp),b(npp,mp)
  integer,dimension(nmax) :: ipiv,indxr,indxc
  integer :: i,j,k,l,ll
  integer :: irow,icol
  real(8) :: big,dum,pivinv

  do j=1,n
     ipiv(j)=0
  enddo

  do i=1,n
     big=0.0d0
     do j=1,n
        if(ipiv(j).ne.1)then
           do k=1,n
              if (ipiv(k).eq. 0) then
                 if (dabs(a(j,k)) .ge. big)then
                    big=dabs(a(j,k))
                    irow=j
                    icol=k
                 endif
              else if (ipiv(k).gt.1) then
                 write(*,*) 'singular matrix'
                 stop
              endif
           enddo
        endif
     enddo

     ipiv(icol)=ipiv(icol)+1

     if (irow.ne.icol) then
        do l=1,n
           dum=a(irow,l)
           a(irow,l)=a(icol,l)
           a(icol,l)=dum
        enddo
        do l=1,m
           dum=b(irow,l)
           b(irow,l)=b(icol,l)
           b(icol,l)=dum
        enddo
     endif

     indxr(i)=irow
     indxc(i)=icol
     if (a(icol,icol) .eq. 0.0d0) then
        write(*,*) 'singular matrix.'
        stop
     endif

     pivinv=1.0d0/a(icol,icol)
     a(icol,icol)=1.0d0

     do l=1,n
        a(icol,l)=a(icol,l)*pivinv
     enddo
     do l=1,m
        b(icol,l)=b(icol,l)*pivinv
     enddo

     do ll=1,n
        if(ll.ne.icol)then
           dum=a(ll,icol)
           a(ll,icol)=0.0d0
           do l=1,n
              a(ll,l)=a(ll,l)-a(icol,l)*dum
           enddo
           do l=1,m
              b(ll,l)=b(ll,l)-b(icol,l)*dum
           enddo
        endif
     enddo

  enddo

  do l=n,1,-1
     if(indxr(l).ne.indxc(l))then
        do k=1,n
           dum=a(k,indxr(l))
           a(k,indxr(l))=a(k,indxc(l))
           a(k,indxc(l))=dum
        enddo
     endif
  enddo
  return
  end


!--------------------------------------------------
!PHY1038 Assignment 5 - Linear Algebra
!URN 6309823 - Penguin Lab Group 1
!May 26th 2015
!--------------------------------------------------

PROGRAM Linear_Algebra
  IMPLICIT NONE

      REAL, DIMENSION(1:3,1:3) :: a
      REAL, DIMENSION(1:3) :: const,Xval
      INTEGER :: i, j

        WRITE(6,*) " "
        WRITE(6,*) " "
        WRITE(6,*) "The purpose of this program is to:"
        WRITE(6,*) " "
        WRITE(6,*) "Read an array from a file"
        WRITE(6,*) "Calculate the determinant of the array"
        WRITE(6,*) "Have a subroutine take a matrix as one argument.
        WRITE(6,*) "It should return it's cofactor matrix in another argument"
        WRITE(6,*) "Calculate the matrix inverse"
        WRITE(6,*) "Solve Simultanious Equations"
        WRITE(6,*) " "
        WRITE(6,*) " "

!This opens a file which contains the matrix 'a'

        OPEN(unit=10,file='matrix.dat')
        READ(10,*) ((a(i,j),j=1,3),i=1,3)

        WRITE(6,*) "The Array 'a' which has been read from the file is"
        WRITE(6,*) a
        WRITE(6,*) " "
        WRITE(6,*) "Aranged into matrix form:"
        WRITE(6,*) "  a = [ 2  1 -1]"
        WRITE(6,*) "      [ 1  2  1]"
        WRITE(6,*) "      [-1  3  2]"
        WRITE(6,*) " "
        WRITE(6,*) " "

        WRITE(6,*) "The determinant of matrix 'a' is:"
        WRITE(6,*) f(a)
        WRITE(6,*) " "
        WRITE(6,*) " "

        WRITE(6,*) "The cofactor matrix of matrix 'a' is:"
        WRITE(6,*) C(a)
        WRITE(6,*) " "
        WRITE(6,*) "Aranged into matrix form:"
        WRITE(6,*) " C = [ 1-3 5]"
        WRITE(6,*) "     [-5 3-7]"
        WRITE(6,*) "     [ 3-3 3]"
        WRITE(6,*) " "
        WRITE(6,*) " "

        WRITE(6,*) "The matrix inverse of matrix 'a' is:"
        WRITE(6,*) B(C(a),f(a))
        WRITE(6,*) " "
        WRITE(6,*) "Aranged into matrix form:"
        WRITE(6,*) " "
        WRITE(6,*) " B = [-0.1666667   0.8333334  -0.5000000]"
        WRITE(6,*) "     [ 0.5000000  -0.5000000   0.5000000]"
        WRITE(6,*) "     [-0.8333334   1.1666667  -0.5000000]"
        WRITE(6,*) " "
        WRITE(6,*) " "

!Where const is the right hand side of the initial simultanious equations

        const=(/0.0,3.0,1.0/)

!Where Xval(:) returns the solutions to all 3 equations.

        Xval(:)=MATMUL(const,B(C(a),f(a)))

        WRITE(6,*) "There are three simultanious equations, which are:"
        WRITE(6,*) " "
        WRITE(6,*) "2x[1]+x[2]-x[3]=0"
        WRITE(6,*) "x[1]+2x[2]+x[3]=3"
        WRITE(6,*) "-x[1]+3x[2]+2x[3]=1"
        WRITE(6,*) " "
        WRITE(6,*) " "
        WRITE(6,*) "The solutions to these equations are:"
        WRITE(6,*) Xval(:)
        WRITE(6,*) " "
        WRITE(6,*) "In other words x[1]=2, x[2]=-1 and x[3]=3

  CONTAINS

!Function finds the determinant of "a"
    FUNCTION f(a)
      IMPLICIT NONE
        REAL :: f
        REAL, INTENT(IN), DIMENSION(1:3,1:3) :: a

          f=a(1,1)*(a(2,2)*a(3,3)-a(2,3)*a(3,2))-a(1,2)*(a(2,1)*a(3,3)-a(2,3)*a(3,1))+a(1,3)*(a(2,1)*a(3,2)-a(2,2)*a(3,1))
    END FUNCTION f

!Funtion finds the cofactor matrix of "a"
    FUNCTION C(a)
      IMPLICIT NONE
        REAL, DIMENSION(1:3,1:3) :: C,co
        REAL, INTENT(IN), DIMENSION(1:3,1:3) :: a

          co(1,1)=(-1)**(1+1)*(a(2,2)*a(3,3)-a(2,3)*a(3,2))
          co(1,2)=(-1)**(1+2)*(a(2,1)*a(3,3)-a(2,3)*a(3,1))
          co(1,3)=(-1)**(1+3)*(a(2,1)*a(3,2)-a(2,2)*a(3,1))
          co(2,1)=(-1)**(2+1)*(a(1,2)*a(3,3)-a(1,3)*a(3,2))
          co(2,2)=(-1)**(2+2)*(a(1,1)*a(3,3)-a(1,3)*a(3,1))
          co(2,3)=(-1)**(2+3)*(a(1,1)*a(3,2)-a(1,2)*a(3,1))
          co(3,1)=(-1)**(3+1)*(a(1,2)*a(2,3)-a(1,3)*a(2,2))
          co(3,2)=(-1)**(3+2)*(a(1,1)*a(2,3)-a(1,3)*a(2,1))
          co(3,3)=(-1)**(3+3)*(a(1,1)*a(2,2)-a(1,2)*a(2,1))

          C=transpose(co)
    END FUNCTION C

!Function finds the matrix inverse of "a"
    FUNCTION B(cc,ff)
      IMPLICIT NONE
        REAL, INTENT(IN) :: cc(1:3,1:3)
        REAL, DIMENSION(1:3,1:3) :: d,B
        real::e,ff

          d=transpose(cc)
          e=1.0/ff
          B=e*d
    END FUNCTION B

END PROGRAM Linear_Algebra


      subroutine eigen(N,A)
      implicit real*8(a-h,o-z)
      INTEGER*4,intent(in) :: N
      complex*16, intent(in) :: A(n,n)
      complex*16 :: mat(n,n)

      INTEGER          LWMAX
      PARAMETER        ( LWMAX = 1000 )
      INTEGER          INFO, LWORK
!     .. Local Arrays ..
!     RWORK dimension should be at least MAX(1,3*N-2)
      DOUBLE PRECISION W( N ), RWORK( 3*N-2 )
      COMPLEX*16       WORK( LWMAX )
      LDA = N
!     .. External Subroutines ..
!      EXTERNAL         ZHEEV
!      EXTERNAL         PRINT_MATRIX, PRINT_RMATRIX
!
!     .. Intrinsic Functions ..
!      INTRINSIC        INT, MIN
!
!     .. Executable Statements ..
!      WRITE(*,*)'ZHEEV Example Program Results'
!
!     Query the optimal workspace.

      mat = A

      LWORK = -1
      CALL ZHEEV( 'Vectors', 'Lower', N, mat, LDA, W, WORK, LWORK, RWORK, INFO )
      LWORK = MIN( LWMAX, INT( WORK( 1 ) ) )

!     Solve eigenproblem.

      CALL ZHEEV( 'Vectors', 'Lower', N, mat, LDA, W, WORK, LWORK, RWORK, INFO)

!     Check for convergence.

      IF( INFO.GT.0 ) THEN
         WRITE(*,*)'The algorithm failed to compute eigenvalues.'
         STOP
      END IF

      ak = maxval(w)/minval(w)
      if (ak > 1d7) then
        stop
      else
        print *,'condition number', maxval(w)/minval(w)
      endif

      return
      end subroutine

!     End of ZHEEV Example.


subroutine Runge_Kutta_Method(f, y0, h, range)
    procedure(Real) :: f
    Real :: y0, h, x, y, k1, k2, k3, k4
    Integer :: range

    dx = h
    y = y0
    x = 0

    Open(19, FILE="ode_result.dat", status="NEW")
    Do 13, I = 1, (range * INT(1/dx))
        k1 = f(x, y)
        k2 = f(x + Real(1) / 3 * h, y + Real(1) / 3 * k1 * h)
        k3 = f(x + 0.5 * h, y - Real(1) / 3 * k1 * h + k2 * h)
        k4 = f(x + h, y + k1 * h - k2 * h + k3 * h)
        Write(19, *) x, y

        x = x + dx
        y = y + h * (k1 + 3 * k2 + 3 * k3 + k4) / 8
13  continue
    Close(19)
contains
end subroutine Runge_Kutta_Method


submodule(euler_interface_m) euler_prob_0010_m
    implicit none

contains

    module character(len=20) function euler0010()
        write (euler0010, "(i20)") ans(2000000_int64)
    end function euler0010

    integer(int64) function ans(n)
        use euler_primes_m, only: sieve_of_eratosthenes
        implicit none
        integer(int64), intent(in) :: n
        integer(int64) :: i, tmp
        logical, allocatable :: is_prime(:)

        tmp = 0_int64
        call sieve_of_eratosthenes(n, is_prime)

        ! ans = sum( pack([ (i, i = 0_int64, n) ], is_prime) )
        do i = 0_int64, n
            if (is_prime(i)) then
                tmp = tmp + i
            end if
        end do
        ans = tmp
    end function ans
end submodule euler_prob_0010_m


        module upsample2d_preallocate

            implicit none
            include "fftw3.f"
        ! 2d upsampling, using Fourier Transform

        contains

        subroutine upsample2d_complex(a,aup,Atrans,Auptrans,plan,plani,m,n,novr)
  ! upsample matrix a (size mxn) by a factor of novr
  ! output is in aa
  ! aup must be size(m*novr x n*novr)

  ! Atrans is workspace, must be size mxn
  ! Auptrans is workspace, must be size m*novr x n*novr

  ! plan and plani must be created thus:
  !  call sfftw_plan_dft_2d(plan,m,n,a,Atrans,FFTW_FORWARD,FFTW_ESTIMATE)
  !  call sfftw_plan_dft_2d(plani,m*novr,n*novr,Auptrans,aup,FFTW_BACKWARD,FFTW_ESTIMATE)

  ! input
            complex, dimension(:,:), intent(in) :: a
            integer, intent(in) :: m, n, novr
            integer*8, intent(in) :: plan, plani

  ! output
            complex, dimension(:,:), intent(out) :: aup
            complex, dimension(:,:), intent(out) :: Atrans,Auptrans

  ! computation variables
            integer :: nyqst_m, nyqst_n

  ! 2d fft
            call sfftw_execute(plan)

  ! Nyquist frequencies
            nyqst_m = ceiling((m+1)/2.0)
            nyqst_n = ceiling((n+1)/2.0)

  ! zero out spectra
            Auptrans(1:(m*novr),1:(n*novr)) = cmplx(0.0,0.0)

  ! copy spectra
            Auptrans(1:nyqst_m,1:nyqst_n) = Atrans(1:nyqst_m,1:nyqst_n);
            Auptrans(m*novr-nyqst_m+3:m*novr,1:nyqst_n) = Atrans(nyqst_m+1:m,1:nyqst_n);
            Auptrans(1:nyqst_m,n*novr-nyqst_n+3:n*novr) = Atrans(1:nyqst_m,nyqst_n+1:n);
            Auptrans(m*novr-nyqst_m+3:m*novr,n*novr-nyqst_n+3:n*novr) = Atrans(nyqst_m+1:m,nyqst_n+1:n);

            if(mod(m,2).eq.0)then
                Auptrans(nyqst_m,1:(n*novr)) = Auptrans(nyqst_m,1:(n*novr))/cmplx(2.0,0.0)
                Auptrans(m*novr-nyqst_m+2,1:(n*novr)) = Auptrans(nyqst_m,1:(n*novr))
            end if

            if(mod(n,2).eq.0) then
                Auptrans(1:(m*novr),nyqst_n) = Auptrans(1:(m*novr),nyqst_n)/cmplx(2.0,0.0)
                Auptrans(1:(m*novr),n*novr-nyqst_n+2) = Auptrans(1:(m*novr),nyqst_n)
            end if

  ! 2d inverse fft
            call sfftw_execute(plani)

  ! normalize
            aup = aup / cmplx(real(m*n),0.0)

        end subroutine upsample2d_complex

        end module upsample2d_preallocate


c Compute distance and azimuth on a sphere

	subroutine delaz(alat, alon, blat, blon, del, dist, az)

c	computes distance and azimuth from a to b
c	a and b are in decimal degrees and n-e coordinates
c	del -- delta in degrees
c	dist -- distance in km
c	az -- azimuth from a to b clockwise from north in degrees

c	Original author:  Bruce Julian
c	new values for radius used (from Edi Kissling)

	implicit none

c	Parameters:
	real	alat, alon	! Coordinates of first point
	real	blat, blon	! Coordinates of second point
	real	del		! Central angle (degrees)
	real	dist		! Distance (km)
	real	az		! Azimuth from a to b (degrees)

	real	xtop
	real	xden

c	Local variables:
	doubleprecision	acol, bcol
	doubleprecision	azr
	doubleprecision	blatr, blonr
	doubleprecision	colat
	doubleprecision	cosdel
	doubleprecision	delr
	doubleprecision	flat
	doubleprecision	geoa
	doubleprecision	geob
	doubleprecision	rad
	doubleprecision	radius
	doubleprecision alatr, alonr
	doubleprecision diflon
	doubleprecision pi2
	doubleprecision tana, tanb

c	Built-in functions:  Declarations not needed
	doubleprecision dtan
	doubleprecision	datan
	doubleprecision	dsin
	doubleprecision	dcos
	doubleprecision	dacos

c	doubleprecision top,den

	data pi2/1.570796d0/
	data rad/1.745329d-02/
	data flat/.993231d0/

c-----convert to radians
	alatr=alat*rad
	alonr=alon*rad
	blatr=blat*rad
	blonr=blon*rad
c-----convert latitudes to geocentric colatitudes
	tana=flat*dtan(alatr)
	geoa=datan(tana)
	acol=pi2-geoa
	tanb=flat*dtan(blatr)
	geob=datan(tanb)
	bcol=pi2-geob
c-----calculate delta
	diflon=blonr-alonr
	cosdel=dsin(acol)*dsin(bcol)*dcos(diflon)+dcos(acol)*
     &	dcos(bcol)
	delr=dacos(cosdel)
c-----calculate azimuth from a to b

c*****	Note the use of single precision xtop and xden instead
c	of the double precision top and den in the original
c	program.
c*****	Note also the call to atan2 instead of datan2.
c	Both of these changes were made so that dyn.load
c	would work in Splus.  For some reason, the ld command
c	ld -r -d didn't find _d_atan2
c						WLE 10/16/91

	xtop = dsin(diflon)
	xden=(dsin(acol)/dtan(bcol))-dcos(diflon)*dcos(acol)
	azr=atan2(xtop,xden)
c----- convert to degrees
	del=delr/rad
	az=azr/rad
	if(az.lt.0.0) az=360.+az
c-----compute distance in kilometers
	colat=pi2-(alatr+blatr)/2.d0
	radius=6378.163d0*
     &	(1.d0+3.35278d-3*((1.d0/3.d0)-(dcos(colat)**2)))
	dist=delr*radius
	return
c  ***** end of subroutine delaz *****
	end


\ Doubles

: d>s                  drop ; macro     \ 8.6.1.1140
: 2rot  2>r 2swap 2r> 2swap ;           \ 8.6.2.0420
: -2rot           2rot 2rot ;
: 2nip          2swap 2drop ;
: 2tuck         2swap 2over ;
: d-             dnegate d+ ;           \ 8.6.1.1050
: d<                  d- 0< ;
: d=                  d- 0= ;           \ 8.6.1.1120
: d0=                 or 0= ; macro     \ 8.6.1.1080  d -- flag
: d0<          swap drop 0< ; macro     \ 8.6.1.1075  d -- flag
: d2*      swap 2* swap 2*c ;           \ 8.6.1.1090  d -- d'
hex
: d2/
   2/ swap ifnc  2/ swap exit then      \ 8.6.1.1100  d -- d'
   80  0 litx  or  swap
;
decimal

: 2literal  \ d --                      \ 8.6.1.0390
   swap  postpone literal
   postpone literal
; immediate

: 2variable  \ <name> --                \ 8.6.1.0440
    create 2 cells /allot
;

: 2constant  \ d <name> --              \ 8.6.1.0360
    create , , does> 2@
;

: d< ( d1 d2 -- flag )                  \ 8.6.1.1110
   rot  2dup = if  2drop u<  exit then  2nip >
;
: du<  \ ud1 ud2 -- flag                \ 8.6.2.1270
   rot  2dup = if  2drop u<  exit then  2nip swap u<
;
: dmax  \ d1 d2 -- d3                   \ 8.6.1.1210
   2over 2over d< if  2swap  then  2drop
;
: dmin ( d d2 -- d3 )                   \ 8.6.1.1220
   2over 2over d< 0= if  2swap  then  2drop
;

: m+    s>d d+ ;                        \ 8.6.1.1830

: m*                                    \ 8.6.1.1820
    2dup xor >r
    abs swap abs um*
    r> 0< if dnegate then
;

\ From Wil Baden's "FPH Popular Extensions"
\ http://www.wilbaden.com/neil_bawd/fphpop.txt

: tnegate                           ( t . . -- -t . . )
    >r  2dup or dup if drop  dnegate 1  then
    r> +  negate ;

: t*                                ( d . n -- t . . )
                                    ( d0 d1 n)
    2dup xor >r                     ( r: sign)
    >r dabs r> abs
    2>r                             ( d0)( r: sign d1 n)
    r@ um* 0                        ( t0 d1 0)
    2r> um*                         ( t0 d1 0 d1*n .)( r: sign)
    d+                              ( t0 t1 t2)
    r> 0< if tnegate then ;

: t/                                ( t . . u -- d . )
                                    ( t0 t1 t2 u)
    over >r >r                      ( t0 t1 t2)( r: t2 u)
    dup 0< if tnegate then
    r@ um/mod                       ( t0 rem d1)
    rot rot                         ( d1 t0 rem)
    r> um/mod                       ( d1 rem' d0)( r: t2)
    nip swap                        ( d0 d1)
    r> 0< if dnegate then ;

: m*/  ( d . n u -- d . )  >r t*  r> t/ ;

\ Double-Number extension words not defined:
\ 8.6.2.0435 2VALUE


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C       Written by: Anshuk Attri
C
C       Contact: contact@anshukattri.in
C       Website: www.anshukattri.in/research
C       GITHUB: github.com/aa-tree/
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

        SUBROUTINE GET_VEC_MOD(I_VEC, O_MOD)
        IMPLICIT NONE

        INCLUDE 'common.dat'

        REAL*8 I_VEC(6)
        REAL*8 O_MOD

!
!       SUMMARY:
!
!       Returns the mod of a vector.
!
!       VARIABLES:
!
!       NAME        TYPE            DESCRIPTION
!
!       I_VEC(6)    INPUT(REAL*8)   The vector for which mod is to be
!                                   calculated.
!
!       O_MOD       OUTPUT(REAL*8)  Modulus of the vector.
!
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

        O_MOD=0.0D0

        O_MOD=SQRT(I_VEC(1)**2.0D0+ I_VEC(2)**2.0D0+ I_VEC(3)**2.0D0)

        RETURN
        END


program test_dpss

!********************************************************************

   implicit none

!  Important variables

   integer, parameter :: npts=101, nev=7
   real(8) :: fw
   real(8), dimension(npts,nev) :: v
   real(8), dimension(nev) :: lambda, theta

!********************************************************************

    fw = 4.d0
    call dpss(npts, fw, nev, v, lambda, theta)

end program

subroutine dpss(npts, fw, nev, v, lambda, theta)

!
!  Modified:
!	German Prieto
!	November 2004
!
!  Calculation of the Discrete Prolate Spheroidal Sequences, and
!  the correspondent eigenvalues. Also, the (1 - eigenvalue) terms
!  are calculated.
!
!  Slepian, D.     1978  Bell Sys Tech J v57 n5 1371-1430
!  Thomson, D. J.  1982  Proc IEEE v70 n9 1055-1096
!
!  Input:
!    npts    	the number of points in the series
!    fw    	the time-bandwidth product (number of Rayleigh bins)
!    nev   	the desired number of tapers
!
!  Output:
!    v     	the eigenvectors (tapers) are returned in v(npts,nev)
!    lambda 	the eigenvalues of the v's
!    theta	the 1-lambda values. The energy outside the bandwidth
!
!  The tapers are the eigenvectors of the tridiagonal matrix sigma(i,j)
!  [see Slepian(1978) eq 14 and 25.] They are also the eigenvectors of
!  the Toeplitz matrix eq. 18. We solve the tridiagonal system in
!  rst_eig (real symmetric tridiagonal solver) for the tapers and use
!  them in the integral equation in the frequency domain
!  (dpss_ev subroutine) to get the eigenvalues more accurately,
!  by performing Chebychev Gaussian Quadrature following Thomson's codes.
!
!  First, we create the main and off-diagonal vectors of the
!  tridiagonal matrix. We compute separetely the even and odd tapers,
!  by calling rst_eig from LAPACK.
!  We, refine the eigenvalues, by computing the inner bandwidth
!  energy in the frequency domain (eq. 2.6 Thomson). Also the "leakage"
!  (1 - eigenvalue) is estimated, independenly if necesary.
!
!  calls rst_eig, dpss_ev
!

!********************************************************************

   implicit none

!  Important variables

   integer, intent(in) :: npts, nev
   real(8), intent(in) :: fw

   real(8), intent(out), dimension(nev) :: lambda, theta
   real(8), intent(out), dimension(npts,nev) :: v

!  Parameters

   real(8), parameter :: pi=3.141592653589793d0, r2=1.4142135623731d0

   integer :: ntot, lh, nr, k, kr, k2, n, i, ierr, nx

   real(8) :: atol, sn, lb, ub

!  Working variables

   integer :: neven, nodd
   integer, dimension(nev) :: ind

   real(8) :: bw, hn, com
   real(8), dimension(nev) :: eigval
   real(8), dimension(:), allocatable :: fv1, fv2
   real(8), dimension(:,:), allocatable :: v2

!********************************************************************

   if (npts < 2) then
      return
   endif

   nx=mod(npts,2)
   lh=(npts/2)+nx

   nodd  = nev/2
   neven = nev - nodd

   print *, 'npts lh nx ', npts, lh, nx
   print *, '101/2, 100/2', npts/2, (npts+1)/2
   print *, nev, nodd, neven

   bw = fw/dble(npts)
   com = cos(2.d0*pi*bw)

   hn = dble(npts-1)/2.d0

   print *, bw,com,hn

   if (allocated(fv1)) then
      deallocate(fv1)
   endif
   if (allocated(fv2)) then
      deallocate(fv2)
   endif

   allocate(fv1(lh))
   allocate(fv2(lh))

!
!  Perform symmetry reduction to half size
!

   do i=1,lh
      n = i-1
!     Main diagonal
      fv1(i)    = com*(hn - dble(n))**2.d0
!     sub diagonal
      fv2(i)    = dble(n*(npts-n))/2.d0

   enddo

   if (nx.eq.0) then
      fv1(lh)   = com* (hn - dble(lh-1))**2.d0 + dble(lh*(npts-lh))/2.d0
   else
      fv2(lh)   = r2*fv2(lh)
   endif

   do i=1,lh
      print *, fv1(i), fv2(i)
   enddo

   return

!
!  Do the even tapers
!

   if (allocated(v2)) then
      deallocate(v2)
   endif
   allocate(v2(lh,neven))

   call rst_eig(lh,fv1,fv2(2:lh),neven,eigval,v2)

   if (nx==1) then
      do k = 1,neven
         v2(lh,k) = r2*v2(lh,k)
      enddo
   endif

   do k = 1,neven
      kr = k
      k2 = 2*k - 1

      theta(k2) = eigval(kr)

!
! Expand the eigenfunctions
!

      nr=npts
      do i=1,lh
         v(i,k2) = v2(i,kr)
         v(nr,k2)= v2(i,kr)
         nr=nr-1
      enddo

!
! Normalize the eigenfunction
!

      sn=0.d0
      do n=1,npts
         sn=sn+v(n,k2)*v(n,k2)
      enddo

      sn=1.d0/sqrt(sn)

!
! Put eigenfunctions positive standard
!

      if ((v(lh+1,k2).lt.0.d0)) then
         sn=-sn
      endif

      do n=1,npts
         v(n,k2)=sn*v(n,k2)
      enddo

   enddo

!
!  Do the odd tapers
!

   if (nodd > 0) then

      if (allocated(v2)) then
         deallocate(v2)
      endif
      allocate(v2(lh-nx,nodd))

      do i=1,lh
         n = i-1
         fv1(i)  = com*(hn - dble(n))**2
         fv2(i)  = dble(n*(npts-n))/2.d0
      enddo

      if (nx.eq.0) then
         fv1(lh)  =  com* (hn - dble(lh-1))**2 - dble(lh*(npts-lh))/2.d0
      endif

      call rst_eig(lh-nx,fv1,fv2(2:lh-nx),nodd,eigval,v2)

      do k = 1,nodd
         kr = k
         k2 = 2*k

         theta(k2) = eigval(kr)

!
! Expand the eigenfunctions
!

         nr=npts
         do i=1,lh-nx
            v(i,k2) = v2(i,kr)
            v(nr,k2)= -v2(i,kr)
            nr=nr-1
         enddo
         if (nx == 1) then
            v(lh,k2) = 0.d0
         endif

!
! Normalize the eigenfunction
!

         sn=0.d0
         do n=1,npts
            sn=sn+v(n,k2)*v(n,k2)
         enddo

         sn=1.d0/sqrt(sn)

!
! Put eigenfunctions positive standard
!

         if ((nx==1) .and. (v(lh+1,k2).lt.0.d0)) then
            sn = -sn
         endif
         if ((nx <= 0) .and. (v(lh+1,k2).lt.0.d0)) then
            sn=-sn
         endif

         do n=1,npts
            v(n,k2)=sn*v(n,k2)
         enddo

      enddo

   endif

   ntot=neven+nodd

!
!  Get the eigenvalues, by Quadrature (Chebychev)
!

   atol = 1.d-14

   call dpss_ev(npts,nev,bw,atol,v,lambda,theta)

   deallocate(fv1,fv2,v2)

   return

end subroutine dpss


*DECK DEXINT
      SUBROUTINE DEXINT (X, N, KODE, M, TOL, EN, NZ, IERR)
C***BEGIN PROLOGUE  DEXINT
C***PURPOSE  Compute an M member sequence of exponential integrals
C            E(N+K,X), K=0,1,...,M-1 for N .GE. 1 and X .GE. 0.
C***LIBRARY   SLATEC
C***CATEGORY  C5
C***TYPE      DOUBLE PRECISION (EXINT-S, DEXINT-D)
C***KEYWORDS  EXPONENTIAL INTEGRAL, SPECIAL FUNCTIONS
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C         DEXINT computes M member sequences of exponential integrals
C         E(N+K,X), K=0,1,...,M-1 for N .GE. 1 and X .GE. 0.  The
C         exponential integral is defined by
C
C         E(N,X)=integral on (1,infinity) of EXP(-XT)/T**N
C
C         where X=0.0 and N=1 cannot occur simultaneously.  Formulas
C         and notation are found in the NBS Handbook of Mathematical
C         Functions (ref. 1).
C
C         The power series is implemented for X .LE. XCUT and the
C         confluent hypergeometric representation
C
C                     E(A,X) = EXP(-X)*(X**(A-1))*U(A,A,X)
C
C         is computed for X .GT. XCUT.  Since sequences are computed in
C         a stable fashion by recurring away from X, A is selected as
C         the integer closest to X within the constraint N .LE. A .LE.
C         N+M-1.  For the U computation, A is further modified to be the
C         nearest even integer.  Indices are carried forward or
C         backward by the two term recursion relation
C
C                     K*E(K+1,X) + X*E(K,X) = EXP(-X)
C
C         once E(A,X) is computed.  The U function is computed by means
C         of the backward recursive Miller algorithm applied to the
C         three term contiguous relation for U(A+K,A,X), K=0,1,...
C         This produces accurate ratios and determines U(A+K,A,X), and
C         hence E(A,X), to within a multiplicative constant C.
C         Another contiguous relation applied to C*U(A,A,X) and
C         C*U(A+1,A,X) gets C*U(A+1,A+1,X), a quantity proportional to
C         E(A+1,X).  The normalizing constant C is obtained from the
C         two term recursion relation above with K=A.
C
C         The maximum number of significant digits obtainable
C         is the smaller of 14 and the number of digits carried in
C         double precision arithmetic.
C
C     Description of Arguments
C
C         Input     * X and TOL are double precision *
C           X       X .GT. 0.0 for N=1 and  X .GE. 0.0 for N .GE. 2
C           N       order of the first member of the sequence, N .GE. 1
C                   (X=0.0 and N=1 is an error)
C           KODE    a selection parameter for scaled values
C                   KODE=1   returns        E(N+K,X), K=0,1,...,M-1.
C                       =2   returns EXP(X)*E(N+K,X), K=0,1,...,M-1.
C           M       number of exponential integrals in the sequence,
C                   M .GE. 1
C           TOL     relative accuracy wanted, ETOL .LE. TOL .LE. 0.1
C                   ETOL is the larger of double precision unit
C                   roundoff = D1MACH(4) and 1.0D-18
C
C         Output    * EN is a double precision vector *
C           EN      a vector of dimension at least M containing values
C                   EN(K) = E(N+K-1,X) or EXP(X)*E(N+K-1,X), K=1,M
C                   depending on KODE
C           NZ      underflow indicator
C                   NZ=0   a normal return
C                   NZ=M   X exceeds XLIM and an underflow occurs.
C                          EN(K)=0.0D0 , K=1,M returned on KODE=1
C           IERR    error flag
C                   IERR=0, normal return, computation completed
C                   IERR=1, input error,   no computation
C                   IERR=2, error,         no computation
C                           algorithm termination condition not met
C
C***REFERENCES  M. Abramowitz and I. A. Stegun, Handbook of
C                 Mathematical Functions, NBS AMS Series 55, U.S. Dept.
C                 of Commerce, 1955.
C               D. E. Amos, Computation of exponential integrals, ACM
C                 Transactions on Mathematical Software 6, (1980),
C                 pp. 365-377 and pp. 420-428.
C***ROUTINES CALLED  D1MACH, DPSIXN, I1MACH
C***REVISION HISTORY  (YYMMDD)
C   800501  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   910408  Updated the REFERENCES section.  (WRB)
C   920207  Updated with code with a revision date of 880811 from
C           D. Amos.  Included correction of argument list.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DEXINT
      DOUBLE PRECISION A,AA,AAMS,AH,AK,AT,B,BK,BT,CC,CNORM,CT,EM,EMX,EN,
     1                 ETOL,FNM,FX,PT,P1,P2,S,TOL,TX,X,XCUT,XLIM,XTOL,Y,
     2                 YT,Y1,Y2
      DOUBLE PRECISION D1MACH,DPSIXN
      INTEGER I,IC,ICASE,ICT,IERR,IK,IND,IX,I1M,JSET,K,KK,KN,KODE,KS,M,
     1        ML,MU,N,ND,NM,NZ
      INTEGER I1MACH
      DIMENSION EN(*), A(99), B(99), Y(2)
      SAVE XCUT
      DATA XCUT / 2.0D0 /
C***FIRST EXECUTABLE STATEMENT  DEXINT
      IERR = 0
      NZ = 0
      ETOL = MAX(D1MACH(4),0.5D-18)
      IF (X.LT.0.0D0) IERR = 1
      IF (N.LT.1) IERR = 1
      IF (KODE.LT.1 .OR. KODE.GT.2) IERR = 1
      IF (M.LT.1) IERR = 1
      IF (TOL.LT.ETOL .OR. TOL.GT.0.1D0) IERR = 1
      IF (X.EQ.0.0D0 .AND. N.EQ.1) IERR = 1
      IF(IERR.NE.0) RETURN
      I1M = -I1MACH(15)
      PT = 2.3026D0*I1M*D1MACH(5)
      XLIM = PT - 6.907755D0
      BT = PT + (N+M-1)
      IF (BT.GT.1000.0D0) XLIM = PT - LOG(BT)
C
      IF (X.GT.XCUT) GO TO 100
      IF (X.EQ.0.0D0 .AND. N.GT.1) GO TO 80
C-----------------------------------------------------------------------
C     SERIES FOR E(N,X) FOR X.LE.XCUT
C-----------------------------------------------------------------------
      TX = X + 0.5D0
      IX = TX
C-----------------------------------------------------------------------
C     ICASE=1 MEANS INTEGER CLOSEST TO X IS 2 AND N=1
C     ICASE=2 MEANS INTEGER CLOSEST TO X IS 0,1, OR 2 AND N.GE.2
C-----------------------------------------------------------------------
      ICASE = 2
      IF (IX.GT.N) ICASE = 1
      NM = N - ICASE + 1
      ND = NM + 1
      IND = 3 - ICASE
      MU = M - IND
      ML = 1
      KS = ND
      FNM = NM
      S = 0.0D0
      XTOL = 3.0D0*TOL
      IF (ND.EQ.1) GO TO 10
      XTOL = 0.3333D0*TOL
      S = 1.0D0/FNM
   10 CONTINUE
      AA = 1.0D0
      AK = 1.0D0
      IC = 35
      IF (X.LT.ETOL) IC = 1
      DO 50 I=1,IC
        AA = -AA*X/AK
        IF (I.EQ.NM) GO TO 30
        S = S - AA/(AK-FNM)
        IF (ABS(AA).LE.XTOL*ABS(S)) GO TO 20
        AK = AK + 1.0D0
        GO TO 50
   20   CONTINUE
        IF (I.LT.2) GO TO 40
        IF (ND-2.GT.I .OR. I.GT.ND-1) GO TO 60
        AK = AK + 1.0D0
        GO TO 50
   30   S = S + AA*(-LOG(X)+DPSIXN(ND))
        XTOL = 3.0D0*TOL
   40   AK = AK + 1.0D0
   50 CONTINUE
      IF (IC.NE.1) GO TO 340
   60 IF (ND.EQ.1) S = S + (-LOG(X)+DPSIXN(1))
      IF (KODE.EQ.2) S = S*EXP(X)
      EN(1) = S
      EMX = 1.0D0
      IF (M.EQ.1) GO TO 70
      EN(IND) = S
      AA = KS
      IF (KODE.EQ.1) EMX = EXP(-X)
      GO TO (220, 240), ICASE
   70 IF (ICASE.EQ.2) RETURN
      IF (KODE.EQ.1) EMX = EXP(-X)
      EN(1) = (EMX-S)/X
      RETURN
   80 CONTINUE
      DO 90 I=1,M
        EN(I) = 1.0D0/(N+I-2)
   90 CONTINUE
      RETURN
C-----------------------------------------------------------------------
C     BACKWARD RECURSIVE MILLER ALGORITHM FOR
C              E(N,X)=EXP(-X)*(X**(N-1))*U(N,N,X)
C     WITH RECURSION AWAY FROM N=INTEGER CLOSEST TO X.
C     U(A,B,X) IS THE SECOND CONFLUENT HYPERGEOMETRIC FUNCTION
C-----------------------------------------------------------------------
  100 CONTINUE
      EMX = 1.0D0
      IF (KODE.EQ.2) GO TO 130
      IF (X.LE.XLIM) GO TO 120
      NZ = M
      DO 110 I=1,M
        EN(I) = 0.0D0
  110 CONTINUE
      RETURN
  120 EMX = EXP(-X)
  130 CONTINUE
      TX = X + 0.5D0
      IX = TX
      KN = N + M - 1
      IF (KN.LE.IX) GO TO 140
      IF (N.LT.IX .AND. IX.LT.KN) GO TO 170
      IF (N.GE.IX) GO TO 160
      GO TO 340
  140 ICASE = 1
      KS = KN
      ML = M - 1
      MU = -1
      IND = M
      IF (KN.GT.1) GO TO 180
  150 KS = 2
      ICASE = 3
      GO TO 180
  160 ICASE = 2
      IND = 1
      KS = N
      MU = M - 1
      IF (N.GT.1) GO TO 180
      IF (KN.EQ.1) GO TO 150
      IX = 2
  170 ICASE = 1
      KS = IX
      ML = IX - N
      IND = ML + 1
      MU = KN - IX
  180 CONTINUE
      IK = KS/2
      AH = IK
      JSET = 1 + KS - (IK+IK)
C-----------------------------------------------------------------------
C     START COMPUTATION FOR
C              EN(IND) = C*U( A , A ,X)    JSET=1
C              EN(IND) = C*U(A+1,A+1,X)    JSET=2
C     FOR AN EVEN INTEGER A.
C-----------------------------------------------------------------------
      IC = 0
      AA = AH + AH
      AAMS = AA - 1.0D0
      AAMS = AAMS*AAMS
      TX = X + X
      FX = TX + TX
      AK = AH
      XTOL = TOL
      IF (TOL.LE.1.0D-3) XTOL = 20.0D0*TOL
      CT = AAMS + FX*AH
      EM = (AH+1.0D0)/((X+AA)*XTOL*SQRT(CT))
      BK = AA
      CC = AH*AH
C-----------------------------------------------------------------------
C     FORWARD RECURSION FOR P(IC),P(IC+1) AND INDEX IC FOR BACKWARD
C     RECURSION
C-----------------------------------------------------------------------
      P1 = 0.0D0
      P2 = 1.0D0
  190 CONTINUE
      IF (IC.EQ.99) GO TO 340
      IC = IC + 1
      AK = AK + 1.0D0
      AT = BK/(BK+AK+CC+IC)
      BK = BK + AK + AK
      A(IC) = AT
      BT = (AK+AK+X)/(AK+1.0D0)
      B(IC) = BT
      PT = P2
      P2 = BT*P2 - AT*P1
      P1 = PT
      CT = CT + FX
      EM = EM*AT*(1.0D0-TX/CT)
      IF (EM*(AK+1.0D0).GT.P1*P1) GO TO 190
      ICT = IC
      KK = IC + 1
      BT = TX/(CT+FX)
      Y2 = (BK/(BK+CC+KK))*(P1/P2)*(1.0D0-BT+0.375D0*BT*BT)
      Y1 = 1.0D0
C-----------------------------------------------------------------------
C     BACKWARD RECURRENCE FOR
C              Y1=             C*U( A ,A,X)
C              Y2= C*(A/(1+A/2))*U(A+1,A,X)
C-----------------------------------------------------------------------
      DO 200 K=1,ICT
        KK = KK - 1
        YT = Y1
        Y1 = (B(KK)*Y1-Y2)/A(KK)
        Y2 = YT
  200 CONTINUE
C-----------------------------------------------------------------------
C     THE CONTIGUOUS RELATION
C              X*U(B,C+1,X)=(C-B)*U(B,C,X)+U(B-1,C,X)
C     WITH  B=A+1 , C=A IS USED FOR
C              Y(2) = C * U(A+1,A+1,X)
C     X IS INCORPORATED INTO THE NORMALIZING RELATION
C-----------------------------------------------------------------------
      PT = Y2/Y1
      CNORM = 1.0E0 - PT*(AH+1.0E0)/AA
      Y(1) = 1.0E0/(CNORM*AA+X)
      Y(2) = CNORM*Y(1)
      IF (ICASE.EQ.3) GO TO 210
      EN(IND) = EMX*Y(JSET)
      IF (M.EQ.1) RETURN
      AA = KS
      GO TO (220, 240), ICASE
C-----------------------------------------------------------------------
C     RECURSION SECTION  N*E(N+1,X) + X*E(N,X)=EMX
C-----------------------------------------------------------------------
  210 EN(1) = EMX*(1.0E0-Y(1))/X
      RETURN
  220 K = IND - 1
      DO 230 I=1,ML
        AA = AA - 1.0D0
        EN(K) = (EMX-AA*EN(K+1))/X
        K = K - 1
  230 CONTINUE
      IF (MU.LE.0) RETURN
      AA = KS
  240 K = IND
      DO 250 I=1,MU
        EN(K+1) = (EMX-X*EN(K))/AA
        AA = AA + 1.0D0
        K = K + 1
  250 CONTINUE
      RETURN
  340 CONTINUE
      IERR = 2
      RETURN
      END


SUBROUTINE RF1D(u,n,a,np)

!****************************************************
!  This routine applies the recursive filter to u for
!  np times with alpha value of a.
!
!  HISTORY: APR. 2003 by YUANFU XIE.
!****************************************************

  IMPLICIT NONE

  INTEGER, INTENT(IN) :: n,np
  REAL,    INTENT(IN) :: a
  REAL                :: u(n)

  ! Local variables:
  INTEGER :: i,ip
  REAL    :: one_a,r(n)

  one_a = 1.0-a

  ! Recurisve filter number of np times:
  DO ip=1,np

     ! Left to right:
     IF (ip .EQ. 1) THEN
        r(1) = one_a*u(1)
     ELSE IF (ip == 2 ) THEN
        r(1) = u(1) / ( 1.0 + a )
     ELSE
        r(1) = one_a * ( u(1) - a**3 * u(2) ) / &
             (1.0-a**2)**2
     END IF
     DO i=2,n
        r(i) = a*r(i-1)+one_a*u(i)
     ENDDO

     ! Right to left:
     IF (ip .EQ. 1) THEN
        u(n) = r(n)/(1.0+a)
     ELSE
        u(n) = one_a * ( r(n) - a**3 * r(n-1) ) / &
             (1.0-a**2)**2
     END IF
     DO i=n-1,1,-1
        u(i) = a*u(i+1)+one_a*r(i)
     ENDDO
  ENDDO

END SUBROUTINE RF1D


      SUBROUTINE TF01RD( NA, NB, NC, N, A, LDA, B, LDB, C, LDC, H, LDH,
     $                   DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute N Markov parameters M(1), M(2),..., M(N) from the
C     parameters (A,B,C) of a linear time-invariant system, where each
C     M(k) is an NC-by-NB matrix and k = 1,2,...,N.
C
C     All matrices are treated as dense, and hence TF01RD is not
C     intended for large sparse problems.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     NA      (input) INTEGER
C             The order of the matrix A.  NA >= 0.
C
C     NB      (input) INTEGER
C             The number of system inputs.  NB >= 0.
C
C     NC      (input) INTEGER
C             The number of system outputs.  NC >= 0.
C
C     N       (input) INTEGER
C             The number of Markov parameters M(k) to be computed.
C             N >= 0.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,NA)
C             The leading NA-by-NA part of this array must contain the
C             state matrix A of the system.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,NA).
C
C     B       (input) DOUBLE PRECISION array, dimension (LDB,NB)
C             The leading NA-by-NB part of this array must contain the
C             input matrix B of the system.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,NA).
C
C     C       (input) DOUBLE PRECISION array, dimension (LDC,NA)
C             The leading NC-by-NA part of this array must contain the
C             output matrix C of the system.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,NC).
C
C     H       (output) DOUBLE PRECISION array, dimension (LDH,N*NB)
C             The leading NC-by-N*NB part of this array contains the
C             multivariable parameters M(k), where each parameter M(k)
C             is an NC-by-NB matrix and k = 1,2,...,N. The Markov
C             parameters are stored such that H(i,(k-1)xNB+j) contains
C             the (i,j)-th element of M(k) for i = 1,2,...,NC and
C             j = 1,2,...,NB.
C
C     LDH     INTEGER
C             The leading dimension of array H.  LDH >= MAX(1,NC).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX(1, 2*NA*NC).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     For the linear time-invariant discrete-time system
C
C            x(k+1) = A x(k) + B u(k)
C             y(k)  = C x(k) + D u(k),
C
C     the transfer function matrix G(z) is given by
C                            -1
C              G(z) = C(zI-A)  B + D
C                             -1        -2     2   -3
C                   = D + CB z   + CAB z   + CA B z   + ...          (1)
C
C     Using Markov parameters, G(z) can also be written as
C                                 -1        -2        -3
C              G(z) = M(0) + M(1)z   + M(2)z   + M(3)z   + ...       (2)
C
C                                                               k-1
C     Equating (1) and (2), we find that M(0) = D and M(k) = C A    B
C     for k > 0, from which the Markov parameters M(1),M(2)...,M(N) are
C     computed.
C
C     REFERENCES
C
C     [1] Chen, C.T.
C         Introduction to Linear System Theory.
C         H.R.W. Series in Electrical Engineering, Electronics and
C         Systems, Holt, Rinehart and Winston Inc., London, 1970.
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires approximately (NA + NB) x NA x NC x N
C     multiplications and additions.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996.
C     Supersedes Release 2.0 routine TF01FD by S. Van Huffel, Katholieke
C     Univ. Leuven, Belgium.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Markov parameters, multivariable system, time-invariant system,
C     transfer function, transfer matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      INTEGER           INFO, LDA, LDB, LDC, LDH, LDWORK, N, NA, NB, NC
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), H(LDH,*)
C     .. Local Scalars ..
      INTEGER           I, JWORK, K, LDW
C     .. External Subroutines ..
      EXTERNAL          DGEMM, DLACPY, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX, MIN
C     .. Executable Statements ..
C
      INFO = 0
C
C     Test the input scalar arguments.
C
      IF( NA.LT.0 ) THEN
         INFO = -1
      ELSE IF( NB.LT.0 ) THEN
         INFO = -2
      ELSE IF( NC.LT.0 ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, NA ) ) THEN
         INFO = -6
      ELSE IF( LDB.LT.MAX( 1, NA ) ) THEN
         INFO = -8
      ELSE IF( LDC.LT.MAX( 1, NC ) ) THEN
         INFO = -10
      ELSE IF( LDH.LT.MAX( 1, NC ) ) THEN
         INFO = -12
      ELSE IF( LDWORK.LT.MAX( 1, 2*NA*NC ) ) THEN
         INFO = -14
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'TF01RD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( MIN( NA, NB, NC, N ).EQ.0 )
     $   RETURN
C
      JWORK = 1 + NC*NA
      LDW   = MAX( 1, NC )
      I = 1
C
C     Copy C in the workspace beginning from the position JWORK.
C     This workspace will contain the product C*A**(K-1), K = 1,2,...,N.
C
      CALL DLACPY( 'Full', NC, NA, C, LDC, DWORK(JWORK), LDW )
C
C     Form M(1), M(2), ..., M(N).
C
      DO 10 K = 1, N
         CALL DLACPY( 'Full', NC, NA, DWORK(JWORK), LDW, DWORK, LDW )
C
C        Form (C * A**(K-1)) * B = M(K).
C
         CALL DGEMM( 'No transpose', 'No transpose', NC, NB, NA, ONE,
     $               DWORK, LDW, B, LDB, ZERO, H(1,I), LDH )
C
         IF ( K.NE.N ) THEN
C
C           Form C * A**K.
C
            CALL DGEMM( 'No transpose', 'No transpose', NC, NA, NA, ONE,
     $                  DWORK, LDW, A, LDA, ZERO, DWORK(JWORK), LDW )
C
            I = I + NB
         END IF
   10 CONTINUE
C
      RETURN
C *** Last line of TF01RD ***
      END


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                       .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c ... file sfvpec.f
c
c     this file includes documentation and code for
c     subroutine sfvpec          i
c
c ... files which must be loaded with sfvpec.f
c
c     sphcom.f, hrfft.f, vhaec.f, shsec.f
c
c
c     subroutine sfvpec(nlat,nlon,isym,nt,sf,vp,idv,jdv,br,bi,cr,ci,
c    +                   mdb,ndb,wshsec,lshsec,work,lwork,ierror)
c
c     given the vector spherical harmonic coefficients br,bi,cr,ci,
c     computed by subroutine vhaec for a vector field (v,w), sfvpec
c     computes a scalar stream function sf and scalar velocity potential
c     vp for (v,w).  (v,w) is expressed in terms of sf and vp by the
c     helmholtz relations (in mathematical spherical coordinates):
c
c          v = -1/sint*d(vp)/dlambda + d(st)/dtheta
c
c          w =  1/sint*d(st)/dlambda + d(vp)/dtheta
c
c     where sint = sin(theta).  w is the east longitudinal and v
c     is the colatitudinal component of the vector field from which
c     br,bi,cr,ci were precomputed.  required associated legendre
c     polynomials are recomputed rather than stored as they are in
c     subroutine sfvpes. sf(i,j) and vp(i,j) are given at colatitude
c
c            theta(i) = (i-1)*pi/(nlat-1)
c
c     and east longitude
c
c            lambda(j) = (j-1)*2*pi/nlon
c
c     on the sphere.
c
c
c     input parameters
c
c     nlat   the number of colatitudes on the full sphere including the
c            poles. for example, nlat = 37 for a five degree grid.
c            nlat determines the grid increment in colatitude as
c            pi/(nlat-1).  if nlat is odd the equator is located at
c            grid point i=(nlat+1)/2. if nlat is even the equator is
c            located half way between points i=nlat/2 and i=nlat/2+1.
c            nlat must be at least 3. note: on the half sphere, the
c            number of grid points in the colatitudinal direction is
c            nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater than
c            3.  the efficiency of the computation is improved when nlon
c            is a product of small prime numbers.
c
c
c     isym   a parameter which determines whether the stream function and
c            velocity potential are computed on the full or half sphere
c            as follows:
c
c      = 0
c
c            the symmetries/antsymmetries described in isym=1,2 below
c            do not exist in (v,w) about the equator.  in this case sf
c            and vp are not necessarily symmetric or antisymmetric about
c            the equator.  sf and vp are computed on the entire sphere.
c            i.e., in arrays sf(i,j),vp(i,j) for i=1,...,nlat and
c            j=1,...,nlon.
c
c      = 1
c
c            w is antisymmetric and v is symmetric about the equator.
c            in this case sf is symmetric and vp antisymmetric about
c            the equator and are computed for the northern hemisphere
c            only.  i.e., if nlat is odd the sf(i,j),vp(i,j) are computed
c            for i=1,...,(nlat+1)/2 and for j=1,...,nlon.  if nlat is
c            even then sf(i,j),vp(i,j) are computed for i=1,...,nlat/2
c            and j=1,...,nlon.
c
c      = 2
c
c            w is symmetric and v is antisymmetric about the equator.
c            in this case sf is antisymmetric and vp symmetric about
c            the equator and are computed for the northern hemisphere
c            only.  i.e., if nlat is odd the sf(i,j),vp(i,j) are computed
c            for i=1,...,(nlat+1)/2 and for j=1,...,nlon.  if nlat is
c            even then sf(i,j),vp(i,j) are computed for i=1,...,nlat/2
c            and j=1,...,nlon.
c
c     nt     nt is the number of scalar and vector fields.  some
c            computational efficiency is obtained for multiple fields. arrays
c            can be three dimensional corresponding to an indexed multiple
c            vector field.  in this case multiple scalar synthesis will
c            be performed to compute sf,vp for each field.  the
c            third index is the synthesis index which assumes the values
c            k=1,...,nt.  for a single synthesis set nt = 1.  the
c            description of the remaining parameters is simplified by
c            assuming that nt=1 or that all the arrays are two dimensional.
c
c     idv    the first dimension of the arrays sf,vp as it appears in
c            the program that calls sfvpec. if isym = 0 then idv
c            must be at least nlat.  if isym = 1 or 2 and nlat is
c            even then idv must be at least nlat/2. if isym = 1 or 2
c            and nlat is odd then idv must be at least (nlat+1)/2.
c
c     jdv    the second dimension of the arrays sf,vp as it appears in
c            the program that calls sfvpec. jdv must be at least nlon.
c
c     br,bi, two or three dimensional arrays (see input parameter nt)
c     cr,ci  that contain vector spherical harmonic coefficients
c            of the vector field (v,w) as computed by subroutine vhaec.
c
c     mdb    the first dimension of the arrays br,bi,cr,ci as it
c            appears in the program that calls sfvpec. mdb must be at
c            least min0(nlat,nlon/2) if nlon is even or at least
c            min0(nlat,(nlon+1)/2) if nlon is odd.
c
c     ndb    the second dimension of the arrays br,bi,cr,ci as it
c            appears in the program that calls sfvpec. ndb must be at
c            least nlat.
c
c     wshsec an array which must be initialized by subroutine shseci.
c            once initialized, wshsec can be used repeatedly by sfvpec
c            as long as nlon and nlat remain unchanged.  wshsec must
c            not bel altered between calls of sfvpec.
c
c
c     lshsec the dimension of the array wshsec as it appears in the
c            program that calls sfvpec. define
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lshsec must be at least
c
c            2*nlat*l2+3*((l1-2)*(nlat+nlat-l1-1))/2+nlon+15
c
c
c     work   a work array that does not have to be saved.
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls sfvpec. define
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2                    if nlat is even or
c               l2 = (nlat+1)/2                if nlat is odd
c
c            if isym is zero then lwork must be at least
c
c                nlat*((nt*nlon+max0(3*l2,nlon)) + 2*l1*nt+1)
c
c            if isym is not zero then lwork must be at least
c
c                l2*(nt*nlon+max0(3*nlat,nlon)) + nlat*(2*l1*nt+1)
c
c     **************************************************************
c
c     output parameters
c
c    sf,vp  two or three dimensional arrays (see input parameter nt)
c           that contains the stream function and velocity potential
c           of the vector field (v,w) whose coefficients br,bi,cr,ci
c           where precomputed by subroutine vhaec.  sf(i,j),vp(i,j)
c           are given at the colatitude point
c
c                theta(i) = (i-1)*pi/(nlat-1)
c
c           and longitude point
c
c                lambda(j) = (j-1)*2*pi/nlon
c
c           the index ranges are defined above at the input parameter isym.
c
c
c    ierror = 0  no errors
c           = 1  error in the specification of nlat
c           = 2  error in the specification of nlon
c           = 3  error in the specification of isym
c           = 4  error in the specification of nt
c           = 5  error in the specification of idv
c           = 6  error in the specification of jdv
c           = 7  error in the specification of mdb
c           = 8  error in the specification of ndb
c           = 9  error in the specification of lshsec
c           = 10 error in the specification of lwork
c **********************************************************************
c
      subroutine sfvpec(nlat,nlon,isym,nt,sf,vp,idv,jdv,br,bi,cr,ci,
     +                   mdb,ndb,wshsec,lshsec,work,lwork,ierror)
      implicit none
      integer nlat,nlon,isym,nt,idv,jdv,mdb,ndb,lshsec,lwork,ierror
      real sf(idv,jdv,nt),vp(idv,jdv,nt)
      real br(mdb,ndb,nt),bi(mdb,ndb,nt)
      real cr(mdb,ndb,nt),ci(mdb,ndb,nt)
      real wshsec(lshsec),work(lwork)
      integer imid,mmax,lzz1,labc,ls,nln,mab,mn,ia,ib,is,lwk,iwk,lwmin
c
c     check input parameters
c
      ierror = 1
      if(nlat .lt. 3) return
      ierror = 2
      if (nlon .lt. 4) return
      ierror = 3
      if (isym.lt.0 .or. isym.gt.2) return
      ierror = 4
      if (nt .lt. 0) return
      ierror = 5
      imid = (nlat+1)/2
      if((isym.eq.0 .and. idv.lt.nlat) .or.
     +   (isym.gt.0 .and. idv.lt.imid)) return
      ierror = 6
      if(jdv .lt. nlon) return
      ierror = 7
      mmax = min0(nlat,(nlon+2)/2)
      if(mdb .lt. min0(nlat,(nlon+1)/2)) return
      ierror = 8
      if (ndb .lt. nlat) return
      ierror = 9
c
c     verify saved work space (same as shsec)
c
      imid = (nlat+1)/2
      lzz1 = 2*nlat*imid
      labc = 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
      lwmin = lzz1+labc+nlon+15

      if(lshsec .lt. lwmin) return
c
c     verify unsaved work space (add to what shec requires)
c
      ierror = 10
      ls = nlat
      if (isym.gt. 0) ls = imid
      nln = nt*ls*nlon
c
c     set first dimension for a,b (as requried by shsec)
c
      mab = min0(nlat,nlon/2+1)
      mn = mab*nlat*nt
      if(lwork .lt. nln+max0(ls*nlon,3*nlat*imid)+2*mn+nlat) return
      ierror = 0
c
c     set work space pointers
c
      ia = 1
      ib = ia+mn
      is = ib+mn
      iwk = is+nlat
      lwk = lwork-2*mn-nlat
      call sfvpec1(nlat,nlon,isym,nt,sf,vp,idv,jdv,br,bi,cr,ci,mdb,ndb,
     +work(ia),work(ib),mab,work(is),wshsec,lshsec,work(iwk),lwk,
     +ierror)
      return
      end

      subroutine sfvpec1(nlat,nlon,isym,nt,sf,vp,idv,jdv,br,bi,cr,ci,
     +mdb,ndb,a,b,mab,fnn,wshsec,lshsec,wk,lwk,ierror)
      implicit none
      integer nlat,nlon,isym,nt,idv,jdv,mdb,ndb,mab,lshsec,lwk,ierror
      real sf(idv,jdv,nt),vp(idv,jdv,nt)
      real br(mdb,ndb,nt),bi(mdb,ndb,nt),cr(mdb,ndb,nt),ci(mdb,ndb,nt)
      real a(mab,nlat,nt),b(mab,nlat,nt)
      real wshsec(lshsec),wk(lwk),fnn(nlat)
      integer n,m,mmax,k
c
c     set coefficient multiplyers
c
      do n=2,nlat
	fnn(n) = 1.0/sqrt(float(n*(n-1)))
      end do
      mmax = min0(nlat,(nlon+1)/2)
c
c     compute sf scalar coefficients from cr,ci
c
      do k=1,nt
	do n=1,nlat
	  do m=1,mab
	    a(m,n,k) = 0.0
	    b(m,n,k) = 0.0
	  end do
	end do
c
c     compute m=0 coefficients
c
	do n=2,nlat
	  a(1,n,k) =-fnn(n)*cr(1,n,k)
	  b(1,n,k) =-fnn(n)*ci(1,n,k)
	end do
c
c     compute m>0 coefficients using vector spherepack value for mmax
c
	do m=2,mmax
	  do n=m,nlat
	    a(m,n,k) =-fnn(n)*cr(m,n,k)
	    b(m,n,k) =-fnn(n)*ci(m,n,k)
	  end do
	end do
      end do
c
c     synthesize a,b into st
c
      call shsec(nlat,nlon,isym,nt,sf,idv,jdv,a,b,
     +           mab,nlat,wshsec,lshsec,wk,lwk,ierror)
c
c    set coefficients for vp from br,bi
c
      do k=1,nt
	do n=1,nlat
	  do m=1,mab
	    a(m,n,k) = 0.0
	    b(m,n,k) = 0.0
	  end do
	end do
c
c     compute m=0 coefficients
c
	do n=2,nlat
	  a(1,n,k) = fnn(n)*br(1,n,k)
	  b(1,n,k) = fnn(n)*bi(1,n,k)
	end do
c
c     compute m>0 coefficients using vector spherepack value for mmax
c
	mmax = min0(nlat,(nlon+1)/2)
	do m=2,mmax
	  do n=m,nlat
	    a(m,n,k) = fnn(n)*br(m,n,k)
	    b(m,n,k) = fnn(n)*bi(m,n,k)
	  end do
	end do
      end do
c
c     synthesize a,b into vp
c
      call shsec(nlat,nlon,isym,nt,vp,idv,jdv,a,b,
     +           mab,nlat,wshsec,lshsec,wk,lwk,ierror)
      return
      end


	FUNCTION PS_VTOT  ( t850, t500 )
C************************************************************************
C* PS_VTOT								*
C*									*
C* This function computes the vertical totals index:			*
C*									*
C*      VTOT = T850 - T500						*
C*									*
C* REAL PS_VTOT  ( T850, T500 )						*
C*									*
C* Input parameters:							*
C*	T850		REAL		850 mb temperature in Celsius	*
C*	T500		REAL		500 mb temperature in Celsius	*
C*									*
C* Output parameters:							*
C*	PS_VTOT		REAL		Vertical totals index		*
C**									*
C* Log:									*
C* M. Goodman/RDS	11/84	Original source				*
C* M. desJardins/GSFC	 3/88	Documentation				*
C************************************************************************
        INCLUDE       'GEMPRM.PRM'
        INCLUDE       'ERMISS.FNC'
C-----------------------------------------------------------------------------
	IF  ( ERMISS (t850) .or. ERMISS (t500) )  THEN
	    PS_VTOT= RMISSD
	  ELSE
C
C*	    Compute vertical totals index by subtracting temperature at
C*	    500 mb from temperature at 850 mb.
C
	    PS_VTOT= t850 - t500
	END IF
C*
	RETURN
	END


!> Data
module conenagle_data
  use coneangle_env, only: wp
  implicit none(type, external)

  private
  public :: RAD_TO_DEG, PI

  !> Pi
  real(wp), parameter :: PI = acos(-1.0_wp)
  !> Radians to degrees conversion factor
  real(wp), parameter :: RAD_TO_DEG = 180._wp/PI
end module conenagle_data


program ulam
  implicit none

  integer, parameter :: nsize = 49
  integer :: i, j, n, x, y
  integer :: a(nsize*nsize) = (/ (i, i = 1, nsize*nsize) /)
  character(1)  :: spiral(nsize, nsize) = " "
  character(2)  :: sstr
  character(10) :: fmt

  n = 1
  x = nsize / 2 + 1
  y = x
  if(isprime(a(n))) spiral(x, y) = "O"
  n = n + 1

  do i = 1, nsize-1, 2
    do j = 1, i
      x = x + 1
      if(isprime(a(n))) spiral(x, y) = "O"
      n = n + 1
    end do

    do j = 1, i
      y = y - 1
      if(isprime(a(n))) spiral(x, y) = "O"
      n = n + 1
    end do

    do j = 1, i+1
      x = x - 1
      if(isprime(a(n))) spiral(x, y) = "O"
      n = n + 1
    end do

    do j = 1, i+1
      y = y + 1
      if(isprime(a(n))) spiral(x, y) = "O"
      n = n + 1
    end do
  end do

  do j = 1, nsize-1
    x = x + 1
    if(isprime(a(n))) spiral(x, y) = "O"
    n = n + 1
  end do

  write(sstr, "(i0)") nsize
  fmt = "(" // sstr // "(a,1x))"
  do i = 1, nsize
    write(*, fmt) spiral(:, i)
  end do

contains

function isprime(number)
  logical :: isprime
  integer, intent(in) :: number
  integer :: i

  if(number == 2) then
    isprime = .true.
  else if(number < 2 .or. mod(number,2) == 0) then
    isprime = .false.
  else
    isprime = .true.
    do i = 3, int(sqrt(real(number))), 2
      if(mod(number,i) == 0) then
        isprime = .false.
        exit
      end if
    end do
  end if
end function
end program


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cc                                                                    cc
cc        mnsurf : surfit test program                                cc
cc                                                                    cc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      real x(80),y(80),z(80),w(80),tx(15),ty(15),c(200),wrk1(12000),
     * wrk2(6000),xx(11),yy(11),zz(121)
      integer iwrk(300)
      integer i,ier,iopt,is,j,kwrk,kx,ky,lwrk1,lwrk2,m,mx,my,nc,
     * nmax,nx,nxest,ny,nyest
      real ai,delta,eps,fp,s,ww,xb,xe,yb,ye
c  we fetch the number of data points
      read(5,900) m
      write(6,905) m
c  we fetch the co-ordinate and function values of each data point.
      write(6,910)
      do 10 i=1,m
        read(5,915) x(i),y(i),z(i)
        if((i/2)*2.ne.i) go to 10
        j = i-1
        write(6,920) j,x(j),y(j),z(j),i,x(i),y(i),z(i)
  10  continue
c  we fetch an estimate of the standard deviation of the data values.
      read(5,925) delta
      write(6,930) delta
c  the weights are set equal to delta**(-1)
      ww = 1./delta
      do 20 i=1,m
        w(i) = ww
  20  continue
c  we set up the boundaries of the approximation domain.
      xb = -2.
      xe = 2.
      yb = -2.
      ye = 2.
c we generate a rectangular grid for evaluating the splines.
      mx = 11
      my = 11
      do 30 i=1,11
        ai = i-6
        xx(i) = ai*0.4
        yy(i) = xx(i)
  30  continue
c  we set up the dimension information
      nxest = 15
      nyest = 15
      nmax = 15
      kwrk = 300
      lwrk1 = 12000
      lwrk2 = 6000
c  we choose a value for eps
      eps=0.1e-05
c  main loop for the different spline approximations.
      do 300 is=1,6
        go to (110,120,130,140,150,160),is
c  we start computing the least-squares bicubic polynomial (large s)
 110    iopt = 0
        kx = 3
        ky = 3
        s = 900000.
        go to 200
c  iopt=1 from the second call on.
 120    iopt = 1
        s = 200.
        go to 200
c  a value for s within its confidence interval
 130    s = m
        go to 200
c  overfitting (s too small)
 140    s = 20.
        go to 200
c  we change the degrees of the spline
 150    iopt = 0
        kx = 5
        ky = 5
        s = m
        go to 200
c  finally, we also calculate a least-squares spline approximation
c  with specified knots.
 160    iopt = -1
        kx = 3
        ky = 3
        nx = 11
        ny = 11
        j = kx+2
        do 170 i=1,3
          ai = i-2
          tx(j) = ai
          ty(j) = ai
          j = j+1
 170    continue
c  determination of the spline approximation.
 200    call surfit(iopt,m,x,y,z,w,xb,xe,yb,ye,kx,ky,s,nxest,nyest,
     *   nmax,eps,nx,tx,ny,ty,c,fp,wrk1,lwrk1,wrk2,lwrk2,iwrk,kwrk,ier)
c  printing of the fitting results.
        if(iopt.ge.0) go to 210
        write(6,935) kx,ky
        go to 220
 210    write(6,940) kx,ky
        write(6,945) s
 220    write(6,950) fp,ier
        write(6,955) nx
        write(6,960)
        write(6,965) (tx(i),i=1,nx)
        write(6,970) ny
        write(6,960)
        write(6,965) (ty(i),i=1,ny)
        nc = (nx-kx-1)*(ny-ky-1)
        write(6,975)
        write(6,980) (c(i),i=1,nc)
c  evaluation of the spline approximation.
        call bispev(tx,nx,ty,ny,c,kx,ky,xx,mx,yy,my,zz,
     *   wrk2,lwrk2,iwrk,kwrk,ier)
        write(6,1000)
        write(6,985) (xx(i),i=1,mx)
        write(6,990)
        do 230 j=1,my
          write(6,995) yy(j),(zz(i),i=j,121,11)
 230    continue
 300  continue
      stop
c  format statements.
 900  format(i3)
 905  format(1h1,i3,12h data points)
 910  format(1h0,2(2x,1hi,5x,4hx(i),6x,4hy(i),6x,4hz(i),6x))
 915  format(3f10.4)
 920  format(1x,2(i3,3f10.4,5x))
 925  format(e20.6)
 930  format(1x,40hestimate of standard deviation of z(i) =,e15.6)
 935  format(32h0least-squares spline of degrees,2i3)
 940  format(28h0smoothing spline of degrees,2i3)
 945  format(20h smoothing factor s=,f9.0)
 950  format(1x,23hsum squared residuals =,e15.6,5x,11herror flag=,i3)
 955  format(1x,42htotal number of knots in the x-direction =,i3)
 960  format(1x,22hposition of the knots )
 965  format(5x,10f7.3)
 970  format(1x,42htotal number of knots in the y-direction =,i3)
 975  format(23h0b-spline coefficients )
 980  format(5x,8f9.4)
 985  format(1h0,1hx,2x,11f7.1)
 990  format(3x,1hy)
 995  format(1x,f4.1,11f7.3)
 1000 format(1h0,33hspline evaluation on a given grid)
      end


SUBROUTINE eta_linear_3D_bottom(H,k,angle,x,y,int_kx,omega,time,eta,etax,etay,etaxx,etayy,etat)
!
! By Allan P. Engsig-Karup.
USE Precision
USE Constants
IMPLICIT NONE
REAL(KIND=long), INTENT(IN)  :: H,k,angle,x,y,omega,time,int_kx
REAL(KIND=long), INTENT(OUT) :: eta,etax,etay
REAL(KIND=long), INTENT(OUT) :: etaxx,etayy,etat
! REAL(KIND=long), OPTIONAL :: y,etay,etayy !Boundary fitted ?
! Local variables
REAL(KIND=long) :: kx, ky, half_H, k_omegat, sink_omegat
!
kx=k*cos(angle)
ky=k*sin(angle)
!
k_omegat=int_kx+ky*y-omega*time
!k_omegat=kx*x+ky*y-omega*time
half_H = H*half
sink_omegat = sin(k_omegat)
!
eta   =  half_H*cos(k_omegat)
etax  = -half_H*kx*sink_omegat
etay  = -half_H*ky*sink_omegat

etat  =  omega*half_H*sink_omegat
etayy  = -eta*(ky)**2
etaxx = -eta*(kx)**2

END SUBROUTINE eta_linear_3D_bottom


      SUBROUTINE rlft3(data,speq,nn1,nn2,nn3,isign)
      INTEGER isign,nn1,nn2,nn3
      COMPLEX data(nn1/2,nn2,nn3),speq(nn2,nn3)
CU    USES fourn
      INTEGER i1,i2,i3,j1,j2,j3,nn(3)
      DOUBLE PRECISION theta,wi,wpi,wpr,wr,wtemp
      COMPLEX c1,c2,h1,h2,w
      c1=cmplx(0.5,0.0)
      c2=cmplx(0.0,-0.5*isign)
      theta=6.28318530717959d0/dble(isign*nn1)
      wpr=-2.0d0*sin(0.5d0*theta)**2
      wpi=sin(theta)
      nn(1)=nn1/2
      nn(2)=nn2
      nn(3)=nn3
      if(isign.eq.1)then
        call fourn(data,nn,3,isign)
        do 12 i3=1,nn3
          do 11 i2=1,nn2
            speq(i2,i3)=data(1,i2,i3)
11        continue
12      continue
      endif
      do 15 i3=1,nn3
        j3=1
        if (i3.ne.1) j3=nn3-i3+2
        wr=1.0d0
        wi=0.0d0
        do 14 i1=1,nn1/4+1
          j1=nn1/2-i1+2
          do 13 i2=1,nn2
            j2=1
            if (i2.ne.1) j2=nn2-i2+2
            if(i1.eq.1)then
              h1=c1*(data(1,i2,i3)+conjg(speq(j2,j3)))
              h2=c2*(data(1,i2,i3)-conjg(speq(j2,j3)))
              data(1,i2,i3)=h1+h2
              speq(j2,j3)=conjg(h1-h2)
            else
              h1=c1*(data(i1,i2,i3)+conjg(data(j1,j2,j3)))
              h2=c2*(data(i1,i2,i3)-conjg(data(j1,j2,j3)))
              data(i1,i2,i3)=h1+w*h2
              data(j1,j2,j3)=conjg(h1-w*h2)
            endif
13        continue
          wtemp=wr
          wr=wr*wpr-wi*wpi+wr
          wi=wi*wpr+wtemp*wpi+wi
          w=cmplx(sngl(wr),sngl(wi))
14      continue
15    continue
      if(isign.eq.-1)then
        call fourn(data,nn,3,isign)
      endif
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/rlft3.for


      SUBROUTINE MB03QX( N, T, LDT, WR, WI, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the eigenvalues of an upper quasi-triangular matrix.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix T.  N >= 0.
C
C     T       (input) DOUBLE PRECISION array, dimension(LDT,N)
C             The upper quasi-triangular matrix T.
C
C     LDT     INTEGER
C             The leading dimension of the array T.  LDT >= max(1,N).
C
C     WR, WI  (output) DOUBLE PRECISION arrays, dimension (N)
C             The real and imaginary parts, respectively, of the
C             eigenvalues of T. The eigenvalues are stored in the same
C             order as on the diagonal of T. If T(i:i+1,i:i+1) is a
C             2-by-2 diagonal block with complex conjugated eigenvalues
C             then WI(i) > 0 and WI(i+1) = -WI(i).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center, DLR Oberpfaffenhofen,
C     March 1998. Based on the RASP routine SEIG.
C
C     ******************************************************************
C     .. Parameters ..
      DOUBLE PRECISION ZERO
      PARAMETER        ( ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      INTEGER          INFO, LDT, N
C     .. Array Arguments ..
      DOUBLE PRECISION T(LDT, *), WI(*), WR(*)
C     .. Local Scalars ..
      INTEGER          I, I1, INEXT
      DOUBLE PRECISION A11, A12, A21, A22, CS, SN
C     .. External Subroutines ..
      EXTERNAL         DLANV2, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC        MAX
C     .. Executable Statements ..
C
      INFO = 0
C
C     Test the input scalar arguments.
C
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
         INFO = -3
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB03QX', -INFO )
         RETURN
      END IF
C
      INEXT = 1
      DO 10 I = 1, N
         IF( I.LT.INEXT )
     $      GO TO 10
         IF( I.NE.N ) THEN
            IF( T(I+1,I).NE.ZERO ) THEN
C
C              A pair of eigenvalues.
C
               INEXT = I + 2
               I1 = I + 1
               A11 = T(I,I)
               A12 = T(I,I1)
               A21 = T(I1,I)
               A22 = T(I1,I1)
               CALL DLANV2( A11, A12, A21, A22, WR(I), WI(I), WR(I1),
     $                      WI(I1), CS, SN )
               GO TO 10
            END IF
         END IF
C
C        Simple eigenvalue.
C
         INEXT = I + 1
         WR(I) = T(I,I)
         WI(I) = ZERO
   10 CONTINUE
C
      RETURN
C *** Last line of MB03QX ***
      END


*deck hermit
      subroutine hermit(nn,x,a,eps)
c                  calculates the zeros  x(i)  of the nn-th order
c                hermite polynomial.  the largest zero will be
c                stored in x(1).  also calculates the corresponding
c                coefficients  a(i)  of the nn-th order gauss-hermite
c                quadrature formula of degree 2*nn-1.  the factor of
c                sqrt(pi) has been removed from the a(i).
c  a. h. stroud & d. secrest, gaussian quadrature formulas,
c  prentice-hall, 1966
c
      implicit real*8 (a-h,o-z)
      parameter (sixth = 1.0d0/6.0d0)
      dimension x(*), a(*)
c
      fn = (nn)
      n1 = nn - 1
      n2 = (nn+1)/2
      cc = 1.0d0
      s  = 0.0d0
      do 15 i=1,n1
        s  = s + 0.5d0
        cc = s*cc
   15 continue
      s  = (2.0d0*fn+1.0d0)**sixth
      do 30 i=1,n2
        if( i.eq.1 ) then
c         # largest zero
          xt = s**3 - 1.85575d0/s
        elseif( i.eq.2 ) then
c         # second zero
          xt = xt - 1.14d0*fn**0.426d0/xt
        elseif( i.eq.3 ) then
c         # third zero
          xt = 1.86d0*xt - 0.86d0*x(1)
        elseif( i.eq.4 ) then
c         # fourth zero
          xt = 1.91d0*xt - 0.91d0*x(2)
        else
c         # all other zeros
          xt = 2.0d0*xt - x(i-2)
        endif
c
        call hroot(xt,nn,dpn,pn1,eps)
        x(i) = xt
        a(i) = cc/dpn/pn1
c       write (6,'(2i4,2d25.17)') nn, i, xt, a(i)
        ni = nn-i+1
        x(ni) = -xt
        a(ni) = a(i)
   30 continue
      return
      end


C     ******************************************************************
C     * ROUTINES TO CONVERT TO MACH NUMBER FROM OTHER NON-DIMENSIONAL  *
C     * COMPRESSIBLE FLOW QUANTITIES. USE F2PY TO COMPILE INTO A       *
C     * PYTHON MODULE.                                                 *
C     *                                                                *
C     * ALL ACCEPT THE PARAMETERS,                                     *
C     * M, DOUBLE 1-D ARRAY : OUTPUT MACH NUMBER;                      *
C     * X, DOUBLE 1-D ARRAY : INPUT QUANTITY;                          *
C     * G, DOUBLE SCALAR : INPUT SPECIFIC HEAT RATIO;                  *
C     * N, INTEGER SCALAR : LENGTH OF ARRAYS (HIDDEN BY F2PY).         *
C     *                                                                *
C     * MCPTO_APO, A_ACRIT ALSO OPTIONALLY ACCEPT,                     *
C     * SUP, LOGICAL : LOOK FOR SUPERSONIC SOLUTIONS (DEFAULT FALSE).  *
C     *                                                                *
C     * WHERE POSSIBLE, USE ANALYTIC INVERSION OF THE FUNCTION,        *
C     * OTHERWISE USE NEWTON/HALLEY ITERATION TO FIND ROOT.            *
C     *                                                                *
C     * JAMES BRIND, DECEMBER 2020                                     *
C     ******************************************************************
C
      SUBROUTINE TO_T(M,X,G,N)
C     ANALYTIC INVERSION SQRT((TO_T-1)*2./(G-1))
C     ARGUMENTS
      INTEGER N
      REAL*8 G
      REAL*8 M(N)
      REAL*8 X(N)
Cf2py intent(in) x
Cf2py intent(in) g
Cf2py intent(out) m
Cf2py intent(hide) n
C     INTERMEDIATE VARS
      REAL*8 GM1_2
      GM1_2 = (G-1.0D0)*0.5D0
C     MAIN LOOP
      DO I=1,N
            M(I) = SQRT((X(I)-1.0D0)/GM1_2)
      ENDDO
      END
C
      SUBROUTINE PO_P(M,X,G,N)
C     ANALYTIC INVERSION SQRT((PO_P^((G-1)/G)-1)*2./(G-1))
C     ARGUMENTS
      INTEGER N
      REAL*8 G
      REAL*8 M(N)
      REAL*8 X(N)
Cf2py intent(in) x
Cf2py intent(in) g
Cf2py intent(out) m
Cf2py intent(hide) n
C     INTERMEDIATE VARS
      REAL*8 GM1_2
      REAL*8 GM1_G
      GM1_2 = (G-1.0D0)*0.5D0
      GM1_G = (G-1.0D0)/G
C     MAIN LOOP
      DO I=1,N
            M(I) = SQRT((X(I)**GM1_G-1.0D0)/GM1_2)
      ENDDO
      END
C
      SUBROUTINE RHOO_RHO(M,X,G,N)
C     ANALYTIC INVERSION SQRT((RHOO_RHO^(G-1)-1)*2./(G-1))
C     ARGUMENTS
      INTEGER N
      REAL*8 G
      REAL*8 M(N)
      REAL*8 X(N)
Cf2py intent(in) x
Cf2py intent(in) g
Cf2py intent(out) m
Cf2py intent(hide) n
C     INTERMEDIATE VARS
      REAL*8 GM1_2
      REAL*8 GM1
      GM1_2 = (G-1.0D0)*0.5D0
      GM1 = G-1.0D0
C     MAIN LOOP
      DO I=1,N
            M(I) = SQRT((X(I)**GM1-1.0D0)/GM1_2)
      ENDDO
      END
C
      SUBROUTINE V_CPTO(M,X,G,N)
C     ANALYTIC INVERSION SQRT( V_cpTo^2/(G-1)/(1-0.5*V_cpTo^2))
C     ARGUMENTS
      INTEGER N
      REAL*8 G
      REAL*8 M(N)
      REAL*8 X(N)
Cf2py intent(in) x
Cf2py intent(in) g
Cf2py intent(out) m
Cf2py intent(hide) n
C     INTERMEDIATE VARS
      REAL*8 GM1
      REAL*8 XSQ
      GM1 = G-1.0D0
C     MAIN LOOP
      DO I=1,N
        XSQ = X(I)*X(I)
        M(I) = SQRT(XSQ/GM1/(1.0D0 - XSQ/2.0D0))
      ENDDO
      END
C
      SUBROUTINE MCPTO_AP(M,X,G,N)
C     NUMERIC INVERSION USING NEWTON'S METHOD
C     ARGUMENTS
      INTEGER N
      REAL*8 G
      REAL*8 M(N)
      REAL*8 X(N)
Cf2py intent(in) x
Cf2py intent(in) g
Cf2py intent(out) m
Cf2py intent(hide) n
C     INTERMEDIATE VARS
      REAL*8 GM1
      REAL*8 GP1
      REAL*8 M_GP1_GM1_2
      REAL*8 G_SQ_GM1
      REAL*8 GM1_2
      REAL*8 GP1_2
C     ITERATION VARS
      INTEGER K
      REAL*8 MA
      REAL*8 TO_T
      REAL*8 MANEW
      REAL*8 ERR
      REAL*8 F
      REAL*8 DF
C     CONSTANTS
      REAL*8 NAN
      REAL*8 TOL
C     CALC GAMMA VARIANTS
      GM1 = G-1.0D0
      GP1 = G+1.0D0
      GM1_2 = GM1/2.0D0
      GP1_2 = GP1/2.0D0
      M_GP1_GM1_2 = GP1/GM1/(-2.0D0)
      G_SQ_GM1 = G/SQRT(GM1)
C     INITIALISE CONSTANTS
      NAN = 0.0D0
      NAN = 0.0D0/NAN
      TOL = 1.0D-6
C     MAIN LOOP
      DO I=1,N
C         INITIAL GUESS
          MA = 0.5D0
C         UP TO 100 ITERATIONS UNTIL TOLERANCE MET
          ERR = HUGE(ERR)
          K = 0
          DO WHILE (ERR.gt.TOL.and.K.lt.100)
          K = K + 1
C         USE NEWTON'S METHOD FOR NEW GUESS OF MA
          TO_T = (1.0D0 + GM1_2 * MA * MA )
          F = G_SQ_GM1 * MA * SQRT(TO_T)
          DF = G_SQ_GM1 * ( TO_T **2.0D0 - GM1_2 *MA*MA / SQRT(TO_T))
          MANEW = MA - (F-X(I)) / DF
C         GET ERROR AND UPDATE MA
          ERR = ABS(MANEW - MA)
          MA = MANEW
          ENDDO
C         RETURN NAN IF NOT CONVERGED
          IF (ERR.lt.TOL) THEN
              M(I) = MA
          ELSE
              M(I) = NAN
          ENDIF
      ENDDO
      END
C
      SUBROUTINE MCPTO_APO(M,X,G,SUP,N)
C     NUMERIC INVERSION USING NEWTON'S METHOD
C     ARGUMENTS
      INTEGER N
      REAL*8 G
      REAL*8 M(N)
      REAL*8 X(N)
      LOGICAL SUP
Cf2py optional :: SUP = .FALSE.
Cf2py intent(in) sup
Cf2py intent(in) x
Cf2py intent(in) g
Cf2py intent(out) m
Cf2py intent(hide) n
C     INTERMEDIATE VARS
      REAL*8 GM1
      REAL*8 GP1
      REAL*8 M_GP1_GM1_2
      REAL*8 G_SQ_GM1
      REAL*8 GM1_2
      REAL*8 GP1_2
C     ITERATION VARS
      INTEGER K
      REAL*8 MA
      REAL*8 MANEW
      REAL*8 ERR
      REAL*8 F
      REAL*8 DF
      REAL*8 TO_T
C     CONSTANTS
      REAL*8 FCRIT
      REAL*8 NAN
      REAL*8 TOL
C     CALC GAMMA VARIANTS
      GM1 = G-1.0D0
      GP1 = G+1.0D0
      GM1_2 = GM1/2.0D0
      GP1_2 = GP1/2.0D0
      M_GP1_GM1_2 = GP1/GM1/(-2.0D0)
      G_SQ_GM1 = G/SQRT(GM1)
C     CALC CONSTANTS
      NAN = 0.0D0
      NAN = 0.0D0/NAN
      TOL = 1.0D-6
C     CHOKING VALUE
      FCRIT = G_SQ_GM1 * (1.0D0 + GM1_2)**M_GP1_GM1_2
C     MAIN LOOP
      DO I=1,N
C       RETURN NAN IF CHOKED
        IF (X(I).gt.FCRIT) THEN
            M(I) = NAN
        ELSE
            IF (SUP) THEN
                MA = 1.5D0
            ELSE
                MA = 0.5D0
            ENDIF
            K = 0
            ERR = HUGE(ERR)
            DO WHILE (ERR.gt.TOL.and.K.lt.100)

            K = K + 1
            TO_T = (1.0D0 + GM1_2 * MA*MA)
            F = G_SQ_GM1 * MA * TO_T**M_GP1_GM1_2
            DF = F *(1.0D0 - GP1_2*MA*MA/TO_T)/MA
            MANEW = MA - (F-X(I)) / DF
            ERR = ABS(MANEW - MA)
            MA = MANEW
            ENDDO
            IF (ERR.lt.TOL) THEN
                M(I) = MA
            ELSE
                M(I) = NAN
            ENDIF
        ENDIF
      ENDDO
      END
C
      SUBROUTINE A_ACRIT(M,X,G,SUP,N)
C     NUMERIC INVERSION USING NEWTON'S METHOD
C     ARGUMENTS
      INTEGER N
      REAL*8 G
      REAL*8 M(N)
      REAL*8 X(N)
      LOGICAL SUP
Cf2py optional :: SUP = .FALSE.
Cf2py intent(in) sup
Cf2py intent(in) x
Cf2py intent(in) g
Cf2py intent(out) m
Cf2py intent(hide) n
C     INTERMEDIATE VARS
      REAL*8 GM1
      REAL*8 GP1
      REAL*8 GP1_GM1_2
      REAL*8 GM1_2
      REAL*8 GP1_2
C     ITERATION VARS
      INTEGER K
      REAL*8 MA
      REAL*8 MANEW
      REAL*8 ERR
      REAL*8 F
      REAL*8 DF
      REAL*8 TO_T
C     CONSTANTS
      REAL*8 NAN
      REAL*8 TOL
C     CALC GAMMA VARIANTS
      GM1 = G-1.0D0
      GP1 = G+1.0D0
      GM1_2 = GM1/2.0D0
      GP1_2 = GP1/2.0D0
      GP1_GM1_2 = GP1/GM1/(2.0D0)
C     SET CONSTANTS
      NAN = 0.0D0
      NAN = 0.0D0/NAN
      TOL = 1.0D-6
C     MAIN LOOP
      DO I=1,N
        IF (SUP) THEN
            MA = 1.5D0
        ELSE
            MA = 0.5D0
        ENDIF
        K = 0
        ERR = HUGE(ERR)
        DO WHILE (ERR.gt.TOL.and.K.lt.100)

        K = K + 1

        TO_T = 1.0D0 + GM1_2 * MA*MA
        F = ((TO_T/GP1_2)**GP1_GM1_2)/MA
        DF = F * MA * (-1.0D0/MA/MA + GP1_2 /TO_T)

        MANEW = MA - (F-X(I)) / DF
        ERR = ABS(MANEW - MA)
        MA = MANEW
        ENDDO
        IF (ERR.lt.TOL) THEN
            M(I) = MA
        ELSE
            M(I) = NAN
        ENDIF
      ENDDO
      END

      SUBROUTINE POSH_PO(M,X,G,N)
C     NUMERIC INVERSION USING NEWTON'S METHOD
C     ARGUMENTS
      INTEGER N
      REAL*8 G
      REAL*8 M(N)
      REAL*8 X(N)
Cf2py intent(in) x
Cf2py intent(in) g
Cf2py intent(out) m
Cf2py intent(hide) n
C     INTERMEDIATE VARS
      REAL*8 GM1
      REAL*8 GP1
      REAL*8 GM1_GP1
      REAL*8 GM1_2
      REAL*8 GP1_2
      REAL*8 G_GM1
      REAL*8 P_GM1
C     ITERATION VARS
      INTEGER K
      REAL*8 A
      REAL*8 B
      REAL*8 C
      REAL*8 MA
      REAL*8 MANEW
      REAL*8 ERR
      REAL*8 F
      REAL*8 DF
      REAL*8 TO_T
      REAL*8 MSQ
C     CONSTANTS
      REAL*8 NAN
      REAL*8 TOL
C     CALC GAMMA VARIANTS
      GM1 = G-1.0D0
      GP1 = G+1.0D0
      GM1_2 = GM1/2.0D0
      GP1_2 = GP1/2.0D0
      GM1_GP1 = GM1/GP1
      G_GM1 = G/GM1
      P_GM1 = 1.0D0/GM1
C     SET CONSTANTS
      NAN = 0.0D0
      NAN = 0.0D0/NAN
      TOL = 1.0D-6
C     MAIN LOOP
      DO I=1,N
        IF (X(I).gt.1.0D0) THEN
            M(I) = NAN
        ELSE
        MA = 1.5D0
        K = 0
        ERR = HUGE(ERR)
        DO WHILE (ERR.gt.TOL.and.K.lt.100)

        K = K + 1

        MSQ = MA*MA
        TO_T = (1.0D0 + GM1_2*MSQ)
        A = GP1_2*MSQ/TO_T
        B = 1.0D0/(G/GP1_2*MSQ - GM1_GP1)
        C = -G*MA*(MSQ-1.0D0)*(MSQ-1.0D0)/TO_T/TO_T
        F = A**G_GM1 * B**P_GM1
        DF = C *(A**P_GM1) *(B**G_GM1)
        MANEW = MA - (F-X(I)) / DF
        ERR = ABS(MANEW - MA)
        MA = MANEW
        ENDDO
        IF (ERR.lt.TOL) THEN
            M(I) = MA
        ELSE
            M(I) = NAN
        ENDIF
        ENDIF
      ENDDO
      END

      SUBROUTINE MASH(M,X,G,N)
C     NUMERIC INVERSION USING NEWTON'S METHOD
C     ARGUMENTS
      INTEGER N
      REAL*8 G
      REAL*8 M(N)
      REAL*8 X(N)
Cf2py intent(in) x
Cf2py intent(in) g
Cf2py intent(out) m
Cf2py intent(hide) n
C     INTERMEDIATE VARS
      REAL*8 GM1
      REAL*8 GP1
      REAL*8 GM1_2
      REAL*8 GP1_2
C     ITERATION VARS
      INTEGER K
      REAL*8 MA
      REAL*8 MANEW
      REAL*8 ERR
      REAL*8 F
      REAL*8 DF
      REAL*8 MSQ
      REAL*8 C
      REAL*8 SQRT_TO_T
C     CONSTANTS
      REAL*8 NAN
      REAL*8 TOL
C     CALC GAMMA VARIANTS
      GM1 = G-1.0D0
      GP1 = G+1.0D0
      GM1_2 = GM1/2.0D0
      GP1_2 = GP1/2.0D0
C     SET CONSTANTS
      NAN = 0.0D0
      NAN = 0.0D0/NAN
      TOL = 1.0D-6
C     MAIN LOOP
      DO I=1,N
C       RETURN NAN FOR PRE SHOCK MA LESS THAN UNITY
        IF (X(I).gt.1.0D0) THEN
            M(I) = NAN
        ELSE
        MA = 0.5D0
        K = 0
        ERR = HUGE(ERR)
        DO WHILE (ERR.gt.TOL.and.K.lt.100)

        K = K + 1

        MSQ = MA*MA
        SQRT_TO_T = SQRT(1.0D0 + GM1_2*MSQ)
        F = SQRT_TO_T/SQRT(G*MSQ - GM1_2)
        C = G * (2.0D0*MSQ - 1.0D0) + 1.0D0
        DF = -GP1**2.0D0 * MA / SQRT(2.0D0)/SQRT_TO_T  / C / SQRT(C)

        MANEW = MA - (F-X(I)) / DF

        ERR = ABS(MANEW - MA)
        MA = MANEW

        ENDDO

        IF (ERR.lt.TOL) THEN
            M(I) = MA
        ELSE
            M(I) = NAN
        ENDIF
        ENDIF
      ENDDO
      END


! Highly divisible triangular number
!
! The sequence of triangle numbers is generated by adding the natural numbers.
! So the 7th trianlge number would be 1 + 2 + 3 + 4 + 5 + 6 + 7 = 28. The first
! ten terms would be:
!
!    1, 3, 6, 10, 15, 21, 28, 36, 45, 55, ...
!
! Let us list the factors of the first seven triangle numbers:
!     1: 1
!     3: 1, 3
!     6: 1, 2, 3, 6
!    10: 1, 2, 5, 10
!    15: 1, 3, 5, 15
!    21: 1, 3, 7, 21
!    28: 1, 2, 4, 7, 14, 28
!
! We can see that 28 is the first triangle number to have over five divisirs.
! What is the value of the first triangle number to have over five hundred divisors?
module Problem12

    implicit none
    private

    public :: solve
contains
    subroutine solve
        write (*, '(A)') 'Problem 12. Highly divisible triangular number.'

        write (*, '(A, I)') 'Triangle 1: ', triangle1()
    end subroutine

    pure function triangle1()
        integer*8 triangle1

        integer number
        integer base
        integer divisors

        ! initial values
        triangle1 = 1
        number    = 1

        do while (.true.)
            divisors = 0
            do base = 1, sqrt(real(triangle1))
                if (mod(triangle1, base) .eq. 0) then
                    divisors = divisors + 1
                end if
            end do

            ! the number of divisors is two times less in case of sqr
            if (divisors .ge. 250) then
                return
            end if

            number    = number + 1
            triangle1 = triangle1 + number
        end do
    end function
end module


!******************************************************************************
!*
!*                             STATISTICAL PHYSICS
!*
!******************************************************************************

  !==========================================================================
  ! 1) AUTHOR: F. Galliano
  !
  ! 2) HISTORY:
  !    - Created 08/2007
  !    - 01/2015: add Maxwell-Boltzmann distribution.
  !
  ! 3) DESCRIPTION: Various functions of statistical physics.
  !==========================================================================

MODULE statistical_physics

  USE utilities, ONLY: DP
  USE constants, ONLY:
  USE special_functions, ONLY:
  IMPLICIT NONE
  PRIVATE

  PUBLIC :: blackbody, maxwell_boltzmann

  INTERFACE blackbody
    MODULE PROCEDURE blackbody_s, blackbody_v
  END INTERFACE blackbody

  INTERFACE maxwell_boltzmann
    MODULE PROCEDURE maxwell_boltzmann_s, maxwell_boltzmann_v
  END INTERFACE maxwell_boltzmann

  ! Peak of the black body function
  REAL(DP), PARAMETER, PUBLIC :: wT_nu = 5.0996E-3_DP ! [m/K] wave*T for Bnu_max
  REAL(DP), PARAMETER, PUBLIC :: wT_w = 3.6698E-3_DP ! [m/K] wave*T for Bw_max

CONTAINS

  !==========================================================================
  ! Bnu[N,M] = BLACKBODY(nu[N],Temperature[M])
  !
  !   Evaluates the planck function at wavelengths nu [Hz], in W/m2/sr/Hz.
  !==========================================================================

  PURE FUNCTION blackbody_v (nu,temp)

    USE utilities, ONLY: DP
    USE constants, ONLY: MKS
    USE special_functions, ONLY: expm1
    IMPLICIT NONE

    REAL(DP), INTENT(IN), DIMENSION(:) :: nu ! Frequency grid in Hz
    REAL(DP), INTENT(IN), DIMENSION(:) :: temp ! Temperature grid in K
    REAL(DP), DIMENSION(SIZE(nu),SIZE(temp)) :: blackbody_v ! Bnu in W/m2/sr/Hz

    REAL(DP) :: twicehovc2, hovk ! Intermediate factors
    REAL(DP), DIMENSION(SIZE(temp)) :: hbeta
    INTEGER :: i, Ntemp

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

    Ntemp = SIZE(temp(:))
    hovk = MKS%hplanck / MKS%kboltz
    twicehovc2 = 2*MKS%hplanck / MKS%clight**2
    hbeta(:) = hovk / temp(:)

    FORALL (i=1:Ntemp) &
      blackbody_v(:,i) = twicehovc2*nu**3 / EXPM1(hbeta(i)*nu)

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

  END FUNCTION blackbody_v

  !==========================================================================

  PURE FUNCTION blackbody_s (nu,temp)

    USE utilities, ONLY: DP
    IMPLICIT NONE

    REAL(DP), INTENT(IN), DIMENSION(:) :: nu ! Frequency grid in Hz
    REAL(DP), INTENT(IN) :: temp ! Temperature in K
    REAL(DP), DIMENSION(SIZE(nu)) :: blackbody_s ! Bnu in W/m2/sr/Hz

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

    blackbody_s(:) = RESHAPE(BLACKBODY_V(nu(:),[temp]),[SIZE(nu(:))])

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

  END FUNCTION blackbody_s

  !==========================================================================
  ! f(E)[N] = MAXWELL_BOLTZMANN(E[N],T)
  !
  !   Returns the Maxwell-Boltzmann distribution in energy [J-1].
  !==========================================================================

  PURE FUNCTION maxwell_boltzmann_v (E,T)

    USE utilities, ONLY: DP
    USE constants, ONLY: pi, MKS
    IMPLICIT NONE

    REAL(DP), DIMENSION(:), INTENT(IN) :: E
    REAL(DP), INTENT(IN) :: T
    REAL(DP), DIMENSION(SIZE(E)) :: maxwell_boltzmann_v

    REAL(DP) :: kT

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

    kT = MKS%kboltz * T ! [J]
    maxwell_boltzmann_v(:) = 2._DP / SQRT(pi) * SQRT(E(:)/kT**3) * EXP(-E(:)/kT)

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

  END FUNCTION maxwell_boltzmann_v

  !==========================================================================

  PURE FUNCTION maxwell_boltzmann_s (E,T)

    USE utilities, ONLY: DP
    IMPLICIT NONE

    REAL(DP), INTENT(IN) :: E
    REAL(DP), INTENT(IN) :: T
    REAL(DP) :: maxwell_boltzmann_s

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

    maxwell_boltzmann_s = MAXVAL(MAXWELL_BOLTZMANN_V([E],T))

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

  END FUNCTION maxwell_boltzmann_s

END MODULE statistical_physics