subroutine differ_backward ( h, o, p, c, x )

!*****************************************************************************80
!
!! DIFFER_BACKWARD computes backward difference coefficients.
!
!  Discussion:
!
!    We determine coefficients C to approximate the derivative at X0
!    of order O and precision P, using equally spaced backward
!    differences, so that
!
!      d^o f(x)/dx^o = sum ( 0 <= i <= o+p-1 ) c(i) f(x-ih) + O(h^(p))
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    10 November 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real ( kind = 8 ) H, the spacing.  0 < H.
!
!    Input, integer ( kind = 4 ) O, the order of the derivative to be
!    approximated.  1 <= O.
!
!    Input, integer ( kind = 4 ) P, the order of the error, as a power of H.
!
!    Output, real ( kind = 8 ) C(O+P), the coefficients.
!
!    Output, real ( kind = 8 ) X(O+P), the evaluation points.
!
  implicit none

  integer ( kind = 4 ) o
  integer ( kind = 4 ) p

  real ( kind = 8 ) b(o+p)
  real ( kind = 8 ) c(o+p)
  real ( kind = 8 ) h
  integer ( kind = 4 ) i
  integer ( kind = 4 ) info
  integer ( kind = 4 ) job
  integer ( kind = 4 ) n
  real ( kind = 8 ) r8_factorial
  real ( kind = 8 ) x(o+p)

  n = o + p

  do i = 1, n
    x(i) = real ( i - n, kind = 8 ) * h
  end do

  b(1:o+p) = 0.0D+00
  b(o+1) = 1.0D+00

  job = 0
  call r8vm_sl ( n, x, b, c, job, info )

  if ( info /= 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'DIFFER_BACKWARD - Fatal error!'
    write ( *, '(a)' ) '  Vandermonde linear system is singular.'
    stop 1
  end if

  c(1:n) = c(1:n) * r8_factorial ( o )

  return
end
subroutine differ_central ( h, o, p, c, x )

!*****************************************************************************80
!
!! DIFFER_CENTRAL computes central difference coefficients.
!
!  Discussion:
!
!    We determine coefficients C to approximate the derivative at X0
!    of order O and precision P, using equally spaced central
!    differences, so that
!
!      d^o f(x)/dx^o = sum ( 0 <= i <= o+p-1 ) c(i) f(x+(2*i-o-p+1)*h/2)
!        + O(h^(p))
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    10 November 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real ( kind = 8 ) H, the spacing.  0 < H.
!
!    Input, integer ( kind = 4 ) O, the order of the derivative to
!    be approximated.  1 <= O.
!
!    Input, integer ( kind = 4 ) P, the order of the error, as a power of H.
!
!    Output, real ( kind = 8 ) C(O+P), the coefficients.
!
!    Output, real ( kind = 8 ) X(O+P), the evaluation points.
!
  implicit none

  integer ( kind = 4 ) o
  integer ( kind = 4 ) p

  real ( kind = 8 ) b(o+p)
  real ( kind = 8 ) c(o+p)
  real ( kind = 8 ) h
  integer ( kind = 4 ) i
  integer ( kind = 4 ) info
  integer ( kind = 4 ) job
  integer ( kind = 4 ) n
  real ( kind = 8 ) r8_factorial
  real ( kind = 8 ) x(o+p)

  n = o + p

  do i = 1, n
    x(i) = real ( - n - 1 + 2 * i, kind = 8 ) * h / 2.0D+00
  end do

  b(1:o+p) = 0.0D+00
  b(o+1) = 1.0D+00

  job = 0
  call r8vm_sl ( n, x, b, c, job, info )

  if ( info /= 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'DIFFER_CENTRAL - Fatal error!'
    write ( *, '(a)' ) '  Vandermonde linear system is singular.'
    stop 1
  end if

  c(1:n) = c(1:n) * r8_factorial ( o )

  return
end
subroutine differ_forward ( h, o, p, c, x )

!*****************************************************************************80
!
!! DIFFER_FORWARD computes forward difference coefficients.
!
!  Discussion:
!
!    We determine coefficients C to approximate the derivative at X0
!    of order O and precision P, using equally spaced forward
!    differences, so that
!
!      d^o f(x)/dx^o = sum ( 0 <= i <= o+p-1 ) c(i) f(x+ih) + O(h^(p))
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    10 November 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real H, the spacing.  0 < H.
!
!    Input, integer O, the order of the derivative to be approximated.
!    1 <= O.
!
!    Input, integer P, the order of the error, as a power of H.
!
!    Output, real C(O+P), the coefficients.
!
!    Output, real X(O+P), the evaluation points.
!
  implicit none

  integer ( kind = 4 ) o
  integer ( kind = 4 ) p

  real ( kind = 8 ) b(o+p)
  real ( kind = 8 ) c(o+p)
  real ( kind = 8 ) h
  integer ( kind = 4 ) i
  integer ( kind = 4 ) info
  integer ( kind = 4 ) job
  integer ( kind = 4 ) n
  real ( kind = 8 ) r8_factorial
  real ( kind = 8 ) x(o+p)

  n = o + p

  do i = 1, n
    x(i) = real ( i - 1, kind = 8 ) * h
  end do

  b(1:o+p) = 0.0D+00
  b(o+1) = 1.0D+00

  job = 0
  call r8vm_sl ( n, x, b, c, job, info )

  if ( info /= 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'DIFFER_FORWARD - Fatal error!'
    write ( *, '(a)' ) '  Vandermonde linear system is singular.'
    stop 1
  end if

  c(1:n) = c(1:n) * r8_factorial ( o )

  return
end
subroutine differ_inverse ( n, stencil, a )

!*****************************************************************************80
!
!! DIFFER_INVERSE returns the inverse of the DIFFER matrix.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    10 January 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the order of the matrix.
!
!    Input, real ( kind = 8 ) STENCIL(N), the values that define A.
!    The entries of STENCIL must be distinct.
!    No entry of STENCIL may be 0.
!
!    Output, real ( kind = 8 ) A(N,N), the matrix.
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ) a(n,n)
  integer ( kind = 4 ) i
  integer ( kind = 4 ) indx
  integer ( kind = 4 ) j
  integer ( kind = 4 ) k
  real ( kind = 8 ) stencil(n)

  do j = 1, n
    do i = 1, n
      if ( j == 1 ) then
        a(i,j) = 1.0D+00
      else
        a(i,j) = 0.0D+00
      end if
    end do
  end do

  do i = 1, n

    indx = 0

    do k = 1, n

      if ( k /= i ) then

        indx = indx + 1

        do j = indx + 1, 1, -1

          a(i,j) = - stencil(k) * a(i,j) / ( stencil(i) - stencil(k) )

          if ( 1 < j ) then
            a(i,j) = a(i,j) + a(i,j-1) / ( stencil(i) - stencil(k) )
          end if

        end do

      end if

    end do

  end do

  do i = 1, n
    a(i,1:n) = a(i,1:n) / stencil(i)
  end do

  return
end
subroutine differ_matrix ( n, stencil, a )

!*****************************************************************************80
!
!! DIFFER_MATRIX computes the stencil matrix from the stencil vector.
!
!  Discussion:
!
!    If N = 4, and STENCIL = ( -3, -2, -1, 1 ), then A will be
!
!    -3  -2  -1  1
!     9   4   1  1
!   -27  -8  -1  1
!    81  16   1  1
!
!    This matrix is a generalized form of a Vandermonde matrix A2:
!
!     1   1   1  1
!    -3  -2  -1  1
!     9   4   1  1
!   -27  -8  -1  1
!
!    and if A * x = b, the A2 * x2 = b, where x2(i) = x(i) * stencil(i)
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    28 October 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of stencil points.
!
!    Input, real ( kind = 8 ) STENCIL(N), the stencil vector.
!    The entries in this vector must be distinct.
!    No entry of STENCIL may be 0.
!
!    Output, real ( kind = 8 ) A(N,N), the stencil matrix.
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ) a(n,n)
  integer ( kind = 4 ) i
  real ( kind = 8 ) stencil(n)

  a(1,1:n) = stencil(1:n)
  do i = 2, n
    a(i,1:n) = a(i-1,1:n) * stencil(1:n)
  end do

  return
end
subroutine differ_solve ( n, stencil, order, c )

!*****************************************************************************80
!
!! DIFFER_SOLVE solves for finite difference coefficients.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    28 October 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of stencil points.
!
!    Input, real ( kind = 8 ) STENCIL(N), the stencil vector.
!    The entries in this vector must be distinct.
!    No entry of STENCIL may be 0.
!
!    Input, integer ( kind = 4 ) ORDER, the order of the derivative to
!    be approximated.  1 <= ORDER <= N.
!
!    Output, real ( kind = 8 ) C(N), the coefficients to be used
!    to multiply U(STENCIL(I))-U(0), so that the sum forms an
!    approximation to the derivative of order ORDER, with error
!    of order H^(N+1-ORDER).
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ) a(n,n)
  real ( kind = 8 ) b(n)
  real ( kind = 8 ) c(n)
!  integer ( kind = 4 ) i
  integer ( kind = 4 ) info
  integer ( kind = 4 ) order
  real ( kind = 8 ) stencil(n)

  call differ_matrix ( n, stencil, a )

  b(1:n) = 0.0D+00
  b(order) = 1.0D+00
!
!  Solve A * C = B.
!
  c(1:n) = b(1:n)
  call r8mat_fs ( n, a, c, info )

  if ( info /= 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'DIFFER_SOLVE - Fatal error!'
    write ( *, '(a)' ) '  The DIFFER system is singular.'
    stop
  end if

  return
end
subroutine differ_stencil ( x0, o, p, x, c )

!*****************************************************************************80
!
!! DIFFER_STENCIL computes finite difference coefficients.
!
!  Discussion:
!
!    We determine coefficients C to approximate the derivative at X0
!    of order O and precision P, using finite differences, so that
!
!      d^o f(x)/dx^o (x0) = sum ( 0 <= i <= o+p-1 ) c(i) f(x(i))
!        + O(h^(p))
!
!    where H is the maximum spacing between X0 and any X(I).
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    10 November 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real ( kind = 8 ) X0, the point where the derivative is to
!    be approximated.
!
!    Input, integer ( kind = 4 ) O, the order of the derivative to be
!    approximated.  1 <= O.
!
!    Input, integer ( kind = 4 ) P, the order of the error, as a power of H.
!
!    Input, real ( kind = 8 ) X(O+P), the evaluation points.
!
!    Output, real ( kind = 8 ) C(O+P), the coefficients.
!
  implicit none

  integer ( kind = 4 ) o
  integer ( kind = 4 ) p

  real ( kind = 8 ) b(o+p)
  real ( kind = 8 ) c(o+p)
  real ( kind = 8 ) dx(o+p)
!  integer ( kind = 4 ) i
  integer ( kind = 4 ) info
  integer ( kind = 4 ) job
  integer ( kind = 4 ) n
  real ( kind = 8 ) r8_factorial
  real ( kind = 8 ) x(o+p)
  real ( kind = 8 ) x0

  n = o + p

  dx(1:n) = x(1:n) - x0

  b(1:o+p) = 0.0D+00
  b(o+1) = 1.0D+00

  job = 0
  call r8vm_sl ( n, dx, b, c, job, info )

  if ( info /= 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'DIFFER_STENCIL - Fatal error!'
    write ( *, '(a)' ) '  Vandermonde linear system is singular.'
    stop 1
  end if

  c(1:n) = c(1:n) * r8_factorial ( o )

  return
end
subroutine inverse_error ( n, a, b, error_frobenius )

!*****************************************************************************80
!
!! INVERSE_ERROR determines the error in an inverse matrix.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    24 November 2007
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the order of the matrix.
!
!    Input, real ( kind = 8 ) A(N,N), the matrix.
!
!    Input, real ( kind = 8 ) B(N,N), the inverse.
!
!    Output, real ( kind = 8 ) ERROR_FROBENIUS, the Frobenius norm
!    of (A*B-I) + (B*A-I).
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ) a(n,n)
  real ( kind = 8 ) b(n,n)
  real ( kind = 8 ) c(n,n)
  real ( kind = 8 ) error_ab
  real ( kind = 8 ) error_ba
  real ( kind = 8 ) error_frobenius
  integer ( kind = 4 ) j

  c(1:n,1:n) = matmul ( a(1:n,1:n), b(1:n,1:n) )

  do j = 1, n
    c(j,j) = c(j,j) - 1.0D+00
  end do

  error_ab = sqrt ( sum ( c(1:n,1:n)**2 ) )

  c(1:n,1:n) = matmul ( b(1:n,1:n), a(1:n,1:n) )

  do j = 1, n
    c(j,j) = c(j,j) - 1.0D+00
  end do

  error_ba = sqrt ( sum ( c(1:n,1:n)**2 ) )

  error_frobenius = error_ab + error_ba

  return
end
function r8_factorial ( n )

!*****************************************************************************80
!
!! R8_FACTORIAL computes the factorial of N.
!
!  Discussion:
!
!    factorial ( N ) = product ( 1 <= I <= N ) I
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    16 January 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the argument of the factorial function.
!    If N is less than 1, the function value is returned as 1.
!
!    Output, real ( kind = 8 ) R8_FACTORIAL, the factorial of N.
!
  implicit none

  real ( kind = 8 ) r8_factorial
  integer ( kind = 4 ) i
  integer ( kind = 4 ) n

  r8_factorial = 1.0D+00

  do i = 1, n
    r8_factorial = r8_factorial * real ( i, kind = 8 )
  end do

  return
end
subroutine r8mat_fs ( n, a, b, info )

!*****************************************************************************80
!
!! R8MAT_FS factors and solves a system with one right hand side.
!
!  Discussion:
!
!    An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
!
!    This routine differs from R8MAT_FSS in two ways:
!    * only one right hand side is allowed;
!    * the input matrix A is not modified.
!
!    This routine uses partial pivoting, but no pivot vector is required.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    21 January 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the order of the matrix.
!    N must be positive.
!
!    Input/output, real ( kind = 8 ) A(N,N).
!    On input, A is the coefficient matrix of the linear system.
!    On output, A is in unit upper triangular form, and
!    represents the U factor of an LU factorization of the
!    original coefficient matrix.
!
!    Input/output, real ( kind = 8 ) B(N).
!    On input, the right hand side of the linear system.
!    On output, the solution of the linear systems.
!
!    Output, integer ( kind = 4 ) INFO, singularity flag.
!    0, no singularity detected.
!    nonzero, the factorization failed on the INFO-th step.
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ) a(n,n)
  real ( kind = 8 ) a2(n,n)
  real ( kind = 8 ) b(n)
  integer ( kind = 4 ) i
  integer ( kind = 4 ) info
  integer ( kind = 4 ) ipiv
