!! ----------------------------------------------------------------------------------
!! MODULE Polynomial234RootSolvers
!!
!!    This module contains the three root solvers for quadratic,
!!    cubic and quartic polynomials.
!!
!! ----------------------------------------------------------------------------------

module Polynomial234RootSolvers

use SetWorkingPrecision, ONLY : wp, wpformat

contains

!!-----------------------------------------------------------------------------------
!!
!! CUBIC POLYNOMIAL ROOT SOLVER
!!
!! SYNOPSIS
!!
!!  call cubicRoots (real,              intent (in)  :: c2,
!!                   real,              intent (in)  :: c1,
!!                   real,              intent (in)  :: c0,
!!                   integer,           intent (out) :: nReal,
!!                   real,              intent (out) :: root (1:3,1:2),
!!                   logical, optional, intent (in)  :: printInfo)
!!
!! DESCRIPTION
!!
!!  Calculates all real + complex roots of the cubic polynomial:
!!
!!                 x^3 + c2 * x^2 + c1 * x + c0
!!
!!  The first real root (which always exists) is obtained using an optimized
!!  Newton-Raphson scheme. The other remaining roots are obtained through
!!  composite deflation into a quadratic. An option for printing detailed info
!!  about the intermediate stages in solving the cubic is available.
!!
!!  The cubic root solver can handle any size of cubic coefficients and there is
!!  no danger of overflow due to proper rescaling of the cubic polynomial.
!!
!!  The order of the roots is as follows:
!!
!!        1) For real roots, the order is according to their algebraic value
!!           on the number scale (largest positive first, largest negative last).
!!
!!        2) Since there can be only one complex conjugate pair root, no order
!!           is necessary.
!!
!!        3) All real roots preceede the complex ones.
!!
!! ARGUMENTS
!!
!!  c2         : coefficient of x^2 term
!!  c1         : coefficient of x term
!!  c0         : independent coefficient
!!  nReal      : number of real roots found
!!  root (n,1) : real part of n-th root
!!  root (n,2) : imaginary part of n-th root
!!  printInfo  : if given and true, detailed info will be printed about intermediate stages
!!
!! NOTES
!!
!!***

subroutine cubicRoots (c2, c1, c0, nReal, root, printInfo)

  implicit none

  logical, optional  , intent (in)  :: printInfo
  integer            , intent (out) :: nReal
  real    (kind = wp), intent (in)  :: c2, c1, c0
  real    (kind = wp), intent (out) :: root (1:3,1:2)

  logical :: bisection
  logical :: converged
  logical :: doPrint

  integer :: cubicType
  integer :: deflateCase
  integer :: oscillate

  integer, parameter :: Re = 1
  integer, parameter :: Im = 2

  integer, parameter :: allzero   = 0
  integer, parameter :: linear    = 1
  integer, parameter :: quadratic = 2
  integer, parameter :: general   = 3

  real (kind = wp) :: a0, a1, a2
  real (kind = wp) :: a, b, c, k, s, t, u, x, y, z
  real (kind = wp) :: xShift

  real (kind = wp), parameter :: macheps = epsilon (1.0_wp)
  real (kind = wp), parameter :: one27th = 1.0_wp / 27.0_wp
  real (kind = wp), parameter :: two27th = 2.0_wp / 27.0_wp
  real (kind = wp), parameter :: third   = 1.0_wp /  3.0_wp

  real (kind = wp), parameter :: p1 = 1.09574_wp         !
  real (kind = wp), parameter :: q1 = 3.23900e-1_wp      ! Newton-Raphson coeffs for class 1 and 2
  real (kind = wp), parameter :: r1 = 3.23900e-1_wp      !
  real (kind = wp), parameter :: s1 = 9.57439e-2_wp      !

  real (kind = wp), parameter :: p3 = 1.14413_wp         !
  real (kind = wp), parameter :: q3 = 2.75509e-1_wp      ! Newton-Raphson coeffs for class 3
  real (kind = wp), parameter :: r3 = 4.45578e-1_wp      !
  real (kind = wp), parameter :: s3 = 2.59342e-2_wp      !

  real (kind = wp), parameter :: q4 = 7.71845e-1_wp      ! Newton-Raphson coeffs for class 4
  real (kind = wp), parameter :: s4 = 2.28155e-1_wp      !

  real (kind = wp), parameter :: p51 = 8.78558e-1_wp     !
  real (kind = wp), parameter :: p52 = 1.92823e-1_wp     !
  real (kind = wp), parameter :: p53 = 1.19748_wp        !
  real (kind = wp), parameter :: p54 = 3.45219e-1_wp     !
  real (kind = wp), parameter :: q51 = 5.71888e-1_wp     !
  real (kind = wp), parameter :: q52 = 5.66324e-1_wp     !
  real (kind = wp), parameter :: q53 = 2.83772e-1_wp     ! Newton-Raphson coeffs for class 5 and 6
  real (kind = wp), parameter :: q54 = 4.01231e-1_wp     !
  real (kind = wp), parameter :: r51 = 7.11154e-1_wp     !
  real (kind = wp), parameter :: r52 = 5.05734e-1_wp     !
  real (kind = wp), parameter :: r53 = 8.37476e-1_wp     !
  real (kind = wp), parameter :: r54 = 2.07216e-1_wp     !
  real (kind = wp), parameter :: s51 = 3.22313e-1_wp     !
  real (kind = wp), parameter :: s52 = 2.64881e-1_wp     !
  real (kind = wp), parameter :: s53 = 3.56228e-1_wp     !
  real (kind = wp), parameter :: s54 = 4.45532e-3_wp     !
!
!
!     ...Start.
!
!
  if (present (printInfo)) then
      doPrint = printInfo
  else
      doPrint = .false.
  end if

  if (doPrint) then
      write (*,wpformat) ' initial cubic c2      = ',c2
      write (*,wpformat) ' initial cubic c1      = ',c1
      write (*,wpformat) ' initial cubic c0      = ',c0
      write (*,wpformat) ' ------------------------------------------------'
  end if
!
!
!     ...Handle special cases.
!
!            1) all terms zero
!            2) only quadratic term is nonzero -> linear equation.
!            3) only independent term is zero -> quadratic equation.
!
!
  if (c0 == 0.0_wp .and. c1 == 0.0_wp .and. c2 == 0.0_wp) then

      cubicType = allzero

  else if (c0 == 0.0_wp .and. c1 == 0.0_wp) then

      k  = 1.0_wp
      a2 = c2

      cubicType = linear

  else if (c0 == 0.0_wp) then

      k  = 1.0_wp
      a2 = c2
      a1 = c1

      cubicType = quadratic

  else
!
!
!     ...The general case. Rescale cubic polynomial, such that largest absolute coefficient
!        is (exactly!) equal to 1. Honor the presence of a special cubic case that might have
!        been obtained during the rescaling process (due to underflow in the coefficients).
!
!
      x = abs (c2)
      y = sqrt (abs (c1))
      z = abs (c0) ** third
      u = max (x,y,z)

      if (u == x) then

          k  = 1.0_wp / x
          a2 = sign (1.0_wp , c2)
          a1 = (c1 * k) * k
          a0 = ((c0 * k) * k) * k

      else if (u == y) then

          k  = 1.0_wp / y
          a2 = c2 * k
          a1 = sign (1.0_wp , c1)
          a0 = ((c0 * k) * k) * k

      else

          k  = 1.0_wp / z
          a2 = c2 * k
          a1 = (c1 * k) * k
          a0 = sign (1.0_wp , c0)

      end if

      if (doPrint) then
          write (*,wpformat) ' rescaling factor      = ',k
          write (*,wpformat) ' ------------------------------------------------'
          write (*,wpformat) ' rescaled cubic c2     = ',a2
          write (*,wpformat) ' rescaled cubic c1     = ',a1
          write (*,wpformat) ' rescaled cubic c0     = ',a0
          write (*,wpformat) ' ------------------------------------------------'
      end if

      k = 1.0_wp / k

      if (a0 == 0.0_wp .and. a1 == 0.0_wp .and. a2 == 0.0_wp) then
          cubicType = allzero
      else if (a0 == 0.0_wp .and. a1 == 0.0_wp) then
          cubicType = linear
      else if (a0 == 0.0_wp) then
          cubicType = quadratic
      else
          cubicType = general
      end if

  end if
!
!
!     ...Select the case.
!
!        1) Only zero roots.
!
!
  select case (cubicType)

    case (allzero)

      nReal = 3

      root (:,Re) = 0.0_wp
      root (:,Im) = 0.0_wp
!
!
!     ...2) The linear equation case -> additional 2 zeros.
!
!
    case (linear)

      x = - a2 * k

      nReal = 3

      root (1,Re) = max (0.0_wp, x)
      root (2,Re) = 0.0_wp
      root (3,Re) = min (0.0_wp, x)
      root (:,Im) = 0.0_wp
!
!
!     ...3) The quadratic equation case -> additional 1 zero.
!
!
    case (quadratic)

      call quadraticRoots (a2, a1, nReal, root (1:2,1:2))

      if (nReal == 2) then

          x = root (1,1) * k         ! real roots of quadratic are ordered x >= y
          y = root (2,1) * k

          nReal = 3

          root (1,Re) = max (x, 0.0_wp)
          root (2,Re) = max (y, min (x, 0.0_wp))
          root (3,Re) = min (y, 0.0_wp)
          root (:,Im) = 0.0_wp

      else

          nReal = 1

          root (3,Re) = root (2,Re) * k
          root (2,Re) = root (1,Re) * k
          root (1,Re) = 0.0_wp
          root (3,Im) = root (2,Im) * k
          root (2,Im) = root (1,Im) * k
          root (1,Im) = 0.0_wp

      end if
!
!
!     ...3) The general cubic case. Set the best Newton-Raphson root estimates for the cubic.
!           The easiest and most robust conditions are checked first. The most complicated
!           ones are last and only done when absolutely necessary.
!
!
    case (general)

      if (a0 == 1.0_wp) then

          x = - p1 + q1 * a1 - a2 * (r1 - s1 * a1)

          a = a2
          b = a1
          c = a0
          xShift = 0.0_wp

      else if (a0 == - 1.0_wp) then

          x = p1 - q1 * a1 - a2 * (r1 - s1 * a1)

          a = a2
          b = a1
          c = a0
          xShift = 0.0_wp

      else if (a1 == 1.0_wp) then

          if (a0 > 0.0_wp) then
              x = a0 * (- q4 - s4 * a2)
          else
              x = a0 * (- q4 + s4 * a2)
          end if

          a = a2
          b = a1
          c = a0
          xShift = 0.0_wp

      else if (a1 == - 1.0_wp) then

          y = - two27th
          y = y * a2
          y = y * a2 - third
          y = y * a2

          if (a0 < y) then
              x = + p3 - q3 * a0 - a2 * (r3 + s3 * a0)               ! + guess
          else
              x = - p3 - q3 * a0 - a2 * (r3 - s3 * a0)               ! - guess
          end if

          a = a2
          b = a1
          c = a0
          xShift = 0.0_wp

      else if (a2 == 1.0_wp) then

          b = a1 - third
          c = a0 - one27th

          if (abs (b) < macheps .and. abs (c) < macheps) then        ! triple -1/3 root

              x = - third * k

              nReal = 3

              root (:,Re) = x
              root (:,Im) = 0.0_wp

              return

          else

              y = third * a1 - two27th

              if (a1 <= third) then
                  if (a0 > y) then
                      x = - p51 - q51 * a0 + a1 * (r51 - s51 * a0)   ! - guess
                  else
                      x = + p52 - q52 * a0 - a1 * (r52 + s52 * a0)   ! + guess
                  end if
              else
                  if (a0 > y) then
                      x = - p53 - q53 * a0 + a1 * (r53 - s53 * a0)   ! <-1/3 guess
                  else
                      x = + p54 - q54 * a0 - a1 * (r54 + s54 * a0)   ! >-1/3 guess
                  end if
              end if

              if (abs (b) < 1.e-2_wp .and. abs (c) < 1.e-2_wp) then  ! use shifted root
                  c = - third * b + c
                  if (abs (c) < macheps) c = 0.0_wp                  ! prevent random noise
                  a = 0.0_wp
                  xShift = third
                  x = x + xShift
              else
                  a = a2
                  b = a1
                  c = a0
                  xShift = 0.0_wp
              end if

          end if

      else if (a2 == - 1.0_wp) then

          b = a1 - third
          c = a0 + one27th

          if (abs (b) < macheps .and. abs (c) < macheps) then        ! triple 1/3 root

              x = third * k

              nReal = 3

              root (:,Re) = x
              root (:,Im) = 0.0_wp

              return

          else

              y = two27th - third * a1

              if (a1 <= third) then
                  if (a0 < y) then
                      x = + p51 - q51 * a0 - a1 * (r51 + s51 * a0)   ! +1 guess
                  else
                      x = - p52 - q52 * a0 + a1 * (r52 - s52 * a0)   ! -1 guess
                  end if
              else
                  if (a0 < y) then
                      x = + p53 - q53 * a0 - a1 * (r53 + s53 * a0)   ! >1/3 guess
                  else
                      x = - p54 - q54 * a0 + a1 * (r54 - s54 * a0)   ! <1/3 guess
                  end if
              end if

              if (abs (b) < 1.e-2_wp .and. abs (c) < 1.e-2_wp) then  ! use shifted root
                  c = third * b + c
                  if (abs (c) < macheps) c = 0.0_wp                  ! prevent random noise
                  a = 0.0_wp
                  xShift = - third
                  x = x + xShift
              else
                  a = a2
                  b = a1
                  c = a0
                  xShift = 0.0_wp
              end if

          end if

      end if
