module UberDuperSimulation
  implicit none
  INTEGER, PARAMETER :: DP = kind(1.0d0)
  REAL (DP), PARAMETER :: R0 = 6378137
  REAL (DP), PARAMETER :: mu = 3.9860047e14
  REAL (DP) :: Pi = 4D0*DATAN(1D0)

  abstract interface
    function rp (t, StateVector)
      INTEGER, PARAMETER :: DP = kind(1.0d0)
      REAL (DP), DIMENSION(0:3) :: StateVector, rp
      REAL (DP) :: t
    end function rp
  end interface

contains

function h_x_y(x, y)
  implicit none
  REAL (DP) :: x,y
  REAL (DP) :: h_x_y
  h_x_y = sqrt(x**2 + y**2) - R0
end function h_x_y

function calculate_T_period(R)
  REAL (DP) :: R
  REAL (DP) :: calculate_T_period
  calculate_T_period = 2 * Pi * sqrt(R**3 / mu)
end function calculate_T_period

function right_part(t, StateVector)
  REAL (DP), DIMENSION(0:3) :: StateVector, right_part
  REAL (DP) :: t, R, R3

  R = sqrt(StateVector(0)**2 + StateVector(1)**2)
  R3 = R**3

  right_part(0) = StateVector(2)
  right_part(1) = StateVector(3)
  right_part(2) = -mu / R3 * StateVector(0)
  right_part(3) = -mu / R3 * StateVector(1)
end function right_part

subroutine runge_kutta_t_state_vector(t, params, t_step, f)
  REAL (DP) :: t, t_step, h
  REAL (DP), DIMENSION(0:3) :: params, k1, k2, k3, k4, new_params
  INTEGER :: i
  REAL (DP) :: p
  procedure (rp), pointer :: f

  h = t_step

  k1 = f(t, params)

  do i=0,3
    p = params(i)
    new_params(i) = p + h / 2 * k1(i)
  end do

  k2 = f(t + h / 2, new_params)

  do i=0,3
    p = params(i)
    new_params(i) = p + h / 2 * k2(i)
  end do

  k3 = f(t + h / 2, new_params)

  do i=0,3
    p = params(i)
    new_params(i) = p + h * k3(i)
  end do

  k4 = f(t + h, new_params)

  do i=0,3
    p = params(i)
    params(i) = p + h / 6 * (k1(i) + 2 * k2(i) + 2 * k3(i) + k4(i))
  end do

end subroutine runge_kutta_t_state_vector

subroutine regular_calculation(t, t_end, t_step, x, y, Vx, Vy)
  REAL (DP) :: t,t_end,t_step,x,y,Vx,Vy
  REAL (DP), DIMENSION(0:3) :: params
  procedure (rp), pointer :: f

  params(0) = x
  params(1) = y
  params(2) = Vx
  params(3) = Vy

  f => right_part

  open(1, file='output.tr')
    do
      if (t > t_end) then
        exit
      end if

      write(1, '(F14.3, F14.0, F14.0, F14.3, F14.3)') t, params
      t = t + t_step
      call runge_kutta_t_state_vector(t, params, t_step, f)
    end do
  close(1)
end subroutine regular_calculation

subroutine benchmark_test(t, t_end, t_step, x, y, Vx, Vy)
  REAL (DP) :: t,t_end,t_step,x,y,Vx,Vy
  REAL (DP), DIMENSION(0:3) :: params
  procedure (rp), pointer :: f

  params(0) = x
  params(1) = y
  params(2) = Vx
  params(3) = Vy

  f => right_part

  do
    if (t > t_end) then
      exit
    end if

    t = t + t_step
    call runge_kutta_t_state_vector(t, params, t_step, f)
  end do

end subroutine benchmark_test

subroutine test(t, t_end, t_step, x, y, Vx, Vy, R)
  REAL (DP) :: t,t_end,t_step,x,y,Vx,Vy,R,T_period,x1,x2,h
  REAL (DP), DIMENSION(0:3) :: params, parameters
  procedure (rp), pointer :: f
  CHARACTER (LEN=2), DIMENSION(0:3) :: texts
  INTEGER :: i

  params(0) = x
  params(1) = y
  params(2) = Vx
  params(3) = Vy

  parameters = params

  texts(0) = "x"
  texts(1) = "y"
  texts(2) = "Vx"
  texts(3) = "Vy"

  f => right_part

  T_period = calculate_T_period(R)

  do
    if (t > t_end) then
      exit
    end if

    t = t + t_step
    call runge_kutta_t_state_vector(t, params, t_step, f)

    if (t .GE. T_period .and. t .LE. (t + t_step)) then
      print *, "Виток № ", t/T_period
      print *, "T = ", t

      do i = 0,3
        x1 = params(i)
        x2 = parameters(i)
        if (abs(x1 - x2) > 1e-5) then
          print *, "Разница в значениях:", texts(i), x1, x2, x1-x2
        end if
      end do
    end if

    h = h_x_y(params(0), params(1))

    if (h - 1000000 > 1e-5) then
      print *, "Высота изменилась", h
      stop
    end if
  end do
end subroutine test

subroutine main(run_type, step)
  REAL (DP) :: t_end, t_step, h0, R, t,x,y,Vx,Vy,step
  CHARACTER (LEN=*) :: run_type
  t_end = 10000
  t_step = step
  h0 = 1000000
  R = R0 + h0
  t = 0
  x = 0
  y = R
  Vx = sqrt(mu / R)
  Vy = 0

  if (run_type == "regular") then
    call regular_calculation(t, t_end, t_step, x, y, Vx, Vy)
  else if (run_type == "benchmark") then
    call benchmark_test(t, t_end, t_step, x, y, Vx, Vy)
  else if (run_type == "test") then
    call test(t, t_end, t_step, x, y, Vx, Vy, R)
  end if

end subroutine main

subroutine run_calculation_and_measure_time(run_type, step, n)
CHARACTER (LEN=*) :: run_type
REAL (DP) :: step
INTEGER :: n
integer (Kind=8) :: start_count, end_count, count_rate, count_max, delta
print *, run_type
call system_clock(start_count, count_rate, count_max)
call main(run_type, step)
call system_clock(end_count, count_rate, count_max)
delta = end_count - start_count
write (n,*) run_type, step
write (n,*) delta
print *, run_type, step, delta
end subroutine run_calculation_and_measure_time

subroutine main2()
CHARACTER (LEN=10), DIMENSION(0:2) :: run_types
REAL (DP), DIMENSION(0:2) :: steps
INTEGER :: i,j
REAL (DP) :: step
CHARACTER (LEN=10) :: run_type
run_types(0) = "benchmark"
run_types(1) = "regular"
run_types(2) = "test"
steps(0) = 1
steps(1) = 0.1
steps(2) = 0.01
open(2, file='results.txt')
do i = 0,2
    run_type = run_types(i)
    if (run_type /= "test") then
      do j = 0,2
        step = steps(j)
        call run_calculation_and_measure_time(run_type, step, 2)
      end do
    else
      step = 0.1
      call run_calculation_and_measure_time(run_type, step, 2)
    end if
end do
close(2)
end subroutine main2

end module UberDuperSimulation

program Uber_Duper_Simulation
  USE UberDuperSimulation
  implicit none
  call main2()
end program Uber_Duper_Simulation


c
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c     *                                                               *
c     *                  copyright (c) 1998 by UCAR                   *
c     *                                                               *
c     *       University Corporation for Atmospheric Research         *
c     *                                                               *
c     *                      all rights reserved                      *
c     *                                                               *
c     *                      SPHEREPACK version 3.2                   *
c     *                                                               *
c     *       A Package of Fortran77 Subroutines and Programs         *
c     *                                                               *
c     *              for Modeling Geophysical Processes               *
c     *                                                               *
c     *                             by                                *
c     *                                                               *
c     *                  John Adams and Paul Swarztrauber             *
c     *                                                               *
c     *                             of                                *
c     *                                                               *
c     *         the National Center for Atmospheric Research          *
c     *                                                               *
c     *                Boulder, Colorado  (80307)  U.S.A.             *
c     *                                                               *
c     *                   which is sponsored by                       *
c     *                                                               *
c     *              the National Science Foundation                  *
c     *                                                               *
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c
c
c
c     11/96
c
c     a program for testing all vector analysis and synthesis subroutines
c
c     (1) first a scalar stream function and a scalar velocity potential function
c         are set in st,sv by restricting polys in x,y,z to the sphere surface
c
c     (2) the vector vield (v,w) is set by analytically differenting the scalar fields in (1)
c         using the standard formula relating a vector field and the stream and velocity
c         potential scalar fields in colatitude X longitude spherical coordinates
c
c          v = -1/sin(theta)*d(st)/dphi + d(sv)/dtheta
c
c          w =  1/sin(theta)*d(sv)/dphi + d(st)/dtheta
c
c     (3) a vector analysis is performed on (v,w)
c
c     (4) a vector synthesis is performed using coeffs from (3)
c
c     (5) the synthesized vector field from (4) is compared with the vector field from (2)
c
c     note:  vhaec,vhaes,vhagc,vhags,vhsec,vhses,vhsgc,vhsgs are all tested!!
c
      program tvha
c
c     set dimensions with parameter statements
c
      parameter(nnlat= 25,nnlon= 19, nnt = 2)
      parameter (lleng= 5*nnlat*nnlat*nnlon,llsav= 5*nnlat*nnlat*nnlon)
      parameter (lldwork = 4*nnlat*nnlat )
      double precision dwork(lldwork)
      dimension work(lleng),wsave(llsav)
      dimension br(nnlat,nnlat,nnt),bi(nnlat,nnlat,nnt)
      dimension cr(nnlat,nnlat,nnt),ci(nnlat,nnlat,nnt)
      dimension st(nnlat,nnlon,nnt),sv(nnlat,nnlon,nnt)
      dimension thetag(nnlat),dtheta(nnlat),dwts(nnlat)
      dimension v(nnlat,nnlon,nnt),w(nnlat,nnlon,nnt)
      double precision dtheta, dwts
c
c     set dimension variables
c
      nlat = nnlat
      nlon = nnlon
      lwork = lleng
      lsave = llsav
      nt = nnt
      call iout(nlat,"nlat")
      call iout(nlon,"nlon")
      call iout(nt,"  nt")
      ityp = 0
c
c     set equally spaced colatitude and longitude increments
c
      pi = 4.0*atan(1.0)
      dphi = (pi+pi)/nlon
      dlat = pi/(nlat-1)
c
c     compute nlat gaussian points in thetag
c
      ldwork = lldwork
      call gaqd(nlat,dtheta,dwts,dwork,ldwork,ier)
      do  i=1,nlat
	thetag(i) = dtheta(i)
      end do
      call name("gaqd")
      call iout(ier," ier")
      call vecout(thetag,"thtg",nlat)
c
c     test all analysis and synthesis subroutines
c
      do icase=1,4
c
c     icase=1 test vhaec,vhsec
c     icase=2 test vhaes,vhses
c     icase=3 test vhagc,vhsgc
c     icase=4 test vhags,vhsgs
c
      call name("****")
      call name("****")
      call iout(icase,"icas")
c
c
c     set scalar stream and velocity potential fields as polys in x,y,z
c     and then set v,w from st,sv scalar fields
c
      do k=1,nt
	do j=1,nlon
	  phi = (j-1)*dphi
	  sinp = sin(phi)
	  cosp = cos(phi)
	  do i=1,nlat
	    theta = (i-1)*dlat
c           if (icase.gt.2) theta=thetag(i)
	    if (icase.eq.3 .or. icase.eq.4) theta = thetag(i)
	    cost = cos(theta)
	    sint = sin(theta)
	    x = sint*cosp
	    y = sint*sinp
	    z = cost
	    dxdt = cost*cosp
	    dxdp = -sint*sinp
	    dydt = cost*sinp
	    dydp = sint*cosp
	    dzdt = -sint
	    dzdp = 0.0
	    if (k.eq.1) then
	    st(i,j,k) = x*y
	    sv(i,j,k) = y*z
	    dstdt = x*dydt+y*dxdt
	    dstdp = x*dydp+y*dxdp
	    dsvdt = y*dzdt+z*dydt
	    dsvdp = y*dzdp+z*dydp
	    v(i,j,k) = -(cosp*dydp+sinp*dxdp) + dsvdt
	    w(i,j,k) = sinp*dzdp + cost*cosp + dstdt
	    else if (k.eq.2) then
	       st(i,j,k) = x*z
	       sv(i,j,k) = x*y
	       dstdp = x*dzdp+z*dxdp
	       dstdt = x*dzdt+z*dxdt
	       dsvdp = x*dydp+y*dxdp
	       dsvdt = x*dydt+y*dxdt
c
c          v = -1/sin(theta)*d(st)/dphi + d(sv)/dtheta
c
c          w =  1/sin(theta)*d(sv)/dphi + d(st)/dtheta
c
	       v(i,j,k) = z*sinp + dsvdt
	       w(i,j,k) = cosp*dydp+ sinp*dxdp + dstdt
	    end if
	  end do
	end do
      end do

c     do kk=1,nt
c     call iout(kk,"**kk")
c     call aout(v(1,1,kk),"   v",nlat,nlon)
c     call aout(w(1,1,kk),"   w",nlat,nlon)
c     end do

      if (icase.eq.1) then

      call name("**ec")

      call vhaeci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("vhai")
      call iout(ierror,"ierr")

      call vhaec(nlat,nlon,ityp,nt,v,w,nlat,nlon,br,bi,cr,ci,nlat,
     +nlat,wsave,lsave,work,lwork,ierror)
      call name("vha ")
      call iout(ierror,"ierr")

c     call aout(br,"  br",nlat,nlat)
c     call aout(bi,"  bi",nlat,nlat)
c     call aout(cr,"  cr",nlat,nlat)
c     call aout(ci,"  ci",nlat,nlat)

c
c     now synthesize v,w from br,bi,cr,ci and compare with original
c
      call vhseci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("vhsi")
      call iout(ierror,"ierr")

      call vhsec(nlat,nlon,ityp,nt,v,w,nlat,nlon,br,bi,cr,ci,nlat,
     +nlat,wsave,lsave,work,lwork,ierror)
      call name("vhs ")
      call iout(ierror,"ierr")

c     call aout(v,"   v",nlat,nlon)
c     call aout(w,"   w",nlat,nlon)

      else if (icase.eq.2) then

      call name("**es")

      call vhaesi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name("vhai")
      call iout(ierror,"ierr")

      call vhaes(nlat,nlon,ityp,nt,v,w,nlat,nlon,br,bi,cr,ci,nlat,
     +nlat,wsave,lsave,work,lwork,ierror)

      call name("vha ")
      call iout(ierror,"ierr")

c     call aout(br,"  br",nlat,nlat)
c     call aout(bi,"  bi",nlat,nlat)
c     call aout(cr,"  cr",nlat,nlat)
c     call aout(ci,"  ci",nlat,nlat)

c
c     now synthesize v,w from br,bi,cr,ci and compare with original
c
      call vhsesi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name("vhsi")
      call iout(ierror,"ierr")

      call vhses(nlat,nlon,ityp,nt,v,w,nlat,nlon,br,bi,cr,ci,nlat,
     +nlat,wsave,lsave,work,lwork,ierror)

      call name("vhs ")
      call iout(ierror,"ierr")

      else if (icase.eq.3) then

      call name("**gc")

      call name("vhgi")
      call iout(nlat,"nlat")

      call vhagci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("vhai")
      call iout(ierror,"ierr")

      call vhagc(nlat,nlon,ityp,nt,v,w,nlat,nlon,br,bi,cr,ci,nlat,
     +nlat,wsave,lsave,work,lwork,ierror)
      call name("vha ")
      call iout(ierror,"ierr")