!  integer ( kind = 4 ) j
  integer ( kind = 4 ) jcol
  real ( kind = 8 ) piv
  real ( kind = 8 ) row(n)
  real ( kind = 8 ) t
  real ( kind = 8 ) temp

  a2(1:n,1:n) = a(1:n,1:n)

  info = 0

  do jcol = 1, n
!
!  Find the maximum element in column I.
!
    piv = abs ( a2(jcol,jcol) )
    ipiv = jcol
    do i = jcol + 1, n
      if ( piv < abs ( a2(i,jcol) ) ) then
        piv = abs ( a2(i,jcol) )
        ipiv = i
      end if
    end do

    if ( piv == 0.0D+00 ) then
      info = jcol
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'R8MAT_FS - Fatal error!'
      write ( *, '(a,i8)' ) '  Zero pivot on step ', info
      stop 1
    end if
!
!  Switch rows JCOL and IPIV, and B.
!
    if ( jcol /= ipiv ) then

      row(1:n) = a2(jcol,1:n)
      a2(jcol,1:n) = a2(ipiv,1:n)
      a2(ipiv,1:n) = row(1:n)

      t       = b(jcol)
      b(jcol) = b(ipiv)
      b(ipiv) = t

    end if
!
!  Scale the pivot row.
!
    a2(jcol,jcol+1:n) = a2(jcol,jcol+1:n) / a2(jcol,jcol)
    b(jcol) = b(jcol) / a2(jcol,jcol)
    a2(jcol,jcol) = 1.0D+00
!
!  Use the pivot row to eliminate lower entries in that column.
!
    do i = jcol + 1, n
      if ( a2(i,jcol) /= 0.0D+00 ) then
        temp = - a2(i,jcol)
        a2(i,jcol) = 0.0D+00
        a2(i,jcol+1:n) = a2(i,jcol+1:n) + temp * a2(jcol,jcol+1:n)
        b(i) = b(i) + temp * b(jcol)
      end if
    end do

  end do
!
!  Back solve.
!
  do jcol = n, 2, -1
    b(1:jcol-1) = b(1:jcol-1) - a2(1:jcol-1,jcol) * b(jcol)
  end do

  return
end
subroutine r8mat_print ( m, n, a, title )

!*****************************************************************************80
!
!! R8MAT_PRINT prints an R8MAT.
!
!  Discussion:
!
!    An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    12 September 2004
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) M, the number of rows in A.
!
!    Input, integer ( kind = 4 ) N, the number of columns in A.
!
!    Input, real ( kind = 8 ) A(M,N), the matrix.
!
!    Input, character ( len = * ) TITLE, a title.
!
  implicit none

  integer ( kind = 4 ) m
  integer ( kind = 4 ) n

  real ( kind = 8 ) a(m,n)
  character ( len = * ) title

  call r8mat_print_some ( m, n, a, 1, 1, m, n, title )

  return
end
subroutine r8mat_print_some ( m, n, a, ilo, jlo, ihi, jhi, title )

!*****************************************************************************80
!
!! R8MAT_PRINT_SOME prints some of an R8MAT.
!
!  Discussion:
!
!    An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    10 September 2009
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) M, N, the number of rows and columns.
!
!    Input, real ( kind = 8 ) A(M,N), an M by N matrix to be printed.
!
!    Input, integer ( kind = 4 ) ILO, JLO, the first row and column to print.
!
!    Input, integer ( kind = 4 ) IHI, JHI, the last row and column to print.
!
!    Input, character ( len = * ) TITLE, a title.
!
  implicit none

  integer ( kind = 4 ), parameter :: incx = 5
  integer ( kind = 4 ) m
  integer ( kind = 4 ) n

  real ( kind = 8 ) a(m,n)
  character ( len = 14 ) ctemp(incx)
  integer ( kind = 4 ) i
  integer ( kind = 4 ) i2hi
  integer ( kind = 4 ) i2lo
  integer ( kind = 4 ) ihi
  integer ( kind = 4 ) ilo
  integer ( kind = 4 ) inc
  integer ( kind = 4 ) j
  integer ( kind = 4 ) j2
  integer ( kind = 4 ) j2hi
  integer ( kind = 4 ) j2lo
  integer ( kind = 4 ) jhi
  integer ( kind = 4 ) jlo
  character ( len = * ) title

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) trim ( title )

  if ( m <= 0 .or. n <= 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) '  (None)'
    return
  end if

  do j2lo = max ( jlo, 1 ), min ( jhi, n ), incx

    j2hi = j2lo + incx - 1
    j2hi = min ( j2hi, n )
    j2hi = min ( j2hi, jhi )

    inc = j2hi + 1 - j2lo

    write ( *, '(a)' ) ' '

    do j = j2lo, j2hi
      j2 = j + 1 - j2lo
      write ( ctemp(j2), '(i8,6x)' ) j
    end do

    write ( *, '(''  Col   '',5a14)' ) ctemp(1:inc)
    write ( *, '(a)' ) '  Row'
    write ( *, '(a)' ) ' '

    i2lo = max ( ilo, 1 )
    i2hi = min ( ihi, m )

    do i = i2lo, i2hi

      do j2 = 1, inc

        j = j2lo - 1 + j2

        if ( a(i,j) == real ( int ( a(i,j) ), kind = 8 ) ) then
          write ( ctemp(j2), '(f8.0,6x)' ) a(i,j)
        else
          write ( ctemp(j2), '(g14.6)' ) a(i,j)
        end if

      end do

      write ( *, '(i5,a,5a14)' ) i, ':', ( ctemp(j), j = 1, inc )

    end do

  end do

  return
end
subroutine r8vec_print ( n, a, title )

!*****************************************************************************80
!
!! R8VEC_PRINT prints an R8VEC.
!
!  Discussion:
!
!    An R8VEC is a vector of R8's.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    22 August 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of components of the vector.
!
!    Input, real ( kind = 8 ) A(N), the vector to be printed.
!
!    Input, character ( len = * ) TITLE, a title.
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ) a(n)
  integer ( kind = 4 ) i
  character ( len = * ) title

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) trim ( title )
  write ( *, '(a)' ) ' '

  do i = 1, n
    write ( *, '(2x,i8,a,1x,g16.8)' ) i, ':', a(i)
  end do

  return
end
subroutine r8vec_uniform_01 ( n, seed, r )

!*****************************************************************************80
!
!! R8VEC_UNIFORM_01 returns a unit pseudorandom R8VEC.
!
!  Discussion:
!
!    An R8VEC is a vector of R8's.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    05 July 2006
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Paul Bratley, Bennett Fox, Linus Schrage,
!    A Guide to Simulation,
!    Springer Verlag, pages 201-202, 1983.
!
!    Bennett Fox,
!    Algorithm 647:
!    Implementation and Relative Efficiency of Quasirandom
!    Sequence Generators,
!    ACM Transactions on Mathematical Software,
!    Volume 12, Number 4, pages 362-376, 1986.
!
!    Peter Lewis, Allen Goodman, James Miller
!    A Pseudo-Random Number Generator for the System/360,
!    IBM Systems Journal,
!    Volume 8, pages 136-143, 1969.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of entries in the vector.
!
!    Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
!    should NOT be 0.  On output, SEED has been updated.
!
!    Output, real ( kind = 8 ) R(N), the vector of pseudorandom values.
!
  implicit none

  integer ( kind = 4 ) n

  integer ( kind = 4 ) i
  integer ( kind = 4 ) k
  integer ( kind = 4 ) seed
  real ( kind = 8 ) r(n)

  if ( seed == 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'R8VEC_UNIFORM_01 - Fatal error!'
    write ( *, '(a)' ) '  Input value of SEED = 0.'
    stop 1
  end if

  do i = 1, n

    k = seed / 127773

    seed = 16807 * ( seed - k * 127773 ) - k * 2836

    if ( seed < 0 ) then
      seed = seed + 2147483647
    end if

    r(i) = real ( seed, kind = 8 ) * 4.656612875D-10

  end do

  return
end
subroutine r8vec2_print ( n, a1, a2, title )

!*****************************************************************************80
!
!! R8VEC2_PRINT prints an R8VEC2.
!
!  Discussion:
!
!    An R8VEC2 is a dataset consisting of N pairs of R8's, stored
!    as two separate vectors A1 and A2.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    13 December 2004
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of components of the vector.
!
!    Input, real ( kind = 8 ) A1(N), A2(N), the vectors to be printed.
!
!    Input, character ( len = * ) TITLE, a title.
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ) a1(n)
  real ( kind = 8 ) a2(n)
  integer ( kind = 4 ) i
  character ( len = * ) title

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) trim ( title )
  write ( *, '(a)' ) ' '

  do i = 1, n
    write ( *, '(2x,i4,2x,g14.6,2x,g14.6)' ) i, a1(i), a2(i)
  end do

  return
end
subroutine r8vm_sl ( n, a, b, x, job, info )

!*****************************************************************************80
!
!! R8VM_SL solves an R8VM linear system.
!
!  Discussion:
!
!    The R8VM storage format is used for an M by N Vandermonde matrix.
!    An M by N Vandermonde matrix is defined by the values in its second
!    row, which will be written here as X(1:N).  The matrix has a first
!    row of 1's, a second row equal to X(1:N), a third row whose entries
!    are the squares of the X values, up to the M-th row whose entries
!    are the (M-1)th powers of the X values.  The matrix can be stored
!    compactly by listing just the values X(1:N).
!
!    Vandermonde systems are very close to singularity.  The singularity
!    gets worse as N increases, and as any pair of values defining
!    the matrix get close.  Even a system as small as N = 10 will
!    involve the 9th power of the defining values.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    29 September 2003
!
!  Author:
!
!    John Burkardt.
!
!  Reference:
!
!    Gene Golub, Charles Van Loan,
!    Matrix Computations,
!    Third Edition,
!    Johns Hopkins, 1996.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of rows and columns of
!    the matrix.
!
!    Input, real ( kind = 8 ) A(N), the R8VM matrix.
!
!    Input, real ( kind = 8 ) B(N), the right hand side.
!
!    Output, real ( kind = 8 ) X(N), the solution of the linear system.
!
!    Input, integer ( kind = 4 ) JOB, specifies the system to solve.
!    0, solve A * x = b.
!    nonzero, solve A' * x = b.
!
!    Output, integer ( kind = 4 ) INFO.
!    0, no error.
!    nonzero, at least two of the values in A are equal.
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ) a(n)
  real ( kind = 8 ) b(n)
  integer ( kind = 4 ) i
  integer ( kind = 4 ) info
  integer ( kind = 4 ) j
  integer ( kind = 4 ) job
  real ( kind = 8 ) x(n)
!
!  Check for explicit singularity.
!
  info = 0

  do j = 1, n - 1
    do i = j + 1, n
      if ( a(i) == a(j) ) then
        info = 1
        return
      end if
    end do
  end do

  x(1:n) = b(1:n)

  if ( job == 0 ) then

    do j = 1, n - 1
      do i = n, j + 1, -1
        x(i) = x(i) - a(j) * x(i-1)
      end do
    end do

    do j = n - 1, 1, -1

      do i = j + 1, n
        x(i) = x(i) / ( a(i) - a(i-j) )
      end do

      do i = j, n - 1
        x(i) = x(i) - x(i+1)
      end do

    end do

  else

    do j = 1, n - 1
      do i = n, j + 1, -1
        x(i) = ( x(i) - x(i-1) ) / ( a(i) - a(i-j) )
      end do
    end do

    do j = n - 1, 1, -1
      do i = j, n - 1
        x(i) = x(i) - x(i+1) * a(j)
      end do
    end do

  end if

  return
end
subroutine timestamp ( )

!*****************************************************************************80
!
!! TIMESTAMP prints the current YMDHMS date as a time stamp.
!
!  Example:
!
!    31 May 2001   9:45:54.872 AM
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 May 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    None
!
  implicit none

  character ( len = 8 ) ampm
  integer ( kind = 4 ) d
  integer ( kind = 4 ) h
  integer ( kind = 4 ) m
  integer ( kind = 4 ) mm
  character ( len = 9 ), parameter, dimension(12) :: month = (/ &
    'January  ', 'February ', 'March    ', 'April    ', &
    'May      ', 'June     ', 'July     ', 'August   ', &
    'September', 'October  ', 'November ', 'December ' /)
  integer ( kind = 4 ) n
  integer ( kind = 4 ) s
  integer ( kind = 4 ) values(8)
  integer ( kind = 4 ) y

  call date_and_time ( values = values )

  y = values(1)
  m = values(2)
  d = values(3)
  h = values(5)
  n = values(6)
  s = values(7)
  mm = values(8)

  if ( h < 12 ) then
    ampm = 'AM'
  else if ( h == 12 ) then
    if ( n == 0 .and. s == 0 ) then
      ampm = 'Noon'
    else
      ampm = 'PM'
    end if
  else
    h = h - 12
    if ( h < 12 ) then
      ampm = 'PM'
    else if ( h == 12 ) then
      if ( n == 0 .and. s == 0 ) then
        ampm = 'Midnight'
      else
        ampm = 'AM'
      end if
    end if
  end if

  write ( *, '(i2.2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) &
    d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm )

  return