!
!
!     ...Perform Newton/Bisection iterations on x^3 + ax^2 + bx + c.
!
!
      z = x + a
      y = x + z
      z = z * x + b
      y = y * x + z       ! C'(x)
      z = z * x + c       ! C(x)
      t = z               ! save C(x) for sign comparison
      x = x - z / y       ! 1st improved root

      oscillate = 0
      bisection = .false.
      converged = .false.

      do while (.not.converged .and. .not.bisection)    ! Newton-Raphson iterates

         z = x + a
         y = x + z
         z = z * x + b
         y = y * x + z
         z = z * x + c

         if (z * t < 0.0_wp) then                       ! does Newton start oscillating ?
             if (z < 0.0_wp) then
                 oscillate = oscillate + 1              ! increment oscillation counter
                 s = x                                  ! save lower bisection bound
             else
                 u = x                                  ! save upper bisection bound
             end if
             t = z                                      ! save current C(x)
         end if

         y = z / y                                      ! Newton correction
         x = x - y                                      ! new Newton root

         bisection = oscillate > 2                      ! activate bisection
         converged = abs (y) <= abs (x) * macheps       ! Newton convergence indicator

         if (doPrint) write (*,wpformat) ' Newton root           = ',x

      end do

      if (bisection) then

          t = u - s                                     ! initial bisection interval
          do while (abs (t) > abs (x) * macheps)        ! bisection iterates

             z = x + a                                  !
             z = z * x + b                              ! C (x)
             z = z * x + c                              !

             if (z < 0.0_wp) then                       !
                 s = x                                  !
             else                                       ! keep bracket on root
                 u = x                                  !
             end if                                     !

             t = 0.5_wp * (u - s)                       ! new bisection interval
             x = s + t                                  ! new bisection root

             if (doPrint) write (*,wpformat) ' Bisection root        = ',x

          end do
      end if

      if (doPrint) write (*,wpformat) ' ------------------------------------------------'

      x = x - xShift                                    ! unshift root
!
!
!     ...Forward / backward deflate rescaled cubic (if needed) to check for other real roots.
!        The deflation analysis is performed on the rescaled cubic. The actual deflation must
!        be performed on the original cubic, not the rescaled one. Otherwise deflation errors
!        will be enhanced when undoing the rescaling on the extra roots.
!
!
      z = abs (x)
      s = abs (a2)
      t = abs (a1)
      u = abs (a0)

      y = z * max (s,z)           ! take maximum between |x^2|,|a2 * x|

      deflateCase = 1             ! up to now, the maximum is |x^3| or |a2 * x^2|

      if (y < t) then             ! check maximum between |x^2|,|a2 * x|,|a1|
          y = t * z               ! the maximum is |a1 * x|
          deflateCase = 2         ! up to now, the maximum is |a1 * x|
      else
          y = y * z               ! the maximum is |x^3| or |a2 * x^2|
      end if

      if (y < u) then             ! check maximum between |x^3|,|a2 * x^2|,|a1 * x|,|a0|
          deflateCase = 3         ! the maximum is |a0|
      end if

      y = x * k                   ! real root of original cubic

      select case (deflateCase)

      case (1)
        x = 1.0_wp / y
        t = - c0 * x              ! t -> backward deflation on unscaled cubic
        s = (t - c1) * x          ! s -> backward deflation on unscaled cubic
      case (2)
        s = c2 + y                ! s ->  forward deflation on unscaled cubic
        t = - c0 / y              ! t -> backward deflation on unscaled cubic
      case (3)
        s = c2 + y                ! s ->  forward deflation on unscaled cubic
        t = c1 + s * y            ! t ->  forward deflation on unscaled cubic
      end select

      if (doPrint) then
          write (*,wpformat) ' Residual quadratic q1 = ',s
          write (*,wpformat) ' Residual quadratic q0 = ',t
          write (*,wpformat) ' ------------------------------------------------'
      end if

      call quadraticRoots (s, t, nReal, root (1:2,1:2))

      if (nReal == 2) then

          x = root (1,Re)         ! real roots of quadratic are ordered x >= z
          z = root (2,Re)         ! use 'z', because 'y' is original cubic real root

          nReal = 3

          root (1,Re) = max (x, y)
          root (2,Re) = max (z, min (x, y))
          root (3,Re) = min (z, y)
          root (:,Im) = 0.0_wp

      else

          nReal = 1

          root (3,Re) = root (2,Re)
          root (2,Re) = root (1,Re)
          root (1,Re) = y
          root (3,Im) = root (2,Im)
          root (2,Im) = root (1,Im)
          root (1,Im) = 0.0_wp

      end if

  end select
!
!
!     ...Ready!
!
!
  return
end subroutine cubicRoots

!!-----------------------------------------------------------------------------------
!!
!! QUADRATIC POLYNOMIAL ROOT SOLVER
!!
!! SYNOPSIS
!!
!!  call quadraticRoots (real,    intent (in)  :: q1,
!!                       real,    intent (in)  :: q0,
!!                       integer, intent (out) :: nReal,
!!                       real,    intent (out) :: root (1:2,1:2))
!!
!! DESCRIPTION
!!
!!  Calculates all real + complex roots of the quadratic polynomial:
!!
!!                 x^2 + q1 * x + q0
!!
!!  The code checks internally, if rescaling of the coefficients is needed to
!!  avoid overflow.
!!
!!  The order of the roots is as follows:
!!
!!        1) For real roots, the order is according to their algebraic value
!!           on the number scale (largest positive first, largest negative last).
!!
!!        2) Since there can be only one complex conjugate pair root, no order
!!           is necessary.
!!
!! ARGUMENTS
!!
!!  q1         : coefficient of x term
!!  q0         : independent coefficient
!!  nReal      : number of real roots found
!!  root (n,1) : real part of n-th root
!!  root (n,2) : imaginary part of n-th root
!!
!! NOTES
!!
!!***

subroutine quadraticRoots (q1, q0, nReal, root)
  implicit none

  integer            , intent (out) :: nReal
  real    (kind = wp), intent (in)  :: q1, q0
  real    (kind = wp), intent (out) :: root (1:2,1:2)

  logical :: rescale

  real (kind = wp) :: a0, a1
  real (kind = wp) :: k, x, y, z

  integer, parameter :: Re = 1
  integer, parameter :: Im = 2

  real (kind = wp), parameter :: LPN     = huge (1.0_wp)   ! the (L)argest (P)ositive (N)umber
  real (kind = wp), parameter :: sqrtLPN = sqrt (LPN)      ! and the square root of it
!
!
!     ...Handle special cases.
!
!
  if (q0 == 0.0_wp .and. q1 == 0.0_wp) then

      nReal = 2

      root (:,Re) = 0.0_wp
      root (:,Im) = 0.0_wp

  else if (q0 == 0.0_wp) then

      nReal = 2

      root (1,Re) = max (0.0_wp, - q1)
      root (2,Re) = min (0.0_wp, - q1)
      root (:,Im) = 0.0_wp

  else if (q1 == 0.0_wp) then

      x = sqrt (abs (q0))

      if (q0 < 0.0_wp) then

          nReal = 2

          root (1,Re) = x
          root (2,Re) = - x
          root (:,Im) = 0.0_wp

      else

          nReal = 0

          root (:,Re) = 0.0_wp
          root (1,Im) = x
          root (2,Im) = - x

      end if

  else
!
!
!     ...The general case. Do rescaling, if either squaring of q1/2 or evaluation of
!        (q1/2)^2 - q0 will lead to overflow. This is better than to have the solver
!        crashed. Note, that rescaling might lead to loss of accuracy, so we only
!        invoke it when absolutely necessary.
!
!
      rescale = (q1 > sqrtLPN + sqrtLPN)     ! this detects overflow of (q1/2)^2

      if (.not.rescale) then
           x = q1 * 0.5                      ! we are sure here that x*x will not overflow
           rescale = (q0 < x * x - LPN)      ! this detects overflow of (q1/2)^2 - q0
      end if

      if (rescale) then

          x = abs (q1)
          y = sqrt (abs (q0))

          if (x > y) then
              k  = x
              z  = 1.0_wp / x
              a1 = sign (1.0_wp , q1)
              a0 = (q0 * z) * z
          else
              k  = y
              a1 = q1 / y
              a0 = sign (1.0_wp , q0)
          end if

      else
          a1 = q1
          a0 = q0
      end if
!
!
!     ...Determine the roots of the quadratic. Note, that either a1 or a0 might
!        have become equal to zero due to underflow. But both cannot be zero.
!
!
      x = a1 * 0.5_wp
      y = x * x - a0

      if (y >= 0.0_wp) then

          y = sqrt (y)

          if (x > 0.0_wp) then
              y = - x - y
          else
              y = - x + y
          end if

          if (rescale) then
              y = y * k                     ! very important to convert to original
              z = q0 / y                    ! root first, otherwise complete loss of
          else                              ! root due to possible a0 = 0 underflow
              z = a0 / y
          end if

          nReal = 2

          root (1,Re) = max (y,z)           ! 1st real root of x^2 + a1 * x + a0
          root (2,Re) = min (y,z)           ! 2nd real root of x^2 + a1 * x + a0
          root (:,Im) = 0.0_wp

      else

          y = sqrt (- y)

          nReal = 0

          root (1,Re) = - x
          root (2,Re) = - x
          root (1,Im) = y                   ! complex conjugate pair of roots
          root (2,Im) = - y                 ! of x^2 + a1 * x + a0

          if (rescale) then
              root = root * k
          end if

      end if

  end if
!
!
!     ...Ready!
!
!
  return
end subroutine quadraticRoots

!!-----------------------------------------------------------------------------------
!!
!! QUARTIC POLYNOMIAL ROOT SOLVER
!!
!! SYNOPSIS
!!
!!  call quarticRoots (real,              intent (in)  :: q3,
!!                     real,              intent (in)  :: q2,
!!                     real,              intent (in)  :: q1,
!!                     real,              intent (in)  :: q0,
!!                     integer,           intent (out) :: nReal,
!!                     real,              intent (out) :: root (1:4,1:2),
!!                     logical, optional, intent (in)  :: printInfo)
!!
!! DESCRIPTION
!!
!!  Calculates all real + complex roots of the quartic polynomial:
!!
!!                 x^4 + q3 * x^3 + q2 * x^2 + q1 * x + q0
!!
!!  An option for printing detailed info about the intermediate stages in solving
!!  the quartic is available. This enables a detailed check in case something went
!!  wrong and the roots obtained are not proper.
!!
!!  The quartic root solver can handle any size of quartic coefficients and there is
!!  no danger of overflow, due to proper rescaling of the quartic polynomial.
!!
!!  The order of the roots is as follows:
!!
!!        1) For real roots, the order is according to their algebraic value
!!           on the number scale (largest positive first, largest negative last).
!!
!!        2) For complex conjugate pair roots, the order is according to the
!!           algebraic value of their real parts (largest positive first). If
!!           the real parts are equal, the order is according to the algebraic
!!           value of their imaginary parts (largest first).
!!
!!        3) All real roots preceede the complex ones.
!!
!! ARGUMENTS
!!
!!  q3         : coefficient of x^3 term
!!  q2         : coefficient of x^2 term
!!  q1         : coefficient of x term
!!  q0         : independent coefficient
!!  nReal      : number of real roots found
!!  root (n,1) : real part of n-th root
!!  root (n,2) : imaginary part of n-th root
!!  printInfo  : if given and true, detailed info will be printed about intermediate stages
!!
!! NOTES
!!
!!***

subroutine quarticRoots (q3, q2, q1, q0, nReal, root, printInfo)

  implicit none

  logical, optional  , intent (in)  :: printInfo
  integer            , intent (out) :: nReal
  real    (kind = wp), intent (in)  :: q3, q2, q1, q0
  real    (kind = wp), intent (out) :: root (1:4,1:2)

  logical :: bisection
  logical :: converged
  logical :: doPrint
  logical :: iterate
  logical :: minimum
  logical :: notZero

  integer :: deflateCase
  integer :: oscillate
  integer :: quarticType

  integer, parameter :: Re = 1
  integer, parameter :: Im = 2

  integer, parameter :: biquadratic = 2
  integer, parameter :: cubic       = 3
  integer, parameter :: general     = 4

  real (kind = wp) :: a0, a1, a2, a3
  real (kind = wp) :: a, b, c, d, k, s, t, u, x, y, z

  real (kind = wp), parameter :: macheps = epsilon (1.0_wp)
  real (kind = wp), parameter :: third   = 1.0_wp / 3.0_wp