c     call aout(br,"  br",nlat,nlat)
c     call aout(bi,"  bi",nlat,nlat)
c     call aout(cr,"  cr",nlat,nlat)
c     call aout(ci,"  ci",nlat,nlat)

c
c     now synthesize v,w from br,bi,cr,ci and compare with original
c
      call vhsgci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("vhsi")
      call iout(ierror,"ierr")

      call vhsgc(nlat,nlon,ityp,nt,v,w,nlat,nlon,br,bi,cr,ci,nlat,
     +nlat,wsave,lsave,work,lwork,ierror)
      call name("vhs ")
      call iout(ierror,"ierr")

c     call aout(v,"   v",nlat,nlon)
c     call aout(w,"   w",nlat,nlon)
c     call exit(0)

c
c **** problem with vhags.f, function indx not defined!!!! talk to Paul
c

      else if (icase.eq.4) then

      call name("**gs")

      call vhagsi(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("vhai")
      call iout(ierror,"ierr")

      call vhags(nlat,nlon,ityp,nt,v,w,nlat,nlon,br,bi,cr,ci,nlat,
     +nlat,wsave,lsave,work,lwork,ierror)
      call name("vha ")
      call iout(ierror,"ierr")

c     call aout(br,"  br",nlat,nlat)
c     call aout(bi,"  bi",nlat,nlat)
c     call aout(cr,"  cr",nlat,nlat)
c     call aout(ci,"  ci",nlat,nlat)

c
c     now synthesize v,w from br,bi,cr,ci and compare with original
c
      call vhsgsi(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("vhsi")
      call iout(ierror,"ierr")

      call vhsgs(nlat,nlon,ityp,nt,v,w,nlat,nlon,br,bi,cr,ci,nlat,
     +nlat,wsave,lsave,work,lwork,ierror)
      call name("vhs ")
      call iout(ierror,"ierr")

      end if

c     do kk=1,nt
c     call iout(kk,"**kk")
c     call aout(v(1,1,kk),"   v",nlat,nlon)
c     call aout(w(1,1,kk),"   w",nlat,nlon)
c     end do

c
c     compute "error" in v,w
c
      err2v = 0.0
      err2w = 0.0
      do k=1,nt
	do j=1,nlon
	  phi = (j-1)*dphi
	  sinp = sin(phi)
	  cosp = cos(phi)
	  do i=1,nlat
	    theta = (i-1)*dlat
	    if (icase.gt.2) theta=thetag(i)
	    cost = cos(theta)
	    sint = sin(theta)
	    x = sint*cosp
	    y = sint*sinp
	    z = cost
	    dxdt = cost*cosp
	    dxdp = -sint*sinp
	    dydt = cost*sinp
	    dydp = sint*cosp
	    dzdt = -sint
	    dzdp = 0.0
	    if (k.eq.1) then
	    st(i,j,k) = x*y
	    sv(i,j,k) = y*z
	    dstdt = x*dydt+y*dxdt
	    dstdp = x*dydp+y*dxdp
	    dsvdt = y*dzdt+z*dydt
	    dsvdp = y*dzdp+z*dydp
	    ve = -(cosp*dydp+sinp*dxdp) + dsvdt
	    we = sinp*dzdp + cost*cosp + dstdt
	    else if (k.eq.2) then
	       st(i,j,k) = x*z
	       sv(i,j,k) = x*y
	       dstdp = x*dzdp+z*dxdp
	       dstdt = x*dzdt+z*dxdt
	       dsvdp =  x*dydp+y*dxdp
	       dsvdt = x*dydt+y*dxdt
	       ve = z*sinp + dsvdt
	       we = cosp*dydp+ sinp*dxdp + dstdt
	    end if
	    err2v = err2v + (v(i,j,k) - ve)**2
	    err2w = err2w + (w(i,j,k) - we)**2
	  end do
	end do
      end do
c
c     set and print least squares error in v,w
c
      err2v = sqrt(err2v/(nt*nlat*nlon))
      err2w = sqrt(err2w/(nt*nlat*nlon))
      call vout(err2v,"errv")
      call vout(err2w,"errw")
c
c     end of icase loop
c
      end do
      end
c
      subroutine iout(ivar,nam)
      real nam
      write(6,10) nam , ivar
   10 format(1h a4, 3h = ,i8)
      return
      end
c
      subroutine vout(var,nam)
      real nam
      write(6,10) nam , var
   10 format(1h a4,3h = ,e12.5)
      return
      end
c
      subroutine name(nam)
      real nam
      write(6,100) nam
  100 format(1h a8)
      return
      end
c
      subroutine vecout(vec,nam,len)
      dimension vec(len)
      real nam
      write(6,109) nam, (vec(l),l=1,len)
  109 format(1h a4,/(1h 8e11.4))
      return
      end


MODULE Prime_Utility

  ! -----------------
  ! Environment setup
  ! -----------------
  ! Module usage
  USE Type_Kinds     , ONLY: fp=>fp_kind
  USE Message_Handler, ONLY: SUCCESS, FAILURE, WARNING, Display_Message
  USE Prime_Define   , ONLY: Prime_type      , &
                             Associated_Prime, &
                             Destroy_Prime   , &
                             Allocate_Prime  , &
                             Assign_Prime    , &
                             Equal_Prime     , &
                             Info_Prime
  ! Disable implicit typing
  IMPLICIT NONE

  ! ------------
  ! Visibilities
  ! ------------
  PRIVATE
  ! Prime data structure definition inherited from Prime_Define
  PUBLIC :: Prime_type
  ! Structure procedures inherited from Prime_Define
  PUBLIC :: Associated_Prime
  PUBLIC :: Destroy_Prime
  PUBLIC :: Allocate_Prime
  PUBLIC :: Assign_Prime
  PUBLIC :: Equal_Prime
  PUBLIC :: Info_Prime
  ! Module procedure
  PUBLIC :: IsPrime
  PUBLIC :: Primes
  PUBLIC :: PrimeFactor

  ! -----------------
  ! Module parameters
  ! -----------------
  CHARACTER(*),PARAMETER :: MODULE_RCS_ID = &

CONTAINS

!##################################################################################
!##################################################################################
!##                                                                              ##
!##                          ## PRIVATE MODULE ROUTINES ##                       ##
!##                                                                              ##
!##################################################################################
!##################################################################################

  ! Specification function for the size of the possible
  ! multiples list automatic array in IsPrime
  PURE FUNCTION mSize(n)
    INTEGER, INTENT(IN) :: n
    INTEGER :: mSize
    mSize = INT(SQRT(REAL(n,fp)))
  END FUNCTION mSize

  ! Subroutine to swap integer values
  SUBROUTINE Swap(i,j)
    INTEGER, INTENT(IN OUT) :: i,j
    INTEGER :: k
    k=i; i=j; j=k
  END SUBROUTINE Swap

!##################################################################################
!##################################################################################
!##                                                                              ##
!##                           ## PUBLIC MODULE ROUTINES ##                       ##
!##                                                                              ##
!##################################################################################
!##################################################################################

  FUNCTION IsPrime(n)
    ! Arguments
    INTEGER, INTENT(IN) :: n
    ! Function result
    LOGICAL :: IsPrime
    ! Local variables
    INTEGER :: multiples(mSize(n))
    INTEGER :: i, nMultiples

    ! Set up
    IsPrime = .FALSE.

    ! Handle edge cases of 1 and 2
    IF ( n == 1 ) RETURN ! Not a prime
    IF ( n == 2 ) THEN
      IsPrime = .TRUE.
      RETURN
    END IF

    ! Create list of candidate multiples of n, p_i, such
    ! that p_i <= SQRT(n)
    multiples = (/ (i,i=2,mSize(n)+1) /)

    ! Is it a prime?
    nMultiples = COUNT( MOD(n,multiples) == 0 )
    IF ( nMultiples == 0 ) IsPrime = .TRUE.

  END FUNCTION IsPrime

  FUNCTION Primes(n) RESULT(Prime)
    ! Arguments
    INTEGER, INTENT(IN) :: n
    ! Function result
    TYPE(Prime_type) :: Prime
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Primes'
    ! Local variables
    INTEGER :: errStatus
    INTEGER :: listA(n-1,2), idx(n-1)
    INTEGER :: listB(n-1)
    INTEGER :: i, i1,i2, nR, nP, nNM

    ! Create list of candidate primes, p_i, such
    ! that 2 <= p_i <= n
    listA(:,1) = (/(i,i=2,n)/); i1=1  ! Each iteration will bounce
    listA(:,2) = 0            ; i2=2  ! between these lists

    ! Initialise the "found" primes list
    nP=1
    listB(nP) = 2

    ! Initialise the count of candidate numbers remaining to check
    nR=n-1

    ! Remove all multiples of listB from listA
    Sieve_Loop: DO

      ! Count the multiples of the current prime number,
      ! listB(nP), in listA
      nNM = COUNT( MOD(listA(1:nR,i1),listB(nP)) /= 0 )

      ! If none, then we've found them all
      IF (nNM == 0) EXIT Sieve_Loop

      ! Determine the indices of the non-multiples of listB(nP)
      idx(1:nNM) = PACK( (/(i,i=1,nR)/), &
                         MOD(listA(1:nR,i1),listB(nP)) /= 0 )

      ! Only keep the non-multiples of listB(nP)
      listA(1:nNM,i2) = listA(idx(1:nNM),i1)

      ! Update array indices
      nR=nNM   ! The new size of the array of candidate primes
      nP=nP+1  ! The new size of the array of found primes

      ! Save the current found prime number
      listB(nP)=listA(1,i2)

      ! Swap the indices referencing the current
      ! list of candidate prime numbers
      CALL Swap(i1,i2)
    END DO Sieve_Loop

    ! Allocate and fill the return structure
    errStatus = Allocate_Prime(nP,Prime)
    IF (errStatus /= SUCCESS ) THEN
      CALL Display_Message(ROUTINE_NAME, &
                           'Error allocating Prime return structure', &
                           FAILURE )
      RETURN
    END IF
    Prime%number = n
    Prime%n      = listB(1:nP)

  END FUNCTION Primes

  FUNCTION PrimeFactor(n) RESULT(Factors)
    ! Arguments
    INTEGER, INTENT(IN) :: n
    ! Function result
    TYPE(Prime_type) :: Factors
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'PrimeFactor'
    ! Local variables
    INTEGER :: errStatus
    INTEGER :: i, j
    INTEGER :: nF, idx(1)
    INTEGER :: nFactors
    TYPE(Prime_type) :: Prime
    TYPE(Prime_type) :: f

    ! Get the list of candidate primes to test
    Prime=Primes(n)

    ! Allocate the local factors structure to hold the candidates
    errStatus = Allocate_Prime(Prime%nPrimes,f)
    IF (errStatus /= SUCCESS ) THEN
      CALL Display_Message(ROUTINE_NAME, &
                           'Error allocating f structure', &
                           FAILURE )
      RETURN
    END IF
    f%number = n
    f%nExp   = 0

    ! Begin the prime factor search
    i=1
    nFactors=0
    Factor_Search: DO
      Prime_Search: DO
        IF (MOD(f%number,Prime%n(i)) == 0 ) EXIT Prime_Search
        i=i+1
      END DO Prime_Search
      ! O.k., we have a prime factor
      ! Do we already have it in the list?
      nF = COUNT( f%n == Prime%n(i) )
      IF (nF == 0) THEN
        ! It doesn't exist, so add it
        nFactors=nFactors+1
        f%n(nFactors)    = Prime%n(i)
        f%nExp(nFactors) = f%nExp(nFactors) + 1
      ELSE
        ! It does exist, so just increment the exponent counter
        idx = PACK( (/(j,j=1,f%nPrimes)/), &
                    f%n == Prime%n(i) )
        f%nExp(idx(1)) = f%nExp(idx(1)) + 1
      END IF
      ! Update the integer
      f%number = f%number/Prime%n(i)
      ! If the number is 1, we're done
      IF ( f%number == 1 ) EXIT Factor_Search
    END DO Factor_Search

    ! Allocate and fill the return structure
    errStatus = Allocate_Prime(nFactors,Factors)
    IF (errStatus /= SUCCESS ) THEN
      CALL Display_Message(ROUTINE_NAME, &
                           'Error allocating return Factors structure', &
                           FAILURE )
      RETURN
    END IF
    Factors%number = n
    Factors%n      = f%n(1:nFactors)
    Factors%nExp   = f%nExp(1:nFactors)

    ! Destroy the local f structure
    errStatus = Destroy_Prime(f)
    IF (errStatus /= SUCCESS ) THEN
      CALL Display_Message(ROUTINE_NAME, &
                           'Error destroying local f structure', &
                           WARNING )
    END IF

    ! Destroy the local Prime structure
    errStatus = Destroy_Prime(Prime)
    IF (errStatus /= SUCCESS ) THEN
      CALL Display_Message(ROUTINE_NAME, &
                           'Error destroying local Prime structure', &
                           WARNING )
    END IF
  END FUNCTION PrimeFactor

END MODULE Prime_Utility


program life

  ! A simple implementation of John Conway's "Game of life"
  ! The system is im x jm cells and runs for nsteps iterations
  ! Boundary conditions may be periodic or 'closed'.

  implicit none

  integer, parameter :: im = 16
  integer, parameter :: jm = 16
  integer, parameter :: imp1 = im+1
  integer, parameter :: jmp1 = jm+1
  integer, parameter :: nsteps = 12

  logical, parameter :: periodic = .true.
  integer            :: nc, np, n
  integer            :: tmp, live
  integer            :: ncount
  integer            :: i, j

  logical, dimension(0:imp1, 0:jmp1, 2) :: state

  ! Initialise system

  nc = 1 ! nc is a pointer to current time level
  np = 2 ! np is a pointer to forward time level

  state(:,:,:) = .false.

  ! initial state, for example live cells marked 'X' ...
  !
  !        i
  !
  ! j-2    X
  ! j-1   X X
  ! j    XX XX

  i = im/2
  j = jm/2
  state(i-2, j,     nc) = .true.
  state(i-1, j-1:j, nc) = .true.
  state(i,   j-2,   nc) = .true.
  state(i+1, j-1:j, nc) = .true.
  state(i+2, j,     nc) = .true.

  ! Iterate

  do n = 1, nsteps

     ! halo regions
     if (periodic) then
        state(0,      1:jm, nc) = state(im,   1:jm, nc)
        state(imp1,   1:jm, nc) = state(1,    1:jm, nc)
        state(0:imp1,    0, nc) = state(0:imp1, jm, nc)
        state(0:imp1, jmp1, nc) = state(0:imp1,  1, nc)
     else
        state(0,      1:jm, nc) = .false.
        state(imp1,   1:jm, nc) = .false.
        state(0:imp1,    0, nc) = .false.
        state(0:imp1, jmp1, nc) = .false.
     end if

     ! update, and keep a count of the number of live cells

     ncount = 0

     do j = 1, jm
        do i = 1, im
           if (state(i,j,nc)) ncount = ncount + 1
           state(i,j,np) = state(i,j,nc)
           ! count the neighbours (including self)
           live = count(state(i-1:i+1,j-1:j+1,nc))
           if (state(i,j,nc)) then
              ! currently alive
              if (live == 3 .or. live == 4) then
                 ! remains alive
              else
                 ! dies
                 state(i,j,np) = .false.
              end if
           else
              ! currently dead
              if (live == 3) then
                 ! new cell
                 state(i,j,np) = .true.
              end if
           end if
           ! next cell
        end do
     end do

     ! output

     do j = 1, jm
        do i = 1, im
           live = 0
           if (state(i,j,nc)) live = 1
           write (*, fmt = '(1x,i1)', advance = 'no') live
        end do
      write (*,*)
     end do
     write (*, fmt = '(a,i3,i3)') "Step, count: ", n, ncount
     write (*,*)

     ! swap time level pointers
     tmp = nc
     nc = np
     np = tmp

  end do

end program life


      SUBROUTINE rstrct(uc,uf,nc)
      INTEGER nc
      DOUBLE PRECISION uc(nc,nc),uf(2*nc-1,2*nc-1)
      INTEGER ic,if,jc,jf
      do 12 jc=2,nc-1
        jf=2*jc-1
        do 11 ic=2,nc-1
          if=2*ic-1
          uc(ic,jc)=.5d0*uf(if,jf)+.125d0*(uf(if+1,jf)+uf(if-1,jf)+
     *uf(if,jf+1)+uf(if,jf-1))
11      continue
12    continue
      do 13 ic=1,nc
        uc(ic,1)=uf(2*ic-1,1)
        uc(ic,nc)=uf(2*ic-1,2*nc-1)
13    continue
      do 14 jc=1,nc
        uc(1,jc)=uf(1,2*jc-1)
        uc(nc,jc)=uf(2*nc-1,2*jc-1)
14    continue
      return
      END

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


      PROGRAM CSEX01
C
C  This example illustrates the effects of using differing numbers
C  of knots in calls to CSA1S with the same input data.
C
C
C  The dimensionality of the problem.
C
      PARAMETER (NDIM=1)
C
C  The number of input data points.
C
      PARAMETER (NDATA=10)
C
C  The number of output data points.
C
      PARAMETER (NPTS=101)
C
C  The maximum number of knots used in any call.
C
      PARAMETER (NCF=9)
C
C  The size of the workspace.
C
      PARAMETER (NWRK=NCF*(NCF+3))
C
C  Dimension arrays.
C
      DIMENSION XDATA(NDIM,NDATA),YDATA(NDATA),XDATAT(NDATA)
      DIMENSION WORK(NWRK)
      DIMENSION XO(NPTS),YO4(NPTS),YO7(NPTS),YO9(NPTS)
C
C  Define the original data.
C
      DATA XDATA(NDIM,1),XDATA(NDIM,2),XDATA(NDIM,3)/ 0.00, 0.1, 0.2 /
      DATA XDATA(NDIM,4),XDATA(NDIM,5),XDATA(NDIM,6)/ 0.30, 0.5, 0.6 /
      DATA XDATA(NDIM,7),XDATA(NDIM,8),XDATA(NDIM,9)/ 0.65, 0.8, 0.9 /
      DATA XDATA(NDIM,10)                           / 1.00           /
      DATA YDATA/0.0, 0.8, -0.9, -0.9, 0.9, 1.0, 0.90, -0.8, -0.8, 0./
C
C  Create the output X coordinate array.
C
      XINC = 1./(NPTS-1)
      DO 10 I=1,NPTS
        XO(I) = (I-1)*XINC
   10 CONTINUE
C
C  Calculate the approximated function values using differing
C  number of knots.
C
      KNOTS = 4
      CALL CSA1S (NDATA,XDATA,YDATA,KNOTS,NPTS,XO,YO4,NWRK,WORK,IER)
      IF (IER .NE. 0) THEN
        WRITE(6,520) IER
  520   FORMAT(' Error ',I3,' returned from CSA1S')
        STOP
      ENDIF
C
      KNOTS = 7
      CALL CSA1S (NDATA,XDATA,YDATA,KNOTS,NPTS,XO,YO7,NWRK,WORK,IER)
      IF (IER .NE. 0) THEN
        WRITE(6,520) IER
        STOP
      ENDIF
C
      KNOTS = 9
      CALL CSA1S (NDATA,XDATA,YDATA,KNOTS,NPTS,XO,YO9,NWRK,WORK,IER)
      IF (IER .NE. 0) THEN
        WRITE(6,520) IER
        STOP
      ENDIF
C
C  Draw a plot of the approximation functions and mark the original points.
C
      DO 34 I=1,NDATA
        XDATAT(I) = XDATA(1,I)
   34 CONTINUE
C
      CALL DRWFT1(NDATA,XDATAT,YDATA,NPTS,XO,YO4,YO7,YO9)
C
      STOP
      END
      SUBROUTINE DRWFT1(NUMO,X,Y,IO,XO,CURVE1,CURVE2,CURVE3)
C
C  This subroutine uses NCAR Graphics to plot three curves on
C  the same picture showing the results from calling CSA1X with
C  differing number of knots.  The values for the curves are
C  contained in arrays CURVE1, CURVE2, and CURVE3.
C
      DIMENSION XO(IO),CURVE1(IO),CURVE2(IO),CURVE3(IO)
C
C Define the error file, the Fortran unit number, the workstation type,
C and the workstation ID to be used in calls to GKS routines.
C
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)   ! NCGM
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=8,  IWKID=1)   ! X Windows
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=11, IWKID=1)   ! PDF
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=20, IWKID=1)   ! PostScript
C
      PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)