end


      FUNCTION BESSY (N,X)
! ------------------------------------------------------------------
!     This subroutine calculates the second kind Bessel Function of
!     integer order N, for any real X. We use here the classical
!     recursive formula.
! ------------------------------------------------------------------
      IMPLICIT NONE
      REAL *8 X,BESSY,BESSY0,BESSY1,TOX,BY,BYM,BYP
      INTEGER N,J
      IF (N.EQ.0) THEN
      BESSY = BESSY0(X)
      RETURN
      ENDIF
      IF (N.EQ.1) THEN
      BESSY = BESSY1(X)
      RETURN
      ENDIF
      IF (X.EQ.0.) THEN
      BESSY = -1.E30
      RETURN
      ENDIF
      TOX = 2./X
      BY  = BESSY1(X)
      BYM = BESSY0(X)
      DO 11 J = 1,N-1
      BYP = J*TOX*BY-BYM
      BYM = BY
      BY  = BYP
   11 CONTINUE
      BESSY = BY
      RETURN
      END


! { dg-do run }
! PR tree-optimization/30092
! This caused once an ICE due to internal tree changes
program test
  implicit none
  integer, parameter :: N = 30
  real, dimension(N) :: rho, pre, cs
  real               :: gamma
  gamma = 2.1314
  rho = 5.0
  pre = 3.0
  call EOS(N, rho, pre, cs, gamma)
  if (abs(CS(1) - sqrt(gamma*pre(1)/rho(1))) > epsilon(cs)) &
     STOP 1
contains
      SUBROUTINE EOS(NODES, DENS, PRES, CS, CGAMMA)
      IMPLICIT NONE
      INTEGER NODES
      REAL CGAMMA
      REAL, DIMENSION(NODES) :: DENS, PRES, CS
      REAL, PARAMETER :: RGAS = 8.314
      CS(:NODES) = SQRT(CGAMMA*PRES(:NODES)/DENS(:NODES))
      END SUBROUTINE EOS
end program test


module m_distance

!$$$ module documentation block
!           .      .    .                                       .
! module:   m_distance   calculates great circle distance between two points
!   prgmmr: eliu
!
! abstract: module to calculate the great circle distance between two points
! assimilation
!
! program history log:
!   1996-10-01  Joiner/Karki - initial coding from NASA/GMAO
!   2012-02-15  eliu         - reformat to use in GSI
!
! subroutines included:
!
! variable definitions:
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block

  use constants, only: deg2rad,half,two
  use kinds,     only: i_kind, r_kind

  interface distance
    module procedure distance1
    module procedure distance2
  end interface

  contains

  function distance1( alat, alon, blat, blon ) result (dist)
  implicit NONE

  !INPUT PARAMETERS:
  real(r_kind), dimension(:), intent(in) :: alat  ! latitude of the 1st point
  real(r_kind), dimension(:), intent(in) :: alon  ! longitude of the 1st point
  real(r_kind), dimension(:), intent(in) :: blat  ! latitude of the 2nd point
  real(r_kind), dimension(:), intent(in) :: blon  ! lontigude of the 2nd point

  !OUTPUT PARAMETERS:
  real(r_kind), dimension(size(alat)) :: dist ! function output, great circle distance

  integer(i_kind), parameter      :: maxlat=3000
  integer(i_kind)                 :: nlat
  real(r_kind), dimension(maxlat) :: work0
  real(r_kind), dimension(maxlat) :: work1
  real(r_kind), dimension(maxlat) :: work2

  !Initialize
  !----------
  dist=0.

  !Compute distances
  !=================
  !>>orig
  !nlat=size(alat)
  !work0(1:nlat)=sin((alat-blat)*deg2rad*0.5 )**2
  !work1(1:nlat)=sin((alon-blon)*deg2rad*0.5 )**2
  !work2(1:nlat)=cos((alat+blat)*deg2rad*0.5 )**2
  !dist=(work2(1:nlat)-work0(1:nlat))*work1(1:nlat)+work0(1:nlat)
  !dist=asin(sqrt(dist))/deg2rad
  !<<orig

  !>>new
  nlat=size(alat)
  work0(1:nlat)=sin((alat-blat)*deg2rad*half)**two
  work1(1:nlat)=sin((alon-blon)*deg2rad*half)**two
  work2(1:nlat)=cos((alat+blat)*deg2rad*half)**two
  dist=(work2(1:nlat)-work0(1:nlat))*work1(1:nlat)+work0(1:nlat)
  dist=asin(sqrt(dist))*two
  dist= 6372.8_r_kind*dist
  !<<new

  !>>test
  !nlat=size(alat)
  !work0(1:nlat)=sin((alat-blat)*deg2rad*0.5_r_kind )**2.0_r_kind
  !work1(1:nlat)=sin((alon-blon)*deg2rad*0.5_r_kind )**2.0_r_kind
  !work2(1:nlat)=cos(alat*deg2rad)*cos(blat*deg2rad)
  !dist = work0(1:nlat)+work2(1:nlat)*work1(1:nlat)
  !dist = sqrt(dist)
  !dist = 2.0_r_kind*asin(min(1.0_r_kind,minval(dist)))
  !dist = 6372.8_r_kind*dist
  !<<test

  end function distance1

  function distance2( alat, alon, blat, blon ) result (dist)

  real(r_kind), intent(in)   :: alat
  real(r_kind), intent(in)   :: alon
  real(r_kind), intent(in)   :: blat
  real(r_kind), intent(in)   :: blon
  real(r_kind)               :: dist

  real(r_kind), dimension(1) :: alat2
  real(r_kind), dimension(1) :: alon2
  real(r_kind), dimension(1) :: blat2
  real(r_kind), dimension(1) :: blon2
  real(r_kind), dimension(1) :: dist2

  alat2(1) = alat
  alon2(1) = alon
  blat2(1) = blat
  blon2(1) = blon
  dist2    = distance1( alat2, alon2, blat2, blon2 )
  dist     = dist2(1)

  end function distance2

end module m_distance


program main
  use diffusion
  use misc
  implicit none

  integer,parameter :: nx = 128
  integer,parameter :: ny = nx
  integer,parameter :: nz = nx
  integer,parameter :: nt = 100000
  real(KIND=4),parameter :: lx = 1.0
  real(KIND=4),parameter :: ly = 1.0
  real(KIND=4),parameter :: lz = 1.0
  real(KIND=4),parameter :: dx = lx/real(nx)
  real(KIND=4),parameter :: dy = lx/real(ny)
  real(KIND=4),parameter :: dz = lx/real(nz)
  real(KIND=4),parameter :: kappa = 0.1
  real(KIND=4),parameter :: dt = 0.1*min(min(dx*dx, dy*dy), dz*dz)/kappa
  integer :: icnt
  double precision :: time, flop, elapsed_time, ferr
  real(KIND=4),pointer,dimension(:,:,:) :: f,fn

  time = 0.d0
  flop = 0.d0
  elapsed_time = 0.d0

  allocate(f(nx,ny,nz))
  allocate(fn(nx,ny,nz))

  call init(nx, ny, nz, dx, dy, dz, f);

!$acc data copy(f) create(fn)
  call start_timer()

  do icnt = 0, nt-1
     if(mod(icnt,100) == 0) write (*,"(A5,I4,A4,F7.5)"), "time(",icnt,") = ",time

     flop = flop + diffusion3d(nx, ny, nz, dx, dy, dz, dt, kappa, f, fn)

     call swap(f, fn)

     time = time + dt
     if(time + 0.5*dt >= 0.1) exit
  end do

  elapsed_time = get_elapsed_time()
!$acc end data

  write(*, "(A7,F8.3,A6)"), "Time = ",elapsed_time," [sec]"
  write(*, "(A13,F7.2,A9)"), "Performance= ",flop/elapsed_time*1.0e-09," [GFlops]"

  ferr = accuracy(time, nx, ny, nz, dx, dy, dz, kappa, f)
  write(*, "(A6,I0,A2,I0,A2,I0,A4,E12.6)"), "Error[",nx,"][",ny,"][",nz,"] = ",ferr

  deallocate(f,fn)