!
!
!     ...Start.
!
!
  if (present (printInfo)) then
      doPrint = printInfo
  else
      doPrint = .false.
  end if

  if (doPrint) then
      write (*,wpformat) ' initial quartic q3    = ',q3
      write (*,wpformat) ' initial quartic q2    = ',q2
      write (*,wpformat) ' initial quartic q1    = ',q1
      write (*,wpformat) ' initial quartic q0    = ',q0
      write (*,wpformat) ' ------------------------------------------------'
  end if
!
!
!     ...Handle special cases. Since the cubic solver handles all its
!        special cases by itself, we need to check only for two cases:
!
!            1) independent term is zero -> solve cubic and include
!               the zero root
!
!            2) the biquadratic case.
!
!
  if (q0 == 0.0_wp) then

      k  = 1.0_wp
      a3 = q3
      a2 = q2
      a1 = q1

      quarticType = cubic

  else if (q3 == 0.0_wp .and. q1 == 0.0_wp) then

      k  = 1.0_wp
      a2 = q2
      a0 = q0

      quarticType = biquadratic

  else
!
!
!     ...The general case. Rescale quartic polynomial, such that largest absolute coefficient
!        is (exactly!) equal to 1. Honor the presence of a special quartic case that might have
!        been obtained during the rescaling process (due to underflow in the coefficients).
!
!
      s = abs (q3)
      t = sqrt (abs (q2))
      u = abs (q1) ** third
      x = sqrt (sqrt (abs (q0)))
      y = max (s,t,u,x)

      if (y == s) then

          k  = 1.0_wp / s
          a3 = sign (1.0_wp , q3)
          a2 = (q2 * k) * k
          a1 = ((q1 * k) * k) * k
          a0 = (((q0 * k) * k) * k) * k

      else if (y == t) then

          k  = 1.0_wp / t
          a3 = q3 * k
          a2 = sign (1.0_wp , q2)
          a1 = ((q1 * k) * k) * k
          a0 = (((q0 * k) * k) * k) * k

      else if (y == u) then

          k  = 1.0_wp / u
          a3 = q3 * k
          a2 = (q2 * k) * k
          a1 = sign (1.0_wp , q1)
          a0 = (((q0 * k) * k) * k) * k

      else

          k  = 1.0_wp / x
          a3 = q3 * k
          a2 = (q2 * k) * k
          a1 = ((q1 * k) * k) * k
          a0 = sign (1.0_wp , q0)

      end if

      k = 1.0_wp / k

      if (doPrint) then
          write (*,wpformat) ' rescaling factor      = ',k
          write (*,wpformat) ' ------------------------------------------------'
          write (*,wpformat) ' rescaled quartic q3   = ',a3
          write (*,wpformat) ' rescaled quartic q2   = ',a2
          write (*,wpformat) ' rescaled quartic q1   = ',a1
          write (*,wpformat) ' rescaled quartic q0   = ',a0
          write (*,wpformat) ' ------------------------------------------------'
      end if

      if (a0 == 0.0_wp) then
          quarticType = cubic
      else if (a3 == 0.0_wp .and. a1 == 0.0_wp) then
          quarticType = biquadratic
      else
          quarticType = general
      end if

  end if
!
!
!     ...Select the case.
!
!        1) The quartic with independent term = 0 -> solve cubic and add a zero root.
!
!
  select case (quarticType)

    case (cubic)

      call cubicRoots (a3, a2, a1, nReal, root (1:3,1:2), printInfo)

      if (nReal == 3) then

          x = root (1,Re) * k       ! real roots of cubic are ordered x >= y >= z
          y = root (2,Re) * k
          z = root (3,Re) * k

          nReal = 4

          root (1,Re) = max (x, 0.0_wp)
          root (2,Re) = max (y, min (x, 0.0_wp))
          root (3,Re) = max (z, min (y, 0.0_wp))
          root (4,Re) = min (z, 0.0_wp)
          root (:,Im) = 0.0_wp

      else                          ! there is only one real cubic root here

          x = root (1,Re) * k

          nReal = 2

          root (4,Re) = root (3,Re) * k
          root (3,Re) = root (2,Re) * k
          root (2,Re) = min (x, 0.0_wp)
          root (1,Re) = max (x, 0.0_wp)

          root (4,Im) = root (3,Im) * k
          root (3,Im) = root (2,Im) * k
          root (2,Im) = 0.0_wp
          root (1,Im) = 0.0_wp

      end if
!
!
!     ...2) The quartic with x^3 and x terms = 0 -> solve biquadratic.
!
!
    case (biquadratic)

      call quadraticRoots (q2, q0, nReal, root (1:2,1:2))

      if (nReal == 2) then

          x = root (1,Re)         ! real roots of quadratic are ordered x >= y
          y = root (2,Re)

          if (y >= 0.0_wp) then

              x = sqrt (x) * k
              y = sqrt (y) * k

              nReal = 4

              root (1,Re) = x
              root (2,Re) = y
              root (3,Re) = - y
              root (4,Re) = - x
              root (:,Im) = 0.0_wp

          else if (x >= 0.0_wp .and. y < 0.0_wp) then

              x = sqrt (x)       * k
              y = sqrt (abs (y)) * k

              nReal = 2

              root (1,Re) = x
              root (2,Re) = - x
              root (3,Re) = 0.0_wp
              root (4,Re) = 0.0_wp
              root (1,Im) = 0.0_wp
              root (2,Im) = 0.0_wp
              root (3,Im) = y
              root (4,Im) = - y

          else if (x < 0.0_wp) then

              x = sqrt (abs (x)) * k
              y = sqrt (abs (y)) * k

              nReal = 0

              root (:,Re) = 0.0_wp
              root (1,Im) = y
              root (2,Im) = x
              root (3,Im) = - x
              root (4,Im) = - y

          end if

      else          ! complex conjugate pair biquadratic roots x +/- iy.

          x = root (1,Re) * 0.5_wp
          y = root (1,Im) * 0.5_wp
          z = sqrt (x * x + y * y)
          y = sqrt (z - x) * k
          x = sqrt (z + x) * k

          nReal = 0

          root (1,Re) = x
          root (2,Re) = x
          root (3,Re) = - x
          root (4,Re) = - x
          root (1,Im) = y
          root (2,Im) = - y
          root (3,Im) = y
          root (4,Im) = - y

      end if
!
!
!     ...3) The general quartic case. Search for stationary points. Set the first
!           derivative polynomial (cubic) equal to zero and find its roots.
!           Check, if any minimum point of Q(x) is below zero, in which case we
!           must have real roots for Q(x). Hunt down only the real root, which
!           will potentially converge fastest during Newton iterates. The remaining
!           roots will be determined by deflation Q(x) -> cubic.
!
!           The best roots for the Newton iterations are the two on the opposite
!           ends, i.e. those closest to the +2 and -2. Which of these two roots
!           to take, depends on the location of the Q(x) minima x = s and x = u,
!           with s > u. There are three cases:
!
!              1) both Q(s) and Q(u) < 0
!                 ----------------------
!
!                 The best root is the one that corresponds to the lowest of
!                 these minima. If Q(s) is lowest -> start Newton from +2
!                 downwards (or zero, if s < 0 and a0 > 0). If Q(u) is lowest
!                 -> start Newton from -2 upwards (or zero, if u > 0 and a0 > 0).
!
!              2) only Q(s) < 0
!                 -------------
!
!                 With both sides +2 and -2 possible as a Newton starting point,
!                 we have to avoid the area in the Q(x) graph, where inflection
!                 points are present. Solving Q''(x) = 0, leads to solutions
!                 x = -a3/4 +/- discriminant, i.e. they are centered around -a3/4.
!                 Since both inflection points must be either on the r.h.s or l.h.s.
!                 from x = s, a simple test where s is in relation to -a3/4 allows
!                 us to avoid the inflection point area.
!
!              3) only Q(u) < 0
!                 -------------
!
!                 Same of what has been said under 2) but with x = u.
!
!
    case (general)

      x = 0.75_wp * a3
      y = 0.50_wp * a2
      z = 0.25_wp * a1

      if (doPrint) then
          write (*,wpformat) ' dQ(x)/dx cubic c2     = ',x
          write (*,wpformat) ' dQ(x)/dx cubic c1     = ',y
          write (*,wpformat) ' dQ(x)/dx cubic c0     = ',z
          write (*,wpformat) ' ------------------------------------------------'
      end if

      call cubicRoots (x, y, z, nReal, root (1:3,1:2), printInfo)

      s = root (1,Re)        ! Q'(x) root s (real for sure)
      x = s + a3
      x = x * s + a2
      x = x * s + a1
      x = x * s + a0         ! Q(s)

      y = 1.0_wp             ! dual info: Q'(x) has more real roots, and if so, is Q(u) < 0 ?

      if (nReal > 1) then
          u = root (3,Re)    ! Q'(x) root u
          y = u + a3
          y = y * u + a2
          y = y * u + a1
          y = y * u + a0     ! Q(u)
      end if

      if (doPrint) then
          write (*,wpformat) ' dQ(x)/dx root s       = ',s
          write (*,wpformat) ' Q(s)                  = ',x
          write (*,wpformat) ' dQ(x)/dx root u       = ',u
          write (*,wpformat) ' Q(u)                  = ',y
          write (*,wpformat) ' ------------------------------------------------'
      end if

      if (x < 0.0_wp .and. y < 0.0_wp) then

          if (x < y) then
              if (s < 0.0_wp) then
                  x = 1.0_wp - sign (1.0_wp,a0)
              else
                  x = 2.0_wp
              end if
          else
              if (u > 0.0_wp) then
                  x = - 1.0_wp + sign (1.0_wp,a0)
              else
                  x = - 2.0_wp
              end if
          end if

          nReal = 1

      else if (x < 0.0_wp) then

          if (s < - a3 * 0.25_wp) then
              if (s > 0.0_wp) then
                  x = - 1.0_wp + sign (1.0_wp,a0)
              else
                  x = - 2.0_wp
              end if
          else
              if (s < 0.0_wp) then
                  x = 1.0_wp - sign (1.0_wp,a0)
              else
                  x = 2.0_wp
              end if
          end if

          nReal = 1

      else if (y < 0.0_wp) then

          if (u < - a3 * 0.25_wp) then
              if (u > 0.0_wp) then
                  x = - 1.0_wp + sign (1.0_wp,a0)
              else
                  x = - 2.0_wp
              end if
          else
              if (u < 0.0_wp) then
                  x = 1.0_wp - sign (1.0_wp,a0)
              else
                  x = 2.0_wp
              end if
          end if

          nReal = 1
      else
          nReal = 0
      end if
!
!
!     ...Do all necessary Newton iterations. In case we have more than 2 oscillations,
!        exit the Newton iterations and switch to bisection. Note, that from the
!        definition of the Newton starting point, we always have Q(x) > 0 and Q'(x)
!        starts (-ve/+ve) for the (-2/+2) starting points and (increase/decrease) smoothly
!        and staying (< 0 / > 0). In practice, for extremely shallow Q(x) curves near the
!        root, the Newton procedure can overshoot slightly due to rounding errors when
!        approaching the root. The result are tiny oscillations around the root. If such
!        a situation happens, the Newton iterations are abandoned after 3 oscillations
!        and further location of the root is done using bisection starting with the
!        oscillation brackets.
!
!
      if (nReal > 0) then

          oscillate = 0
          bisection = .false.
          converged = .false.

          do while (.not.converged .and. .not.bisection)    ! Newton-Raphson iterates

             y = x + a3                                     !
             z = x + y                                      !
             y = y * x + a2                                 ! y = Q(x)
             z = z * x + y                                  !
             y = y * x + a1                                 ! z = Q'(x)
             z = z * x + y                                  !
             y = y * x + a0                                 !

             if (y < 0.0_wp) then                           ! does Newton start oscillating ?
                 oscillate = oscillate + 1                  ! increment oscillation counter
                 s = x                                      ! save lower bisection bound
             else
                 u = x                                      ! save upper bisection bound
             end if

             y = y / z                                      ! Newton correction
             x = x - y                                      ! new Newton root

             bisection = oscillate > 2                      ! activate bisection
             converged = abs (y) <= abs (x) * macheps       ! Newton convergence indicator

             if (doPrint) write (*,wpformat) ' Newton root           = ',x

          end do

          if (bisection) then

              t = u - s                                     ! initial bisection interval
              do while (abs (t) > abs (x) * macheps)        ! bisection iterates

                 y = x + a3                                 !
                 y = y * x + a2                             ! y = Q(x)
                 y = y * x + a1                             !
                 y = y * x + a0                             !

                 if (y < 0.0_wp) then                       !
                     s = x                                  !
                 else                                       ! keep bracket on root
                     u = x                                  !
                 end if                                     !

                 t = 0.5_wp * (u - s)                       ! new bisection interval
                 x = s + t                                  ! new bisection root

                 if (doPrint) write (*,wpformat) ' Bisection root        = ',x

              end do
          end if

          if (doPrint) write (*,wpformat) ' ------------------------------------------------'