C
C  Vertical position for initial curve.
C
      DATA YPOS_TOP/0.88/
C
C  Open GKS, open and activate a workstation.
C
      CALL GOPKS (IERRF, ISZDM)
      CALL GOPWK (IWKID, LUNIT, IWTYPE)
      CALL GACWK (IWKID)
C
C  Define a color table.
C
      CALL GSCR(IWKID, 0, 1.0, 1.0, 1.0)
      CALL GSCR(IWKID, 1, 0.0, 0.0, 0.0)
      CALL GSCR(IWKID, 2, 1.0, 0.0, 0.0)
      CALL GSCR(IWKID, 3, 0.0, 0.0, 1.0)
      CALL GSCLIP(0)
C
C  Plot the main title.
C
      CALL PLCHHQ(0.50,0.95,':F21:Demo for csa1s',0.035,0.,0.)
C
C  Draw a background grid for the first curve.
C
      YB = -1.2
      YT =  1.2
      CALL BKGFT1(YPOS_TOP,'knots = 4',YB,YT)
      CALL GRIDAL(5,5,4,1,1,1,10,0.0,YB)
C
C  Mark the original data points.
C
      CALL GSMKSC(2.2)
      CALL GSPMCI(3)
      CALL GSLWSC(1.)
      CALL GPM(NUMO,X,Y)
C
C  Graph the approximated function values for KNOTS=4.
C
      CALL GSPLCI(1)
      CALL GPL(IO,XO,CURVE1)
C
C  Graph the approximated function values for KNOTS=7.
C
      CALL BKGFT1(YPOS_TOP-0.3,'knots = 7',YB,YT)
      CALL GRIDAL(5,5,4,1,1,1,10,0.0,YB)
      CALL GPM(NUMO,X,Y)
      CALL GPL(IO,XO,CURVE2)
      CALL GSPLCI(1)
C
C  Graph the approximated function values for KNOTS=9.
C
      CALL BKGFT1(YPOS_TOP-0.6,'knots = 9',YB,YT)
      CALL GRIDAL(5,5,4,1,1,1,10,0.0,YB)
      CALL GPM(NUMO,X,Y)
      CALL GPL(IO,XO,CURVE3)
      CALL GSPLCI(1)
      CALL FRAME
C
      CALL GDAWK(IWKID)
      CALL GCLWK(IWKID)
      CALL GCLKS
C
      RETURN
      END
      SUBROUTINE BKGFT1(YPOS,LABEL,YB,YT)
C
C  This subroutine draws a background grid.
C
      DIMENSION XX(2),YY(2)
      CHARACTER*(*) LABEL
C
      CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
C
C  Plot the curve label using font 21 (Helvetica).
C
      CALL PCSETI('FN',21)
      CALL PLCHHQ(0.25,YPOS - 0.03,LABEL,0.025,0.,-1.)
      CALL SET(0.13,0.93,YPOS-0.2,YPOS,0.0,1., YB, YT, 1)
C
C  Draw a horizontal line at Y=0. using color index 2.
C
      XX(1) = 0.
      XX(2) = 1.
      YY(1) = 0.
      YY(2) = 0.
      CALL GSPLCI(2)
      CALL GPL(2,XX,YY)
      CALL GSPLCI(1)
C
C  Set Gridal parameters.
C
C
C   Set LTY to indicate that the Plotchar routine PLCHHQ should be used.
C
      CALL GASETI('LTY',1)
C
C   Size and format for X axis labels.
C
      CALL GASETR('XLS',0.02)
      CALL GASETC('XLF','(F3.1)')
C
C   Size and format for Y axis labels.
C
      CALL GASETR('YLS',0.02)
      CALL GASETC('YLF','(F5.1)')
C
C   Length of major tick marks for the X and Y axes.
C
      CALL GASETR('XMJ',0.02)
      CALL GASETR('YMJ',0.02)
C
      RETURN
      END


program test_ArraySort

  use fsystem
  use ArraySort

  integer(I32), parameter :: nindex = 3
  integer(I32), parameter :: nnode = 100

  integer(I32), dimension(nindex, nnode) :: Ielem
  integer(I32) :: iindex, inode
  real(DP) :: tmp

  call RANDOM_SEED

  do inode=1, nnode
    do iindex=1, nindex
      call random_number(tmp)
      Ielem(iindex,inode) = int (tmp*100,I32)
    end do
    print *, Ielem(:,inode)
  end do

  do iindex=1, nindex
    print *, ''
    print *, 'Sort by index:',iindex
    call arraySort_sortByIndex(Ielem,iindex,nnode,nindex,SORT_STABLE)
    do inode=1, nnode
      print *, Ielem(:,inode)
    end do
  end do

end program


! { dg-do run }

module e_51_4_mod
contains
  subroutine init (v1, v2, N)
    integer :: i, N
    real :: v1(N), v2(N)
    do i = 1, N
      v1(i) = i + 2.0
      v2(i) = i - 3.0
    end do
  end subroutine

  subroutine check (p, N)
    integer :: i, N
    real, parameter :: EPS = 0.00001
    real :: diff, p(N)
    do i = 1, N
      diff = p(i) - (i + 2.0) * (i - 3.0)
      if (diff > EPS .or. -diff > EPS) call abort
    end do
  end subroutine

  subroutine foo (p, v1, v2, N)
    real, pointer, dimension(:) :: p, v1, v2
    integer :: N
    call init (v1, v2, N)
    !$omp target data map(to: v1, v2) map(from: p)
      call vec_mult (p, v1, v2, N)
    !$omp end target data
    call check (p, N)
  end subroutine

  subroutine vec_mult (p, v1, v2, N)
    real, pointer, dimension(:) :: p, v1, v2
    integer :: i, N
    !$omp target map(to: v1, v2) map(from: p)
      !$omp parallel do
      do i = 1, N
        p(i) = v1(i) * v2(i)
      end do
    !$omp end target
  end subroutine
end module

program e_51_4
  use e_51_4_mod, only : foo
  integer :: n
  real, pointer, dimension(:) :: p, v1, v2
  n = 1000
  allocate (p(n), v1(n), v2(n))
  call foo (p, v1, v2, n)
  deallocate (p, v1, v2)
end program


!> @brief ZAXPY3 3D point-wise operator performing Z = a*X + Y (scalar a)
!>
!> ZAXPY3 performs Z = a*X + Y where a is a double precision scalar and
!> inputs @em x, @em y and output @em z are each three-dimensional arrays.
!> The kernel operates on the rectangular interval specified by
!> @em {ijk}min, @em {ijk}max
!> The size of the input and output arrays are
!> specified by @em (m,n,l)
!>
!> @param m - const long integer indicating size in I direction
!> @param n - const long integer indicating size in J direction
!> @param l - const long integer indicating size in K direction
!> @param imin - const long integer indicating Region of Interest (ROI) in I direction
!> @param imax - const long integer indicating Region of Interest (ROI) in I direction
!> @param jmin - const long integer indicating Region of Interest (ROI) in J direction
!> @param jmax - const long integer indicating Region of Interest (ROI) in J direction
!> @param kmin - const long integer indicating Region of Interest (ROI) in K direction
!> @param kmax - const long integer indicating Region of Interest (ROI) in K direction
!> @param a - const double precision input scalar
!> @param x - const double precision input array
!> @param y - const double precision input array
!> @param z - double precision output array
subroutine zaxpy3(m,n,l,imin,imax,jmin,jmax,kmin,kmax,a,x,y,z)

  implicit none

  ! === Input & Parameters ===
  integer*8 :: m,n,l
  integer*8 :: imin,imax,jmin,jmax,kmin,kmax
  real*8    :: a,x(m,n,l),y(m,n,l)
  ! === Output ===
  real*8    :: z(m,n,l)

  ! === Local ===
  integer*8 :: i, j, k

  do k = kmin,kmax
     do j = jmin, jmax
        do i = imin, imax
           z(i,j,k) = y(i,j,k) + a*x(i,j,k)
        end do
     end do
  end do

end subroutine zaxpy3


      SUBROUTINE ITER(CHI,PHI,EPS,PI)
C     21 JAN 93    SP  PORTED TO UNIX
C	5/21/83 -JAM- CONVERT VAX
C     16 JAN 78    ...JJL...   INITIAL RELEASE
C  GET PHI FROM CHI
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      VAL(EPS,PHIL)=((1.D0+EPS*DSIN(PHIL))/(1.D0-EPS*DSIN(PHIL)))**
     * (EPS/2.D0)
C==================================================================
      A=DTAN(PI/4.D0+CHI/2.D0)
      Q=A*VAL(EPS,CHI)
      PHIL=2.D0*(DATAN(Q)-PI/4.D0)
10    Q=A*VAL(EPS,PHIL)
      PHI =2.D0*(DATAN(Q)-PI/4.D0)
      IF(DABS(PHI-PHIL).LT.1.D-7) RETURN
      PHIL=PHI
      GO TO 10
      END


submodule(mini_test) mini_test_is_close

contains

    elemental module function is_close_rsp(a, b, rtol, atol) result(bool)
        real(sp), intent(in) :: a, b
        real(sp), intent(in), optional  :: rtol, atol
        logical :: bool

        bool = abs(a - b) <= abs(optval(rtol, 1.0e-5_sp)*b) + &
                             abs(optval(atol, 1.0e-8_sp))

    end function is_close_rsp
    elemental module function is_close_rdp(a, b, rtol, atol) result(bool)
        real(dp), intent(in) :: a, b
        real(dp), intent(in), optional  :: rtol, atol
        logical :: bool

        bool = abs(a - b) <= abs(optval(rtol, 1.0e-5_dp)*b) + &
                             abs(optval(atol, 1.0e-8_dp))

    end function is_close_rdp
    elemental module function is_close_rqp(a, b, rtol, atol) result(bool)
        real(qp), intent(in) :: a, b
        real(qp), intent(in), optional  :: rtol, atol
        logical :: bool

        bool = abs(a - b) <= abs(optval(rtol, 1.0e-5_qp)*b) + &
                             abs(optval(atol, 1.0e-8_qp))

    end function is_close_rqp

    elemental module function is_close_csp(a, b, rtol, atol) result(bool)
        complex(sp), intent(in) :: a, b
        real(sp), intent(in), optional  :: rtol, atol
        logical :: bool

        bool = is_close_rsp(real(a),  real(b),  rtol, atol) .and. &
               is_close_rsp(aimag(a), aimag(b), rtol, atol)

    end function is_close_csp
    elemental module function is_close_cdp(a, b, rtol, atol) result(bool)
        complex(dp), intent(in) :: a, b
        real(dp), intent(in), optional  :: rtol, atol
        logical :: bool

        bool = is_close_rdp(real(a),  real(b),  rtol, atol) .and. &
               is_close_rdp(aimag(a), aimag(b), rtol, atol)

    end function is_close_cdp
    elemental module function is_close_cqp(a, b, rtol, atol) result(bool)
        complex(qp), intent(in) :: a, b
        real(qp), intent(in), optional  :: rtol, atol
        logical :: bool

        bool = is_close_rqp(real(a),  real(b),  rtol, atol) .and. &
               is_close_rqp(aimag(a), aimag(b), rtol, atol)

    end function is_close_cqp