end program main


      real             function SCOSHM (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 SCOSHM Krogh  Changes to use M77CON
c>> 1993-05-07 SCOSHM WVSnyder JPL Initial code
c
c     Compute cosh(x) - 1 using a rational approximation when abs(x)
c     is less than 1.2, else use the Fortran intrinsic function.
c
c--S replaces "?": ?COSHM
      real             CP5, CP4, CP3, CP2, CP1, CQ1, X, XS
      parameter ( CP5 = .116744361560051e-08)
      parameter ( CP4 = .280407224259429e-06 )
      parameter ( CP3 = .344417983443219e-04 )
      parameter ( CP2 = .232293648552398e-02 )
      parameter ( CP1 = .778752378267155e-01 )
      parameter ( CQ1 = -.545809550662099e-02*2.0e0)
      xs = x*x
      if (xs .lt. 1.44e0) then
         scoshm = ((((((cp5*xs+cp4)*xs+cp3)*xs+cp2)*xs+cp1)*xs+1.0e0)
     *                  *xs)/(cq1*xs+2.0e0)
      else
         scoshm = cosh(x) - 1.0e0
      end if
      return
      end


      SUBROUTINE spread(y,yy,n,x,m)
      INTEGER m,n
      REAL x,y,yy(n)
      INTEGER ihi,ilo,ix,j,nden,nfac(10)
      REAL fac
      SAVE nfac
      DATA nfac /1,1,2,6,24,120,720,5040,40320,362880/
      if(m.gt.10) pause 'factorial table too small in spread'
      ix=x
      if(x.eq.float(ix))then
        yy(ix)=yy(ix)+y
      else
        ilo=min(max(int(x-0.5*m+1.0),1),n-m+1)
        ihi=ilo+m-1
        nden=nfac(m)
        fac=x-ilo
        do 11 j=ilo+1,ihi
          fac=fac*(x-j)
11      continue
        yy(ihi)=yy(ihi)+y*fac/(nden*(x-ihi))
        do 12 j=ihi-1,ilo,-1
          nden=(nden/(j+1-ilo))*(j-ihi)
          yy(j)=yy(j)+y*fac/(nden*(x-j))
12      continue
      endif
      return
      END

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


module mc_mod

    implicit none
    integer, parameter :: dp=kind(0.d0)
    save

contains

    subroutine gauss(garr,sig,n)
    ! This funtion generates an array of Gaussian random variables
    ! with zero norm and sig**2 variance.

    implicit none

    integer, intent(in) :: n
    real(dp),intent(in) :: sig

    real(dp),dimension(n),intent(out) :: garr

    integer :: i
    real(dp) :: rnd1, rnd2, p1, p2, rr, fac

    do i=1,n
        rr=2.0d0
        do while (rr>1.0d0)
            call random_number(rnd1)
            call random_number(rnd2)
            p1=2.0d0*rnd1-1.0d0
            P2=2.0d0*rnd2-1.0d0
            rr=p1*p1+p2*p2
            enddo

        fac=DSQRT(-2.0d0*DLOG(rr)/rr)
        garr(i)=p1*fac
          enddo

    garr=sig*garr

    return
    end subroutine gauss

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

    subroutine ssort (x, iy)
    implicit none
    !
    !    This code performs a "bubble sort".
    !
    !    Sort an array and make the same interchanges in
    !    an auxiliary array.  The array is sorted in
    !    decreasing order.
    !
    !   Description of parameters
    !      X - array of values to be sorted   (usually abscissas)
    !      IY - array to be carried with X (all swaps of X elements are
    !          matched in IY .  After the sort IY(J) contains the original
    !          position of the value X(J) in the unsorted X array.
    !      N - number of values in array X to be sorted
    !
    real(dp), dimension(:), intent(inout) :: x
    integer, dimension(:), intent(inout):: iy

    integer :: n,i,j,jmax,itemp
    real(dp) :: temp

    n=size(x)

    if(n/=size(iy)) then
        write(0,*) "ERROR (ssort): input arrays of different sizes."
    endif

    jmax=n-1
    do i=1,n-1
        temp=1.e38
        do j=1,jmax
            if ( x(j) > x(j+1) ) cycle
            temp=x(j)
            x(j)=x(j+1)
            x(j+1)=temp
            itemp=iy(j)
            iy(j)=iy(j+1)
            iy(j+1)=itemp
            enddo
        if(temp==1.e38) exit
        jmax=jmax-1
    enddo
    return
    end subroutine ssort

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

    subroutine interx1(x,y,xd,yd)

    !    ----
    !    This routine interpolates the sequence:
    !    X(I),Y(I), I=1,2,...,N1
    !
    !    in X(I), into the value xd
    !
    !    output is given as:
    !    yd
    !    ----

    implicit none

    real(dp),dimension(:),intent(in) :: x,y
    real(dp),intent(in) :: xd

    real(dp),intent(out) :: yd

    integer :: iq,j,jj,j1,j2,j3,n1
    real(dp) :: aa,bb,cc,d,dev

    n1=size(x)
    if(n1/=size(y)) then
        write(0,*) "ERROR (interx1): input arrays of different sizes."
    endif

    iq=2
    !    IQ = 2 --> QUADRATIC INTERPOLATION
    !       = 1 --> LINEAR INTERPOLATION

    !    Find the proper array indices for the interpolation regime:

    dev=1.0d30

    !    in this cycle we find the x value
    !    which is the closest one to the actual xd
    do j=1,n1
        d=dabs(xd-x(j))
        if(d.gt.dev) cycle
        dev=d
        jj = j
        enddo

    if (jj.eq.1) then
          j1=1
          j2=2
          j3=3
    else if (jj.eq.n1) then
          j1=n1-2
          j2=n1-1
          j3=n1
    else
          j1=jj-1
          j2=jj
          j3=jj+1
    endif

    if(IQ==1) then
        ! LINEAR INTERPOLATION
        YD=Y(J1)+(xd-X(J1))*(Y(J2)-Y(J1))/(X(J2)-X(J1))
    else if (IQ==2) then
        ! QUADRATIC INTERPOLATION
        AA=(xd-X(J2))*(xd-X(J3))/(X(J1)-X(J2))/(X(J1)-X(J3))
        BB=(xd-X(J1))*(xd-X(J3))/(X(J2)-X(J1))/(X(J2)-X(J3))
        CC=(xd-X(J1))*(xd-X(J2))/(X(J3)-X(J1))/(X(J3)-X(J2))
        YD=Y(J1)*AA+Y(J2)*BB+Y(J3)*CC
        endif

    return
    end subroutine interx1

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

    subroutine shuffle(a)

    implicit none

    real(dp), dimension(:), intent(inout) :: a

    integer :: i, randpos, n
    real(dp) :: temp,r

    n=size(a)

    do i = n, 2, -1
        call random_number(r)
        randpos = int(r * i) + 1
        temp = a(randpos)
        a(randpos) = a(i)
        a(i) = temp
        end do

    end subroutine shuffle

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

    subroutine init_random_seed()
      use iso_fortran_env, only: int32
      implicit none
      integer, allocatable :: seed(:)
      integer :: i, n, un, istat, dt(8), pid
      integer(int32) :: t

      call random_seed(size = n)
      allocate(seed(n))
      ! First try if the OS provides a random number generator
      open(newunit=un, file="/dev/urandom", access="stream", &
           form="unformatted", action="read", status="old", iostat=istat)
      if (istat == 0) then
         read(un) seed
         close(un)
      else
         ! Fall back to the current time and pid. The PID is
         ! useful in case one launches multiple instances of the same
         ! program in parallel.
         call system_clock(t)
         if (t == 0) then
            call date_and_time(values=dt)
            t = (dt(1) - 1970) * 365_int32 * 24 * 60 * 60 * 1000 &
                 + dt(2) * 31_int32 * 24 * 60 * 60 * 1000 &
                 + dt(3) * 24_int32 * 60 * 60 * 1000 &
                 + dt(5) * 60 * 60 * 1000 &
                 + dt(6) * 60 * 1000 + dt(7) * 1000 &
                 + dt(8)
         end if
         pid = getpid()
         t = ieor(t, int(pid, kind(t)))
         do i = 1, n
            seed(i) = lcg(t)
         end do
      end if
      call random_seed(put=seed)
    contains
      ! This simple PRNG might not be good enough for real work, but is
      ! sufficient for seeding a better PRNG.
      function lcg(s)
        integer :: lcg
        integer(int32) :: s
        if (s == 0) then
           s = 104729
        else
           s = mod(s, 4294967296_int32)
        end if
        s = mod(s * 279470273_int32, 4294967291_int32)
        lcg = int(mod(s, int(huge(0), int32)), kind(0))
      end function lcg
    end subroutine init_random_seed

end module mc_mod


module linfuncs
use utils, only: fp,ip

interface diagonal
   module procedure diagonal_real,diagonal_complex
end interface diagonal

interface get_diag_matrix
   module procedure get_diag_matrix_real,get_diag_matrix_complex
end interface get_diag_matrix

interface kron
   module procedure kron_real,kron_complex,kron_real_complex,kron_complex_real
end interface kron

interface print_matrix
   module procedure print_matrix_real,print_matrix_complex
end interface print_matrix

interface trace
   module procedure trace_real,trace_complex
end interface trace

interface trace_abs
   module procedure trace_abs_real,trace_abs_complex
end interface trace_abs

interface l2norm
   module procedure l2norm_real,l2norm_complex
end interface l2norm

interface interp1
   module procedure interp1_real,interp1_complex
end interface interp1

contains
subroutine linspace(a, b, n,out)
  implicit none
  real(fp) ::a,b
  integer(ip) :: n,ii
  real(fp), dimension(n) :: out
  real(fp), dimension(n) :: index_vector

  do ii = 1,n
     index_vector(ii) = ii-1
  end do
  if(n>1) then
     out = index_vector / (n - 1) * (b - a) + a
     out(n) = b ! Just to make sure that the last index really is correct.
  else
     out(1) = a
  end if

end subroutine linspace
!#############################################
subroutine print_matrix_complex(mat,is_real_in)
implicit none
integer(ip) :: dim
complex(fp),dimension(:,:),intent(in) :: mat
integer(ip) :: ii,jj
logical,optional,intent(in) :: is_real_in
logical :: is_real

if(present(is_real_in)) then
   is_real = is_real_in
else
   is_real = .false.
end if

dim = size(mat,1)
if (dim > 60) then
   write(*,*) 'unable to print larger than 60x60 matrices.'
end if
write(*,*) 'entering. dim is ', dim
do ii=1,dim
   if(is_real) then
      write(*,'(601pe10.3)') (real(mat(ii,jj)),jj=1,dim)
   else
      write(*,'(60(1pe10.3,e10.3))') (real(mat(ii,jj)),aimag(mat(ii,jj)),jj=1,dim)
   end if
end do
end subroutine print_matrix_complex
!-----------------------------------------------------------
subroutine print_matrix_real(mat,is_real_in)
implicit none
integer(ip) :: dim
real(fp),dimension(:,:),intent(in) :: mat
integer(ip) :: ii,jj
logical,intent(in),optional :: is_real_in

dim = size(mat,1)
if (dim > 60) then
   write(*,*) 'unable to print larger than 60x60 matrices.'
end if
write(*,*) 'entering. dim is ', dim
do ii=1,dim
   write(*,'(60e10.3)') (real(mat(ii,jj)),jj=1,dim)
end do
end subroutine print_matrix_real
!#############################################
subroutine print_real_matrix(mat,dim)
implicit none
integer(ip) :: dim
real(fp),dimension(dim,dim) :: mat
integer(ip) :: ii,jj

if (dim > 60) then
   write(*,*) 'unable to print larger than 60x60 matrices.'
end if
write(*,*) 'entering. dim is ', dim
do ii=1,dim
   write(*,'(60e10.3)') (mat(ii,jj),jj=1,dim)
end do
end subroutine print_real_matrix
!#############################################
function kron_complex(a,b) result(k)
    implicit none
    ! k = a\cross b
    complex(fp), dimension(:,:),intent(in) :: a
    complex(fp), dimension(:,:),intent(in) :: b

    integer(ip) :: i, j

    integer(ip) :: ma
    integer(ip) :: na
    integer(ip) :: mb
    integer(ip) :: nb
    complex(fp), dimension(size(a,1)*size(b,1),size(a,2)*size(b,2)) :: k
    ma = size(a,1)
    na = size(a,2)
    mb = size(b,1)
    nb = size(b,2)

    !if (size(k,1) /= ma*mb .or. size(k,2) /= na*nb) then
    !   write(*,*) 'k has invalid size'
       !call stop
    !end if
    k = (0.0_fp,0.0_fp)
    forall(i=1:ma, j=1:na)
        k(mb*(i-1)+1:mb*i,nb*(j-1)+1:nb*j) = a(i,j)*b
    end forall
  end function kron_complex
!-----------------------------------------------------------
function kron_real(a,b) result(k)
    implicit none
    ! k = a\cross b
    real(fp), dimension(:,:),intent(in) :: a
    real(fp), dimension(:,:),intent(in) :: b

    integer(ip) :: i, j

    integer(ip) :: ma
    integer(ip) :: na
    integer(ip) :: mb
    integer(ip) :: nb
    real(fp), dimension(size(a,1)*size(b,1),size(a,2)*size(b,2)) :: k
    ma = size(a,1)
    na = size(a,2)
    mb = size(b,1)
    nb = size(b,2)

    !if (size(k,1) /= ma*mb .or. size(k,2) /= na*nb) then
    !   write(*,*) 'k has invalid size'
       !call stop
    !end if
    k = 0.0_fp
    forall(i=1:ma, j=1:na)
        k(mb*(i-1)+1:mb*i,nb*(j-1)+1:nb*j) = a(i,j)*b
    end forall
  end function kron_real
!-----------------------------------------------------------
function kron_real_complex(a,b) result(k)
    implicit none
    ! k = a\cross b
    real(fp), dimension(:,:),intent(in) :: a
    complex(fp), dimension(:,:),intent(in) :: b

    integer(ip) :: i, j

    integer(ip) :: ma
    integer(ip) :: na
    integer(ip) :: mb
    integer(ip) :: nb
    complex(fp), dimension(size(a,1)*size(b,1),size(a,2)*size(b,2)) :: k
    ma = size(a,1)
    na = size(a,2)
    mb = size(b,1)
    nb = size(b,2)

    !if (size(k,1) /= ma*mb .or. size(k,2) /= na*nb) then
    !   write(*,*) 'k has invalid size'
       !call stop
    !end if
    k = (0.0_fp,0.0_fp)
    forall(i=1:ma, j=1:na)
        k(mb*(i-1)+1:mb*i,nb*(j-1)+1:nb*j) = a(i,j)*b
    end forall
  end function kron_real_complex
!-----------------------------------------------------------
function kron_complex_real(a,b) result(k)
    implicit none
    ! k = a\cross b
    complex(fp), dimension(:,:),intent(in) :: a
    real(fp), dimension(:,:),intent(in) :: b

    integer(ip) :: i, j

    integer(ip) :: ma
    integer(ip) :: na
    integer(ip) :: mb
    integer(ip) :: nb
    complex(fp), dimension(size(a,1)*size(b,1),size(a,2)*size(b,2)) :: k
    ma = size(a,1)
    na = size(a,2)
    mb = size(b,1)
    nb = size(b,2)

    !if (size(k,1) /= ma*mb .or. size(k,2) /= na*nb) then
    !   write(*,*) 'k has invalid size'
       !call stop
    !end if
    k = (0.0_fp,0.0_fp)
    forall(i=1:ma, j=1:na)
        k(mb*(i-1)+1:mb*i,nb*(j-1)+1:nb*j) = a(i,j)*b
    end forall
  end function kron_complex_real
!#############################################
subroutine expm(a,adim,out)
implicit none
integer(ip) :: adim,counter,max_num_terms,ii
complex(fp), dimension(adim,adim) :: a,out,apt
real(fp) :: tol,coef
tol = 1e-2
max_num_terms = 50
out = (0.0,0.0)
do ii=1,adim
   out(ii,ii) = (1.0,0.0)
end do

apt = out

coef = 1.0
counter = 0

do while (maxval(real(matmul(apt,conjg(transpose(apt)))))/coef > tol .and. counter < max_num_terms)
   counter = counter + 1
   apt = matmul(apt,a)
   coef = coef*counter
   out = out + apt/coef
 !  write(*,*) 'counter: ', counter
!   call print_matrix(out,adim,.true.)
end do

end subroutine expm
!#############################################
function diagonal_complex(a) result(diagonal)! COMPLEX
implicit none
complex(fp), dimension(:,:),intent(in) :: a
integer(ip) :: ii,adim
complex(fp), dimension(size(a,1)) :: diagonal
adim = size(a,1)
do ii=1,adim
   diagonal(ii) = a(ii,ii)
end do
end function diagonal_complex
!--------------------------------------------
function diagonal_real(a) result(diagonal)! REAL
implicit none
real(fp), dimension(:,:),intent(in) :: a
integer(ip) :: ii,adim
real(fp), dimension(size(a,1)) :: diagonal
adim = size(a,1)
do ii=1,adim
   diagonal(ii) = a(ii,ii)
end do
end function diagonal_real
!#############################################
function get_eye(dim) result(eye)
    implicit none
    integer(ip), intent(in) :: dim
    real(fp), dimension(dim,dim) :: eye
    integer(ip) :: ii
    eye = 0.0_fp
    do ii=1,dim
       eye(ii,ii) = 1.0_fp
    end do
  end function get_eye
!#############################################
  function get_diag_matrix_complex(diag) result(eye)
    implicit none
    complex(fp), dimension(:),intent(in) :: diag
    complex(fp), dimension(size(diag),size(diag)) :: eye
    integer(ip) :: ii
    eye = (0.0_fp,0.0_fp)
    do ii=1,size(diag)
       eye(ii,ii) = diag(ii)
    end do
  end function get_diag_matrix_complex
!-----------------------------------------------------------
  function get_diag_matrix_real(diag) result(eye)
    implicit none
    real(fp), dimension(:),intent(in) :: diag
    real(fp), dimension(size(diag),size(diag)) :: eye
    integer(ip) :: ii
    eye = 0.0_fp
    do ii=1,size(diag)
       eye(ii,ii) = diag(ii)
    end do
  end function get_diag_matrix_real
  !#############################################
  function get_creation_op(dim) result(cc)
    implicit none
    integer(ip), intent(in) :: dim
    complex(fp), dimension(dim,dim) :: cc
    integer(ip) :: ii

    cc = (0.0_fp,0.0_fp)
    do ii=1,dim-1
       cc(ii+1,ii) = cmplx(sqrt(real(ii,kind=fp)),kind=fp)
       !cc(ii+1,ii) = (0.0_fp,1.0_fp)
    end do
  end function get_creation_op
!#############################################
  function get_annihilation_op(dim) result(aa)
    implicit none
    integer(ip), intent(in) :: dim
    complex(fp), dimension(dim,dim) :: aa
    integer(ip) :: ii
    aa = (0.0_fp,0.0_fp)
    do ii=1,dim-1
       aa(ii,ii+1) = cmplx(sqrt(real(ii,kind=fp)),kind=fp)
    end do
  end function get_annihilation_op
!#############################################
  ! Performs cubic Hermite interpolation for complex numbers.
  function interp1_complex(x,y,xquery) result(yquery)
    implicit none
    real(fp),dimension(:),intent(in) :: x
    complex(fp), dimension(:,:),intent(in) :: y
    real(fp),dimension(:),intent(in) :: xquery
    complex(fp), dimension(size(y,1),size(xquery)) :: yquery
    integer(ip) :: dim_in,dim,ii,jj,n
    real(fp),dimension(2*size(y,1),size(x)) :: ya,fd
    real(fp) :: xk,xk1,t,h00,h01,h10,h11
    real(fp) :: yquery_t(2*size(y,1))
    dim_in = size(x)
    dim = size(xquery)
    n = size(y,1)
    ! First calculate the finite differences
    !write(*,*) 'xquery:', xquery
    !write(*,*) 'x', x
    if(x(dim_in) < xquery(dim) .or. xquery(1) < x(1)) then
       write(*,*) 'In interp1, the query point is outside of the range of the data points.'
       stop (1)
    end if

    ya(1:n,:) = real(y)
    ya(n+1:2*n,:) = aimag(y)

    fd = finite_difference(x,ya)
    jj = 1
    !write(*,*) 'x:', x
    !write(*,*) 'xq:', xquery
    do ii=1,dim
       do while(x(jj) < xquery(ii) + tiny(x(1)))
          jj = jj+1
       end do
       !write(*,*) 'jj:',jj,', size x:',size(x)
       xk1 = x(jj)
       xk = x(jj-1)
       !write(*,*) 'xk',xk,'xk1: ',xk1
       t = (xquery(ii) - xk)/(xk1-xk)
       h00 = 2*t**3-3*t**2+1
       h10 = t**3 - 2*t**2+t
       h01 = -2*t**3+3*t**2
       h11 = t**3-t**2
       !write(*,*) fd(:,jj-1)
       yquery_t = h00*ya(:,jj-1) + h10*fd(:,jj-1)*(xk1-xk) + h01*ya(:,jj) + h11*fd(:,jj)*(xk1-xk)
       yquery(:,ii) = cmplx(yquery_t(1:n),yquery_t(n+1:2*n),fp)
    end do
  end function interp1_complex
  !------------------------------------------
  ! Performs cubic Hermite interpolation for complex numbers.
  function interp1_real(x,y,xquery) result(yquery)
    implicit none
    real(fp),dimension(:),intent(in) :: x
    real(fp), dimension(:,:),intent(in) :: y
    real(fp),dimension(:),intent(in) :: xquery
    real(fp), dimension(size(y,1),size(xquery)) :: yquery
    integer(ip) :: dim_in,dim,ii,jj,n
    real(fp),dimension(2*size(y,1),size(x)) :: ya,fd
    real(fp) :: xk,xk1,t,h00,h01,h10,h11
    real(fp) :: yquery_t(size(y,1))
    dim_in = size(x)
    dim = size(xquery)
    n = size(y,1)
    ! First calculate the finite differences
    if(x(dim_in) < xquery(dim) .or. xquery(1) < x(1)) then
       write(*,*) 'In interp1, the query point is outside of the range of the data points.'
       stop (1)
    end if

    fd = finite_difference(x,y)
    jj = 1
    !write(*,*) 'x:', x
    !write(*,*) 'xq:', xquery
    do ii=1,dim
       do while(x(jj) < xquery(ii) + tiny(x(1)))
          jj = jj+1
       end do
       !write(*,*) 'jj:',jj,', size x:',size(x)
       xk1 = x(jj)
       xk = x(jj-1)
       !write(*,*) 'xk',xk,'xk1: ',xk1
       t = (xquery(ii) - xk)/(xk1-xk)
       h00 = 2*t**3-3*t**2+1
       h10 = t**3 - 2*t**2+t
       h01 = -2*t**3+3*t**2
       h11 = t**3-t**2
       !write(*,*) fd(:,jj-1)
       yquery_t = h00*y(:,jj-1) + h10*fd(:,jj-1)*(xk1-xk) + h01*y(:,jj) + h11*fd(:,jj)*(xk1-xk)
       yquery(:,ii) = yquery_t
    end do
  end function interp1_real
  !------------------------------------------
  function finite_difference(x,y) result(fd)
    implicit none
    real(fp),dimension(:),intent(in) :: x
    real(fp),dimension(:,:),intent(in) :: y
    real(fp),dimension(size(y,1),size(y,2)) :: fd
    integer(ip) :: ii,dim,n
    n = size(y,1)
    dim = size(y,2)
    ! First and last points
    fd(:,1) = (y(:,2) - y(:,1))/(x(2) - x(1))
    fd(:,dim) = (y(:,dim) - y(:,dim-1))/(x(dim) - x(dim-1))

    ! This is calculated in a stupid way. The below formula simplifies to central difference with delta = x(ii+1)-x(ii-1).
    do ii=2,dim-1
       fd(:,ii) = (y(:,ii+1) - y(:,ii))/(2.0_fp*(x(ii+1) - x(ii))) &
            + (y(:,ii) - y(:,ii-1))/(2.0_fp*(x(ii) - x(ii-1)))
    end do
  end function finite_difference
!#############################################
  function trace_real(A) result(tr)
    implicit none
    real(fp), dimension(:,:),intent(in) :: A
    real(fp) :: tr
    integer(ip) :: ii,nn
    nn = size(A,1)
    tr = 0.0_fp
    do ii=1,nn
       tr = tr + A(ii,ii)
    end do
  end function trace_real
  function trace_complex(A) result(tr)
    implicit none
    complex(fp), dimension(:,:),intent(in) :: A
    complex(fp) :: tr
    integer(ip) :: ii,nn

    nn = size(A,1)
    tr = 0.0_fp
    do ii=1,nn
       tr = tr + A(ii,ii)
    end do
  end function trace_complex
!#############################################
  function trace_abs_real(A) result(tr)
    implicit none
    real(fp), dimension(:,:),intent(in) :: A
    real(fp) :: tr
    integer(ip) :: ii,nn
    nn = size(A,1)
    tr = 0.0_fp
    do ii=1,nn
       tr = tr + abs(A(ii,ii))
    end do
  end function trace_abs_real
  function trace_abs_complex(A) result(tr)
    implicit none
    complex(fp), dimension(:,:),intent(in) :: A
    real(fp) :: tr
    integer(ip) :: ii,nn

    nn = size(A,1)
    tr = 0.0_fp
    do ii=1,nn
       tr = tr + sqrt(conjg(A(ii,ii))*A(ii,ii))
    end do
  end function trace_abs_complex
!###########################################################
  function l2norm_real(v) result(norm)
    implicit none
    real(fp), dimension(:),intent(in) :: v
    real(fp) :: norm
    norm = sqrt(dot_product(v,v))
  end function l2norm_real
!-----------------------------------------------------------
    function l2norm_complex(v) result(norm)
    implicit none
    complex(fp), dimension(:),intent(in) :: v
    real(fp) :: norm
    norm = sqrt(dot_product(v,v))
  end function l2norm_complex
!############################################################
  function dephasing_operator(dim,l1,l2) result(sl1l2)
    implicit none
    integer(ip), intent(in) :: dim,l1,l2
    complex(fp), dimension(dim,dim) :: sl1l2
    if(l1>dim .or. l2>dim) then
       write(*,*) 'Improper values for parameters in dephasing_operator.'
       stop (1)
    endif

    sl1l2 = (0.0_fp,0.0_fp)
    !sl1l2(l1,l1) = -1.0_fp/sqrt(2.0_fp)
    !sl1l2(l2,l2) = 1.0_fp/sqrt(2.0_fp)
    !write(*,*) 'Warning, modified stuff in dephasing_operator!.'
    sl1l2(l1,l1) = 0.0_fp
    sl1l2(l2,l2) = sqrt(2.0_fp)
  end function dephasing_operator
!############################################################
  function pauli_x(dim,l1,l2) result(op)
    implicit none
    integer(ip),intent(in) :: dim,l1,l2
    complex(fp),dimension(dim,dim) :: op
    if(l1 > dim .or. l2 > dim .or. l1 < 1 .or. l2 < 1) then
       write(*,*) 'Incorrect parameters in pauli_x.'
       stop
    endif
    op = (0.0_fp,0.0_fp)
    op(l1,l2) = (1.0_fp,0.0_fp)
    op(l2,l1) = (1.0_fp,0.0_fp)
  end function pauli_x

  function pauli_y(dim,l1,l2) result(op)
    implicit none
    integer(ip),intent(in) :: dim,l1,l2
    complex(fp),dimension(dim,dim) :: op
    if(l1 > dim .or. l2 > dim .or. l1 < 1 .or. l2 < 1) then
       write(*,*) 'Incorrect parameters in pauli_y.'
       stop
    endif
    op = (0.0_fp,0.0_fp)
    op(l1,l2) = (0.0_fp,-1.0_fp)
    op(l2,l1) = (0.0_fp,1.0_fp)
  end function pauli_y
!#############################################
  ! Generates the generalized Gell-Mann matrices for a system with dim dimensions. ggm is the output matrix with dimensions (dim,dim,dim**2-1). Uses convention, where sigma_z = [-1,0;0,1]. Equations form "Bloch vectors for qudits", Reinhold A. Bertlmann and Philipp Krammer.
  subroutine generate_ggm(dim,ggm,ggmnorm)
    implicit none
    integer(ip),intent(in) :: dim
    complex(fp),intent(out),dimension(dim,dim,dim**2) :: ggm
    real(fp),intent(out),optional,dimension(dim**2) :: ggmnorm
    integer(ip) :: jj,kk,ll,nn
    real(fp) :: ll_factor

    if(dim<2) then
       write(*,*) 'Dimension < 2 in generate_ggm.'
       stop
    end if

    ggm = (0.0_fp,0.0_fp)
    nn = 1

    ! Identity
    do jj=1,dim
       ggm(jj,jj,nn) = 1.0_fp
    end do
    nn = nn+1

    do kk=2,dim
       do jj=1,kk-1
          ggm(jj,kk,nn) = 1.0_fp
          ggm(kk,jj,nn) = 1.0_fp
          nn = nn+1
       end do
    end do
    do kk=2,dim
       do jj=1,kk-1
          ggm(jj,kk,nn) = -(0.0_fp,1.0_fp)
          ggm(kk,jj,nn) = (0.0_fp,1.0_fp)
          nn = nn+1
       end do
    end do
    do ll=1,dim-1
       ll_factor = sqrt(2.0_fp/(ll*(ll+1)))
       do jj=1,ll
          ggm(jj,jj,nn) = -ll_factor
       end do
       ggm(ll+1,ll+1,nn) = ll*ll_factor
       nn = nn+1
    end do

    if(present(ggmnorm)) then
       do kk=1,dim**2
          ggmnorm(kk) = trace(matmul(ggm(:,:,kk),ggm(:,:,kk)))
       end do
    endif
  end subroutine generate_ggm
!#############################################
  subroutine density_matrix_to_ggm(rho,ggm,b)
    implicit none
    complex(fp),intent(in),dimension(:,:) :: rho
    complex(fp),intent(in),dimension(size(rho,1),size(rho,2),size(rho,1)**2) :: ggm
    real(fp),intent(out),dimension(size(rho,1)**2) :: b
    integer(ip) :: ii,nn
    integer(ip) :: c1,c2
    complex(fp),dimension(size(rho,1),size(rho,2)) :: ggmrho
    nn = size(rho,1)
    !call system_clock(c1)
    do ii=1,(nn**2)
       !b(ii) = real(trace(matmul(ggm(:,:,ii),rho)))
       call zgemm('n','n',nn,nn,nn,(1.0_fp,0.0_fp),ggm(:,:,ii),nn,rho,nn,&
            (0.0_fp,0.0_fp),ggmrho,nn)
       b(ii) = real(trace(ggmrho))
    end do
    !call system_clock(c2)
    !write(*,*) 'Density_matrix_to_ggm. Duration: ', c2-c1,'ms.'
  end subroutine density_matrix_to_ggm
!----------------------------------------------!
  subroutine ggm_to_density_matrix(rho,ggm,ggmnorm,b,dim)
    implicit none
    integer(ip),intent(in) :: dim
    real(fp),intent(in),dimension(dim**2) :: b
    complex(fp),intent(out),dimension(dim,dim) :: rho
    complex(fp),intent(out),dimension(dim,dim,dim**2) :: ggm
    real(fp),intent(in),dimension(dim**2) :: ggmnorm
    integer(ip) :: ii
    integer(ip) :: c1,c2
    !rho = get_eye(dim)/dim
    rho = 0.0_fp
    !write(*,*) 'After eye:'
    !call print_matrix(rho)
    ! rho = I/d + \sum_i=1^{d^2-1} b_i A_i/N_i, where N_i = Tr A^2
    !call system_clock(c1)
    do ii=1,dim**2
       !write(*,*) 'b(',ii,')=', b(ii)
       !rho = rho + b(ii)*ggm(:,:,ii)/trace(matmul(ggm(:,:,ii),ggm(:,:,ii))) ! included the normalization
       rho = rho + b(ii)/ggmnorm(ii)*ggm(:,:,ii)! included the normalization

       !call print_matrix(rho)
    end do
    !call system_clock(c2)
    !write(*,*) 'ggm_to_density_matrix. Duration: ', c2-c1,'ms.'
    !rho = rho/dim
  end subroutine ggm_to_density_matrix
!#############################################
  function trapz(x,y) result(r)
    implicit none
    real(fp), dimension(:),intent(in) :: x,y
    real(fp) :: r
    integer(ip) :: n,ii
    n = size(y)
    r = 0.0_fp
    do ii=2,n
       r = r + (x(ii) - x(ii-1))*(y(ii) + y(ii-1))
    end do
    r = r/2.0_fp
  end function trapz

end module linfuncs


      SUBROUTINE mnewt(ntrial,x,n,tolx,tolf)
      INTEGER n,ntrial,NP
      REAL tolf,tolx,x(n)
      PARAMETER (NP=15)
CU    USES lubksb,ludcmp,usrfun
      INTEGER i,k,indx(NP)
      REAL d,errf,errx,fjac(NP,NP),fvec(NP),p(NP)
      do 14  k=1,ntrial
        call usrfun(x,n,NP,fvec,fjac)
        errf=0.
        do 11 i=1,n
          errf=errf+abs(fvec(i))
11      continue
        if(errf.le.tolf)return
        do 12 i=1,n
          p(i)=-fvec(i)
12      continue
        call ludcmp(fjac,n,NP,indx,d)
        call lubksb(fjac,n,NP,indx,p)
        errx=0.
        do 13 i=1,n
          errx=errx+abs(p(i))
          x(i)=x(i)+p(i)
13      continue
        if(errx.le.tolx)return
14    continue
      return
      END

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


      SUBROUTINE C2FFT(C,ID,NM,NN,WM,WN,ISIG,IORD,IWORK,IERR)
****PURPOSE:
*       THIS ROUTINE PERFORMS A 2-DIMENSIONAL COMPLEX FOURIER TRANSFORM,
*       OF ORDER NM*NN.
****USAGE:
*       THE USER IS EXPECTED TO PROVIDE THE DATA IN A 2-DIMENSIONAL
*       COMPLEX ARRAY C, DIMENSIONED IN THE CALLING PROGRAM C(ID,NN);
*       ID CAN BE DIFFERENT FROM NM, AND IT IS RECOMMENDED THAT IT IS
*       CHOSEN EQUAL TO NM+1 IF NM IS EVEN OR TO NM IF NM IS ODD.
*       THE ELEMENTS C(K,*),NM<K<=ID MUST BE ZEROED. THE ROUTINE IS
*       INTENDED FOR REPEATED USAGE, THUS SEPARATE SET-UP AND
*       OPERATING CALLS ARE AVAILABLE : THE USER SHOULD ALWAYS PERFORM
*       A SET-UP CALL ( ISIG=0 ) PASSING THE CHOSEN PARAMETERS, BEFORE
*       PERFORMING THE ACTUAL TRANSFORM ( ISIG= +1 OR -1 ); THE USER CAN
*       CHOOSE WHETHER TO OBTAIN THE RESULTS OF THE DIRECT TRANSFORM
*       IN NATURAL ORDER (ISIG=-1,IORD=1) OR LEAVE THEM IN THE
*      'BIT-REVERSED' ORDER( ISIG=-1,IORD=0); THIS CHOICE SAVES
*       SOME COMPUTER TIME, AND IT IS RECOMMENDED IN CASES DISCUSSED
*       IN THE LONG WRITE-UP. ANALOGOUSLY,THE INVERSE TRANSFORM ACCEPTS
*       INPUT ( PLEASE NOTE| ) DATA IN NATURAL ORDER ( ISIG=1,IORD=1),
*       OR DATA ALREADY SUBJECTED TO A BIT-REVERSAL PERMUTATION( ISIG=1
*       IORD=0 ).
****PARAMETERS :
*       INPUT :
*       C : ARRAY TO BE TRANSFORMED; DECLARED COMPLEX C(ID,NN) IN THE
*           CALLING PROGRAM;
*       ID : FIRST DIMENSION OF C IN THE CALLING PROGRAM
*       ISIG : OPTION FLAG : ISIG=0 : SET-UP RUN, C NOT USED
*                            ISIG=-1: DIRECT TRANSFORM
*                            ISIG=+1: INVERSE TRANSFORM
*       WM,WN : INTEGER ARRAYS , USED TO HOST TABLES FOR THE TRANSFORM;
*               DIMENSIONED IN THE CALLING PROGRAM AT LEAST (4*NM+14)
*               AND (4*NN+14) RESPECTIVELY; IF ISIG.NE.0 ,THEY ARE
*               ASSUMED TO HAVE BEEN SET BY A PREVIOUS CALL WITH ISIG=0
*               (ALL OTHER ARGUMENTS UNCHANGED), AND NEVER HAVE BEEN
*               MODIFIED SINCE THEN;
*               IF NM=NN, WM AND WN DO NOT NEED TO BE DISTINCT;
*       NM : ORDER OF THE TRANSFORM ALONG THE COLUMNS OF C
*       NN : ORDER OF THE TRANSFORM ALONG THE ROWS OF C
*       IORD : OPTION FLAG : =1 : OUTPUT IN NATURAL ORDER (ISIG=-1)
*                                 INPUT IN NATURAL ORDER  (ISIG=+1)
*                            =0 : OUTPUT IN BIT-REVERSED ORDER(ISIG=-1)
*                                 INPUT IN BIT-REVERSED ORDER(ISIG=+1)
*       IWORK : INTEGER ARRAY, USED AS WORK AREA FOR REORDERING IF IORD=
*                1, IT MUST BE AT LEAST MAX(NM,NN) WORDS LONG.
*                IT IS UNUSED IF IORD=0.
*
****OUTPUT :
*       C : TRANSFORMED ARRAY
*       WM, WN : ONLY IF ISIG=0, WM AND WN ARE FILLED WITH THE
*               APPROPRIATE  TABLES (TWIDDLE FACTORS).
*       IWORK : UNDEFINED
*       IERR  : ERROR CODE : =0 : SUCCESSFUL
*                            =1 : DATA DIMENSIONS ARE NOT CORRECT
*                            =2 : PRIME FACTORS DIFFERENT FROM 2,3,5
*                                 ARE PRESENT IN DATA DIMENSIONS
*                            =3 : TABLES NOT CORRECTLY INITIALIZED
*
      COMPLEX C(*)
      INTEGER WM(-14:*),WN(-14:*)
      INTEGER IWORK(*)
      INTEGER IDERR,FACERR,TBERR
      PARAMETER (IDERR=1,FACERR=2,TBERR=3)
      IF(ID.LT.NM)THEN
        IERR=IDERR
        RETURN
      ENDIF
      IERR=0
      IF(ISIG.EQ.0)THEN
        CALL MFFTP(NM,WM,0,IERR)
        IF(IERR.NE.0)RETURN
        IF(NN.NE.NM)THEN
          CALL MFFTP(NN,WN,0,IERR)
          IF(IERR.NE.0)RETURN
        ELSE
          CALL MFFTZ0(WM,1,4*NM+14,WN,1)
        ENDIF
        RETURN

      ELSE IF(ISIG.GT.0)THEN

        IF(IORD.NE.0)THEN
         CALL MFFTOV(C,1,ID,NM,NN,WM(3*NM),IWORK)
         CALL MFFTOV(C,ID,1,NN,NM,WN(3*NN),IWORK)
        ENDIF

        CALL MFFTIV(C,1,ID,NM,NN,WM,IERR)
        IF(IERR.NE.0)RETURN
        CALL MFFTIV(C,ID,1,NN,NM,WN,IERR)
        IF(IERR.NE.0)RETURN

      ELSE
        CALL MFFTDV(C,1,ID,NM,NN,WM,IERR)
        IF(IERR.NE.0)RETURN
        CALL MFFTDV(C,ID,1,NN,NM,WN,IERR)
        IF(IERR.NE.0)RETURN

        IF(IORD.NE.0)THEN
         CALL MFFTOV(C,1,ID,NM,NN,WM(2*NM),IWORK)
         CALL MFFTOV(C,ID,1,NN,NM,WN(2*NN),IWORK)
        ENDIF
      ENDIF

      END


program problem_12b

    !! What is the Manhattan distance between that location
    !! and the ship's starting position?

    use aoc_utilities
    use iso_fortran_env

    implicit none

    integer,parameter :: chunk_size = 256

    integer :: n, iunit, istat, i
    character(len=:),allocatable :: line
    logical :: status_ok
    character(len=1) :: action
    integer :: value
    integer,dimension(2) :: r ! (x,y) position
    integer,dimension(2) :: waypoint ! waypoint (x,y) position

    open(newunit=iunit, file='input.txt', iostat=istat)
    n = number_of_lines_in_file(iunit)

    r = 0               ! initial position
    waypoint = [10,1]   ! 10 units east and 1 unit north

    do i = 1, n
        call read_line_from_file(iunit,chunk_size,line,status_ok)

        action = line(1:1)
        read(line(2:),'(I5)') value

        select case (action)
        case('N'); waypoint(2) = waypoint(2) + value  ! move waypoint north by the given value.
        case('S'); waypoint(2) = waypoint(2) - value  ! move waypoint south by the given value.
        case('E'); waypoint(1) = waypoint(1) + value  ! move waypoint east by the given value.
        case('W'); waypoint(1) = waypoint(1) - value  ! move waypoint west by the given value.
        case('F'); r = r + waypoint * value  ! move forward to the waypoint a number of times equal to the given value

        ! L: rotate the waypoint around the ship left (counter-clockwise) the given number of degrees.
        ! R: rotate the waypoint around the ship right (clockwise) the given number of degrees.
        case('L', 'R')
            if (action=='R' .and. value /= 180) value = wrap(value + 180)
            select case (value)
            case(90);  waypoint = [-waypoint(2), waypoint(1)]
            case(180); waypoint = [-waypoint(1), -waypoint(2)]
            case(270); waypoint = [waypoint(2), -waypoint(1)]
            case default
                write(*,*) value
                error stop 'invalid rotation'
            end select
        case default
            error stop 'invalid action: '//action
        end select

    end do

    write(*,*) 'Manhattan distance: ', abs(r(1)) + abs(r(2))

    contains

    pure function wrap(angle) result(wrapped_angle)
    !! wrap from 0 -> 360
    implicit none
    integer,intent(in) :: angle
    integer :: wrapped_angle
    wrapped_angle = mod(angle, 360)
    if (wrapped_angle<0) wrapped_angle = wrapped_angle + 360
    end function wrap

    end program problem_12b


module class_circle2
  implicit none
  private
  public :: main
  real :: pi = 3.1415926535897931d0 ! Class-wide private constant

  type, public :: Circle
     real :: radius
   contains
     procedure :: circle_area  !=> circle_area ! Can you point to implementation in diff module?
     procedure :: circle_print
  end type Circle
contains
  real function circle_area(this)
    class(Circle), intent(in) :: this
    circle_area = pi * this%radius**2
  end function circle_area

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

  subroutine main()
  type(Circle) :: c     ! Declare a variable of type Circle.
  c = Circle(1.0)       ! Use the implicit constructor, radius = 1.5.
  c%radius = 1.5
  call c%circle_print          ! Call the type-bound subroutine
  end subroutine
end module

program circle_test
use class_circle2, only: main
implicit none

call main()
end program


! constants.f90
! author: sunder

!-----------------------------------------------------------------------
! Number of physical constants and conversion factors frequently used
! in computations
!-----------------------------------------------------------------------

module constants
    implicit none
    public

    ! ---------------------------------------------------------------------------------------------------------
    ! Mathematical Constants
    ! ---------------------------------------------------------------------------------------------------------

    double precision, parameter :: m_e                       = 2.71828182845904523536028747135d0      ! e
    double precision, parameter :: m_log2e                   = 1.44269504088896340735992468100d0      ! log_2 (e)
    double precision, parameter :: m_log10e                  = 0.43429448190325182765112891892d0      ! log_10 (e)
    double precision, parameter :: m_sqrt2                   = 1.41421356237309504880168872421d0      ! sqrt(2)
    double precision, parameter :: m_sqrt1_2                 = 0.70710678118654752440084436210d0      ! sqrt(1/2)
    double precision, parameter :: m_sqrt3                   = 1.73205080756887729352744634151d0      ! sqrt(3)
    double precision, parameter :: m_pi                      = 3.14159265358979323846264338328d0      ! pi
    double precision, parameter :: m_pi_2                    = 1.57079632679489661923132169164d0      ! pi/2
    double precision, parameter :: m_pi_4                    = 0.78539816339744830961566084582d0      ! pi/4
    double precision, parameter :: m_sqrtpi                  = 1.77245385090551602729816748334d0      ! sqrt(pi)
    double precision, parameter :: m_1_pi                    = 0.31830988618379067153776752675d0      ! 1/pi
    double precision, parameter :: m_2_pi                    = 0.63661977236758134307553505349d0      ! 2/pi
    double precision, parameter :: m_ln10                    = 2.30258509299404568401799145468d0      ! ln(10)
    double precision, parameter :: m_ln2                     = 0.69314718055994530941723212146d0      ! ln(2)
    double precision, parameter :: m_lnpi                    = 1.14472988584940017414342735135d0      ! ln(pi)
    double precision, parameter :: m_euler                   = 0.57721566490153286060651209008d0      ! Euler constant

    ! ---------------------------------------------------------------------------------------------------------
    ! Fundamental Physical Constants (All units are in MKSA)
    ! ---------------------------------------------------------------------------------------------------------

    double precision, parameter :: speed_of_light            = 2.99792458d8                           ! Speed of light in vacuum
    double precision, parameter :: vacuum_permeability       = 1.25663706144d-6                       ! Permeability of free space
    double precision, parameter :: vacuum_permittivity       = 8.854187817d-12                        ! Permittivity of free space
    double precision, parameter :: plancks_constant_h        = 6.62606896d-34                         ! Planck’s constant, h
    double precision, parameter :: plancks_constant_hbar     = 1.05457162825d-34                      ! Planck’s constant divided by 2\pi, h_bar
    double precision, parameter :: num_avogadro              = 6.02214199d23                          ! Avogadro’s number, 1 mol
    double precision, parameter :: faraday                   = 9.64853429775d4                        ! The molar charge of 1 Faraday
    double precision, parameter :: boltzman                  = 1.3806504d-23                          ! Boltzmann constant, k
    double precision, parameter :: molar_gas                 = 8.314472d0                             ! Molar gas constant
    double precision, parameter :: standard_gas_volume       = 2.2710981d-2                           ! Standard gas volume
    double precision, parameter :: stefan_boltzman_constant  = 5.67040047374d-8                       ! Stefan-Boltzmann radiation constant
    double precision, parameter :: gauss                     = 1.0d-4                                 ! Magnetic field of 1 Gauss

    ! ---------------------------------------------------------------------------------------------------------
    ! Astronomy and Astrophysics
    ! ---------------------------------------------------------------------------------------------------------

    double precision, parameter :: astronomical_unit         = 1.49597870691d11                       ! The length of 1 astronomical unit (mean earth-sun distance)
    double precision, parameter :: gravitational_constant    = 6.673d-11                              ! Universal gravitational constant
    double precision, parameter :: light_year                = 9.46053620707d15                       ! The distance of 1 light-year
    double precision, parameter :: parsec                    = 3.08567758135d16                       ! The distance of 1 parsec
    double precision, parameter :: grav_accel                = 9.80665d0                              ! Standard gravitational acceleration on Earth, g
    double precision, parameter :: solar_mass                = 1.98892d30                             ! Mass of the Sun

    ! ---------------------------------------------------------------------------------------------------------
    ! Atomic and Nuclear Physics
    ! ---------------------------------------------------------------------------------------------------------

    double precision, parameter :: electron_charge           = 1.602176487d-19                        ! Charge of the electron
    double precision, parameter :: electron_volt             = 1.602176487d-19                        ! Energy of 1 electron volt
    double precision, parameter :: unified_atomic_mass       = 1.660538782d-27                        ! Unified atomic mass
    double precision, parameter :: mass_electron             = 9.10938188d-31                         ! Mass of the electron
    double precision, parameter :: mass_muon                 = 1.88353109d-28                         ! Mass of the muon
    double precision, parameter :: mass_proton               = 1.67262158d-27                         ! Mass of the proton
    double precision, parameter :: mass_neutron              = 1.67492716d-27                         ! Mass of the neutron
    double precision, parameter :: num_fine_structure        = 7.297352533d-3                         ! Electromagnetic fine structure constant
    double precision, parameter :: rydberg                   = 2.17987196968d-18                      ! Rydberg constant
    double precision, parameter :: bohr_radius               = 5.291772083d-11                        ! Bohr radius
    double precision, parameter :: angstrom                  = 1.0d-10                                ! Length of 1 angstrom
    double precision, parameter :: barn                      = 1.0d-28                                ! Area of 1 barn
    double precision, parameter :: bohr_magneton             = 9.27400899d-24                         ! Bohr Magneton
    double precision, parameter :: nuclear_magneton          = 5.05078317d-27                         ! Nuclear Magneton
    double precision, parameter :: electron_magnetic_moment  = 9.28476362d-24                         ! Absolute value of the magnetic moment of the electron
    double precision, parameter :: proton_magnetic_moment    = 1.410606633d-26                        ! Magnetic moment of the proton
    double precision, parameter :: thomson_cross_section     = 6.65245893699d-29                      ! Thomson cross section
    double precision, parameter :: debye                     = 3.33564095198d-30                      ! Electric dipole moment of 1 Debye

    ! ---------------------------------------------------------------------------------------------------------
    ! Measurement of Time
    ! ---------------------------------------------------------------------------------------------------------

    double precision, parameter :: minute                    = 60.d0                                   ! Number of seconds in 1 minute
    double precision, parameter :: hour                      = 3.6d3                                  ! Number of seconds in 1 hour
    double precision, parameter :: day                       = 8.64d4                                 ! Number of seconds in 1 day
    double precision, parameter :: week                      = 6.048d5                                ! Number of seconds in 1 week

    ! ---------------------------------------------------------------------------------------------------------
    ! Imperial units
    ! ---------------------------------------------------------------------------------------------------------

    double precision, parameter :: inch                      = 2.54d-2                                ! Length of 1 inch
    double precision, parameter :: foot                      = 3.048d-1                               ! Length of 1 foot
    double precision, parameter :: yard                      = 9.144d-1                               ! Length of 1 yard
    double precision, parameter :: mile                      = 1.609344d3                             ! Length of 1 mile
    double precision, parameter :: mil                       = 2.54d-5                                ! Length of 1 mil (1/1000 of inch)

    ! ---------------------------------------------------------------------------------------------------------
    ! Speed and Nautical Units
    ! ---------------------------------------------------------------------------------------------------------

    double precision, parameter :: kilometers_per_hour       = 2.77777777778d-1                       ! Speed of 1 kilometer per hour
    double precision, parameter :: miles_per_hour            = 4.4704d-1                              ! Speed of 1 mile per hour
    double precision, parameter :: nautical_mile             = 1.852d3                                ! One Nautical mile
    double precision, parameter :: fathom                    = 1.8288d0                               ! Length of 1 fathom
    double precision, parameter :: knot                      = 5.14444444444d-1                       ! Speed of 1 knot

    ! ---------------------------------------------------------------------------------------------------------
    ! Printers Units
    ! ---------------------------------------------------------------------------------------------------------

    double precision, parameter :: point                     = 3.52777777778d-4                       ! Length of 1 printer’s point (1/72 inch)
    double precision, parameter :: texpoint                  = 3.51459803515d-4                       ! length of 1 TeX point (1/72.27 inch)

    ! ---------------------------------------------------------------------------------------------------------
    ! Volume, Area and Length
    ! ---------------------------------------------------------------------------------------------------------

    double precision, parameter :: micron                    = 1.0d-6                                 ! Length of 1 micron
    double precision, parameter :: hectare                   = 1.0d4                                  ! Area of 1 hectare
    double precision, parameter :: acre                      = 4.04685642241d3                        ! Area of 1 acre
    double precision, parameter :: liter                     = 1.0d-3                                 ! Volume of 1 liter
    double precision, parameter :: us_gallon                 = 3.78541178402d-3                       ! Volume of 1 US gallon
    double precision, parameter :: canadian_gallon           = 4.54609d-3                             ! Volume of 1 Canadian gallon
    double precision, parameter :: uk_gallon                 = 4.546092d-3                            ! Volume of 1 UK gallon
    double precision, parameter :: quart                     = 9.46352946004d-4                       ! Volume of 1 quart
    double precision, parameter :: pint                      = 4.73176473002d-4                       ! Volume of 1 pint

    ! ---------------------------------------------------------------------------------------------------------
    ! Mass and Weight
    ! ---------------------------------------------------------------------------------------------------------

    double precision, parameter :: pound_mass                = 4.5359237d-1                           ! Mass of 1 pound
    double precision, parameter :: ounce_mass                = 2.8349523125d-2                        ! Mass of 1 ounce
    double precision, parameter :: ton                       = 9.0718474d2                            ! Mass of 1 ton
    double precision, parameter :: metric_ton                = 1.0d3                                  ! Mass of 1 metric ton
    double precision, parameter :: uk_ton                    = 1.0160469088d3                         ! Mass of 1 UK ton
    double precision, parameter :: troy_ounce                = 3.1103475d-2                           ! Mass of 1 troy ounce
    double precision, parameter :: carat                     = 2.0d-4                                 ! Mass of 1 carat
    double precision, parameter :: gram_force                = 9.80665d-3                             ! Weight force of 1 gram
    double precision, parameter :: pound_force               = 4.44822161526d0                        ! Weight force of 1 pound
    double precision, parameter :: kilopound_force           = 4.44822161526d3                        ! Weight force of 1 kilo-pound
    double precision, parameter :: poundal                   = 1.38255d-1                             ! Weight force of 1 poundal

    ! ---------------------------------------------------------------------------------------------------------
    ! Thermal energy and power
    ! ---------------------------------------------------------------------------------------------------------

end module constants


! This file is part of mctc-lib.
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!     http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.

!> Simple algebraic functions
module mctc_io_math
   use mctc_env_accuracy, only : wp
   use mctc_io_constants, only : pi
   implicit none
   private

   public :: matdet_3x3, matinv_3x3, crossprod, eigval_3x3, eigvec_3x3

   real(wp), parameter :: twothirdpi = 2.0_wp * pi / 3.0_wp

contains

!> Performs a direct calculation of the inverse of a 3×3 matrix.
!
!  reference: http://fortranwiki.org/fortran/show/Matrix+inversion
pure function matinv_3x3(a) result(b)

   !> Matrix
   real(wp), intent(in) :: a(3, 3)

   !> Inverse matrix
   real(wp) :: b(3, 3)

   real(wp) :: detinv

   ! Calculate the inverse determinant of the matrix
   detinv = 1.0_wp/matdet_3x3(a)

   ! Calculate the inverse of the matrix
   b(1, 1) = +detinv * (a(2, 2) * a(3, 3) - a(2, 3) * a(3, 2))
   b(2, 1) = -detinv * (a(2, 1) * a(3, 3) - a(2, 3) * a(3, 1))
   b(3, 1) = +detinv * (a(2, 1) * a(3, 2) - a(2, 2) * a(3, 1))
   b(1, 2) = -detinv * (a(1, 2) * a(3, 3) - a(1, 3) * a(3, 2))
   b(2, 2) = +detinv * (a(1, 1) * a(3, 3) - a(1, 3) * a(3, 1))
   b(3, 2) = -detinv * (a(1, 1) * a(3, 2) - a(1, 2) * a(3, 1))
   b(1, 3) = +detinv * (a(1, 2) * a(2, 3) - a(1, 3) * a(2, 2))
   b(2, 3) = -detinv * (a(1, 1) * a(2, 3) - a(1, 3) * a(2, 1))
   b(3, 3) = +detinv * (a(1, 1) * a(2, 2) - a(1, 2) * a(2, 1))

end function matinv_3x3

!> Determinat of 3×3 matrix
pure function matdet_3x3(a) result (det)

   !> Matrix
   real(wp), intent(in) :: a(3, 3)

   !> Determinant
   real(wp) :: det

   det =  a(1, 1) * a(2, 2) * a(3, 3)  &
      & - a(1, 1) * a(2, 3) * a(3, 2)  &
      & - a(1, 2) * a(2, 1) * a(3, 3)  &
      & + a(1, 2) * a(2, 3) * a(3, 1)  &
      & + a(1, 3) * a(2, 1) * a(3, 2)  &
      & - a(1, 3) * a(2, 2) * a(3, 1)

end function matdet_3x3

!> Implements the cross/vector product between two 3D vectors
pure function crossprod(a,b) result(c)

   !> First vector
   real(wp), intent(in) :: a(3)

   !> Second vector
   real(wp), intent(in) :: b(3)

   !> Orthogonal vector
   real(wp) :: c(3)

   c(1) = a(2) * b(3) - b(2) * a(3)
   c(2) = a(3) * b(1) - b(3) * a(1)
   c(3) = a(1) * b(2) - b(1) * a(2)

end function crossprod

!> Calculates eigenvalues based on the trigonometric solution of A = pB + qI
pure subroutine eigval_3x3(a, w)

   !> The symmetric input matrix
   real(wp), intent(in) :: a(3, 3)

   !> Contains eigenvalues on exit
   real(wp), intent(out) :: w(3)

   real(wp) :: q, p, r

   r = a(1, 2) * a(1, 2) + a(1, 3) * a(1, 3) + a(2, 3) * a(2, 3)
   q = (a(1, 1) + a(2, 2) + a(3, 3)) / 3.0_wp
   w(1) = a(1, 1) - q
   w(2) = a(2, 2) - q
   w(3) = a(3, 3) - q
   p = sqrt((w(1) * w(1) + w(2) * w(2) + w(3) * w(3) + 2*r) / 6.0_wp)
   r = (w(1) * (w(2) * w(3) - a(2, 3) * a(2, 3)) &
      & - a(1, 2) * (a(1, 2) * w(3) - a(2, 3) * a(1, 3)) &
      & + a(1, 3) * (a(1, 2) * a(2, 3) - w(2) * a(1, 3))) / (p*p*p) * 0.5_wp

   if (r <= -1.0_wp) then
      r = 0.5_wp * twothirdpi
   else if (r >= 1.0_wp) then
      r = 0.0_wp
   else
      r = acos(r) / 3.0_wp
   end if

   w(3) = q + 2 * p * cos(r)
   w(1) = q + 2 * p * cos(r + twothirdpi)
   w(2) = 3 * q - w(1) - w(3)

end subroutine eigval_3x3

!> Calculates eigenvector using an analytical method based on vector cross
!  products.
pure subroutine eigvec_3x3(a, w, q)
   real(wp), intent(inout) :: a(3,3)
   real(wp), intent(out) :: w(3)
   real(wp), intent(out) :: q(3,3)

   real(wp), parameter :: eps = epsilon(1.0_wp)
   real(wp) norm, n1, n2, n3, precon
   integer :: i

   w(1) = max(abs(a(1, 1)), abs(a(1, 2)))
   w(2) = max(abs(a(1, 3)), abs(a(2, 2)))
   w(3) = max(abs(a(2, 3)), abs(a(3, 3)))
   precon = max(w(1), max(w(2), w(3)))

   ! null matrix
   if (precon < eps) then
      w(1) = 0.0_wp
      w(2) = 0.0_wp
      w(3) = 0.0_wp
      q(1, 1) = 1.0_wp
      q(2, 2) = 1.0_wp
      q(3, 3) = 1.0_wp
      q(1, 2) = 0.0_wp
      q(1, 3) = 0.0_wp
      q(2, 3) = 0.0_wp
      q(2, 1) = 0.0_wp
      q(3, 1) = 0.0_wp
      q(3, 2) = 0.0_wp
      return
   end if

   norm = 1.0_wp / precon

   a(1, 1) = a(1, 1) * norm
   a(1, 2) = a(1, 2) * norm
   a(2, 2) = a(2, 2) * norm
   a(1, 3) = a(1, 3) * norm
   a(2, 3) = a(2, 3) * norm
   a(3, 3) = a(3, 3) * norm

   ! Calculate eigenvalues
   call eigval_3x3(a, w)

   ! Compute first eigenvector
   a(1, 1) = a(1, 1) - w(1)
   a(2, 2) = a(2, 2) - w(1)
   a(3, 3) = a(3, 3) - w(1)

   q(1, 1) = a(1, 2) * a(2, 3) - a(1, 3) * a(2, 2)
   q(2, 1) = a(1, 3) * a(1, 2) - a(1, 1) * a(2, 3)
   q(3, 1) = a(1, 1) * a(2, 2) - a(1, 2) * a(1, 2)
   q(1, 2) = a(1, 2) * a(3, 3) - a(1, 3) * a(2, 3)
   q(2, 2) = a(1, 3) * a(1, 3) - a(1, 1) * a(3, 3)
   q(3, 2) = a(1, 1) * a(2, 3) - a(1, 2) * a(1, 3)
   q(1, 3) = a(2, 2) * a(3, 3) - a(2, 3) * a(2, 3)
   q(2, 3) = a(2, 3) * a(1, 3) - a(1, 2) * a(3, 3)
   q(3, 3) = a(1, 2) * a(2, 3) - a(2, 2) * a(1, 3)
   n1 = q(1, 1) * q(1, 1) + q(2, 1) * q(2, 1) + q(3, 1) * q(3, 1)
   n2 = q(1, 2) * q(1, 2) + q(2, 2) * q(2, 2) + q(3, 2) * q(3, 2)
   n3 = q(1, 3) * q(1, 3) + q(2, 3) * q(2, 3) + q(3, 3) * q(3, 3)

   norm = n1
   i = 1
   if (n2 > norm) then
      i = 2
      norm = n1
   end if
   if (n3 > norm) then
      i = 3
   end if

   if (i == 1) then
      norm = sqrt(1.0_wp / n1)
      q(1, 1) = q(1, 1) * norm
      q(2, 1) = q(2, 1) * norm
      q(3, 1) = q(3, 1) * norm
   else if (i == 2) then
      norm = sqrt(1.0_wp / n2)
      q(1, 1) = q(1, 2) * norm
      q(2, 1) = q(2, 2) * norm
      q(3, 1) = q(3, 2) * norm
   else
      norm = sqrt(1.0_wp / n3)
      q(1, 1) = q(1, 3) * norm
      q(2, 1) = q(2, 3) * norm
      q(3, 1) = q(3, 3) * norm
   end if

   ! Robustly compute a right-hand orthonormal set (ev1, u, v)
   if (abs(q(1, 1)) > abs(q(2, 1))) then
      norm = sqrt(1.0_wp / (q(1, 1) * q(1, 1) + q(3, 1) * q(3, 1)))
      q(1, 2) = -q(3, 1) * norm
      q(2, 2) = 0.0_wp
      q(3, 2) = +q(1, 1) * norm
   else
      norm = sqrt(1.0_wp / (q(2, 1) * q(2, 1) + q(3, 1) * q(3, 1)))
      q(1, 2) = 0.0_wp
      q(2, 2) = +q(3, 1) * norm
      q(3, 2) = -q(2, 1) * norm
   end if
   q(1, 3) = q(2, 1) * q(3, 2) - q(3, 1) * q(2, 2)
   q(2, 3) = q(3, 1) * q(1, 2) - q(1, 1) * q(3, 2)
   q(3, 3) = q(1, 1) * q(2, 2) - q(2, 1) * q(1, 2)

   ! Reset A
   a(1, 1) = a(1, 1) + w(1)
   a(2, 2) = a(2, 2) + w(1)
   a(3, 3) = a(3, 3) + w(1)

   ! A*U
   n1 = a(1, 1) * q(1, 2) + a(1, 2) * q(2, 2) + a(1, 3) * q(3, 2)
   n2 = a(1, 2) * q(1, 2) + a(2, 2) * q(2, 2) + a(2, 3) * q(3, 2)
   n3 = a(1, 3) * q(1, 2) + a(2, 3) * q(2, 2) + a(3, 3) * q(3, 2)

   ! A*V, note out of order computation
   a(3, 3) = a(1, 3) * q(1, 3) + a(2, 3) * q(2, 3) + a(3, 3) * q(3, 3)
   a(1, 3) = a(1, 1) * q(1, 3) + a(1, 2) * q(2, 3) + a(1, 3) * q(3, 3)
   a(2, 3) = a(1, 2) * q(1, 3) + a(2, 2) * q(2, 3) + a(2, 3) * q(3, 3)

   ! UT*(A*U) - l2*E
   n1 = q(1, 2) * n1 + q(2, 2) * n2 + q(3, 2) * n3 - w(2)
   ! UT*(A*V)
   n2 = q(1, 2) * a(1, 3) + q(2, 2) * a(2, 3) + q(3, 2) * a(3, 3)
   ! VT*(A*V) - l2*E
   n3 = q(1, 3) * a(1, 3) + q(2, 3) * a(2, 3) + q(3, 3) * a(3, 3) - w(2)

   if (abs(n1) >= abs(n3)) then
      norm = max(abs(n1), abs(n2))
      if (norm > eps) then
         if (abs(n1) >= abs(n2)) then
            n2 = n2 / n1
            n1 = sqrt(1.0_wp / (1.0_wp + n2 * n2))
            n2 = n2 * n1
         else
            n1 = n1 / n2
            n2 = sqrt(1.0_wp / (1.0_wp + n1 * n1))
            n1 = n1 * n2
         end if
         q(1, 2) = n2 * q(1, 2) - n1 * q(1, 3)
         q(2, 2) = n2 * q(2, 2) - n1 * q(2, 3)
         q(3, 2) = n2 * q(3, 2) - n1 * q(3, 3)
      end if
   else
      norm = max(abs(n3), abs(n2))
      if (norm > eps) then
         if (abs(n3) >= abs(n2)) then
            n2 = n2 / n3
            n3 = sqrt(1.0_wp / (1.0_wp + n2 * n2))
            n2 = n2 * n3
         else
            n3 = n3 / n2
            n2 = sqrt(1.0_wp / (1.0_wp + n3 * n3))
            n3 = n3 * n2
         end if
         q(1, 2) = n3 * q(1, 2) - n2 * q(1, 3)
         q(2, 2) = n3 * q(2, 2) - n2 * q(2, 3)
         q(3, 2) = n3 * q(3, 2) - n2 * q(3, 3)
      end if
   end if

   ! Calculate third eigenvector from cross product
   q(1, 3) = q(2, 1) * q(3, 2) - q(3, 1) * q(2, 2)
   q(2, 3) = q(3, 1) * q(1, 2) - q(1, 1) * q(3, 2)
   q(3, 3) = q(1, 1) * q(2, 2) - q(2, 1) * q(1, 2)

   w(1) = w(1) * precon
   w(2) = w(2) * precon
   w(3) = w(3) * precon

end subroutine eigvec_3x3

end module mctc_io_math


subroutine tewelesf(vart, varf, plat, plon, ntt, ntf, nlat, nlon, tws)
! Estimate the Teweles-Wobus distance between the given atmospheric circulation
! variable, say X, daily or monthly mean and all other daily or monthly means within the training period
!
! INPUT->  vart(nxy,ntt)      : X array for all months/days of the training period
!          varf(nxy,ntf)      : X array for the month/day under scrutiny for the analogue search
!          plat(nlat)         : latitude array
!          plon(nlon)         : longitude array
!          ntt                : number of months/days in the training period
!          ntf                : number of months/days under scrutiny for the analogue search
!          nlat               : number of latitudes
!          nlon               : number of longitudes
!
! OUTPUT-> tws(ntf,ntt)       : distance array
!
! Note: this function uses a simple cos(lat) weighting in the gradient estimation
  implicit none
   integer      ntt, ntf, nlat, nlon
   integer      n, m, i, j
   real         vart(nlon,nlat,ntt), varf(nlon,nlat,ntf), plat(nlat), plon(nlon), tws(ntf,ntt)
   real         di(nlat), dvari(nlat), mdvari(nlat), dj(nlon), dvarj(nlon), mdvarj(nlon)
   real         gradi, gradj, Gi, Gj, pi

   ! Get Pi value.
   pi             = 4.*atan(1.)

   ! Weights (works for regular grids)
   !
   di             = cos(plat*pi/180) * 2 * (plon(2) - plon(1))
   dj             = 2 * abs(plat(2) - plat(1))

   !$OMP PARALLEL DO PRIVATE(gradi, gradj, Gi, Gj, dvari, dvarj, mdvari, mdvarj, m, i, j)
   do n=1,ntt
      do m=1,ntf

         gradi             = 0
         Gi                = 0

         do i=2,nlon-1
            ! Gradient différences in longitude
            dvari          = abs(     (vart(i+1,:,n) - vart(i-1,:,n))     - (varf(i+1,:,m) - varf(i-1,:,m))   )
            ! Weighting
            gradi          = gradi + sum(dvari / di)

            ! Maximum gradient
            mdvari         = max( abs( vart(i+1,:,n) - vart(i-1,:,n) ), abs( varf(i+1,:,m) - varf(i-1,:,m) )  )
            Gi             = Gi + sum(mdvari / di)
         end do

         gradj             = 0
         Gj                = 0

         do j=2,nlat-1
            !  Gradient différences in latitude
            dvarj          = abs(     (vart(:,j+1,n) - vart(:,j-1,n))     - (varf(:,j+1,m) - varf(:,j-1,m))   )
            ! Weighting
            gradj          = gradj + sum(dvarj / dj)

            ! Maximum gradient
            mdvarj         = max( abs( vart(:,j+1,n) - vart(:,j-1,n) ), abs( varf(:,j+1,m) - varf(:,j-1,m) )  )
            Gj             = Gj + sum(mdvarj / dj)
         end do
            ! Get distance
        tws(m,n)             = 100 * (gradi + gradj) / (Gi + Gj)

      end do

   end do
   !$OMP END PARALLEL DO

end subroutine tewelesf


	FUNCTION PR_VWND  ( sped, drct )
C************************************************************************
C* PR_VWND 								*
C*									*
C* This function computes VWND from SPED and DRCT or VKNT from SKNT	*
C* and DRCT.  The following equation is used:				*
C*									*
C*                VWND = -COS ( DRCT ) * SPED				*
C*									*
C* REAL PR_VWND  ( SPED, DRCT )						*
C*									*
C* Input parameters:							*
C*	SPED		REAL		Wind speed			*
C*	DRCT		REAL		Wind direction in degrees	*
C*									*
C* Output parameters:							*
C*	PR_VWND		REAL		V component			*
C**									*
C* Log:									*
C* P. Kocin/914		1980	Original source code			*
C* I. Graffman/RDS	12/87	GEMPAK4					*
C* G. Huffman/GSC	 8/88	Modified documentation			*
C************************************************************************
        INCLUDE   	'GEMPRM.PRM'
        INCLUDE   	'ERMISS.FNC'
C------------------------------------------------------------------------
	IF  ( ERMISS ( sped ) .or. ERMISS ( drct ) )  THEN
	    PR_VWND = RMISSD
	  ELSE
	    PR_VWND = (-COS( drct * DTR )) * sped
	END IF
C*
	RETURN
	END


program problem11
  implicit none
  integer, parameter      :: n=20,m=4
  integer, dimension(n,n) :: numbers
  integer                 :: i,j,k,up,right,down,temp,best=-1

  open(33,file='./data/problem11.dat')
  read(33,*) numbers

  do i=1,n
     do j=1,n
        up=min(m-1,j-1)
        right=min(m-1,n-i)
        down=min(m-1,n-j)

        ! up
        best = max(best,product(numbers(i,j:j-up:-1)))

        ! up right
        temp=1
        do k=0,min(up,right)
           temp=temp*numbers(i+k,j-k)
        end do
        best = max(best,temp)

        ! right
        best = max(best,product(numbers(i:i+right,j)))

        ! down right
        temp=1
        do k=0,min(down,right)
           temp=temp*numbers(i+k,j+k)
        end do
        best = max(best,temp)

     end do
  end do

  print *, best

end program problem11