!
!
!     ...Find remaining roots -> reduce to cubic. The reduction to a cubic polynomial
!        is done using composite deflation to minimize rounding errors. Also, while
!        the composite deflation analysis is done on the reduced quartic, the actual
!        deflation is being performed on the original quartic again to avoid enhanced
!        propagation of root errors.
!
!
          z = abs (x)            !
          a = abs (a3)           !
          b = abs (a2)           ! prepare for composite deflation
          c = abs (a1)           !
          d = abs (a0)           !

          y = z * max (a,z)      ! take maximum between |x^2|,|a3 * x|

          deflateCase = 1        ! up to now, the maximum is |x^4| or |a3 * x^3|

          if (y < b) then        ! check maximum between |x^2|,|a3 * x|,|a2|
              y = b * z          ! the maximum is |a2| -> form |a2 * x|
              deflateCase = 2    ! up to now, the maximum is |a2 * x^2|
          else
              y = y * z          ! the maximum is |x^3| or |a3 * x^2|
          end if

          if (y < c) then        ! check maximum between |x^3|,|a3 * x^2|,|a2 * x|,|a1|
              y = c * z          ! the maximum is |a1| -> form |a1 * x|
              deflateCase = 3    ! up to now, the maximum is |a1 * x|
          else
              y = y * z          ! the maximum is |x^4|,|a3 * x^3| or |a2 * x^2|
          end if

          if (y < d) then        ! check maximum between |x^4|,|a3 * x^3|,|a2 * x^2|,|a1 * x|,|a0|
              deflateCase = 4    ! the maximum is |a0|
          end if

          x = x * k              ! 1st real root of original Q(x)

          select case (deflateCase)

          case (1)
            z = 1.0_wp / x
            u = - q0 * z         ! u -> backward deflation on original Q(x)
            t = (u - q1) * z     ! t -> backward deflation on original Q(x)
            s = (t - q2) * z     ! s -> backward deflation on original Q(x)
          case (2)
            z = 1.0_wp / x
            u = - q0 * z         ! u -> backward deflation on original Q(x)
            t = (u - q1) * z     ! t -> backward deflation on original Q(x)
            s = q3 + x           ! s ->  forward deflation on original Q(x)
          case (3)
            s = q3 + x           ! s ->  forward deflation on original Q(x)
            t = q2 + s * x       ! t ->  forward deflation on original Q(x)
            u = - q0 / x         ! u -> backward deflation on original Q(x)
          case (4)
            s = q3 + x           ! s ->  forward deflation on original Q(x)
            t = q2 + s * x       ! t ->  forward deflation on original Q(x)
            u = q1 + t * x       ! u ->  forward deflation on original Q(x)
          end select

          if (doPrint) then
              write (*,wpformat) ' Residual cubic c2     = ',s
              write (*,wpformat) ' Residual cubic c1     = ',t
              write (*,wpformat) ' Residual cubic c0     = ',u
              write (*,wpformat) ' ------------------------------------------------'
          end if

          call cubicRoots (s, t, u, nReal, root (1:3,1:2), printInfo)

          if (nReal == 3) then

              s = root (1,Re)    !
              t = root (2,Re)    ! real roots of cubic are ordered s >= t >= u
              u = root (3,Re)    !

              root (1,Re) = max (s, x)
              root (2,Re) = max (t, min (s, x))
              root (3,Re) = max (u, min (t, x))
              root (4,Re) = min (u, x)
              root (:,Im) = 0.0_wp

              nReal = 4

          else                   ! there is only one real cubic root here

              s = root (1,Re)

              root (4,Re) = root (3,Re)
              root (3,Re) = root (2,Re)
              root (2,Re) = min (s, x)
              root (1,Re) = max (s, x)
              root (4,Im) = root (3,Im)
              root (3,Im) = root (2,Im)
              root (2,Im) = 0.0_wp
              root (1,Im) = 0.0_wp

              nReal = 2

          end if

      else
!
!
!     ...If no real roots have been found by now, only complex roots are possible.
!        Find real parts of roots first, followed by imaginary components.
!
!
          s = a3 * 0.5_wp
          t =  s * s - a2
          u =  s * t + a1                   ! value of Q'(-a3/4) at stationary point -a3/4

          notZero = (abs (u) >= macheps)    ! H(-a3/4) is considered > 0 at stationary point

          if (doPrint) then
              write (*,wpformat) ' dQ/dx (-a3/4) value   = ',u
              write (*,wpformat) ' ------------------------------------------------'
          end if

          if (a3 /= 0.0_wp) then
              s = a1 / a3
              minimum = (a0 > s * s)                            ! H''(-a3/4) > 0 -> minimum
          else
              minimum = (4 * a0 > a2 * a2)                      ! H''(-a3/4) > 0 -> minimum
          end if

          iterate = notZero .or. (.not.notZero .and. minimum)

          if (iterate) then

              x = sign (2.0_wp,a3)                              ! initial root -> target = smaller mag root

              oscillate = 0
              bisection = .false.
              converged = .false.

              do while (.not.converged .and. .not.bisection)    ! Newton-Raphson iterates

                 a = x + a3                                     !
                 b = x + a                                      ! a = Q(x)
                 c = x + b                                      !
                 d = x + c                                      ! b = Q'(x)
                 a = a * x + a2                                 !
                 b = b * x + a                                  ! c = Q''(x) / 2
                 c = c * x + b                                  !
                 a = a * x + a1                                 ! d = Q'''(x) / 6
                 b = b * x + a                                  !
                 a = a * x + a0                                 !
                 y = a * d * d - b * c * d + b * b              ! y = H(x), usually < 0
                 z = 2 * d * (4 * a - b * d - c * c)            ! z = H'(x)

                 if (y > 0.0_wp) then                           ! does Newton start oscillating ?
                     oscillate = oscillate + 1                  ! increment oscillation counter
                     s = x                                      ! save upper bisection bound
                 else
                     u = x                                      ! save lower bisection bound
                 end if

                 y = y / z                                      ! Newton correction
                 x = x - y                                      ! new Newton root

                 bisection = oscillate > 2                      ! activate bisection
                 converged = abs (y) <= abs (x) * macheps       ! Newton convergence criterion

                 if (doPrint) write (*,wpformat) ' Newton H(x) root      = ',x

              end do

              if (bisection) then

                  t = u - s                                     ! initial bisection interval
                  do while (abs (t) > abs (x * macheps))        ! bisection iterates

                     a = x + a3                                 !
                     b = x + a                                  ! a = Q(x)
                     c = x + b                                  !
                     d = x + c                                  ! b = Q'(x)
                     a = a * x + a2                             !
                     b = b * x + a                              ! c = Q''(x) / 2
                     c = c * x + b                              !
                     a = a * x + a1                             ! d = Q'''(x) / 6
                     b = b * x + a                              !
                     a = a * x + a0                             !
                     y = a * d * d - b * c * d + b * b          ! y = H(x)

                     if (y > 0.0_wp) then                       !
                         s = x                                  !
                     else                                       ! keep bracket on root
                         u = x                                  !
                     end if                                     !

                     t = 0.5_wp * (u - s)                       ! new bisection interval
                     x = s + t                                  ! new bisection root

                     if (doPrint) write (*,wpformat) ' Bisection H(x) root   = ',x

                  end do
              end if

              if (doPrint) write (*,wpformat) ' ------------------------------------------------'

              a = x * k                                         ! 1st real component -> a
              b = - 0.5_wp * q3 - a                             ! 2nd real component -> b

              x = 4 * a + q3                                    ! Q'''(a)
              y = x + q3 + q3                                   !
              y = y * a + q2 + q2                               ! Q'(a)
              y = y * a + q1                                    !
              y = max (y / x, 0.0_wp)                           ! ensure Q'(a) / Q'''(a) >= 0
              x = 4 * b + q3                                    ! Q'''(b)
              z = x + q3 + q3                                   !
              z = z * b + q2 + q2                               ! Q'(b)
              z = z * b + q1                                    !
              z = max (z / x, 0.0_wp)                           ! ensure Q'(b) / Q'''(b) >= 0
              c = a * a                                         ! store a^2 for later
              d = b * b                                         ! store b^2 for later
              s = c + y                                         ! magnitude^2 of (a + iy) root
              t = d + z                                         ! magnitude^2 of (b + iz) root

              if (s > t) then                                   ! minimize imaginary error
                  c = sqrt (y)                                  ! 1st imaginary component -> c
                  d = sqrt (q0 / s - d)                         ! 2nd imaginary component -> d
              else
                  c = sqrt (q0 / t - c)                         ! 1st imaginary component -> c
                  d = sqrt (z)                                  ! 2nd imaginary component -> d
              end if

          else                                                  ! no bisection -> real components equal

              a = - 0.25_wp * q3                                ! 1st real component -> a
              b = a                                             ! 2nd real component -> b = a

              x = a + q3                                        !
              x = x * a + q2                                    ! Q(a)
              x = x * a + q1                                    !
              x = x * a + q0                                    !
              y = - 0.1875_wp * q3 * q3 + 0.5_wp * q2           ! Q''(a) / 2
              z = max (y * y - x, 0.0_wp)                       ! force discriminant to be >= 0
              z = sqrt (z)                                      ! square root of discriminant
              y = y + sign (z,y)                                ! larger magnitude root
              x = x / y                                         ! smaller magnitude root
              c = max (y, 0.0_wp)                               ! ensure root of biquadratic > 0
              d = max (x, 0.0_wp)                               ! ensure root of biquadratic > 0
              c = sqrt (c)                                      ! large magnitude imaginary component
              d = sqrt (d)                                      ! small magnitude imaginary component

          end if

          if (a > b) then

              root (1,Re) = a
              root (2,Re) = a
              root (3,Re) = b
              root (4,Re) = b
              root (1,Im) = c
              root (2,Im) = - c
              root (3,Im) = d
              root (4,Im) = - d

          else if (a < b) then

              root (1,Re) = b
              root (2,Re) = b
              root (3,Re) = a
              root (4,Re) = a
              root (1,Im) = d
              root (2,Im) = - d
              root (3,Im) = c
              root (4,Im) = - c

          else

              root (1,Re) = a
              root (2,Re) = a
              root (3,Re) = a
              root (4,Re) = a
              root (1,Im) = c
              root (2,Im) = - c
              root (3,Im) = d
              root (4,Im) = - d

          end if

      end if    ! # of real roots 'if'

  end select    ! quartic type select
!
!
!     ...Ready!
!
!
  return
end subroutine quarticRoots

end module Polynomial234RootSolvers


! $UWHPSC/codes/fortran/circles/circle_mod.f90
! Version where pi is a module variable.

module circle_mod

    implicit none
    real(kind=8) :: pi
    save

contains

    real(kind=8) function area(r)
        real(kind=8), intent(in) :: r
        area = pi * r**2
    end function area

    real(kind=8) function circumference(r)
        real(kind=8), intent(in) :: r
        circumference = 2.d0 * pi * r
    end function circumference

end module circle_mod


subroutine cum_simps(np,n,x,f,g)
  ! !INPUT/OUTPUT PARAMETERS:
  !   np : order of fitting polynomial (in,integer)
  !   n  : number of points (in,integer)
  !   x  : abscissa array (in,real(n))
  !   f  : function array (in,real(n))
  !   g  : integrated function (out,real(n))
  ! !DESCRIPTION:
  !   Calculates the integrals $g(x_i)$ of a function $f$ defined on a set of
  !   points $x_i$ as follows
  !   $$ g(x_i)=\int_0^{x_i} f(x)\,dx. $$
  !   This is performed by piecewise fitting the function to polynomials of order
  !   $n_p-1$ and performing the integrations analytically.
  !
  ! !REVISION HISTORY:
  !   Created May 2002 (JKD)
  !EOP
  !BOC
  implicit none
  ! arguments
  integer, intent(in) :: np
  integer, intent(in) :: n
  real(8), intent(in) :: x(n)
  real(8), intent(in) :: f(n)
  real(8), intent(out) :: g(n)
  ! local variables
  integer i,i0,npo2
  ! automatic arrays
  real(8) c(np)
  ! external functions
  real(8) polynom
  external polynom
  if (n.lt.2) then
     write(*,*)
     write(*,'("Error(fint): n < 2 : ",I8)') n
     write(*,*)
     stop
  end if
  if (np.lt.2) then
     write(*,*)
     write(*,'("Error(fint): np < 2 : ",I8)') np
     write(*,*)
     stop
  end if
  if (n.lt.np) then
     write(*,*)
     write(*,'("Error(fint): n < np : ",2I8)') n,np
     write(*,*)
     stop
  end if
  npo2=np/2
  g(1)=0.d0
  do i=2,n
     if (i.le.npo2) then
        i0=1
     else if (i.gt.n-npo2) then
        i0=n-np+1
     else
        i0=i-npo2
     end if
     g(i)=polynom(-1,np,x(i0),f(i0),c,x(i))+g(i0)
  end do
  return