end submodule mini_test_is_close


        subroutine idd_poweroftwo(m,l,n)
c
c       computes l = floor(log_2(m)) and n = 2**l.
c
c       input:
c       m -- integer whose log_2 is to be taken
c
c       output:
c       l -- floor(log_2(m))
c       n -- 2**l
c
        implicit none
        integer l,m,n
c
c
        l = 0
        n = 1
c
 1000   continue
          l = l+1
          n = n*2
        if(n .le. m) goto 1000
c
        l = l-1
        n = n/2
c
c
        return
        end


program sierpinski
    use, intrinsic :: iso_fortran_env, only : DP => REAL64, error_unit
    implicit none
    integer, parameter :: NR_POINTS = 3
    integer :: nr_iters = 100000
    real(kind=DP), dimension(NR_POINTS, 2) :: edge_points
    real(kind=DP), dimension(2) :: point
    integer :: iter, nr_edge

    nr_iters = get_nr_iters()
    call init_random_seed()
    call init_edge_points(edge_points)
    call init_point(point)
    do iter = 1, nr_iters
        nr_edge = get_edge(NR_POINTS)
        call move(point, edge_points, nr_edge)
        print *, point
    end do

contains

    function get_nr_iters() result(nr_iters)
        use, intrinsic :: iso_fortran_env, only : error_unit
        implicit none
        integer :: nr_iters
        character(len=1024) :: buffer

        if (command_argument_count() < 1) then
            write(unit=error_unit, fmt='(A)') &
                'error: number of iterations expected'
            stop 1
        end if
        call get_command_argument(1, buffer)
        read (buffer, fmt=*) nr_iters
    end function get_nr_iters

    subroutine init_random_seed()
        implicit none
        integer :: i, n, clock
        integer, dimension(:), allocatable :: seed

        call random_seed(size = n)
        allocate(seed(n))
        call system_clock(count=clock)
        seed = clock + 37 * [ (i - 1, i = 1, n) ]
        call random_seed(put=seed)
        deallocate(seed)
    end subroutine init_random_seed

    subroutine init_edge_points(points)
        implicit none
        real(kind=DP), dimension(:, :), intent(out) :: points
        points(1, 1) = 0.0_DP
        points(1, 2) = 0.0_DP
        points(2, 1) = 0.5_DP
        points(2, 2) = 1.0_DP
        points(3, 1) = 1.0_DP
        points(3, 2) = 0.0_DP
    end subroutine init_edge_points

    subroutine init_point(point)
        implicit none
        real(kind=DP), dimension(2), intent(out) :: point

        call random_number(point(1))
        call random_number(point(2))
    end subroutine init_point

    function get_edge(nr_edges) result(edge)
        implicit none
        integer, value :: nr_edges
        integer :: edge
        real(kind=DP) :: r

        call random_number(r)
        edge = 1 + int(nr_edges*r)
    end function get_edge

    subroutine move(point, edge_points, nr_edge)
        implicit none
        real(kind=DP), dimension(2), intent(inout) :: point
        real(kind=DP), dimension(:, :), intent(in) :: edge_points
        integer, value :: nr_edge

        point(1) = point(1) + (edge_points(nr_edge, 1) - point(1))/2.0_DP
        point(2) = point(2) + (edge_points(nr_edge, 2) - point(2))/2.0_DP
    end subroutine move

end program sierpinski


      subroutine fpsysy(a,n,g)
c subroutine fpsysy solves a linear n x n symmetric system
c    (a) * (b) = (g)
c on input, vector g contains the right hand side ; on output it will
c contain the solution (b).
c  ..
c  ..scalar arguments..
      integer n
c  ..array arguments..
      real a(6,6),g(6)
c  ..local scalars..
      real fac
      integer i,i1,j,k
c  ..
      g(1) = g(1)/a(1,1)
      if(n.eq.1) return
c  decomposition of the symmetric matrix (a) = (l) * (d) *(l)'
c  with (l) a unit lower triangular matrix and (d) a diagonal
c  matrix
      do 10 k=2,n
         a(k,1) = a(k,1)/a(1,1)
  10  continue
      do 40 i=2,n
         i1 = i-1
         do 30 k=i,n
            fac = a(k,i)
            do 20 j=1,i1
               fac = fac-a(j,j)*a(k,j)*a(i,j)
  20        continue
            a(k,i) = fac
            if(k.gt.i) a(k,i) = fac/a(i,i)
  30     continue
  40  continue
c  solve the system (l)*(d)*(l)'*(b) = (g).
c  first step : solve (l)*(d)*(c) = (g).
      do 60 i=2,n
         i1 = i-1
         fac = g(i)
         do 50 j=1,i1
            fac = fac-g(j)*a(j,j)*a(i,j)
  50     continue
         g(i) = fac/a(i,i)
  60  continue
c  second step : solve (l)'*(b) = (c)
      i = n
      do 80 j=2,n
         i1 = i
         i = i-1
         fac = g(i)
         do 70 k=i1,n
            fac = fac-g(k)*a(k,i)
  70     continue
         g(i) = fac
  80  continue
      return
      end


!---------------------------------------------------!
! Copyright (c) 2017 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
subroutine single_particle_GS
  use global_variables
  use timer
  implicit none
  integer,parameter :: Ncg_t = 500
! CG
  real(dp),allocatable :: xvec(:),pvec(:),rvec(:)
  real(dp),allocatable :: hxvec(:),gvec(:),hpvec(:)

  real(dp) :: xx,pp,xp,xhx,php,xhp,esp,esp_res,gg,gg0
  real(dp) :: ss,lambda,alpha,beta,aa,bb,cc

  integer :: ix, icg
  real(dp) :: rnd

  real(8) :: time_ini,time_end,time_elapse

  call elapse_time(time_ini)

  allocate (wfn_sp(0:Nx))
  allocate( xvec(0:Nx),pvec(0:Nx),rvec(0:Nx) )
  allocate( hxvec(0:Nx),gvec(0:Nx),hpvec(0:Nx) )

  do ix = 0,Nx
    call random_number(rnd)
    wfn_sp(ix) = rnd
  end do

  ss = sum(wfn_sp(:)**2)*dx
  wfn_sp(:) = wfn_sp(:)/sqrt(ss)

  xvec(:) = wfn_sp(:)
  call hpsi_sp(xvec,hxvec,v_ext)
  xx=sum(xvec(:)**2)*dx
  xhx=sum(xvec(:)*hxvec(:))*dx
  lambda=xhx/xx

  do icg = 1, Ncg_t
    gvec(:)=2d0*(hxvec(:)-lambda*xvec(:))/xx

    gg0=sum(gvec(:)**2)*dx
    select case(icg)
    case(1)
      pvec(:)=-gvec(:)
    case default
      beta=gg0/gg
      pvec(:)=-gvec(:)+beta*pvec(:)
    end select
    gg=gg0

    call hpsi_sp(pvec,hpvec,v_ext)

    pp=sum(pvec(:)**2)*dx
    php=sum(pvec(:)*hpvec(:))*dx
    xp=sum(xvec(:)*pvec(:))*dx
    xhp=sum(hxvec(:)*pvec(:))*dx

    aa=php*xp-xhp*pp
    bb=php*xx-xhx*pp
    cc=xhp*xx-xhx*xp
    ss=bb**2-4d0*aa*cc
    if(ss > 0d0)then
      alpha=(-bb+sqrt(ss))/(2d0*aa)
    else
      exit
    end if

    xvec(:)=xvec(:)+alpha*pvec(:)

    call hpsi_sp(xvec,hxvec,v_ext)
    xx=sum(xvec(:)**2)*dx
    xhx=sum(xvec(:)*hxvec(:))*dx
    lambda=xhx/xx

    write(*,'(I7,2x,3e26.16e3)')icg-1,lambda,sum((hxvec(:)-lambda*xvec(:))**2)*dx
  end do

  xx=sum(xvec(:)**2)*dx
  wfn_sp(:) = xvec(:)/sqrt(xx)

  call elapse_time(time_end)
  time_elapse = time_end - time_ini
  write(*,"(A,2x,e16.6e3,A)")'Elapse time for single_particle_GS',time_elapse,"[sec]"

end subroutine single_particle_GS


      SUBROUTINE  BLOMARF( ZS,N,ID,C,LAG,NS0,KMAX,ZMEAN,ZVARI,BW,AIC,A,
cxx     *                     E,AICB,LKS,LKE )
     *                     E,AICB,LKS,LKE,M )
C

C
cc      PROGRAM  BLOMAR
C.......................................................................
C.....PLANNED BY H.AKAIKE...............................................
C.....DESIGNED BY H.AKAIKE AND G.KITAGAWA...............................
C.....PROGRAMMED BY G.KITAGAWA AND F.TADA...............................
C.....ADDRESS: THE INSTITUTE OF STATISTICAL MATHEMATICS, 4-6-7 MINAMI-AZ
C..............MINATO-KU, TOKYO 106, JAPAN..............................
C.....DATE OF THE LATEST REVISION:  MAR. 6,1979.........................
C.......................................................................
C.....THIS PROGRAM WAS ORIGINALLY PUBLISHED IN "TIMSAC-78", BY H.AKAIKE,
C.....G.KITAGAWA, E.ARAHATA AND F.TADA, COMPUTER SCIENCE MONOGRAPHS, NO.
C.....THE INSTITUTE OF STATISTICAL MATHEMATICS, TOKYO, 1979.............
C.......................................................................
C     TIMSAC 78.3.4.
C     _                  __                 _            __
C     BAYESIAN METHOD OF LOCALLY STATIONARY MULTIVARIATE AR MODEL FITTIN
C
C     THIS PROGRAM LOCALLY FITS MULTI-VARIATE AUTOREGRESSIVE MODELS TO
C     NON-STATIONARY TIME SERIES BY A BAYESIAN PROCEDURE.
C
C       ---------------------------------------------------------------
C       REFERENCES:
C          G.KITAGAWA AND H.AKAIKE(1978), "A PROCEDURE FOR THE MODELING
C          OF NON-STATIONARY TIME SERIES.",  ANN. INST. STATIST. MATH.,
C          30,B,351-363.
C          H.AKAIKE(1978), "A BAYESIAN EXTENSION OF THE MINIMUM AIC
C          PROCEDURE OF AUTOREGRESSIVE MODEL FITTING.",  RESEARCH MEMO.
C          NO. 126, THE INSTITUTE OF STATISTICAL MATHEMATICS; TOKYO.
C       ---------------------------------------------------------------
C       THE FOLLOWING SUBROUTINES ARE DIRECTLY CALLED BY THIS PROGRAM:
C             MRDATA
C             MNONSB
C       ---------------------------------------------------------------
C       INPUTS REQUIRED;
C          MT:    INPUT DEVICE FOR ORIGINAL DATA (MT=5: CARD READER).
C          LAG:   UPPER LIMIT OF THE ORDER OF AR-MODEL, MUST BE LESS THA
C                 OR EQUAL TO 50.
C          NS:    LENGTH OF BASIC LOCAL SPAN.
C          KSW:   =0  CONSTANT VECTOR IS NOT INCLUDED AS A REGRESSOR
C                 =1  CONSTANT VECTOR IS INCLUDED AS THE FIRST REGRESSOR
C
C            -- THE FOLLOWING INPUTS ARE REQUESTED BY SUBROUTINE MRDATA
C          TITLE: SPECIFICATION OF DATA
C          N:     DATA LENGTH, MUST BE LESS THAN OR EQUAL TO 1000.
C          ID:    DIMENSION OF DATA,  MUST BE LESS THAN 6
C                       < ID*(LAG+1)+KSW MUST BE LESS THAN 101 >
C          IFM:   INPUT FORMAT
C          FORM:  INPUT DATA FORMAT SPECIFICATION STATEMENT.
C                 -- EXAMPLE --     (8F10.5)
C          C(J):  CALIBRATION CONSTANT FOR CHANNEL J (J=1,ID)
C          Z(I,J): ORIGINAL DATA
C            -----------------------------------------------------------
C
cc      !DEC$ ATTRIBUTES DLLEXPORT :: BLOMARF
C
cxx      IMPLICIT  REAL * 8  ( A-H , O-Z )
CC      REAL * 4  Z
cc      DIMENSION  Z(1500,10)
cc      DIMENSION  X(200,100) , D(200)
cc      DIMENSION  A(10,10,50) , B(10,10,50)
cc      DIMENSION  G(10,10,50) , H(10,10,50) , E(10,10)
cxx      DIMENSION  ZS(N,ID), Z(N,ID), C(ID)
cxx      DIMENSION  ZMEAN(ID), ZVARI(ID)
cxx      DIMENSION  A(ID,ID,LAG,KMAX) , B(ID,ID,LAG)
cxx      DIMENSION  G(ID,ID,LAG) , H(ID,ID,LAG) , E(ID,ID,KMAX)
cxx      DIMENSION  BW(KMAX,KMAX), AIC(KMAX,KMAX)
cxx      DIMENSION  AICB(KMAX), LKS(KMAX), LKE(KMAX)
cxx      DIMENSION  F1(LAG*ID,ID,KMAX), F2(LAG*ID,ID,KMAX)
cxxcxx      DIMENSION  X(NS0+LAG+1,(LAG+1)*ID)
cxx      DIMENSION  X((LAG+1)*ID*2,(LAG+1)*ID)
      INTEGER :: N, ID, LAG, NS0, KMAX, LKS(KMAX), LKE(KMAX), M
      REAL(8) :: ZS(N,ID), C(ID), ZMEAN(ID), ZVARI(ID),
     1           BW(KMAX,KMAX), AIC(KMAX,KMAX), A(ID,ID,LAG,KMAX),
     2           E(ID,ID,KMAX), AICB(KMAX)
      REAL(8) :: Z(N,ID), B(ID,ID,LAG), G(ID,ID,LAG), H(ID,ID,LAG),
     1           F1(LAG*ID,ID,KMAX), F2(LAG*ID,ID,KMAX),
     2           X((LAG+1)*ID*2,(LAG+1)*ID)
C
C       PARAMETERS:
C          MJ:    ABSOLUTE DIMENSION FOR SUBROUTINE CALL
C          MJ1:   ABSOLUTE DIMENSION FOR SUBROUTINE CALL
C          MJ2:   ABSOLUTE DIMENSION FOR SUBROUTINE CALL
C          MJ3:   ABSOLUTE DIMENSION FOR SUBROUTINE CALL
C
cc      CHARACTER(100) IFLNAM,OFLNAM
cc      CALL FLNAM2( IFLNAM,OFLNAM,NFL )
cc      IF (NFL.EQ.0) GO TO 999
cc      IF (NFL.EQ.2) THEN
cc         OPEN( 6,FILE=OFLNAM,ERR=900,IOSTAT=IVAR)
cc      ELSE
cc         CALL SETWND
cc      END IF
C
cc      MJ = 1500
cc      MJ1 = 200
cc      MJ3 = 10
cc      KMAX = 10
      MJ = N
cxx      MJ1 = NS0+LAG+1
      MJ1 = (LAG+1)*ID*2
      MJ3 = ID
      KSW = 0
C
      BW(1:KMAX,1:KMAX) = 0.0D0
      AIC(1:KMAX,1:KMAX) = 0.0D0
      A(1:ID,1:ID,1:LAG,1:KMAX) = 0.0D0
      E(1:ID,1:ID,1:KMAX) = 0.0D0
      AICB(1:KMAX) = 0.0D0
      LKS(1:KMAX) = 0
      LKE(1:KMAX) = 0
      F1(1:LAG*ID,1:ID,1:KMAX) = 0.0D0
      F2(1:LAG*ID,1:ID,1:KMAX) = 0.0D0
      X(1:MJ1,1:(LAG+1)*ID) = 0.0D0