end subroutine cum_simps
!EOC

real(8) function polynom(m,np,xa,ya,c,x)
  implicit none
  integer, intent(in) :: m
  integer, intent(in) :: np
  real(8), intent(in) :: xa(np)
  real(8), intent(in) :: ya(np)
  real(8), intent(out) :: c(np)
  real(8), intent(in) :: x
  ! !LOCAL VARIABLES:
  integer i,j
  real(8) x1,t1,sum
  if (np.le.0) then
     write(6,*)
     write(6,'("Error(polynom): np <= 0 : ",I8)') np
     write(6,*)
     print *, "ERROR: polynom", "np<=0"
  end if
  if (m.gt.np) then
     polynom=0.d0
     return
  end if
  x1=xa(1)
  ! find the polynomial coefficients in divided differences form
  c(:)=ya(:)
  do i=2,np
     do j=np,i,-1
        c(j)=(c(j)-c(j-1))/(xa(j)-xa(j+1-i))
     end do
  end do
  ! special case m=0
  if (m.eq.0) then
     sum=c(1)
     t1=1.d0
     do i=2,np
        t1=t1*(x-xa(i-1))
        sum=sum+c(i)*t1
     end do
     polynom=sum
     return
  end if
  ! convert to standard form
  do j=1,np-1
     do i=1,np-j
        c(np-i)=c(np-i)-(xa(np-i-j+1)-x1)*c(np-i+1)
     end do
  end do
  if (m.gt.0) then
     ! take the m'th derivative
     do j=1,m
        do i=m+1,np
           c(i)=c(i)*dble(i-j)
        end do
     end do
     t1=c(np)
     do i=np-1,m+1,-1
        t1=t1*(x-x1)+c(i)
     end do
     polynom=t1
  else
     ! find the integral
     t1=c(np)/dble(np)
     do i=np-1,1,-1
        t1=t1*(x-x1)+c(i)/dble(i)
     end do
     polynom=t1*(x-x1)
  end if
  return
end function polynom
!EOC


      subroutine taper(w,lb,p,sw,nt,io)
c***************************************
c  M.J. Hinich   Version: 8-22-94
c  Compute trancated cosine taper array
c=======================================
c   Input:
c    lb    Number of samples in frame
c    p     % of data series to be tapered (0.< p < 50.)
c    io    File number for error message
c   Output:
c    w     Cosine taper weights as a symmetric array
c    sw    mean sum of squares of the taper including the middle 1's
c    nt    Number of observations tapered on each end of window
c=======================================
      real w(lb)
      intent(in) lb,p,io
      intent(out) w,sw,nt
c***************************************
      pi=acos(-1.)
c  Return if p=0
      if(p<=0.) then
       return
      endif
      if(p<0..or.p>50.) then
       write(io,*) '* ERROR *  Improper % for tapering: ',p
       return
      endif
c-------
c  Compute number of values to be tapered on each end
      nt=nint(p*float(lb)/200.)
      if(nt>lb/4) then
       write(io,*) 'Taper size ',nt,' > lb/4. Increase data frame ',lb
       return
      endif
c  Taper weights and sum of squares sw
      sw=0.
      do k=1,nt
       w(k)=sin(pi*k/(2.*float(nt+1)))
       w(lb+1-k)=w(k)
       sw=sw+w(k)*w(k)
      enddo
      sw=(2.*sw+float(lb-2*nt))/float(lb)
c  Fill out w array
      do k=nt+1,lb-nt
       w(k)=1.
      enddo
c-------
      return
      end


! { dg-do run }
! { dg-options "-floop-nest-optimize" }

MODULE test
  IMPLICIT NONE
  TYPE subset_type
     INTEGER                                    :: ncon_tot
     REAL(KIND=8),DIMENSION(:,:),ALLOCATABLE   :: coeff
  END TYPE
CONTAINS
  SUBROUTINE foo(subset)
      TYPE(subset_type)                        :: subset
      INTEGER :: icon1
      DO icon1=1,subset%ncon_tot
       subset%coeff(:,icon1)=subset%coeff(:,icon1)/&
        SQRT(DOT_PRODUCT(subset%coeff(:,icon1),subset%coeff(:,icon1)))
      END DO
  END SUBROUTINE
END MODULE

USE test
    TYPE(subset_type)                        :: subset
    INTEGER, VOLATILE :: n1=7,n2=4
    ALLOCATE(subset%coeff(n1,n2))
    CALL RANDOM_NUMBER(subset%coeff)
    subset%coeff=subset%coeff-0.5
    subset%ncon_tot=n2
    CALL foo(subset)
    WRITE(6,*) MAXVAL(subset%coeff)
END


    MODULE random_multivariate_normal_mod
! .. Implicit None Statement ..
      IMPLICIT NONE
! ..
! .. Local Arrays ..
      REAL, ALLOCATABLE, SAVE :: param(:)
! ..
    CONTAINS

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

      SUBROUTINE random_multivariate_normal(x)
! .. Use Statements ..
        USE random_standard_normal_mod
! ..
! .. Implicit None Statement ..
        IMPLICIT NONE
! ..
! .. Array Arguments ..
        REAL, INTENT (OUT) :: x(:)
! ..
! .. Local Scalars ..
        REAL :: ae
        INTEGER :: i, icount, j, p
! ..
! .. Intrinsic Functions ..
        INTRINSIC ALLOCATED, INT, SIZE
! ..
! .. Local Arrays ..
        REAL, ALLOCATABLE :: work(:)
! ..
! .. Executable Statements ..

!----------------------------------------------------------------------
!     SUBROUTINE RANDOM_MULTIVARIATE_NORMAL(X)
!                              Arguments
!     X    <-- Vector deviate generated.
!                                             REAL X(P)
!                              Method
!     1) Generate P independent standard normal deviates - Ei ~ N(0,1)
!     2) Using Cholesky decomposition find A s.t. trans(A)*A = COVM
!     3) trans(A)E + MEANV ~ N(MEANV,COVM)
!______________________________________________________________________
        p = INT(param(1))

!    Allocate array work if necessary

        IF ( .NOT. ALLOCATED(work)) ALLOCATE (work(p))

        IF (SIZE(work)<p) THEN
          DEALLOCATE (work)
          ALLOCATE (work(p))
        END IF

!     Generate P independent normal deviates - WORK ~ N(0,1)

        DO i = 1, p
          work(i) = random_standard_normal()
        END DO
        DO i = 1, p

!     PARAM (P+2 : P*(P+3)/2 + 1) contains A, the Cholesky
!      decomposition of the desired covariance matrix.
!          trans(A)(1,1) = PARAM(P+2)
!          trans(A)(2,1) = PARAM(P+3)
!          trans(A)(2,2) = PARAM(P+2+P)
!          trans(A)(3,1) = PARAM(P+4)
!          trans(A)(3,2) = PARAM(P+3+P)
!          trans(A)(3,3) = PARAM(P+2-1+2P)  ...

!     trans(A)*WORK + MEANV ~ N(MEANV,COVM)

          icount = 0
          ae = 0.0
          DO j = 1, i
            icount = icount + j - 1
            ae = ae + param(i+(j-1)*p-icount+p+1)*work(j)
          END DO
          x(i) = ae + param(i+1)
        END DO
        RETURN

      END SUBROUTINE random_multivariate_normal

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

      SUBROUTINE set_random_multivariate_normal(meanv,covm,p)
! .. Implicit None Statement ..
        IMPLICIT NONE
! ..
! .. Scalar Arguments ..
        INTEGER :: p
! ..
! .. Array Arguments ..
        REAL :: covm(:,:)
        REAL, INTENT (IN) :: meanv(p)
! ..
! .. Local Scalars ..
        INTEGER :: dim1_covm, dim2_covm, i, icount, info, size_meanv
! ..
! .. Intrinsic Functions ..
        INTRINSIC SIZE
! ..
! .. Executable Statements ..

!**********************************************************************
!      SUBROUTINE set_random_multivariate_normal(meanv,covm,p,param)
!     JJV changed this routine to take leading dimension of COVM
!     JJV argument and pass it to SPOFA, making it easier to use
!     JJV if the COVM which is used is contained in a larger matrix
!     JJV and to make the routine more consistent with LINPACK.
!     JJV Changes are in comments, declarations, and the call to SPOFA.
!**********************************************************************
!     SUBROUTINE SETGMN( MEANV, COVM, DIM1_COVM, P, PARAM)
!            SET Generate Multivariate Normal random deviate
!                              Function
!      Places P, MEANV, and the Cholesky factoriztion of COVM
!      in PARAM for GENMN.
!                              Arguments
!     MEANV --> Mean vector of multivariate normal distribution.
!                                        REAL MEANV(P)
!     COVM   <--> (Input) Covariance   matrix    of  the  multivariate
!                 normal distribution.  This routine uses only the
!                 (1:P,1:P) slice of COVM, but needs to know DIM1_COVM.
!                 (Output) Destroyed on output
!                                        REAL COVM(DIM1_COVM,P)
!     P     --> Dimension of the normal, or length of MEANV.
!                                        INTEGER P
!**********************************************************************
        IF (p<=0) THEN
          WRITE (*,*) 'P nonpositive in SET_RANDOM_MULTIVARIATE_NORMAL'
          WRITE (*,*) 'Value of P: ', p
          STOP 'P nonpositive in SET_RANDOM_MULTIVARIATE_NORMAL'
        END IF

        dim1_covm = SIZE(covm,dim=1)
        dim2_covm = SIZE(covm,dim=2)

        IF ((dim1_covm<p) .OR. (dim2_covm<p)) THEN
          WRITE (*,90000) p
90000     FORMAT (' Error in routine SET_RANDOM_MULTIVARIATE_NORMAL'/ &
            ' Dimension of multivariate normal input as: ',I4/)
          WRITE (*,90100) dim1_covm, dim2_covm, p
90100     FORMAT (' At least one dimension of argument covm too small:'/ &
            ' Dimensions are: ( ',I4,',',I4,' )'/ &
            ' Each dimension should be at least: ',I4)
        END IF

        size_meanv = SIZE(meanv)

        IF (size_meanv<p) THEN
          WRITE (*,90000) p
          WRITE (*,90200) size_meanv, p
90200     FORMAT (' Size of argument meanv is too small: '/ &
            ' The size is: ',I4/' It should be at least: ',I4)
        END IF

        param(1) = p

!     PUT P AND MEANV INTO PARAM

        param(2:p+1) = meanv(:p)

!      Cholesky decomposition to find A s.t. trans(A)*(A) = COVM

        CALL spofa(covm,dim1_covm,p,info)
        IF (info/=0) THEN
          WRITE (*,*) ' COVM not positive definite in SETGMN'
          STOP ' COVM not positive definite in SETGMN'
        END IF

        icount = p + 1

!     PUT UPPER HALF OF A, WHICH IS NOW THE CHOLESKY FACTOR, INTO PARAM
!          COVM(1,1) = PARAM(P+2)
!          COVM(1,2) = PARAM(P+3)
!                    :
!          COVM(1,P) = PARAM(2P+1)
!          COVM(2,2) = PARAM(2P+2)  ...

        DO i = 1, p
          IF (p-i+1>0) THEN
            param(icount+1:p-i+1+icount) = covm(i,i:p)
            icount = p - i + 1 + icount
          END IF
        END DO
        RETURN

      CONTAINS

!.....................................................................

        FUNCTION sdot(n,sx,incx,sy,incy)
! .. Implicit None Statement ..
          IMPLICIT NONE
! ..
! .. Function Return Value ..
          REAL :: sdot
! ..
! .. Scalar Arguments ..
          INTEGER, INTENT (IN) :: incx, incy, n
! ..
! .. Array Arguments ..
          REAL, INTENT (IN) :: sx(1), sy(1)
! ..
! .. Local Scalars ..
          REAL :: stemp
          INTEGER :: ix, iy, m, mp1
! ..
! .. Intrinsic Functions ..
          INTRINSIC DOT_PRODUCT, MOD
! ..
! .. Executable Statements ..

!-----------------------------------------------
          stemp = 0.0E0
          sdot = 0.0E0
          IF (n<=0) RETURN
          IF (incx/=1 .OR. incy/=1) THEN
            ix = 1
            iy = 1
            IF (incx<0) ix = ((-n)+1)*incx + 1
            IF (incy<0) iy = ((-n)+1)*incy + 1
            stemp = DOT_PRODUCT(sx(ix:(n-1)*incx+ix:incx),sy(iy:(n- &
              1)*incy+iy:incy))
            sdot = stemp
            RETURN
          END IF

          m = MOD(n,5)
          IF (m==0) GO TO 10
          stemp = DOT_PRODUCT(sx(:m),sy(:m))
          IF (n<5) GO TO 20
10        CONTINUE
          mp1 = m + 1
          stemp = stemp + DOT_PRODUCT(sx(mp1:((n-mp1+5)/5)*5-1+mp1),sy( &
            mp1:((n-mp1+5)/5)*5-1+mp1))
20        CONTINUE
          sdot = stemp
          RETURN

        END FUNCTION sdot

!.....................................................................

        SUBROUTINE spofa(a,lda,n,info)
! .. Implicit None Statement ..
          IMPLICIT NONE
! ..
! .. Scalar Arguments ..
          INTEGER, INTENT (OUT) :: info
          INTEGER, INTENT (IN) :: lda, n
! ..
! .. Array Arguments ..
          REAL :: a(lda,1)
! ..
! .. Local Scalars ..
          REAL :: s, t
          INTEGER :: j, jm1, k
! ..
! .. Intrinsic Functions ..
          INTRINSIC SQRT
! ..
! .. Executable Statements ..

!**********************************************************************
!     SPOFA FACTORS A REAL SYMMETRIC POSITIVE DEFINITE MATRIX.
!     SPOFA IS USUALLY CALLED BY SPOCO, BUT IT CAN BE CALLED
!     DIRECTLY WITH A SAVING IN TIME IF  RCOND  IS NOT NEEDED.
!     (TIME FOR SPOCO) = (1 + 18/N)*(TIME FOR SPOFA) .
!     ON ENTRY
!        A       REAL(LDA, N)
!                THE SYMMETRIC MATRIX TO BE FACTORED.  ONLY THE
!                DIAGONAL AND UPPER TRIANGLE ARE USED.
!        LDA     INTEGER
!                THE LEADING DIMENSION OF THE ARRAY  A .
!        N       INTEGER
!                THE ORDER OF THE MATRIX  A .
!     ON RETURN
!        A       AN UPPER TRIANGULAR MATRIX  R  SO THAT  A = TRANS(R)*R
!                WHERE  TRANS(R)  IS THE TRANSPOSE.
!                THE STRICT LOWER TRIANGLE IS UNALTERED.
!                IF  INFO .NE. 0 , THE FACTORIZATION IS NOT COMPLETE.
!        INFO    INTEGER
!                = 0  FOR NORMAL RETURN.
!                = K  SIGNALS AN ERROR CONDITION.  THE LEADING MINOR
!                     OF ORDER  K  IS NOT POSITIVE DEFINITE.
!     LINPACK.  THIS VERSION DATED 08/14/78 .
!     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
!     SUBROUTINES AND FUNCTIONS
!     BLAS SDOT
!     FORTRAN SQRT
!     INTERNAL VARIABLES
!     BEGIN BLOCK WITH ...EXITS TO 40
!**********************************************************************
          DO j = 1, n
            info = j
            s = 0.0E0
            jm1 = j - 1
            IF (jm1>=1) THEN
              DO k = 1, jm1
                t = a(k,j) - sdot(k-1,a(1,k),1,a(1,j),1)
                t = t/a(k,k)
                a(k,j) = t
                s = s + t*t
              END DO
            END IF
            s = a(j,j) - s
            IF (s<=0.0E0) GO TO 10
            a(j,j) = SQRT(s)
          END DO
          info = 0
10        CONTINUE
          RETURN

        END SUBROUTINE spofa

!.....................................................................

      END SUBROUTINE set_random_multivariate_normal

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

    END MODULE random_multivariate_normal_mod


program compute_distance
    use, intrinsic :: iso_fortran_env, only : error_unit, DP => REAL64
    implicit none
    real(kind=DP), parameter :: PI = acos(-1.0_DP), &
                                PHI = 0.5_DP*(1.0_DP + sqrt(5.0_DP)), &
                                B_REC = 0.5_DP*PI/log(PHI), &
                                DELTA_R = 1e-3_DP
    integer :: nr_values, i
    real(kind=DP) :: r, theta, x, y, distance, x_old, y_old

    call get_arguments(nr_values)

    distance = 0.0_DP
    r = 1.0_DP
    x_old = 1.0_DP
    y_old = 0.0_DP
    do i = 1, nr_values
        theta = golden_spiral(r)
        x = r*cos(theta)
        y = r*sin(theta)
        distance = distance + sqrt((x_old - x)**2 + (y_old - y)**2)
        x_old = x
        y_old = y
        r = r + DELTA_R
    end do

    print '(A, E27.15)', 'distance = ', distance

contains

    subroutine get_arguments(nr_values)
        implicit none
        integer, intent(out) :: nr_values
        character(len=128) :: buffer, msg
        integer :: istat

        if (command_argument_count() /= 1) then
            write (unit=error_unit, fmt='(A)') &
                'error: expecting number of values as argument'
            stop 1
        end if

        call get_command_argument(1, buffer)
        read (buffer, fmt=*, iomsg=msg, iostat=istat) nr_values
        if (istat /= 0) then
            write (unit=error_unit, fmt='(2A)') 'error: ', trim(msg)
            stop 2
        end if
    end subroutine get_arguments

    function golden_spiral(r) result(theta)
        implicit none
        real(kind=DP), value :: r
        real(kind=DP) :: theta
        theta = B_REC*log(r)
    end function golden_spiral

end program compute_distance


FUNCTION bessi1_s(x)
  use mo_kind
  use mo_nrutil, ONLY : poly
  IMPLICIT NONE
  REAL(SP), INTENT(IN) :: x
  REAL(SP) :: bessi1_s
  REAL(SP) :: ax
  REAL(sp), DIMENSION(7) :: p = (/0.5_sp,0.87890594_sp,&
       0.51498869_sp,0.15084934_sp,0.2658733e-1_sp,&
       0.301532e-2_sp,0.32411e-3_sp/)
  REAL(sp), DIMENSION(9) :: q = (/0.39894228_sp,-0.3988024e-1_sp,&
       -0.362018e-2_sp,0.163801e-2_sp,-0.1031555e-1_sp,&
       0.2282967e-1_sp,-0.2895312e-1_sp,0.1787654e-1_sp,&
       -0.420059e-2_sp/)
  ax=abs(x)
  if (ax < 3.75_sp) then
     bessi1_s=ax*poly(real((x/3.75_sp)**2,sp),p)
  else
     bessi1_s=(exp(ax)/sqrt(ax))*poly(real(3.75_sp/ax,sp),q)
  end if
  if (x < 0.0_sp) bessi1_s=-bessi1_s
END FUNCTION bessi1_s

FUNCTION bessi1_v(x)
  use mo_kind
  use mo_nrutil, ONLY : poly
  IMPLICIT NONE
  REAL(SP), DIMENSION(:), INTENT(IN) :: x
  REAL(SP), DIMENSION(size(x)) :: bessi1_v
  REAL(SP), DIMENSION(size(x)) :: ax
  REAL(sp), DIMENSION(size(x)) :: y
  LOGICAL(LGT), DIMENSION(size(x)) :: mask
  REAL(sp), DIMENSION(7) :: p = (/0.5_sp,0.87890594_sp,&
       0.51498869_sp,0.15084934_sp,0.2658733e-1_sp,&
       0.301532e-2_sp,0.32411e-3_sp/)
  REAL(sp), DIMENSION(9) :: q = (/0.39894228_sp,-0.3988024e-1_sp,&
       -0.362018e-2_sp,0.163801e-2_sp,-0.1031555e-1_sp,&
       0.2282967e-1_sp,-0.2895312e-1_sp,0.1787654e-1_sp,&
       -0.420059e-2_sp/)
  ax=abs(x)
  mask = (ax < 3.75_sp)
  where (mask)
     bessi1_v=ax*poly(real((x/3.75_sp)**2,sp),p,mask)
  elsewhere
     y=3.75_sp/ax
     bessi1_v=(exp(ax)/sqrt(ax))*poly(real(y,sp),q,.not. mask)
  end where
  where (x < 0.0_sp) bessi1_v=-bessi1_v
END FUNCTION bessi1_v

FUNCTION dbessi1_s(x)
  use mo_kind
  use mo_nrutil, ONLY : poly
  IMPLICIT NONE
  REAL(DP), INTENT(IN) :: x
  REAL(DP) :: dbessi1_s
  REAL(DP) :: ax
  REAL(DP), DIMENSION(7) :: p = (/0.5_dp,0.87890594_dp,&
       0.51498869_dp,0.15084934_dp,0.2658733e-1_dp,&
       0.301532e-2_dp,0.32411e-3_dp/)
  REAL(DP), DIMENSION(9) :: q = (/0.39894228_dp,-0.3988024e-1_dp,&
       -0.362018e-2_dp,0.163801e-2_dp,-0.1031555e-1_dp,&
       0.2282967e-1_dp,-0.2895312e-1_dp,0.1787654e-1_dp,&
       -0.420059e-2_dp/)
  ax=abs(x)
  if (ax < 3.75_dp) then
     dbessi1_s=ax*poly(real((x/3.75_dp)**2,dp),p)
  else
     dbessi1_s=(exp(ax)/sqrt(ax))*poly(real(3.75_dp/ax,dp),q)
  end if
  if (x < 0.0_dp) dbessi1_s=-dbessi1_s
END FUNCTION dbessi1_s

FUNCTION dbessi1_v(x)
  use mo_kind
  use mo_nrutil, ONLY : poly
  IMPLICIT NONE
  REAL(DP), DIMENSION(:), INTENT(IN) :: x
  REAL(DP), DIMENSION(size(x)) :: dbessi1_v
  REAL(DP), DIMENSION(size(x)) :: ax
  REAL(DP), DIMENSION(size(x)) :: y
  LOGICAL(LGT), DIMENSION(size(x)) :: mask
  REAL(DP), DIMENSION(7) :: p = (/0.5_dp,0.87890594_dp,&
       0.51498869_dp,0.15084934_dp,0.2658733e-1_dp,&
       0.301532e-2_dp,0.32411e-3_dp/)
  REAL(DP), DIMENSION(9) :: q = (/0.39894228_dp,-0.3988024e-1_dp,&
       -0.362018e-2_dp,0.163801e-2_dp,-0.1031555e-1_dp,&
       0.2282967e-1_dp,-0.2895312e-1_dp,0.1787654e-1_dp,&
       -0.420059e-2_dp/)
  ax=abs(x)
  where (ax .gt. 709._dp)
     ax = 709._dp
  end where
  mask = (ax < 3.75_dp)
  where (mask)
     dbessi1_v=ax*poly(real((x/3.75_dp)**2,dp),p,mask)
  elsewhere
     y=3.75_dp/ax
     dbessi1_v=(exp(ax)/sqrt(ax))*poly(real(y,dp),q,.not. mask)
  end where
  where (x < 0.0_dp) dbessi1_v=-dbessi1_v
END FUNCTION dbessi1_v


! save this program as file f.f08
! gnu-linux command to  build and test
! $ a=./f && gfortran -Wall -std=f2008 $a.f08 -o $a && echo -e 2\\n5\\n\\n | $a

! -*- mode: compilation; default-directory: "/tmp/" -*-
! Compilation started at Fri Apr  4 23:20:27
!
! a=./f && gfortran -Wall -std=f2008 $a.f08 -o $a && echo -e 2\\n8\\ny\\n | $a
! Enter the number of terms to sum: Show the the first how many terms of the sequence?   Accept this initial sequence (y/n)?
!            1           1
!            1           1           2           3           5           8          13          21
!
! Compilation finished at Fri Apr  4 23:20:27

program f
  implicit none
  integer :: n, terms
  integer, allocatable, dimension(:) :: sequence
  integer :: i
  character :: answer
  write(6,'(a)',advance='no')'Enter the number of terms to sum: '
  read(5,*) n
  if ((n < 2) .or. (29 < n)) stop'Unreasonable!  Exit.'
  write(6,'(a)',advance='no')'Show the the first how many terms of the sequence?  '
  read(5,*) terms
  if (terms < 1) stop'Lazy programmer has not implemented backward sequences.'
  n = min(n, terms)
  allocate(sequence(1:terms))
  sequence(1) = 1
  do i = 0, n - 2
     sequence(i+2) = 2**i
  end do
  write(6,*)'Accept this initial sequence (y/n)?'
  write(6,*) sequence(:n)
  read(5,*) answer
  if (answer .eq. 'n') then
     write(6,*) 'Fine.  Enter the initial terms.'
     do i=1, n
        write(6, '(i2,a2)', advance = 'no') i, ': '
        read(5, *) sequence(i)
     end do
  end if
  call nacci(n, sequence)
  write(6,*) sequence(:terms)
  deallocate(sequence)