C
CC      READ( 5,1 )     MT
cc      MT = 5
cc      OPEN( MT,FILE=IFLNAM,ERR=910,IOSTAT=IVAR,STATUS='OLD' )
cc      READ( 5,1 )     LAG , NS
      NS = NS0
C
cc      WRITE( 6,2 )
cc      WRITE( 6,4 )
cc      WRITE( 6,3 )     LAG , NS , MT
C
cc      CALL  MRDATA( MT,MJ,Z,N,ID )
      CALL MRDATA( ZS,Z,N,ID,C,ZMEAN,ZVARI )
cc      CLOSE( MT )
C
      L = 0
      KD = LAG * ID + KSW
      MX = KD * 2
      KC = 0
C
C
      M = 0
  111 CONTINUE
cxx      M = M+1
      LK = L + LAG
      LK1 = LK + 1
      IF( LK1 .GE. N )     GO TO 300
      M = M+1
      IF( N-LK1 .LE. NS )     NS = N - LK
      IF( N-LK1-NS .LT. MX )     NS = N - LK
C
cc      CALL MNONSB( Z,X,D,G,H,E,KSW,LAG,L,NS,ID,KMAX,MJ,MJ1,MJ3,A,B,AIC )
cxx      CALL MNONSB( Z,G,H,E(1,1,M),KSW,LAG,L,NS,ID,KMAX,KC,MJ,MJ1,MJ3,
cxx     *             BW(1,M),AIC(1,M),A(1,1,1,M),B,AICB(M),F1,F2 )
      CALL MNONSB( Z,X,G,H,E(1,1,M),KSW,LAG,L,NS,ID,KMAX,KC,MJ,MJ1,
     *             MJ3,BW(1,M),AIC(1,M),A(1,1,1,M),B,AICB(M),F1,F2 )
C
      L = L + NS
C
cc      LKE = LK + NS
      LKE(M) = LK + NS
      MF = LAG
cc      WRITE( 6,13 )
cc      WRITE( 6,16 )
cc      WRITE( 6,14 )     LK1 , LKE
      LKS(M) = LK1
cc      DO 10  I=1,MF
cc      WRITE( 6,16 )
cc      DO 10  II=1,ID
cc      WRITE( 6,15 )     (A(II,JJ,I),JJ=1,ID)
cc      IF( II .EQ. 1 )     WRITE( 6,17 )   I
cc      IF( II .NE. 1 )     WRITE( 6,21 )
cc   10 CONTINUE
cc      WRITE( 6,16 )
cc      WRITE( 6,19 )     MF , AIC
cc      WRITE( 6,16 )
cc      WRITE( 6,12 )
cc      DO 20  I=1,ID
cc      WRITE( 6,11 )     (E(I,J),J=1,ID)
cc   20 WRITE( 6,17 )     I
cc      WRITE( 6,16 )
cc      WRITE( 6,18 )
C
      GO TO 111
  300 CONTINUE
cc      GO TO 999
C
cc  900 CONTINUE
cc      WRITE(6,600) IVAR,OFLNAM
cc      GO TO 999
C
cc  910 CONTINUE
cc      IF (NFL.EQ.2) CLOSE( 6 )
cc#ifdef __linux__
ccC	reopen #6 as stdout
cc      IF (NFL.EQ.2) OPEN(6, FILE='/dev/fd/1')
cc#endif
ccC /* __linux__ */
ccWRITE(6,610) IVAR,IFLNAM
ccC
cxx  600 FORMAT(/,' !!! Output_Data_File OPEN ERROR ',I8,//,5X,100A)
cxx  610 FORMAT(/,' !!! Input_Data_File OPEN ERROR ',I8,//,5X,100A)
C
cc  999 CONTINUE
      RETURN
cxx    1 FORMAT( 16I5 )
cxx    2 FORMAT( 1H ,'PROGRAM TIMSAC 78.3.4',//,'   BAYESIAN METHOD OF LOCA
cxx     *LLY STATIONARY MULTIVARIATE AR MODEL FITTING;',//,'  < BASIC AUTOR
cxx     *EGRESSIVE MODEL >' )
cxx    3 FORMAT( //,1H ,'  UPPER LIMIT OF THE ORDER  K =',I3,/,'   BASIC LO
cxx     1CAL SPAN LENGTH  NS =',I4,/,'   ORIGINAL DATA INPUT DEVICE  MT =',
cxx     2I3 )
cxx    4 FORMAT( //1H ,10X,'Z(N) = A1*Z(N-1) + A2*Z(N-2) + ... + AK*Z(N-K)
cxx     1+ W(N)',/,1H ,'  WHERE',/,11X,'K:     ORDER OF THE MODEL',/,11X,
cxx     2'W(N):  INNOVATION' )
cxx   11 FORMAT( 1H ,18X,5D15.5 )
cxx   12 FORMAT( 1H ,10X,1H.,6X,'INNOVATION VARIANCE MATRIX',53X,1H. )
cxx   13 FORMAT( 1H ,//11X,35(1H.),'  CURRENT MODEL  ',35(1H.) )
cxx   14 FORMAT( 1H ,10X,1H.,6X,'M',7X,'AM(I,J)',30X,'DATA  Z(K,.); K=',I5,
cxx     11H,,I5,7X,1H. )
cxx   15 FORMAT( 1H ,18X,5F15.8 )
cxx   16 FORMAT( 1H ,10X,1H.,85X,1H. )
cxx   17 FORMAT( 1H+,10X,1H.,I7,78X,1H. )
cxx   18 FORMAT( 1H ,10X,87(1H.) )
cxx   19 FORMAT( 1H ,10X,1H.,6X,'ORDER =',I5,67X,1H.,/,11X,1H.,6X,'AIC =',
cxx     1 F15.3,59X,1H. )
cxx   21 FORMAT( 1H+,10X,1H.,85X,1H. )
      END
cc      SUBROUTINE  MNONSB( Z,X,D,G,H,E,KSW,LAG,N0,NS,ID,KMAX,MJ,MJ1,MJ3,A
cc     *,B,AICB )
cxx      SUBROUTINE  MNONSB( Z,G,H,E,KSW,LAG,N0,NS,ID,KMAX1,KC,MJ,MJ1,MJ3,
cxx     *                    C,AIC,A,B,AICB,F1,F2 )
      SUBROUTINE  MNONSB( Z,X,G,H,E,KSW,LAG,N0,NS,ID,KMAX1,KC,MJ,MJ1,
     *                    MJ3,C,AIC,A,B,AICB,F1,F2 )
C       ----------------------------------------------------------------
C       THE FOLLOWING SUBROUTINES ARE DIRECTLY CALLED BY THIS SUBROUTINE
C             DMIN
C             BAYSWT
C             MARCOF
C             MBYSAR
C             MREDCT
C             MSDCOM
C       ----------------------------------------------------------------
C
C       INPUTS:
C          Z:     ORIGINAL DATA; Z(K,I) (K=1,N) REPRESENTS THE RECORD OF
C                 THE I-TH CHANNEL
C          X:     WORKING AREA
C          D:     WORKING AREA
C          G:     WORKING AREA (PARTIAL AUTOREGRESSION COEFFICIENT MATRI
C                 FORWARD MODEL)
C          H:     WORKING AREA (PARTIAL AUTOREGRESSION COEFFICIENT MATRI
C                 BACKWARD MODEL)
C          E:     WORKING AREA
C          KSW:   =0   CONSTATNT VECTOR IS NOT INCLUDED AS A REGRESSOR
C                 =1   CONSTANT VECTOR IS INCLUDED AS THE FIRST REGRESSO
C          LAG:   UPPER LIMIT OF THE ORDER OF AR-MODEL
C          N0:    INDEX OF THE END POINT OF THE FORMER SPAN
C          NS:    LENGTH OF BASIC LOCAL SPAN
C          ID:    DIMENSION OF DATA
C          KMAX:  MAXIMUM NUMBER OF PRECEDING MODELS STORED
C          MJ:    ABSOLUTE DIMENSION OF Z IN THE MAIN PROGRAM
C          MJ1:   ABSOLUTE DIMENSION OF X IN THE MAIN PROGRAM
C          MJ3:   ABSOLUTE DIMENSION OF A AND B IN THE MAIN PROGRAM
C
C       OUTPUTS:
C          A:     AUTOREGRESSIVE COEFFICIENT MATRIX OF FORWARD MODEL
C          B:     AUTOREGRESSIVE COEFFICIENT MATRIX OF BACKWARD MODEL
C          AICB:  AIC OF THE CURRENT MODEL
C
cxx      IMPLICIT  REAL *8  ( A-H , O-Z )
CC      REAL*4     Z(MJ,1) , F1(100,10,11) , F2(100,10,11)
cc      DIMENSION  X(MJ1,1) , D(1) , A(MJ3,MJ3,1) , B(MJ3,MJ3,1)
cx      DIMENSION  Z(MJ,1) , F1(LAG*ID,ID,KMAX1) , F2(LAG*ID,ID,KMAX1)
cx      DIMENSION  X(MJ1,(LAG+1)*ID), A(MJ3,MJ3,1) , B(MJ3,MJ3,1)
cx      DIMENSION  G(MJ3,MJ3,1) , H(MJ3,MJ3,1) , E(MJ3,1)
cc      DIMENSION  Y(100,10) , AIC(11) , C(11)
cxx      DIMENSION  Z(MJ,ID) , F1(LAG*ID,ID,KMAX1) , F2(LAG*ID,ID,KMAX1)
cxx      DIMENSION  X(MJ1,(LAG+1)*ID), A(MJ3,MJ3,LAG) , B(MJ3,MJ3,LAG)
cxx      DIMENSION  G(MJ3,MJ3,LAG) , H(MJ3,MJ3,LAG) , E(MJ3,ID)
cxx      DIMENSION  AIC(KMAX1) , C(KMAX1)
      INTEGER :: KSW, LAG, N0, NS, ID, KMAX1, KC, MJ, MJ1, MJ3
      REAL(8) :: Z(MJ,ID), X(MJ1,(LAG+1)*ID), G(MJ3,MJ3,LAG),
     1           H(MJ3,MJ3,LAG), E(MJ3,ID), C(KMAX1), AIC(KMAX1),
     2           A(MJ3,MJ3,LAG), B(MJ3,MJ3,LAG), AICB,
     3           F1(LAG*ID,ID,KMAX1), F2(LAG*ID,ID,KMAX1)
cc      DATA     KC  / 0 /
C
cxx      DIMENSION  SD1(LAG+1), AIC1(LAG+1), DIC1(LAG+1)
cxx      DIMENSION  BW1(LAG+1), BW2(LAG)
      REAL(8) :: SD1(LAG+1), AIC1(LAG+1), DIC1(LAG+1),
     1           BW1(LAG+1), BW2(LAG), AICM, EK, SD, SDMIN
C
      KMAX = KMAX1-1
cc      MJ5 = 100
      IPR = 0
      KD = LAG * ID
C          -----------------------------------------------
C          NEW DATA LOADING AND HOUSEHOLDER TRANSFORMATION
C          -----------------------------------------------
cc      CALL  MREDCT( Z,D,NS,N0,LAG,ID,MJ,MJ1,KSW,X )
      CALL  MREDCT( Z,NS,N0,LAG,ID,MJ,MJ1,KSW,X )
C
C          -------------------------------------
C          BAYESIAN MODEL FITTED TO THE NEW SPAN
C          -------------------------------------
cc      CALL  MBYSAR( X,D,NS,LAG,ID,KSW,IPR,MJ1,MJ3,A,B,G,H,E,AICB,EK )
cxx      CALL  MBYSAR( X,NS,LAG,ID,KSW,IPR,MJ1,MJ3,SD1,AIC1,DIC1,
      CALL  MBYSAR( X,NS,LAG,ID,KSW,MJ1,MJ3,SD1,AIC1,DIC1,
     *              AICM,SDMIN,IMIN,BW1,BW2,A,B,G,H,E,AICB,EK )
C
      IF( KC .EQ. 0 )  GO TO 20
C          -----------------------------
C          "PARCOR'S" SHIFTED AND STORED
C          -----------------------------
      KC1 = KC+1
cxx      DO 10  JJ=1,KC
      DO 12  JJ=1,KC
        II = KC1 - JJ
cxx        DO 10  I=1,KD
        DO 11  I=1,KD
        DO 10  J=1,ID
      F1(I,J,II+1) = F1(I,J,II)
cxx   10 F2(I,J,II+1) = F2(I,J,II)
      F2(I,J,II+1) = F2(I,J,II)
   10 CONTINUE
   11 CONTINUE
   12 CONTINUE
   20 IM = 0
cxx      DO 30  II=1,LAG
cxx      DO 30  I=1,ID
      DO 32  II=1,LAG
      DO 31  I=1,ID
      IM = IM+1
      DO 30  J=1,ID
      F1(IM,J,1) = G(I,J,II)
cxx   30 F2(IM,J,1) = H(I,J,II)
      F2(IM,J,1) = H(I,J,II)
   30 CONTINUE
   31 CONTINUE
   32 CONTINUE
      IF( KC .EQ. 0 )  GO TO 100
C          ---------------------------------------------------------
C          PREDICTION ERROR VARIANCES AND AIC'S OF THE FORMER MODELS
C          ---------------------------------------------------------
      AIC(1) = AICB
      DO 50  JJ=1,KC
        IM = 0
cxx        DO 40  II=1,LAG
cxx        DO 40  I=1,ID
        DO 42  II=1,LAG
        DO 41  I=1,ID
          IM = IM+1
          DO 40  J=1,ID
        G(I,J,II) = F1(IM,J,JJ+1)
cxx   40   H(I,J,II) = F2(IM,J,JJ+1)
        H(I,J,II) = F2(IM,J,JJ+1)
   40     CONTINUE
   41   CONTINUE
   42   CONTINUE
C
        CALL  MARCOF( G,H,ID,LAG,MJ3,A,B )
cc      CALL  MSDCOM( X,A,Y,D,NS,LAG,ID,KSW,IPR,MJ1,MJ3,MJ5,E,SD )
cxx      CALL  MSDCOM( X,A,NS,LAG,ID,KSW,IPR,MJ1,E,SD )
      CALL  MSDCOM( X,A,NS,LAG,ID,KSW,MJ1,E,SD )
cxx   50 AIC(JJ+1) = NS*DLOG( SD ) + ID*(ID+1)
      AIC(JJ+1) = NS*DLOG( SD ) + ID*(ID+1)
   50 CONTINUE
C          ----------------------------------------
C          BAYESIAN WEIGHTS OF THE PRECEDING MODELS
C          ----------------------------------------
c-----------------------------  06/11/01
ccx      AICM = DMIN( AIC,KC )
      AICM = AIC(1)
      DO 55  I=1,KC
cxx   55 IF( AIC(I) .LT. AICM )  AICM = AIC(I)
      IF( AIC(I) .LT. AICM )  AICM = AIC(I)
   55 CONTINUE
c-----------------------------
      CALL  BAYSWT( AIC,AICM,KC,2,C )
cc      WRITE( 6,3 )     C(1) , AIC(1)
cc      DO 60  I=2,KC1
cc      IM1 = I-1
cc   60 WRITE( 6,4 )     IM1 , C(I) , AIC(I)
C
C          ------------------------
C          AVERAGING OF THE MODELS
C          -----------------------
      EK = EK*C(1)**2
cxx      DO 70  II=1,LAG
cxx      DO 70  I=1,ID
      DO 72  II=1,LAG
      DO 71  I=1,ID
      DO 70  J=1,ID
cxx   70 B(I,J,II) = A(I,J,II)*C(1)
      B(I,J,II) = A(I,J,II)*C(1)
   70 CONTINUE
   71 CONTINUE
   72 CONTINUE
cxx      DO 80  I=1,KD
      DO 81  I=1,KD
      DO 80  J=1,ID
      F1(I,J,1) = F1(I,J,1)*C(1)
cxx   80 F2(I,J,1) = F2(I,J,1)*C(1)
      F2(I,J,1) = F2(I,J,1)*C(1)
   80 CONTINUE
   81 CONTINUE
C
cxx      DO 90  JJ=1,KC
cxx        DO 90  I=1,KD
      DO 92  JJ=1,KC
        DO 91  I=1,KD
        DO 90  J=1,ID
        F1(I,J,1) = F1(I,J,1) + F1(I,J,JJ+1)*C(JJ+1)
cxx   90   F2(I,J,1) = F2(I,J,1) + F2(I,J,JJ+1)*C(JJ+1)
        F2(I,J,1) = F2(I,J,1) + F2(I,J,JJ+1)*C(JJ+1)
   90   CONTINUE
   91   CONTINUE
   92 CONTINUE
C          -----------------------------------------
C          PREDICTION ERROR VARIANCE MATRIX COMPUTED
C          -----------------------------------------
  100 IM = 0
      KC = KC + 1
      IF( KC .GT. KMAX )     KC = KMAX
cxx      DO 110  II=1,LAG
cxx      DO 110  I=1,ID
      DO 112  II=1,LAG
      DO 111  I=1,ID
        IM = IM+1
        DO 110  J=1,ID
        G(I,J,II) = F1(IM,J,1)
cxx  110   H(I,J,II) = F2(IM,J,1)
        H(I,J,II) = F2(IM,J,1)
  110   CONTINUE
  111 CONTINUE
  112 CONTINUE
C
      CALL  MARCOF( G,H,ID,LAG,MJ3,A,B )
cc      CALL  MSDCOM( X,A,Y,D,NS,LAG,ID,KSW,IPR,MJ1,MJ3,MJ5,E,SD )
cxx      CALL  MSDCOM( X,A,NS,LAG,ID,KSW,IPR,MJ1,E,SD )
      CALL  MSDCOM( X,A,NS,LAG,ID,KSW,MJ1,E,SD )
      AICB = NS*DLOG( SD ) + 2.D0*(EK + KSW*ID) + ID*(ID+1)
C
      RETURN
cxx    3 FORMAT( ///1H ,13X,'AR-MODEL FITTED TO  !  BAYESIAN WEIGHTS  ! AIC
cxx     1 WITH RESPECT TO THE PRESENT DATA',/,10X,83(1H-),/,1H ,11X,'CURREN
cxx     2T BLOCK',9X,'!',F13.5,7X,'!',F21.3 )
cxx    4 FORMAT( 1H ,6X,I5,' PERIOD FORMER BLOCK  !',F13.5,7X,'!',F21.3 )
      E N D


      INCLUDE 'VICMAIN_FOR'
      SUBROUTINE MAIN44
C
C                 VARIABLE DEFINITIONS
C
      CHARACTER*480 BUFFER
C==================================================================
      PI = 3.14159265
      REQ = 6378.15
      FL = 6356.76
      F = 0.5
      CPSI = 120.0
      ZC = 0.0
      ITYPE = 1
C
      RLAT = 500.0
      RLON = 500.0
C
      WRITE(BUFFER,100)ITYPE,RLAT,RLON,FLAG,ZC,CPSI,F,FL,
     1              REQ,PI
      CALL XVMESSAGE(' ',' ')
      CALL XVMESSAGE(BUFFER(2:80),' ')
      CALL XVMESSAGE(BUFFER(82:160),' ')
      CALL XVMESSAGE(BUFFER(162:240),' ')
      CALL XVMESSAGE(' ',' ')
C
      CALL CYLCAL(ITYPE,RLAT,RLON,ZC,CPSI,F,FL,REQ,PI,FLAG)
C
      WRITE(BUFFER,110)ITYPE,RLAT,RLON,FLAG,ZC,CPSI,F,FL,
     1              REQ,PI
      CALL XVMESSAGE(BUFFER(2:80),' ')
      CALL XVMESSAGE(BUFFER(81:160),' ')
      CALL XVMESSAGE(BUFFER(162:240),' ')
      CALL XVMESSAGE(' ',' ')
C
      ITYPE = 2
      CALL CYLCAL(ITYPE,RLAT,RLON,ZC,CPSI,F,FL,REQ,PI,FLAG)
C
      WRITE(BUFFER,120)ITYPE,RLAT,RLON,FLAG,ZC,CPSI,F,FL,
     1              REQ,PI
      CALL XVMESSAGE(BUFFER(2:80),' ')
      CALL XVMESSAGE(BUFFER(81:160),' ')
      CALL XVMESSAGE(BUFFER(162:240),' ')
      CALL XVMESSAGE(' ',' ')
C
      RETURN
  100 FORMAT(' INITIAL CONDITIONS FOR LINE/SAMPLE TO LAT/LONG:',
     1       32X,' ITYPE: ',I2,'  LINE:     ',F10.2,'  SAMPLE:    ',
     2       F10.2,'  FLAG: ',F10.2,7X,' ZC: ',F3.1,'  CPSI: ',F7.2,
     3       '  F: ',F5.2,'  FL: ',F8.1,'  REQ: ',F8.1,'  PI: ',F6.4,
     4       '   ')
  110 FORMAT(' AFTER CYLCAL CALL:',61X,
     1       'ITYPE: ',I2,'  LATITUDE: ',F10.2,'  LONGITUDE: ',F10.2,
     2       '  FLAG: ',F10.2,9X,'ZC: ',F3.1,'  CPSI: ',F7.2,'  F: ',
     3       F5.2,'  FL: ',F8.1,'  REQ: ',F8.1,'  PI: ',F6.4,5X)
  120 FORMAT(' AFTER CYLCAL CALL FOR LAT/LONG TO LINE/SAMPLE:',33X,
     1       'ITYPE: ',I2,'  LINE:     ',F10.2,'  SAMPLE:    ',F10.2,
     2       '  FLAG: ',F10.2,9X,'ZC: ',F3.1,'  CPSI: ',F7.2,'  F: ',
     3       F5.2,'  FL: ',F8.1,'  REQ: ',F8.1,'  PI: ',F6.4,5X)
      END


      real function hdepth(t2,x)
c
c     + + + PURPOSE + + +
c     Finds depth H on an overland flow element by solving the
c     partial differential equation:
c
c       h1+alpha*m*h**(m-1)*h2=s ,t and x non-negative    (1)
c
c    where:
c
c      h1    =  partial of h with respect to t,
c      h2    =  partial of h with respect to x,
c      alpha =  chezy depth-discharge coefficient,
c      m     =  chezy depth-discharge exponent,
c      s     =  step function with ns initial non-zero steps that
c               is zero after the last step, and h is zero when
c               either t or x is zero.
c
c XXX -- I cannot determine the structure of the equation being
c        discussed, from these comments. -- CRM 6/3/91.
c    Let phi(t) be psi(t,0), where psi(t,u) is defined to be the
c    integral from u to t with respect to l of the m-1th power of
c    ***the integral of s from time u to l.***
c XXX -- With respect to what variable?  S? TIME? -- CRM 6/3/91.
c    Psi(t,u) strictly decreases from
c    phi(t) to 0 for fixed t and for u between 0 and ***am1n(t,tstar)***
c XXX -- What does this mean? -- CRM 6/3/91.
c    (s>0 before tstar,s=0 after);  let psiinv(t,-) be the inverse
c    of psi(t,-). Then the general solution to (1) is given by:
c
c    for x >= x1, h(t,x)=integral of s from 0 to t             (2)
c    for x <= x1, h(t,x)=integral of s from psiinv(t,x2) to t  (3)
c
c    where x1 = alpha*m*phi(t) and x2 = x/(alpha*m).
c
c    Subroutine phi(-) computes phi, subroutine psiinv(t,-)
c    computes the inverse of psi(t,-), and subroutine sint(t)
c    computes the integral of s from 0 to t.
c
c
c     Called from HDRIVE
c     Author(s): Shirley, Stone
c     Reference in User Guide:
c
c     Changes:
c          1) SAVE, which saves all applicable local variables,
c             deleted.
c          2) Common block PASS never used.  It was de-referenced.
c          3) No parameters were used.  Their include files were
c             dereferenced.
c
c     Version: This module recoded from WEPP version 91.10.
c     Date recoded: 04/24/91.
c     Recoded by: Charles R. Meyer.
c
c     + + + KEYWORDS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
      real t2, x
c
c     + + + ARGUMENT DEFINITIONS + + +
c     t2     - current time
c     x      - length of equivalent plane
c
c     + + + COMMON BLOCKS + + +
c
      include 'cconsts.inc'
c       read: a1
c
c     + + + LOCAL VARIABLES + + +
      real xx
c
c     + + + LOCAL DEFINITIONS + + +
c     xx     - X/A1
c
c     + + + FUNCTION DECLARATIONS + + +
c     real phi, sint, psiinv
      real phi, psiinv
      double precision sint
c
c     + + + END SPECIFICATIONS + + +
c
      xx = x / a1
c
      if (xx.lt.phi(t2)) then
        hdepth = sint(t2) - sint(psiinv(t2,xx))
      else
        hdepth = sint(t2)
      end if
c
c     Following line inserted 12/11/92 to prevent hdepth from becoming
c     a negative number for test data set 45     dcf
c
      if (hdepth.lt.0.0) hdepth = 0.0
c
      return
      end


	SUBROUTINE SNDSPL ( nparms, np, nlvin, datain,
     +			    nlvout, hghts, dataout, iret )
C************************************************************************
C* SNDSPL								*
C* 									*
C* This subroutine fits a curve to a set of input points and then	*
C* evaluates the curve for values of x.  The input points must be	*
C* strictly monotonic in x:						*
C* 									*
C*     datain (1) < datain (2) < ... < datain (nlvin)			*
C*			or						*
C*     datain (1) > datain (2) > ... > datain (nlvin)			*
C* 									*
C* SNDSPL ( NPARMS, NP, NLVIN, DATAIN, NLVOUT, HGHTS, DATAOUT, IRET )	*
C* 									*
C* Input parameters:							*
C*	NPARMS		INTEGER		Number of parameters		*
C*	NP		INTEGER		Current parameter		*
C*	NLVIN		INTEGER		Number of levels in		*
C*	DATAIN (LLMXLV) REAL		Input sounding data		*
C*	NLVOUT		INTEGER		Number of levels out		*
C*	HGHTS (NLVOUT) 	REAL		Height levels			*
C* 									*
C* Output parameters:							*
C*	DATAOUT(LLMXLV)	REAL		Output sounding data		*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal			*
C**									*
C* Log:									*
C* S. Jacobs/SSAI	 4/92		Copied from GCURVE		*
C* J. Whistler/SSAI	 4/93		Cleaned up code			*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'ERROR.PRM'
	INCLUDE		'CURVE.CMN'
C*
	REAL		datain(*), dataout(*), hghts(*)
C*
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = 0
C
C*	Check for enough points.
C
	IF  ( ( nlvin .lt. 3 ) .or. ( nlvout .lt. 1 ) )
     +		iret = NOPNTS
	IF  ((nlvin .gt. MAXPTS) .or. (nlvout .gt. MAXPTS))
     +		iret = NIPNTS
	IF  ( iret .ne. NORMAL ) RETURN
C
C*	Move data into internal arrays sorted in increasing order.
C*	Return with error if data is not strictly monotonic.
C
	delx = datain(1*nparms+1) - datain(0*nparms+1)
	IF  ( delx .lt. 0. ) THEN
	    ibegin = nlvin
	    iend   = 1
	    inc    = -1
	ELSE
	    ibegin = 1
	    iend   = nlvin
	    inc    = 1
	END IF
C*
	x(1) = datain( (ibegin-1)*nparms +  1 )
	y(1) = datain( (ibegin-1)*nparms + np )
	nknt  = 1
	xx    = x (1)
	DO  i = ibegin+inc, iend, inc
	    tx = datain( (i-1)*nparms +  1 )
	    ty = datain( (i-1)*nparms + np )
	    IF  ( ( .not. ERMISS (tx) ) .and.
     +            ( .not. ERMISS (ty) ) ) THEN
		IF  ( tx .le. xx ) THEN
		    iret = NIMONO
		    RETURN
		ELSE
		    nknt     = nknt + 1
		    x (nknt) = tx
		    y (nknt) = ty
		    xx       = tx
		END IF
	    END IF
	END DO
C
C*	Check to see if there are still at least two points.
C
	IF  ( nknt .lt. 2 ) THEN
	    iret = NOPNTS
	    RETURN
	END IF
C
C*	Generate coefficients for evaluating curve.
C
	jend = 1
	CALL SNDFSP ( x, y, nknt, jend, coeffs, iret )
C
	IF  ( iret .ne. NORMAL ) THEN
	    iret = NORMAL
	    DO  i = 1, nlvout
		dataout( (i-1)*nparms + np ) = RMISSD
	    END DO
	    RETURN
	END IF
C
C*	Transform evaluating points to normalized coordinates.
C
	DO  i = 1, nlvout
	    xout(i) = hghts(i)
	END DO
C
C*	Evaluate curve.
C
	CALL SNDESP ( x, nknt, coeffs, xout, nlvout, yout, iret )
C
C*	Move points into output array.
C
	DO  i = 1, nlvout
	    dataout( (i-1)*nparms + np ) = yout(i)
	END DO
C*
	RETURN
	END


program main
    use GAClass
    use IOClass
    implicit none

    type(GA_) :: solver
    type(IO_) :: f, timeseries
    real(real64),allocatable :: height(:)
    real(real64),allocatable :: NumberOfBranch(:)
    integer(int32) :: i
    real(real64)  :: x, y

    ! ==================================
    !             Problem
    ! ==================================
    ! Maximize f(x) = -2x^3+15x^2-24x-3
    ! subject to 0 <= x <= 100
    ! Ans. max(f(x)) = f(4) = 13
    ! ==================================

    ! ==================================
    ! Solve by Genetic Algorithm (GA)
    ! ==================================

    call f%open("Graph.txt")
    do i=1,100
        x = dble(i)
        y = -2.0d0*x*x*x &
            +15.0d0*x*x &
            -24.0d0*x &
            -3
        call f%write(x,y )
    enddo
    call f%close()

    ! initialize
    call solver%init(&
        num_individual=10000,&
        num_real=2,&
        num_int=0)

    ! setup 1st generation

    call solver%setup(&
        DataType=real64,&
        DataID=1,&
        DataRange=[0.0,100.1],&
        DataAnnotation="Height")

    ! dummy data (not necessary)
    call solver%setup(&
        DataType=real64,&
        DataID=2,&
        DataRange=[0.0,10.1],&
        DataAnnotation="NumberOfBranch")

    ! GA optimization loopd

    do i=1, 100 ! 100 generations

        ! evaluate (random)
        !solver%score = random%randn(solver%num_individual)
        ! select by height
        height = solver%parse(KeyWord="Height")
        NumberOfBranch = solver%parse(KeyWord="NumberOfBranch")

        ! score = x*(1-x)
        solver%score(:) = &
        -2.0d0*height(:)*height(:)*height(:) &
            +15.0d0*height(:)*height(:) &
            -24.0d0*height(:) &
            -3.0d0

        call timeseries%open("TimeSeries"//str(i)//".txt")
        do i_i=1,size(height)
            call timeseries%write(height(i_i),solver%score(i_i) )
        enddo
        call timeseries%close()

        ! select
        call solver%select(score=solver%score, SurvivalRate=0.01d0)

        ! re-generate (crossing)
        call solver%cross()

        if ( mod(i,30)==0 )then
            ! mutation in 1/30
            call solver%mutate(KeyWord="Height",sigma=0.00001d0)
            call solver%mutate(KeyWord="NumberOfBranch",sigma=3.0d0)
        endif

        ! generation, AVE. and SD.
        print *, i,average(height),standardDeviation(height)
    enddo

    height = solver%parse("Height")
    print *, "Height Average : ",average(height)
    print *, "SD : ",standardDeviation(height)

    NumberOfBranch = solver%parse("NumberOfBranch")
    print *, "NumberOfBranch Average : ",average(NumberOfBranch)
    print *, "SD : ",standardDeviation(NumberOfBranch)

end program main


! { dg-do compile }
!
! PR fortran/40873
!
! Failed to compile (segfault) with -fwhole-file.
! Cf. PR 40873 comment 24; test case taken from
! PR fortran/31867 comment 6.
!

pure integer function lensum (words, sep)
  character (len=*), intent(in)        :: words(:), sep
  lensum = (size (words)-1) * len (sep) + sum (len_trim (words))
end function

module util_mod
  implicit none
  interface
    pure integer function lensum (words, sep)
      character (len=*), intent(in)        :: words(:), sep
    end function
  end interface
  contains
  function join (words, sep) result(str)
! trim and concatenate a vector of character variables,
! inserting sep between them
    character (len=*), intent(in)        :: words(:), sep
    character (len=lensum (words, sep))  :: str
    integer                              :: i, nw
    nw  = size (words)
    str = ""
    if (nw < 1) then
      return
    else
      str = words(1)
    end if
    do i=2,nw
      str = trim (str) // sep // words(i)
    end do
  end function join
end module util_mod
!
program xjoin
  use util_mod, only: join
  implicit none
  character (len=5) :: words(2) = (/"two  ","three"/)
  write (*,"(1x,'words = ',a)") "'"//join (words, "&")//"'"
end program xjoin


!>
module HillsVortex
    use  PrecisionMod, only: MK
    implicit none

contains

    !> Velocity induced by Hills vortex (hence in the frame with no free stream at infinity).
    ! Induced velocity returned in Cartesian coordinates
    !
    ! Cylindrical coordinate system (rho,phi,z)
    subroutine fUi_HillsVortex_1(CP,a,us,z0,Uind,Grad,Defm,Vort,Strm)
        ! Arguments
        real(MK),dimension(3), intent(in) :: CP !< Control Point
        real(MK), intent(in) :: a  !< hill vortex radius
        real(MK), intent(in) :: us !< hills self induced velocity us=-5/2 U0  (ie convects along -ez)
        real(MK), intent(in) :: z0 !< Position on the z axis
        real(MK),dimension(3),intent(out) :: Uind !< Induced velocity
        real(MK),dimension(9),intent(out) :: Grad !< Gradient
        real(MK),dimension(3),intent(out) :: Defm !< Deformation
        real(MK),dimension(3),intent(out) :: Vort !< Vorticity
        real(MK),dimension(3),intent(out),optional :: Strm !< Stremfunction (optional)
        ! Variables
        real(MK)              :: r3d,rho
        real(MK)              :: x,y,z
        real(MK)              :: urho
        real(MK)              :: uz
        real(MK),dimension(3) :: e_phi  ! Tangential coordinate
        real(MK),dimension(3) :: e_rho  ! Cylindrical radial
        real(MK)              :: om_phi
        real(MK)              :: defm_phi
        real(MK)              :: U0 !< I don't want to think : U0 =-2/5 us
        real(MK)              :: Stokes
        real(MK)              :: Stokes0
        !
        U0=-2._MK/5._MK*us
        !
        !
        x=CP(1)
        y=CP(2)
        z=CP(3)-z0  ! Note the allowed offset

        r3d=sqrt(x**2 + y**2 + z**2)
        rho=sqrt(x**2 + y**2)
        ! Tangential coordinate (tangent to (y,z))
        if (rho/a<1.e-12) then
            ! This should save us from singularities
            e_phi(1:3)=0.0_MK
            e_rho(1:3)=0.0_MK
        else
            e_phi(1)=-y/rho
            e_phi(2)= x/rho
            e_phi(3)=0
            e_rho(1)= x/rho
            e_rho(2)= y/rho
            e_rho(3)=0
        endif
        if(r3d<a) then
            ! --- Inside the sphere
            ! Velocity
            uz     =3._MK/5._MK*us*(1._MK-(2._MK*rho**2+z**2)/(a**2))+us*2._MK/5._MK ;
            urho   =3._MK/5._MK*us*(rho*z)/(a**2);
            ! Vorticity (along e_phi)
            om_phi= 3._MK*us*rho/a**2  != -15/2  * (u0 rho)/a^2 = 3 us rho/a**2
            ! Deformation
            defm_phi= 9._MK/5._MK*us**2/a**2*rho*z ! =45/4 * uo^2/a^2 * rho z
            ! Gradient
            Grad(1:9)=0.0_MK !TODO
            ! Stokes Stream function
            Stokes=-3.0_MK/4.0_MK*U0*rho**2*(1-(rho**2+z**2)/(a**2))
            Stokes0=-rho**2*U0/2.0_MK !< Due to the addition of a free stream term in uz_in
        else
            ! --- Outside of the sphere
            ! Velocity
            uz    =2._MK/5._MK*us* (((a**2)/(z**2+rho**2))**(5._MK/2._MK))*(2._MK*z**2-rho**2)/(2._MK*a**2);
            urho  =3._MK/5._MK*us*rho*z/(a**2)*(((a**2)/(z**2+rho**2))**(5._MK/2._MK));
            ! Vorticity
            om_phi   = 0.0_MK
            ! Deformation
            defm_phi = 0.0_MK
            ! Gradient
            Grad(1:9)=0.0_MK !TODO
            ! Stokes Streamfunction
            Stokes=1.0_MK/2.0_MK*U0*rho**2*(1-a**3/((rho**2+z**2)**1.5_MK))
            Stokes0=-rho**2*U0/2.0_MK !< Due to the addition of a free stream term in uz_in
        endif
        !
        Uind(1) = urho * e_rho(1)
        Uind(2) = urho * e_rho(2)
        Uind(3) = uz
        !
        Defm(1) =  defm_phi * e_phi(1)
        Defm(2) =  defm_phi * e_phi(2)
        Defm(3) = 0.0_MK
        !
        Vort(1) = om_phi * e_phi(1)
        Vort(2) = om_phi * e_phi(2)
        Vort(3) = 0.0_MK
        ! Streamfunction
        if(present(Strm)) then
            if (rho/a>1.e-12) then
                Strm(1) = (Stokes0+Stokes)/rho * e_phi(1)
                Strm(2) = (Stokes0+Stokes)/rho * e_phi(2)
                Strm(3) = 0.0_MK
            else
                Strm=0.0_MK
            endif
        endif

    end subroutine

end module HillsVortex


C ----------------------------------------------------------------------
C  SR: hpfilter
C  Kalman smoothing routine for HP filter written by E Prescott.
C   y=data series, d=deviations from trend, t=trend, n=no. obs,
C   s=smoothing parameter (eg, 1600 for std HP).
C   Array v is scratch area and must have dimension at least 3n.
C   If IOPT=1 and n and s are the same as for the previous call,
C   the numbers in v are not recomputed.  This reduces execution
C   time by about 30 percent.  Note that if this option is exercised,
C   v cannot be used for other purposes between calls.
C   This version does NOT release the trend in order to save memory.
C ----------------------------------------------------------------------
      SUBROUTINE HPFILTER(Y,D,V,N,S,IOPT,T)
      INTEGER*2 IOPT,NN,I,I1,IB,N
      REAL*8 Y(N),T(N),V(N,3),D(N),SS
      REAL*8 M1,M2,V11,V12,V22,X,Z,B11,B12,B22,DET,E1,E2,S
      DATA SS,NN/0.D0,0/
Cf2py intent(in) y,n,s,v,iopt
Cf2py intent(out) d,t
Cf2py depend(n) y,d,v
C
C     compute sequences of covariance matrix for f[x(t),x(t-1) | y(<t)]
C
      IF(IOPT.NE.1.OR.NN.NE.N.OR.S.NE.SS)  THEN
        SS=S
        NN=N
        V11=1.D0
        V22=1.D0
        V12=0.D0
       DO 5 I=3,N
        X=V11
        Z=V12
        V11=1.D0/S + 4.D0*(X-Z) + V22
        V12=2.D0*X - Z
        V22=X
        DET=V11*V22-V12*V12
        V(I,1)=V22/DET
        V(I,3)=V11/DET
        V(I,2)=-V12/DET
        X=V11+1.D0
        Z=V11
        V11=V11-V11*V11/X
        V22=V22-V12*V12/X
        V12=V12-Z*V12/X
  5    CONTINUE
                                       ENDIF
C
C     this is the forward pass
C
      M1=Y(2)
      M2=Y(1)
      DO 10 I=3,N
        X=M1
        M1=2.0*M1-M2
        M2=X
        T(I-1)= V(I,1)*M1+V(I,2)*M2
        D(I-1)= V(I,2)*M1+V(I,3)*M2
        DET=V(I,1)*V(I,3)-V(I,2)*V(I,2)
        V11=V(I,3)/DET
        V12=-V(I,2)/DET
        Z=(Y(I)-M1)/(V11+1.D0)
        M1=M1+V11*Z
        M2=M2+V12*Z
 10     CONTINUE
      T(N)=M1
      T(N-1)=M2
C
C       this is the backward pass
C
         M1=Y(N-1)
         M2=Y(N)
        DO 15 I=N-2,1,-1
           I1=I+1
           IB=N-I+1
         X=M1
         M1=2.D0*M1 - M2
         M2=X
C
C           combine info for y(.lt.i) with info for y(.ge.i)
C
         IF(I.GT.2)                 THEN
           E1=V(IB,3)*M2 + V(IB,2)*M1 + T(I)
           E2=V(IB,2)*M2 + V(IB,1)*M1 + D(I)
           B11=V(IB,3)+V(I1,1)
           B12=V(IB,2)+V(I1,2)
           B22=V(IB,1)+V(I1,3)
           DET=B11*B22-B12*B12
           T(I)=(-B12*E1+B11*E2)/DET
                                    ENDIF
C
C           end of combining
C
        DET=V(IB,1)*V(IB,3)-V(IB,2)*V(IB,2)
        V11=V(IB,3)/DET
        V12=-V(IB,2)/DET
        Z=(Y(I)-M1)/(V11+1.D0)
         M1=M1+V11*Z
         M2=M2+V12*Z
 15     CONTINUE
       T(1)=M1
       T(2)=M2
        DO 20 I=1,N
 20      D(I)=Y(I)-T(I)
        RETURN
        END
C***********************************************************************


*DECK DBESI
      SUBROUTINE DBESI (X, ALPHA, KODE, N, Y, NZ)
C***BEGIN PROLOGUE  DBESI
C***PURPOSE  Compute an N member sequence of I Bessel functions
C            I/SUB(ALPHA+K-1)/(X), K=1,...,N or scaled Bessel functions
C            EXP(-X)*I/SUB(ALPHA+K-1)/(X), K=1,...,N for nonnegative
C            ALPHA and X.
C***LIBRARY   SLATEC
C***CATEGORY  C10B3
C***TYPE      DOUBLE PRECISION (BESI-S, DBESI-D)
C***KEYWORDS  I BESSEL FUNCTION, SPECIAL FUNCTIONS
C***AUTHOR  Amos, D. E., (SNLA)
C           Daniel, S. L., (SNLA)
C***DESCRIPTION
C
C     Abstract  **** a double precision routine ****
C         DBESI computes an N member sequence of I Bessel functions
C         I/sub(ALPHA+K-1)/(X), K=1,...,N or scaled Bessel functions
C         EXP(-X)*I/sub(ALPHA+K-1)/(X), K=1,...,N for nonnegative ALPHA
C         and X.  A combination of the power series, the asymptotic
C         expansion for X to infinity, and the uniform asymptotic
C         expansion for NU to infinity are applied over subdivisions of
C         the (NU,X) plane.  For values not covered by one of these
C         formulae, the order is incremented by an integer so that one
C         of these formulae apply.  Backward recursion is used to reduce
C         orders by integer values.  The asymptotic expansion for X to
C         infinity is used only when the entire sequence (specifically
C         the last member) lies within the region covered by the
C         expansion.  Leading terms of these expansions are used to test
C         for over or underflow where appropriate.  If a sequence is
C         requested and the last member would underflow, the result is
C         set to zero and the next lower order tried, etc., until a
C         member comes on scale or all are set to zero.  An overflow
C         cannot occur with scaling.
C
C         The maximum number of significant digits obtainable
C         is the smaller of 14 and the number of digits carried in
C         double precision arithmetic.
C
C     Description of Arguments
C
C         Input      X,ALPHA are double precision
C           X      - X .GE. 0.0D0
C           ALPHA  - order of first member of the sequence,
C                    ALPHA .GE. 0.0D0
C           KODE   - a parameter to indicate the scaling option
C                    KODE=1 returns
C                           Y(K)=        I/sub(ALPHA+K-1)/(X),
C                                K=1,...,N
C                    KODE=2 returns
C                           Y(K)=EXP(-X)*I/sub(ALPHA+K-1)/(X),
C                                K=1,...,N
C           N      - number of members in the sequence, N .GE. 1
C
C         Output     Y is double precision
C           Y      - a vector whose first N components contain
C                    values for I/sub(ALPHA+K-1)/(X) or scaled
C                    values for EXP(-X)*I/sub(ALPHA+K-1)/(X),
C                    K=1,...,N depending on KODE
C           NZ     - number of components of Y set to zero due to
C                    underflow,
C                    NZ=0   , normal return, computation completed
C                    NZ .NE. 0, last NZ components of Y set to zero,
C                             Y(K)=0.0D0, K=N-NZ+1,...,N.
C
C     Error Conditions
C         Improper input arguments - a fatal error
C         Overflow with KODE=1 - a fatal error
C         Underflow - a non-fatal error(NZ .NE. 0)
C
C***REFERENCES  D. E. Amos, S. L. Daniel and M. K. Weston, CDC 6600
C                 subroutines IBESS and JBESS for Bessel functions
C                 I(NU,X) and J(NU,X), X .GE. 0, NU .GE. 0, ACM
C                 Transactions on Mathematical Software 3, (1977),
C                 pp. 76-92.
C               F. W. J. Olver, Tables of Bessel Functions of Moderate
C                 or Large Orders, NPL Mathematical Tables 6, Her
C                 Majesty's Stationery Office, London, 1962.
C***ROUTINES CALLED  D1MACH, DASYIK, DLNGAM, I1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   750101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890911  Removed unnecessary intrinsics.  (WRB)
C   890911  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DBESI
C
      INTEGER I, IALP, IN, INLIM, IS, I1, K, KK, KM, KODE, KT,
     1 N, NN, NS, NZ
      INTEGER I1MACH
      DOUBLE PRECISION AIN,AK,AKM,ALPHA,ANS,AP,ARG,ATOL,TOLLN,DFN,
     1 DTM, DX, EARG, ELIM, ETX, FLGIK,FN, FNF, FNI,FNP1,FNU,GLN,RA,
     2 RTTPI, S, SX, SXO2, S1, S2, T, TA, TB, TEMP, TFN, TM, TOL,
     3 TRX, T2, X, XO2, XO2L, Y, Z
      DOUBLE PRECISION D1MACH, DLNGAM
      DIMENSION Y(*), TEMP(3)
      SAVE RTTPI, INLIM
      DATA RTTPI           / 3.98942280401433D-01/
      DATA INLIM           /          80         /
C***FIRST EXECUTABLE STATEMENT  DBESI
      NZ = 0
      KT = 1
C     I1MACH(15) REPLACES I1MACH(12) IN A DOUBLE PRECISION CODE
C     I1MACH(14) REPLACES I1MACH(11) IN A DOUBLE PRECISION CODE
      RA = D1MACH(3)
      TOL = MAX(RA,1.0D-15)
      I1 = -I1MACH(15)
      GLN = D1MACH(5)
      ELIM = 2.303D0*(I1*GLN-3.0D0)
C     TOLLN = -LN(TOL)
      I1 = I1MACH(14)+1
      TOLLN = 2.303D0*GLN*I1
      TOLLN = MIN(TOLLN,34.5388D0)
      IF (N-1) 590, 10, 20
   10 KT = 2
   20 NN = N
      IF (KODE.LT.1 .OR. KODE.GT.2) GO TO 570
      IF (X) 600, 30, 80
   30 IF (ALPHA) 580, 40, 50
   40 Y(1) = 1.0D0
      IF (N.EQ.1) RETURN
      I1 = 2
      GO TO 60
   50 I1 = 1
   60 DO 70 I=I1,N
        Y(I) = 0.0D0
   70 CONTINUE
      RETURN
   80 CONTINUE
      IF (ALPHA.LT.0.0D0) GO TO 580
C
      IALP = INT(ALPHA)
      FNI = IALP + N - 1
      FNF = ALPHA - IALP
      DFN = FNI + FNF
      FNU = DFN
      IN = 0
      XO2 = X*0.5D0
      SXO2 = XO2*XO2
      ETX = KODE - 1
      SX = ETX*X
C
C     DECISION TREE FOR REGION WHERE SERIES, ASYMPTOTIC EXPANSION FOR X
C     TO INFINITY AND ASYMPTOTIC EXPANSION FOR NU TO INFINITY ARE
C     APPLIED.
C
      IF (SXO2.LE.(FNU+1.0D0)) GO TO 90
      IF (X.LE.12.0D0) GO TO 110
      FN = 0.55D0*FNU*FNU
      FN = MAX(17.0D0,FN)
      IF (X.GE.FN) GO TO 430
      ANS = MAX(36.0D0-FNU,0.0D0)
      NS = INT(ANS)
      FNI = FNI + NS
      DFN = FNI + FNF
      FN = DFN
      IS = KT
      KM = N - 1 + NS
      IF (KM.GT.0) IS = 3
      GO TO 120
   90 FN = FNU
      FNP1 = FN + 1.0D0
      XO2L = LOG(XO2)
      IS = KT
      IF (X.LE.0.5D0) GO TO 230
      NS = 0
  100 FNI = FNI + NS
      DFN = FNI + FNF
      FN = DFN
      FNP1 = FN + 1.0D0
      IS = KT
      IF (N-1+NS.GT.0) IS = 3
      GO TO 230
  110 XO2L = LOG(XO2)
      NS = INT(SXO2-FNU)
      GO TO 100
  120 CONTINUE
C
C     OVERFLOW TEST ON UNIFORM ASYMPTOTIC EXPANSION
C
      IF (KODE.EQ.2) GO TO 130
      IF (ALPHA.LT.1.0D0) GO TO 150
      Z = X/ALPHA
      RA = SQRT(1.0D0+Z*Z)
      GLN = LOG((1.0D0+RA)/Z)
      T = RA*(1.0D0-ETX) + ETX/(Z+RA)
      ARG = ALPHA*(T-GLN)
      IF (ARG.GT.ELIM) GO TO 610
      IF (KM.EQ.0) GO TO 140
  130 CONTINUE
C
C     UNDERFLOW TEST ON UNIFORM ASYMPTOTIC EXPANSION
C
      Z = X/FN
      RA = SQRT(1.0D0+Z*Z)
      GLN = LOG((1.0D0+RA)/Z)
      T = RA*(1.0D0-ETX) + ETX/(Z+RA)
      ARG = FN*(T-GLN)
  140 IF (ARG.LT.(-ELIM)) GO TO 280
      GO TO 190
  150 IF (X.GT.ELIM) GO TO 610
      GO TO 130
C
C     UNIFORM ASYMPTOTIC EXPANSION FOR NU TO INFINITY
C
  160 IF (KM.NE.0) GO TO 170
      Y(1) = TEMP(3)
      RETURN
  170 TEMP(1) = TEMP(3)
      IN = NS
      KT = 1
      I1 = 0
  180 CONTINUE
      IS = 2
      FNI = FNI - 1.0D0
      DFN = FNI + FNF
      FN = DFN
      IF(I1.EQ.2) GO TO 350
      Z = X/FN
      RA = SQRT(1.0D0+Z*Z)
      GLN = LOG((1.0D0+RA)/Z)
      T = RA*(1.0D0-ETX) + ETX/(Z+RA)
      ARG = FN*(T-GLN)
  190 CONTINUE
      I1 = ABS(3-IS)
      I1 = MAX(I1,1)
      FLGIK = 1.0D0
      CALL DASYIK(X,FN,KODE,FLGIK,RA,ARG,I1,TEMP(IS))
      GO TO (180, 350, 510), IS
C
C     SERIES FOR (X/2)**2.LE.NU+1
C
  230 CONTINUE
      GLN = DLNGAM(FNP1)
      ARG = FN*XO2L - GLN - SX
      IF (ARG.LT.(-ELIM)) GO TO 300
      EARG = EXP(ARG)
  240 CONTINUE
      S = 1.0D0
      IF (X.LT.TOL) GO TO 260
      AK = 3.0D0
      T2 = 1.0D0
      T = 1.0D0
      S1 = FN
      DO 250 K=1,17
        S2 = T2 + S1
        T = T*SXO2/S2
        S = S + T
        IF (ABS(T).LT.TOL) GO TO 260
        T2 = T2 + AK
        AK = AK + 2.0D0
        S1 = S1 + FN
  250 CONTINUE
  260 CONTINUE
      TEMP(IS) = S*EARG
      GO TO (270, 350, 500), IS
  270 EARG = EARG*FN/XO2
      FNI = FNI - 1.0D0
      DFN = FNI + FNF
      FN = DFN
      IS = 2
      GO TO 240
C
C     SET UNDERFLOW VALUE AND UPDATE PARAMETERS
C
  280 Y(NN) = 0.0D0
      NN = NN - 1
      FNI = FNI - 1.0D0
      DFN = FNI + FNF
      FN = DFN
      IF (NN-1) 340, 290, 130
  290 KT = 2
      IS = 2
      GO TO 130
  300 Y(NN) = 0.0D0
      NN = NN - 1
      FNP1 = FN
      FNI = FNI - 1.0D0
      DFN = FNI + FNF
      FN = DFN
      IF (NN-1) 340, 310, 320
  310 KT = 2
      IS = 2
  320 IF (SXO2.LE.FNP1) GO TO 330
      GO TO 130
  330 ARG = ARG - XO2L + LOG(FNP1)
      IF (ARG.LT.(-ELIM)) GO TO 300
      GO TO 230
  340 NZ = N - NN
      RETURN
C
C     BACKWARD RECURSION SECTION
C
  350 CONTINUE
      NZ = N - NN
  360 CONTINUE
      IF(KT.EQ.2) GO TO 420
      S1 = TEMP(1)
      S2 = TEMP(2)
      TRX = 2.0D0/X
      DTM = FNI
      TM = (DTM+FNF)*TRX
      IF (IN.EQ.0) GO TO 390
C     BACKWARD RECUR TO INDEX ALPHA+NN-1
      DO 380 I=1,IN
        S = S2
        S2 = TM*S2 + S1
        S1 = S
        DTM = DTM - 1.0D0
        TM = (DTM+FNF)*TRX
  380 CONTINUE
      Y(NN) = S1
      IF (NN.EQ.1) RETURN
      Y(NN-1) = S2
      IF (NN.EQ.2) RETURN
      GO TO 400
  390 CONTINUE
C     BACKWARD RECUR FROM INDEX ALPHA+NN-1 TO ALPHA
      Y(NN) = S1
      Y(NN-1) = S2
      IF (NN.EQ.2) RETURN
  400 K = NN + 1
      DO 410 I=3,NN
        K = K - 1
        Y(K-2) = TM*Y(K-1) + Y(K)
        DTM = DTM - 1.0D0
        TM = (DTM+FNF)*TRX
  410 CONTINUE
      RETURN
  420 Y(1) = TEMP(2)
      RETURN
C
C     ASYMPTOTIC EXPANSION FOR X TO INFINITY
C
  430 CONTINUE
      EARG = RTTPI/SQRT(X)
      IF (KODE.EQ.2) GO TO 440
      IF (X.GT.ELIM) GO TO 610
      EARG = EARG*EXP(X)
  440 ETX = 8.0D0*X
      IS = KT
      IN = 0
      FN = FNU
  450 DX = FNI + FNI
      TM = 0.0D0
      IF (FNI.EQ.0.0D0 .AND. ABS(FNF).LT.TOL) GO TO 460
      TM = 4.0D0*FNF*(FNI+FNI+FNF)
  460 CONTINUE
      DTM = DX*DX
      S1 = ETX
      TRX = DTM - 1.0D0
      DX = -(TRX+TM)/ETX
      T = DX
      S = 1.0D0 + DX
      ATOL = TOL*ABS(S)
      S2 = 1.0D0
      AK = 8.0D0
      DO 470 K=1,25
        S1 = S1 + ETX
        S2 = S2 + AK
        DX = DTM - S2
        AP = DX + TM
        T = -T*AP/S1
        S = S + T
        IF (ABS(T).LE.ATOL) GO TO 480
        AK = AK + 8.0D0
  470 CONTINUE
  480 TEMP(IS) = S*EARG
      IF(IS.EQ.2) GO TO 360
      IS = 2
      FNI = FNI - 1.0D0
      DFN = FNI + FNF
      FN = DFN
      GO TO 450
C
C     BACKWARD RECURSION WITH NORMALIZATION BY
C     ASYMPTOTIC EXPANSION FOR NU TO INFINITY OR POWER SERIES.
C
  500 CONTINUE
C     COMPUTATION OF LAST ORDER FOR SERIES NORMALIZATION
      AKM = MAX(3.0D0-FN,0.0D0)
      KM = INT(AKM)
      TFN = FN + KM
      TA = (GLN+TFN-0.9189385332D0-0.0833333333D0/TFN)/(TFN+0.5D0)
      TA = XO2L - TA
      TB = -(1.0D0-1.0D0/TFN)/TFN
      AIN = TOLLN/(-TA+SQRT(TA*TA-TOLLN*TB)) + 1.5D0
      IN = INT(AIN)
      IN = IN + KM
      GO TO 520
  510 CONTINUE
C     COMPUTATION OF LAST ORDER FOR ASYMPTOTIC EXPANSION NORMALIZATION
      T = 1.0D0/(FN*RA)
      AIN = TOLLN/(GLN+SQRT(GLN*GLN+T*TOLLN)) + 1.5D0
      IN = INT(AIN)
      IF (IN.GT.INLIM) GO TO 160
  520 CONTINUE
      TRX = 2.0D0/X
      DTM = FNI + IN
      TM = (DTM+FNF)*TRX
      TA = 0.0D0
      TB = TOL
      KK = 1
  530 CONTINUE
C
C     BACKWARD RECUR UNINDEXED
C
      DO 540 I=1,IN
        S = TB
        TB = TM*TB + TA
        TA = S
        DTM = DTM - 1.0D0
        TM = (DTM+FNF)*TRX
  540 CONTINUE
C     NORMALIZATION
      IF (KK.NE.1) GO TO 550
      TA = (TA/TB)*TEMP(3)
      TB = TEMP(3)
      KK = 2
      IN = NS
      IF (NS.NE.0) GO TO 530
  550 Y(NN) = TB
      NZ = N - NN
      IF (NN.EQ.1) RETURN
      TB = TM*TB + TA
      K = NN - 1
      Y(K) = TB
      IF (NN.EQ.2) RETURN
      DTM = DTM - 1.0D0
      TM = (DTM+FNF)*TRX
      KM = K - 1
C
C     BACKWARD RECUR INDEXED
C
      DO 560 I=1,KM
        Y(K-1) = TM*Y(K) + Y(K+1)
        DTM = DTM - 1.0D0
        TM = (DTM+FNF)*TRX
        K = K - 1
  560 CONTINUE
      RETURN
C
C
C
  570 CONTINUE
      CALL XERMSG ('SLATEC', 'DBESI',
     +   'SCALING OPTION, KODE, NOT 1 OR 2.', 2, 1)
      RETURN
  580 CONTINUE
      CALL XERMSG ('SLATEC', 'DBESI', 'ORDER, ALPHA, LESS THAN ZERO.',
     +   2, 1)
      RETURN
  590 CONTINUE
      CALL XERMSG ('SLATEC', 'DBESI', 'N LESS THAN ONE.', 2, 1)
      RETURN
  600 CONTINUE
      CALL XERMSG ('SLATEC', 'DBESI', 'X LESS THAN ZERO.', 2, 1)
      RETURN
  610 CONTINUE
      CALL XERMSG ('SLATEC', 'DBESI',
     +   'OVERFLOW, X TOO LARGE FOR KODE = 1.', 6, 1)
      RETURN
      END


program qml_driver

    implicit none

    double precision, allocatable, dimension(:,:) :: Q
    double precision, allocatable, dimension(:):: Y

    double precision :: sigma
    integer :: rep_size
    integer :: n_molecules

    double precision, allocatable, dimension(:,:) :: b
    double precision, allocatable, dimension(:) :: alphas

    integer :: m, n, nrhs, lda, ldb, info
    integer :: na
    integer :: i, j

    integer :: lwork
    double precision, dimension(:), allocatable :: work
    double precision, dimension(:,:), allocatable :: K

    ! Read hyperparameters and arrat suzes
    open(unit = 9, file = "parameters.fout", form="formatted")

        read(9,*) sigma, rep_size, n_molecules

        ! Allocate labels
        allocate(Y(n_molecules))

        read(9,*) Y(:n_molecules)

    close(9)

    ! allocate alphas
    allocate(alphas(n_molecules))
    ! Allocate representations
    allocate(Q(n_molecules, rep_size))

    ! Read representations
    open(unit = 9, file = "representations.fout", form="formatted")

        ! Read representaions for each molecule
        do i = 1, n_molecules
            read(9,*) Q(i,:rep_size)
        enddo

    close(9)

    ! Size of kernel
    na = size(Q, dim=1)

    ! Allocate kernel
    allocate(K(na,na))

    ! Calculate Laplacian kernel
    do i = 1, na
        do j = 1, na
            K(j,i) = exp(-sum(abs(Q(j,:) - Q(i,:)))/sigma)
        enddo
    enddo

    ! Setup variables for LAPACK
    m = size(K, dim=1)
    n = size(K, dim=2)
    nrhs = 1
    lda = m
    ldb = max(m,n)
    allocate(b(ldb,1))
    b = 0.0d0
    b(:m,1) = y(:m)
    lwork = (min(m,n) + max(m,n)) * 10
    allocate(work(lwork))

    ! Solver
    call dgels("N", m, n, nrhs, K, lda, b, ldb, work, lwork, info)

    ! Copy LAPACK output
    alphas(:n) = b(:n,1)

    ! Save alphas to file
    open(unit = 9, file = "alphas.fout", form="formatted")
        write(9,*) alphas(:)
    close(9)

    ! Clean up
    deallocate(work)
    deallocate(b)
    deallocate(Q)
    deallocate(K)
    deallocate(Y)
    deallocate(alphas)

end program qml_driver