contains

    subroutine nacci(n, s)
      ! nacci =:  (] , +/@{.)^:(-@#@]`(-#)`])
      integer, intent(in) :: n
      integer, intent(inout), dimension(:) :: s
      integer :: i, terms
      terms = size(s)
!      do i = n+1, terms
 !        s(i) = sum(s(i-n:i-1))
  !    end do
      i = n+1
      if (n+1 .le. terms) s(i) = sum(s(i-n:i-1))
      do i = n + 2, terms
         s(i) = 2*s(i-1) - s(i-(n+1))
      end do
    end subroutine nacci
end program f


       function rotation_2(phi,i)
        implicit none

        real(kind=8), intent(in)     :: phi
        integer,      intent(in)     :: i
        real(kind=8), dimension(2,2) :: R
        type(Tensor2)                :: rotation_2

        R = reshape( (/cos(phi), sin(phi),
     *                -sin(phi), cos(phi)/), (/2,2/)  )

        rotation_2 = identity2(rotation_2)

        if (i == 1) then
         rotation_2%ab(2:3,2:3) = R
        else if (i == 3) then
         rotation_2%ab(1:2,1:2) = R
        else !i == 2
         rotation_2%ab(1,1) = R(1,1)
         rotation_2%ab(3,3) = R(2,2)
         rotation_2%ab(1,3) = R(1,2)
         rotation_2%ab(3,1) = R(2,1)
        end if

       end function rotation_2


module linalg
    implicit none

    integer,parameter   :: dp = kind(1.d0)

    interface GAssembly
        procedure   GAssembly1
        procedure   GAssembly2
        procedure   GAssembly3
    end interface

    contains

    !-------- Matrix inversion --------!
    function inv(A) result(Ainv)
        implicit none

        complex(dp),intent(in)       :: A(:,:)
        complex(dp)                  :: Ainv(size(A,1),size(A,2))

        integer                      :: s(2), nrows, ncols
        integer                      :: lda, lwork, info

        integer                      :: ipiv(size(A,1))
        complex(dp)                  :: work(size(A,1))

        external zgetrf
        external zgetri

        s = shape(A)
        nrows = s(1)
        ncols = s(2)
        lda = max(1,nrows)
        lwork = max(1,nrows)

        Ainv = A
        call zgetrf(nrows,ncols,Ainv,lda,ipiv,info)

        if (info .ne. 0) then
            print *, "Error in the LU factorization!"
        end if

        call zgetri(nrows,Ainv,lda,ipiv,work,lwork,info)

        if (info .ne. 0) then
            print *,"Error in the matrix inversion!"
        end if

    end function

    !------- Solve Linear System -------!
    function solve(A,B) result(X)
        implicit none

        complex(dp),intent(in)   :: A(:,:), B(:,:)
        complex(dp)              :: X(size(B,1),size(B,2))
        complex(dp)              :: Y(size(A,1),size(A,2))

        integer                  :: s(2), nra, nrb, nca, ncb
        integer                  :: lda, ldb, info

        integer                  :: ipiv(size(A,1))

        external zgesv

        s = shape(A)
        nra = s(1)
        nca = s(2)
        s = shape(B)
        nrb = s(1)
        ncb = s(2)
        lda = max(1,nra)
        ldb = max(1,nrb)

        X = B
        Y = A
        call zgesv(nra,ncb,Y,lda,ipiv,X,ldb,info)

        if (info .ne. 0) then
            print *,"Error in the linear system solver!"
        end if
    end function

    !---------------------------------------------------!
    ! Triple Matrix Product                             !
    !                                                   !
    ! D = A.B.C                                         !
    !                                                   !
    ! A: Complex                                        !
    ! B: Real                                           !
    ! C: Complex                                        !
    !---------------------------------------------------!
    function tri(A,B,C) result(D)
        implicit none

        complex(dp),intent(in)     :: A(:,:)
        complex(dp),intent(in)     :: B(:,:)
        complex(dp),intent(in)     :: C(:,:)
        complex(dp)                :: D(size(A,1),size(C,2))

        ! Hu & Shing matrix chain multiplication
        ! [m] ---B--- [k]
        !  |           |
        !  A           C
        !  |           |
        ! [n]---ABC-- [l]

        integer :: n,m,k,l
        integer :: s(2)

        s = shape(A)
        n = s(1)
        m = s(2)
        s = shape(C)
        k = s(1)
        l = s(2)

        if (n*m*k + n*k*l < m*k*l + n*m*l) then
            D = matmul(matmul(A,B),C)
        else
            D = matmul(A,matmul(B,C))
        end if
    end function

    !---------------------------------------------------!
    ! For a diagonal matrix B:                          !
    ! C = B.A.B+ if invert = false                      !
    ! C = B+.A.B if invert = true                       !
    !---------------------------------------------------!
    function d2tri(A,B,invert) result(C)
        use omp_lib
        implicit none

        complex(dp),intent(in)  :: A(:,:)
        complex(dp),intent(in)  :: B(:,:)
        logical,intent(in)      :: invert
        complex(dp)             :: C(size(A,1),size(A,2))

        integer     :: i,j
        complex(dp) :: p

        !$OMP PARALLEL DO
        do j = 1,size(B,1)
            p = B(j,j)
            if (invert .eqv. .false.) then
                p = conjg(p)
            end if
            do i = 1,size(A,1)
                C(i,j) = p*A(i,j)
                if (invert .eqv. .false.) then
                    C(i,j) = C(i,j)*B(i,i)
                else
                    C(i,j) = C(i,j)*conjg(B(i,i))
                end if
            end do
        end do
        !$OMP END PARALLEL DO
    end function

    !---------------------------------------------------!
    ! G = [(E+i.eta).I - H - S1 - S2]^(-1)                    !
    !---------------------------------------------------!
    function GAssembly3(E,H,S1,S2,eta) result(G)
        implicit none

        real,intent(in)         :: E
        complex(dp),intent(in)  :: H(:,:)
        complex(dp),intent(in)  :: S1(:,:)
        complex(dp),intent(in)  :: S2(:,:)
        real(dp),intent(in)     :: eta
        complex(dp)             :: G(size(H,1),size(H,2))

        integer             :: i

        ! G = (E+i.eta).I - H - S1 - S2
        G = -(H + S1 + S2)
        do i = 1,size(H,2)
            G(i,i) = G(i,i) + E + cmplx(0,1)*eta
        end do

        G = inv(G)
    end function

    !---------------------------------------------------!
    ! G = [(E+i.eta).I - H - S]^(-1)                    !
    !---------------------------------------------------!
    function GAssembly2(E,H,S,eta) result(G)
        implicit none

        real,intent(in)         :: E
        complex(dp),intent(in)  :: H(:,:)
        complex(dp),intent(in)  :: S(:,:)
        real(dp),intent(in)     :: eta
        complex(dp)             :: G(size(H,1),size(H,2))

        integer             :: i

        ! G = (E+i.eta).I - H - S
        G = -(H + S)
        do i = 1,size(H,2)
            G(i,i) = G(i,i) + E + cmplx(0,1)*eta
        end do

        G = inv(G)
    end function

    !---------------------------------------------------!
    ! G = [(E+i.eta).I - H]^(-1)                        !
    !---------------------------------------------------!
    function GAssembly1(E,H,eta) result(G)
        implicit none

        real,intent(in)         :: E
        complex(dp),intent(in)  :: H(:,:)
        real(dp),intent(in)     :: eta
        complex(dp)             :: G(size(H,1),size(H,2))

        integer             :: i

        ! G = (E+i.eta).I - H
        G = -H
        do i = 1,size(H,2)
            G(i,i) = G(i,i) + E + cmplx(0,1)*eta
        end do

        G = inv(G)
    end function

end module


      FUNCTION bico(n,k)
      INTEGER k,n
      REAL bico
CU    USES factln
      REAL factln
      bico=nint(exp(factln(n)-factln(k)-factln(n-k)))
      return
      END

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


C polygraf.for:
C
C  Graphs the polynomial  (x-x0)(x-x1)...(x-xn) where xi are equally-spaced.
C
C  link with FUNGRAF,COREGFX
C
C  This is the well-known "error polynomial:" the error in interpolation
C  of a function by a polynomial of order n is bounded by a limit
C  proportional to this polynomial.  The lessons to learn are: 1) see
C  how it takes off outside [-1,1] illustrating the hazard of using
C  polynomials for extrapolation, and 2) observe that within [-1,1] it
C  has smallest amplitude near x=0, in contrast to the Chebyshev polynomials
C  which are well-balanced over the whole interval [-1,1].
C
C  NOTE: If your compiler does not accept identifiers over 6 chars
C  long, all such identifiers herein can be safely truncated to 6
C  characters by chopping off their ends.
C
C This program is associated with the CORE graphics package.  See
C the CORE documentation for explanation of the graphics routines.
C
C                         CORE Version 1.1
C                          January, 1990
C
C Robert Moniot                 NOTE: This is free software.  It may
C Fordham University            be freely copied so long as it is not
C College at Lincoln Center     being directly sold for profit.  No
C New York, NY 10023            guarantees accompany the software.
C                               If you find bugs, please notify me,
C MONIOT@FORDMULC.BITNET        and I will try to fix them when I get
C                               the chance.  This does not apply to
C                               problems which may arise in porting
C                               the code to non-VMS systems.
      parameter (MAX=20)
      external poly,cheby
      real poly,cheby, x(0:MAX)
      common /polyn/ n
      character *4 namdev
      character choice
C
C  pick up the standard logical unit numbers.
C
      call inqgfu(igrafu)
      call inqeru(mesgu)
      call inqinu(inptu)
C
C       Give instructions to user.
C
      write(mesgu, *)
     $      'This program will graph either the error polynomial'
      write(mesgu, *) 'or the Chebyshev polynomial.  Which do you want?'
      write(mesgu, *) 'Enter E for error poly and C for Chebyshev'
      read(inptu,1000) choice
1000  format(a1)
      if(choice .eq. 'e') choice = 'E'
      write(mesgu,*)
      if(choice .eq. 'E') then
      write(mesgu,*)
     $ 'Graph of the polynomial psi(x)=x(x-h)(x-2h)...(x-nh)'
      write(mesgu,*)
     $ 'where nh=1.  The error in interpolation by a polynomial'
      write(mesgu,*)
     $ 'of order n is bounded by a term proportional to psi(x).'
      else
      write(mesgu,*)
     $'Graph of the Chebyshev polynomial.  The family of Chebyshev'
      write(mesgu,*)
     $'polynomials is well suited to approximation of functions. The'
      write(mesgu,*)
     $'zeroes of a Chebyshev polynomial are not equally spaced, but'
      write(mesgu,*)
     $'chosen so that the polynomial oscillates between +1 and -1 on'
      write(mesgu,*)
     $'the interval [-1,1].'

      endif

      call grafinstrs
C
C       Get device from user: graph can be made on various types.
C
      call grafdev(namdev)
      call getspd(igrafu,ibaud)
C

1     continue
      write(mesgu, *) 'Enter order n (-1 to stop)'
      read(inptu,*) n
      if(n .lt. 0) stop
      if(n .gt. MAX) then
        write(mesgu, *) 'Enter n between 0 and',MAX
        goto 1
      endif

      if(n .ne. 0) then
        h = 2.0/n
      else
        h = 1.0
      endif

      do 10 i=0,n
        x(i) = -1.0 + i*h
10    continue

      xmax = 1.0+h
      xmin = -1.0-h
      if(choice .eq. 'E') then
          ymax = abs(poly(1.0 - 0.5*h,x))*1.1
      else
          ymax = abs(cheby(1.0 + 0.1*h,x))*1.1
      endif
      if(n .eq. 0) ymax = ymax*1.5
      ymin = -ymax
C
C       Draw the graph
C
      call startgraf(xmin,xmax,ymin,ymax,namdev,ibaud)

      if(choice .eq. 'E') then
          call fungraf(poly,x,1)
          call legend('Error Polynomial')
      else
          call fungraf(cheby,x,1)
          call legend('Chebyshev Polynomial')
      endif

      call endgraf
      goto 1
      end
C
C       Function to be graphed is defined here.
C
      function poly(x,p)
      common /polyn/ n
      real p(1)
C
      poly = 1.0
      do 10 i=0,n
        poly = poly * (x - p(i+1))
10    continue
      return
      end
C
C  Chebyshev polynomial computed here.  Uses the recurrence formula:
C
C      T  (x) = 2*x*T (x) - T  (x)
C     n+1            n       n-1
C
      function cheby(x,p)
      common /polyn/ n
      real p(1)
C

      if(n .eq. 0) then
          cheby = 1.0
          return
      else
          t1 = 1.0
          cheby = x
          do 10 i=2,n
        t0 = t1
        t1 = cheby
        cheby = 2.0*x*t1 - t0
10        continue
      endif
      return
      end


module sort
  !! Contains functions for sorting vector data sets

  implicit none

contains

  pure subroutine insertion_sort(S)
    !! An unconditionally stable, adaptive sorting algorithm with low overhead and /(O\left(n^2\)/) worst-case time. This algorithm is ideal when the data set is nearly sorted or when the data set's range is small.

    real, intent(in out) :: S(:)
    real :: tmp
    integer :: l, u, i, j

    l = lbound(S,1); u = ubound(S,1)

    do i = l+1, u
       j = i - 1
       tmp = S(i)
       do while (j >= l .and. S(j) > tmp)
          S(j+1) = S(j)
          j = j - 1
       end do
       S(j+1) = tmp
    end do
  end subroutine insertion_sort

  pure subroutine selection_sort(S)
    !! Conditionally stable, /(\Theta\left(n^2\right)/) comparisons but only /(\Theta\left(n\right)) swaps. Generally considered to have poor performance, but may be the algorithm of choice if the cost of swapping is expensive.

    real, allocatable, intent(in out) :: S(:)
    real :: tmp
    integer :: l, u, i, j, k

    l = lbound(S,1); u = ubound(S,1)

    do i = l, u
       k = i
       tmp = S(i)
       do j = l+1, u
          if (S(j) < S(k)) k = j
       end do
       S(i) = S(k)
       S(k) = tmp
    end do

  end subroutine selection_sort

end module sort


      subroutine resid_dph(ctfmp,n_K,n_alpha,n_beta,n_divbeta,n_phi,np1_
     &K,np1_alpha,np1_beta,np1_divbeta,np1_phi,x,Nx,ht,hx,myzero,zepsdis
     &,phys_bdy,res)
      implicit none
      integer i
      integer Nx
      real*8 ht
      real*8 hx
      real*8 myzero
      real*8 zepsdis
      real*8 ctfmp(Nx)
      real*8 n_K(Nx)
      real*8 n_alpha(Nx)
      real*8 n_beta(Nx)
      real*8 n_divbeta(Nx)
      real*8 n_phi(Nx)
      real*8 np1_K(Nx)
      real*8 np1_alpha(Nx)
      real*8 np1_beta(Nx)
      real*8 np1_divbeta(Nx)
      real*8 np1_phi(Nx)
      real*8 x(Nx)
      integer phys_bdy(2)
      real*8 res
      real*8 qb
      res = 0.0D0
      if (phys_bdy(1) .eq. 1) then
      do i=1, 1, 1
      qb = -0.5000000000000000D0 * (0.3D1 * np1_phi(i) - 0.4D1 * np1_phi
     #(i + 1) + np1_phi(i + 2)) / hx
      res = res + qb**2
      end do
      endif
      if (phys_bdy(1) .eq. 1) then
      do i=2, 2, 1
      qb = (-0.1D1 * n_phi(i) + np1_phi(i)) / ht + 0.2500000000000000D0
     #/ ctfmp(i) * (np1_phi(i - 1) - 0.1D1 * np1_phi(i + 1)) / hx * np1_
     #beta(i) + 0.8333333333333333D-1 * np1_alpha(i) * np1_K(i) - 0.8333
     #333333333333D-1 * np1_divbeta(i) + 0.2500000000000000D0 / ctfmp(i)
     # * (n_phi(i - 1) - 0.1D1 * n_phi(i + 1)) / hx * n_beta(i) + 0.8333
     #333333333333D-1 * n_alpha(i) * n_K(i) - 0.8333333333333333D-1 * n_
     #divbeta(i) + 0.3125000000000000D-1 * zepsdis / ht * (0.7D1 * np1_p
     #hi(i) + np1_phi(i + 2) - 0.4D1 * np1_phi(i + 1) - 0.4D1 * np1_phi(
     #i - 1)) + 0.3125000000000000D-1 * zepsdis / ht * (0.7D1 * n_phi(i)
     # + n_phi(i + 2) - 0.4D1 * n_phi(i + 1) - 0.4D1 * n_phi(i - 1))
      res = res + qb**2
      end do
      endif
      do i=3, Nx-2, 1
      qb = (-0.1D1 * n_phi(i) + np1_phi(i)) / ht + 0.2500000000000000D0
     #/ ctfmp(i) * (np1_phi(i - 1) - 0.1D1 * np1_phi(i + 1)) / hx * np1_
     #beta(i) + 0.8333333333333333D-1 * np1_alpha(i) * np1_K(i) - 0.8333
     #333333333333D-1 * np1_divbeta(i) + 0.2500000000000000D0 / ctfmp(i)
     # * (n_phi(i - 1) - 0.1D1 * n_phi(i + 1)) / hx * n_beta(i) + 0.8333
     #333333333333D-1 * n_alpha(i) * n_K(i) - 0.8333333333333333D-1 * n_
     #divbeta(i) + 0.3125000000000000D-1 * zepsdis / ht * (0.6D1 * np1_p
     #hi(i) + np1_phi(i + 2) + np1_phi(i - 2) - 0.4D1 * np1_phi(i + 1) -
     # 0.4D1 * np1_phi(i - 1)) + 0.3125000000000000D-1 * zepsdis / ht *
     #(0.6D1 * n_phi(i) + n_phi(i + 2) + n_phi(i - 2) - 0.4D1 * n_phi(i
     #+ 1) - 0.4D1 * n_phi(i - 1))
      res = res + qb**2
      end do
      do i=Nx-1, Nx-1, 1
      qb = (-0.1D1 * n_phi(i) + np1_phi(i)) / ht + 0.2500000000000000D0
     #/ ctfmp(i) * (np1_phi(i - 1) - 0.1D1 * np1_phi(i + 1)) / hx * np1_
     #beta(i) + 0.8333333333333333D-1 * np1_alpha(i) * np1_K(i) - 0.8333
     #333333333333D-1 * np1_divbeta(i) + 0.2500000000000000D0 / ctfmp(i)
     # * (n_phi(i - 1) - 0.1D1 * n_phi(i + 1)) / hx * n_beta(i) + 0.8333
     #333333333333D-1 * n_alpha(i) * n_K(i) - 0.8333333333333333D-1 * n_
     #divbeta(i)
      res = res + qb**2
      end do
      if (phys_bdy(2) .eq. 1) then
      do i=Nx, Nx, 1
      qb = (-0.1D1 * n_phi(i) + np1_phi(i)) / ht - 0.1D1 * myzero * x(i)
      res = res + qb**2
      end do
      endif
      res = sqrt(res/(1*Nx))
      END


!! implements calculation:
!! $$ \pi = \int^1_{-1} \frac{dx}{\sqrt{1-x^2}}

use, intrinsic:: iso_fortran_env, only: dp=>real64, int64, stderr=>error_unit
implicit none

integer, parameter :: wp = dp
real(wp), parameter :: x0 = -1.0_wp, x1 = 1.0_wp
real(wp), parameter :: pi = 4._wp*atan(1.0_wp)
real(wp) :: psum[*]  ! this is a scalar coarray
integer(int64) :: rate,tic,toc
real(wp) :: f,x,telaps, dx
integer :: i, stat, im, Ni
character(16) :: cbuf

psum = 0._wp

if (command_argument_count() > 0) then
  call get_command_argument(1, cbuf)
  read(cbuf,*, iostat=stat) dx
  if (stat/=0) error stop 'must input real number for resolution e.g. 1e-6'
else
  dx = 1e-6
endif

Ni = int((x1-x0) / dx)    ! (1 - (-1)) / interval
im = this_image()

!---------------------------------
if (im == 1) then
    call system_clock(tic)
    print '(A,I3)', 'number of Fortran coarray images:', num_images()
    print *,'approximating pi in ',Ni,' steps.'
end if
!---------------------------------

do i = im, Ni-1, num_images() ! Each image works on a subset of the problem
    x = x0 + i*dx
    f = dx / sqrt(1.0_wp - x**2)
    psum = psum + f
!    print *,x,f,psum
end do

! --- co_sum is much simpler, but not working on ifort 2017 yet
! ---- alternative to Fortran 2018 co_sum for Fortran 2008
sync all
if (im==1) then
  do i = 2, num_images()
    psum = psum + psum[i]
  enddo
endif

if (im == 1)  then
    print *,'pi:',pi,'  iterated pi: ',psum
    print '(A,E10.3)', 'pi error',pi - psum
endif

if (im == 1) then
    call system_clock(toc)
    call system_clock(count_rate=rate)
    telaps = real((toc - tic),wp)  / rate
    print '(A,E10.3,A,I3,A)', 'Elapsed wall clock time ', telaps, ' seconds, using',num_images(),' images.'
end if

end program


!  Program to perform a random walk in 2 dimensions
!  with equal probability for moves to the letf, right, up and down
!  Only one walker present

PROGRAM random_walk_2dim
  USE constants
  USE f90library
  IMPLICIT NONE
  INTEGER::  max_trials, number_walks
  REAL(dp):: move_probability
  INTEGER, ALLOCATABLE, DIMENSION(:) :: x_cum, x2_cum, y_cum, y2_cum

  ! get max trials, number of walks and the probability to move
  CALL  initialise(max_trials, number_walks, move_probability)
  ! allocate memory
  ALLOCATE (x_cum(number_walks), x2_cum(number_walks), &
       y_cum(number_walks), y2_cum(number_walks))
  x_cum = 0; y_cum = 0; x2_cum = 0; y2_cum = 0
  ! do the Monte Carlo move
  CALL  mc_sampling(max_trials, number_walks, move_probability, &
       x_cum, x2_cum, y_cum, y2_cum)
  ! Print out results
  CALL  output(max_trials, number_walks, x_cum, x2_cum, y_cum, y2_cum)
  ! free memory
  DEALLOCATE(x_cum, x2_cum, y_cum, y2_cum)
END PROGRAM random_walk_2dim

! Read in data from screen

SUBROUTINE initialise(max_trials, number_walks, move_probability)
  USE constants
  IMPLICIT NONE
  INTEGER, INTENT(inout) ::max_trials, number_walks
  REAL(DP) :: move_probability
  WRITE(*,*)'Number of Monte Carlo trials ='
  READ(*,*)  max_trials
  WRITE(*,*) 'Number of attempted walks='
  READ(*,*) number_walks
  WRITE(*,*) 'Move probability='
  READ(*,*)  move_probability
END SUBROUTINE initialise

! Output of expectation values, <x>, <y> and their variances
! <x^2> - <x>^2  and <y^2> - <y>^2

SUBROUTINE output(max_trials, number_walks, x_cum, x2_cum, y_cum, y2_cum)
  USE constants
  IMPLICIT NONE
  INTEGER :: i
  INTEGER, INTENT(in) :: max_trials, number_walks
  INTEGER, INTENT(in) :: x_cum(number_walks), x2_cum(number_walks), &
       y_cum(number_walks), y2_cum(number_walks)
  REAL(dp) :: xaverage, yaverage , x2average, y2average, total_average, &
       total_variance, yvariance, xvariance

  OPEN(UNIT=6, FILE='out.dat')
  DO i =1, number_walks
     xaverage = x_cum(i)/FLOAT(max_trials)
     x2average = x2_cum(i)/FLOAT(max_trials)
     xvariance = x2average - xaverage*xaverage
     yaverage = y_cum(i)/FLOAT(max_trials)
     y2average = y2_cum(i)/FLOAT(max_trials)
     yvariance = y2average - yaverage*yaverage
     total_average = xaverage+yaverage
     total_variance = xvariance+yvariance
     WRITE(6,'(I3,2X,6F12.6)') i, xaverage, yaverage ,xvariance, yvariance, &
          total_average, total_variance
  ENDDO
END SUBROUTINE output

! Here we perform the Monte Carlo samplings and moves in 2 dim

SUBROUTINE mc_sampling(max_trials,number_walks, move_probability, x_cum, &
     x2_cum, y_cum, y2_cum)
  USE constants
  USE f90library
  IMPLICIT NONE
  INTEGER, INTENT(in) :: max_trials,number_walks
  INTEGER, INTENT(inout) :: x_cum(number_walks), x2_cum(number_walks), &
       y_cum(number_walks), y2_cum(number_walks)
  INTEGER :: idum, x, y, trial, walks
  REAL(dp) :: rantest
  REAL(dp), INTENT(in) :: move_probability
  idum=-1
  ! loop over Monte Carlo trials
  DO trial = 1, max_trials
     x = 0;  y = 0
     ! loop over attempted walks in 2 dimensions
     DO walks = 1, number_walks
        !  note code taylored to equal probability for up, down, left and right
        rantest = ran0(idum)
        IF (rantest <= move_probability) THEN
           x = x+1
        ELSEIF(rantest <= 2*move_probability)THEN
           x = x-1
        ELSEIF(rantest <= 3*move_probability)THEN
           y = y+1
        ELSE
           y = y-1
        ENDIF
        x_cum(walks) = x_cum(walks)+x
        x2_cum(walks) = x2_cum(walks)+x*x
        y_cum(walks) = y_cum(walks)+y
        y2_cum(walks) = y2_cum(walks)+y*y
     ENDDO
  ENDDO
END SUBROUTINE mc_sampling