      program rms_error

      implicit double precision (a-h,o-z)

      parameter (imax = 5000000)

      double precision t(imax), u(imax)
      double precision t_temp(3), u_temp(3)  ! four-point interp
      double precision tb(imax), ub(imax)
      double precision ub_interp(imax)

      character tmp

      external polint
      external locate

      open (unit = 20, file = 'Bench.dat', status = 'old')
      open (unit = 21, file = 'Test.dat', status = 'old')

! read in benchmark data
! first line of Bench.dat should be # followed by number of lines of data,
! e.g.,
! # 2484
      read(20,*) tmp, numpts_b
      do i = 1, numpts_b
        read(20,*) tb(i), ub(i)
      enddo
      write(*,*) 'numpts_b is', numpts_b

! first line of Test.dat should be # followed by number of lines of data,
! e.g.,
! # 2484

      read(21,*) tmp, numpts
! read in benchmark data
      do i = 1, numpts
        read(21,*) t(i), u(i)
      enddo
      write(*,*) 'numpts is', numpts

C interpolate ub to same grid as u, store in ub_interp
      do i = 1, numpts
        time = t(i)
        call locate(tb, numpts_b, time, locat)
        if (locat.eq.0) locat= 1
        do j = 1,3
          t_temp(j) = tb(locat+j-1)
          u_temp(j) = ub(locat+j-1)
        enddo
        call polint(t_temp, u_temp,3,time,ub_out,dy)
        ub_interp(i) = ub_out
        !write(*,*) time, ub_out
      enddo

C calculate normalized rms error and the normalized inf error
C use trap rule integration

      rms = 0.d0
      dnorm = 0.d0

      error_max = 0.d0

      do i = 1, numpts-1

         dmid_u  = (u(i) + u(i+1)) / 2.d0

         dmid_ub = (ub_interp(i) + ub_interp(i+1)) / 2.d0

         error = abs(ub_interp(i) - u(i))
         if (error .gt. error_max) error_max = error

         rms = rms + (dmid_u - dmid_ub)**2

         dnorm = dnorm + dmid_ub**2

      enddo

      total_time = t(numpts)

      dnorm = sqrt(total_time * dnorm / dble(numpts-1))

      rms = sqrt(total_time * rms / dble(numpts-1))

      write(*,*) 'errornorm ', dnorm

      write(*,*) 'normalized rms error = ', rms/dnorm

      write(*,*) 'error_max = ', error_max

      end

c--------------------------------------------------------------------
      subroutine locate(xx,n,x,j)
      integer j,n
      double precision x,xx(n)
      integer jl,jm,ju
      jl=0
      ju=n+1
10    if(ju-jl.gt.1)then
        jm=(ju+jl)/2
        if((xx(n).gt.xx(1)).eqv.(x.gt.xx(jm)))then
          jl=jm
        else
          ju=jm
        endif
      goto 10
      endif
      j=jl
      return
      end
c  (c) copr. 1986-92 numerical recipes software +k$<,(5cl.
c--------------------------------------------------------------------
      subroutine polint(xa,ya,n,x,y,dy)
      integer n,nmax
      double precision dy,x,y,xa(n),ya(n)
      parameter (nmax=10)
      integer i,m,ns
      double precision den,dif,dift,ho,hp,w,c(nmax),d(nmax)
      ns=1
      dif=abs(x-xa(1))
      do 11 i=1,n
        dift=abs(x-xa(i))
        if (dift.lt.dif) then
          ns=i
          dif=dift
        endif
        c(i)=ya(i)
        d(i)=ya(i)
11    continue
      y=ya(ns)
      ns=ns-1
      do 13 m=1,n-1
        do 12 i=1,n-m
          ho=xa(i)-x
          hp=xa(i+m)-x
          w=c(i+1)-d(i)
          den=ho-hp
          if(den.eq.0.) stop 'failure in polint'
          den=w/den
          d(i)=hp*den
          c(i)=ho*den
12      continue
        if (2*ns.lt.n-m)then
          dy=c(ns+1)
        else
          dy=d(ns)
          ns=ns-1
        endif
        y=y+dy
13    continue
      return
      end
c  (c) copr. 1986-92 numerical recipes software +k$<,(5cl.
c--------------------------------------------------------------------


program IntegerLiteral

  implicit none
  integer, parameter   :: dec = 727
  integer, parameter   :: hex = Z'2d7'
  integer, parameter   :: oct = O'1327'
  integer, parameter   :: bin = B'1011010111'

  print *, dec, hex, oct, bin

end program IntegerLiteral


module optimization

use parameters
use constants
use ray

implicit none

private

public pattern_search, optimise_alpha_beta

contains

subroutine pattern_search(alpha,beta,nu_obs,ds,stat)

use parameters
use constants

implicit none

!Arguments
real(kind=dp), intent(inout) :: alpha,beta,ds
real(kind=dp),intent(in) :: nu_obs
integer(kind=dp), intent(out) :: stat !status - did we exit ok, or else interrupt by error/precision limit

integer(kind=dp) :: idx
real(kind=dp) :: dsR, dsL, dsU, dsD
real(kind=dp),dimension(4) :: ds_collection
real(kind=dp),dimension(4,2) :: AB_collection
real(kind=dp) :: aBest, bBest, dsBest
!Gradient alpha

call run(alpha+dg,beta,nu_obs,dsR,0)

call run(alpha-dg,beta,nu_obs,dsL,0)

call run(alpha, beta+dg, nu_obs, dsU,0)

call run(alpha, beta-dg, nu_obs, dsD,0)

ds_collection(1) = dsR
ds_collection(2) = dsL
ds_collection(3) = dsU
ds_collection(4) = dsD

AB_collection(1,1) = alpha+ dg
AB_collection(1,2) = beta

AB_collection(2,1) = alpha- dg
AB_collection(2,2) = beta

AB_collection(3,1) = alpha
AB_collection(3,2) = beta + dg

AB_collection(4,1) = alpha
AB_collection(4,2) = beta - dg

idx = minloc(ds_collection,1)

aBest = AB_collection(idx,1)
bBest = AB_collection(idx,2)

dsBest = ds_collection(idx)

!print *, 'out = ',aBest, bBest, dsBest,ds,dg,decay_factor

if (dsBest .lt. epsilon(dsBest)) then
! Has fallen ino BH likely
print *, 'Fallen into BH'
stat = 5 !Exit condition
return
endif

if (dsBest .LT. ds) then
alpha = aBest
beta = bBest
ds = dsBest

else

dg = dg / decay_factor

if (dg .LT. epsilon(dg) .or. dsBest .eq. 0.0_dp) then
    !Dont let stepsoie get too small

    !Also guard against BH fall in

    print *, 'REACHED PRECSIION LIMIT------------------------------------'
    print *, rTarget, thetaTarget, phiTarget
    print *, 'Best ds = ', ds
    stat = 1 !Exit condition

    return
endif

endif

end subroutine pattern_search

 subroutine optimise_alpha_beta(alpha,beta,nu_obs,ds,stat,globals)

 use parameters
 use constants

 implicit none

 !Arguments
 real(kind=dp), intent(inout) :: alpha,beta,ds
 real(kind=dp),intent(in) :: nu_obs
 integer(kind=dp), intent(out) :: stat
 real(kind=dp), intent(inout),dimension(4) :: globals

 !Other
 real(kind=dp) :: ds_alpha, ds_beta
 real(kind=dp) :: gA, gB
 real(kind=dp) :: zeta,hA,hB
 real(kind=dp) :: eta, t, ds_trial
 real(kind=dp) :: ds1, alpha1, beta1
 real(kind=dp) :: trial_alpha, trial_beta

 !Get the gradients in the alpha/beta directions

!print *, 'dg = ', bit

 !Gradient alpha
 call run(alpha+bit,beta,nu_obs,ds_alpha,0)
 gA = - ((ds_alpha - ds)/bit)
! print *, ds_alpha, ds, ds_alpha -ds

! call run(alpha-bit,beta,nu_obs,ds_alpha,1)
! gA = - ((ds_alpha - ds)/dg)
! print *, ds_alpha -ds

 !Gradient beta
 call run(alpha,beta+bit,nu_obs,ds_beta,0)
 gB = - ((ds_beta - ds)/bit)
 !print *, ds_beta - ds

 !call run(alpha,beta-bit,nu_obs,ds_beta,1)
 !gB = - ((ds_beta - ds)/dg)
 !print *, ds_beta - ds

!stop

 if (globals(1) .EQ. 0.0_dp) then
 !First go
 zeta = 0.0_dp
 else
 zeta = (gA*gA +gB*gB)/(globals(1)**2 + globals(2)**2)
 endif

 hA = gA +zeta*globals(3)
 hB = gB +zeta*globals(4)

 !Got the direction, now get the stepsizze by performing a line search
 eta = 2.0_dp !0.50_dp
 t = global_t
 ds1 = 1e20

!tracking line search
 do

     !Trial values
     trial_alpha = alpha + t*hA
     trial_beta = beta + t*hB

     !Try a step in the direction
     call run(trial_alpha,trial_beta,nu_obs,ds_trial,0)

     print *, 'Trial:', ds, ds_trial,t

     if (ds_trial .lt. ds1) then
     !Update and exit
     alpha1 = trial_alpha
     beta1 = trial_beta
     ds1 = ds_trial

    else

    exit

    endif

    t = t*eta

 enddo

if (ds1 .lt. ds) then
print *, 'Good'
alpha = alpha1 ; beta = beta1 ; ds = ds1
global_t = t/5.0_dp
!global_t = 5d-9
else
!globals = 0.0_dp
global_t = 5d-9
global_counter = global_counter + 1
print *, 'bad', global_counter
endif

globals(1) = gA ; globals(2) = gB ; globals(3) = hA ; globals(4) = hB
print *, '----------------------'

if (global_counter .GT. 10) then
globals=0.0_dp
global_counter = 0
print *, 'resetting globals'
endif

 end subroutine optimise_alpha_beta

end module optimization


program nrtools_main
  use nrtools
  implicit none
  integer :: n, k
  real(sp):: i
  real(sp):: a, b
  complex(dpc) :: test
  integer :: j
  real(dp) :: start, finish
  real(dp) :: rln_gamma

  test = 0.

  !n = 4
  !k = 5

  ! n!/(k!(n-k)!)

  !print*, rcsv_bicoef(n,k)

  !test = (1._dp,0._dp)

  !open(unit=1, file='gammatest.dat')
  !do i = 1., 5., 0.1
    !write(1,*) i-1, rcsv_gamma(test)
  !  test = test + 0.1
  !end do

  test = (142._dp, 0._dp)

  call cpu_time(start)
  do j = 1, 1000000
    rln_gamma = real(rcsv_ln_gamma(test))
  end do
  call cpu_time(finish)

  print*, "rcsv_ln_gamma execution time = ", finish - start

  call cpu_time(start)
  do j = 1, 1000000
    rln_gamma = log(real(rcsv_gamma(test)))
  end do
  call cpu_time(finish)

  print*, "log(rcsv_gamma) execution time = ", finish - start

end program nrtools_main


program kokkos_program2
implicit none
real, dimension(10000) :: a, b, c
real :: scalar
integer :: i, nsize
scalar = 10
nsize = size(a)
do concurrent (i = 1:nsize)
    a(i) = 5
    b(i) = 5
end do
call triad(a, b, scalar, c)
print *, "End Stream Triad"

contains

    subroutine triad(a, b, scalar, c)
    real, intent(in) :: a(:), b(:), scalar
    real, intent(out) :: c(:)
    integer :: N, i
    N = size(a)
    do concurrent (i = 1:N)
        c(i) = a(i) + scalar * b(i)
    end do
    end subroutine

end program


Module m_indmed
Integer, Parameter :: kdp = selected_real_kind(15)
public :: indmed
private :: kdp
private :: R_indmed, I_indmed, D_indmed
private :: r_med, i_med, d_med
Integer, Allocatable, Dimension(:), Private, Save :: IDONT
interface indmed
  module procedure d_indmed, r_indmed, i_indmed
end interface indmed
contains

Subroutine D_indmed (XDONT, INDM)
!  Returns index of median value of XDONT.
! __________________________________________________________
      Real (kind=kdp), Dimension (:), Intent (In) :: XDONT
      Integer, Intent (Out) :: INDM
! __________________________________________________________
      Integer :: IDON
!
      Allocate (IDONT (SIZE(XDONT)))
      Do IDON = 1, SIZE(XDONT)
         IDONT (IDON) = IDON
      End Do
!
      Call d_med (XDONT, IDONT, INDM)
!
      Deallocate (IDONT)
End Subroutine D_indmed
   Recursive Subroutine d_med (XDATT, IDATT, ires_med)
!  Finds the index of the median of XDONT using the recursive procedure
!  described in Knuth, The Art of Computer Programming,
!  vol. 3, 5.3.3 - This procedure is linear in time, and
!  does not require to be able to interpolate in the
!  set as the one used in INDNTH. It also has better worst
!  case behavior than INDNTH, but is about 30% slower in
!  average for random uniformly distributed values.
! __________________________________________________________
      Real (kind=kdp), Dimension (:), Intent (In) :: XDATT
      Integer, Dimension (:), Intent (In) :: IDATT
      Integer, Intent (Out):: ires_med
! __________________________________________________________
!
      Real (kind=kdp), Parameter :: XHUGE = HUGE (XDATT)
      Real (kind=kdp) :: XWRK, XWRK1, XMED7, XMAX, XMIN
!
      Integer, Dimension (7*(((Size (IDATT)+6)/7+6)/7)) :: ISTRT, IENDT, IMEDT
      Integer, Dimension (7*((Size(IDATT)+6)/7)) :: IWRKT
      Integer :: NTRI, NMED, NORD, NEQU, NLEQ, IMED, IDON, IDON1
      Integer :: IDEB, ITMP, IDCR, ICRS, ICRS1, ICRS2, IMAX, IMIN
      Integer :: IWRK, IWRK1, IMED1, IMED7, NDAT
!
      NDAT = Size (IDATT)
      NMED = (NDAT+1) / 2
      IWRKT = IDATT
!
!  If the number of values is small, then use insertion sort
!
     If (NDAT < 35) Then
!
!  Bring minimum to first location to save test in decreasing loop
!
         IDCR = NDAT
         If (XDATT (IWRKT (1)) < XDATT (IWRKT (IDCR))) Then
            IWRK = IWRKT (1)
         Else
            IWRK = IWRKT (IDCR)
            IWRKT (IDCR) = IWRKT (1)
         Endif
         XWRK = XDATT (IWRK)
         Do ITMP = 1, NDAT - 2
            IDCR = IDCR - 1
            IWRK1 = IWRKT (IDCR)
            XWRK1 = XDATT (IWRK1)
            If (XWRK1 < XWRK) Then
                IWRKT (IDCR) = IWRK
                XWRK = XWRK1
                IWRK = IWRK1
            Endif
         End Do
         IWRKT (1) = IWRK
!
! Sort the first half, until we have NMED sorted values
!
         Do ICRS = 3, NMED
            XWRK = XDATT (IWRKT (ICRS))
            IWRK = IWRKT (ICRS)
            IDCR = ICRS - 1
            Do
                  If (XWRK >= XDATT (IWRKT(IDCR))) Exit
                  IWRKT (IDCR+1) = IWRKT (IDCR)
                  IDCR = IDCR - 1
            End Do
            IWRKT (IDCR+1) = IWRK
         End Do
!
!  Insert any value less than the current median in the first half
!
         XWRK1 = XDATT (IWRKT (NMED))
         Do ICRS = NMED+1, NDAT
            XWRK = XDATT (IWRKT (ICRS))
            IWRK = IWRKT (ICRS)
            If (XWRK < XWRK1) Then
               IDCR = NMED - 1
               Do
                  If (XWRK >= XDATT (IWRKT(IDCR))) Exit
                  IWRKT (IDCR+1) = IWRKT (IDCR)
                  IDCR = IDCR - 1
               End Do
               IWRKT (IDCR+1) = IWRK
               XWRK1 = XDATT (IWRKT (NMED))
            End If
         End Do
         ires_med = IWRKT (NMED)
         Return
      End If
!
!  Make sorted subsets of 7 elements
!  This is done by a variant of insertion sort where a first
!  pass is used to bring the smallest element to the first position
!  decreasing disorder at the same time, so that we may remove
!  remove the loop test in the insertion loop.
!
      IMAX = 1
      IMIN = 1
      XMAX = XDATT (IWRKT(IMAX))
      XMIN = XDATT (IWRKT(IMIN))
      DO IDEB = 1, NDAT-6, 7
         IDCR = IDEB + 6
         If (XDATT (IWRKT(IDEB)) < XDATT (IWRKT(IDCR))) Then
            IWRK = IWRKT(IDEB)
         Else
            IWRK = IWRKT (IDCR)
            IWRKT (IDCR) = IWRKT(IDEB)
         Endif
         XWRK = XDATT (IWRK)
         Do ITMP = 1, 5
            IDCR = IDCR - 1
            IWRK1 = IWRKT (IDCR)
            XWRK1 = XDATT (IWRK1)
            If (XWRK1 < XWRK) Then
                IWRKT (IDCR) = IWRK
                IWRK = IWRK1
                XWRK = XWRK1
            Endif
         End Do
         IWRKT (IDEB) = IWRK
         If (XWRK < XMIN) Then
             IMIN = IWRK
             XMIN = XWRK
         End If
         Do ICRS = IDEB+1, IDEB+5
            IWRK = IWRKT (ICRS+1)
            XWRK = XDATT (IWRK)
            IDON = IWRKT(ICRS)
            If (XWRK < XDATT(IDON)) Then
               IWRKT (ICRS+1) = IDON
               IDCR = ICRS
               IWRK1 = IWRKT (IDCR-1)
               XWRK1 = XDATT (IWRK1)
               Do
                  If (XWRK >= XWRK1) Exit
                  IWRKT (IDCR) = IWRK1
                  IDCR = IDCR - 1
                  IWRK1 = IWRKT (IDCR-1)
                  XWRK1 = XDATT (IWRK1)
               End Do
               IWRKT (IDCR) = IWRK
            EndIf
         End Do
         If (XWRK > XMAX) Then
             IMAX = IWRK
             XMAX = XWRK
         End If
      End Do
!
!  Add-up alternatively MAX and MIN values to make the number of data
!  an exact multiple of 7.
!
      IDEB = 7 * (NDAT/7)
      NTRI = NDAT
      If (IDEB < NDAT) Then
!
         Do ICRS = IDEB+1, NDAT
            XWRK1 = XDATT (IWRKT (ICRS))
            IF (XWRK1 > XMAX) Then
               IMAX = IWRKT (ICRS)
               XMAX = XWRK1
            End If
            IF (XWRK1 < XMIN) Then
               IMIN = IWRKT (ICRS)
               XMIN = XWRK1
            End If
         End Do
         IWRK1 = IMAX
         Do ICRS = NDAT+1, IDEB+7
               IWRKT (ICRS) = IWRK1
               If (IWRK1 == IMAX) Then
                  IWRK1 = IMIN
               Else
                  NMED = NMED + 1
                  IWRK1 = IMAX
               End If
         End Do
!
         Do ICRS = IDEB+2, IDEB+7
            IWRK = IWRKT (ICRS)
            XWRK = XDATT (IWRK)
            Do IDCR = ICRS - 1, IDEB+1, - 1
               If (XWRK >= XDATT (IWRKT(IDCR))) Exit
               IWRKT (IDCR+1) = IWRKT (IDCR)
            End Do
            IWRKT (IDCR+1) = IWRK
         End Do
!
         NTRI = IDEB+7
      End If
!
!  Make the set of the indices of median values of each sorted subset
!
         IDON1 = 0
         Do IDON = 1, NTRI, 7
            IDON1 = IDON1 + 1
            IMEDT (IDON1) = IWRKT (IDON + 3)
         End Do
!
!  Find XMED7, the median of the medians
!
         Call d_med (XDATT, IMEDT(1:IDON1), IMED7)
         XMED7 = XDATT (IMED7)
!
!  Count how many values are not higher than (and how many equal to) XMED7
!  This number is at least 4 * 1/2 * (N/7) : 4 values in each of the
!  subsets where the median is lower than the median of medians. For similar
!  reasons, we also have at least 2N/7 values not lower than XMED7. At the
!  same time, we find in each subset the index of the last value < XMED7,
!  and that of the first > XMED7. These indices will be used to restrict the
!  search for the median as the Kth element in the subset (> or <) where
!  we know it to be.
!
         IDON1 = 1
         NLEQ = 0
         NEQU = 0
         Do IDON = 1, NTRI, 7
            IMED = IDON+3
            If (XDATT (IWRKT (IMED)) > XMED7) Then
                  IMED = IMED - 2
                  If (XDATT (IWRKT (IMED)) > XMED7) Then
                     IMED = IMED - 1
                  Else If (XDATT (IWRKT (IMED)) < XMED7) Then
                     IMED = IMED + 1
                  Endif
            Else If (XDATT (IWRKT (IMED)) < XMED7) Then
                  IMED = IMED + 2
                  If (XDATT (IWRKT (IMED)) > XMED7) Then
                     IMED = IMED - 1
                  Else If (XDATT (IWRKT (IMED)) < XMED7) Then
                     IMED = IMED + 1
                  Endif
            Endif
            If (XDATT (IWRKT (IMED)) > XMED7) Then
               NLEQ = NLEQ + IMED - IDON
               IENDT (IDON1) = IMED - 1
               ISTRT (IDON1) = IMED
            Else If (XDATT (IWRKT (IMED)) < XMED7) Then
               NLEQ = NLEQ + IMED - IDON + 1
               IENDT (IDON1) = IMED
               ISTRT (IDON1) = IMED + 1
            Else                    !       If (XDATT (IWRKT (IMED)) == XMED7)
               NLEQ = NLEQ + IMED - IDON + 1
               NEQU = NEQU + 1
               IENDT (IDON1) = IMED - 1
               Do IMED1 = IMED - 1, IDON, -1
                  If (XDATT (IWRKT (IMED1)) == XMED7) Then
                     NEQU = NEQU + 1
                     IENDT (IDON1) = IMED1 - 1
                  Else
                     Exit
                  End If
               End Do
               ISTRT (IDON1) = IMED + 1
               Do IMED1 = IMED + 1, IDON + 6
                  If (XDATT (IWRKT (IMED1)) == XMED7) Then
                     NEQU = NEQU + 1
                     NLEQ = NLEQ + 1
                     ISTRT (IDON1) = IMED1 + 1
                  Else
                     Exit
                  End If
               End Do
            Endif
            IDON1 = IDON1 + 1
         End Do
!
!  Carry out a partial insertion sort to find the Kth smallest of the
!  large values, or the Kth largest of the small values, according to
!  what is needed.
!
!
         If (NLEQ - NEQU + 1 <= NMED) Then
            If (NLEQ < NMED) Then   !      Not enough low values
                IWRK1 = IMAX
                XWRK1 = XDATT (IWRK1)
                NORD = NMED - NLEQ
                IDON1 = 0
                ICRS1 = 1
                ICRS2 = 0
                IDCR = 0
                Do IDON = 1, NTRI, 7
                   IDON1 = IDON1 + 1
                   If (ICRS2 < NORD) Then
                      Do ICRS = ISTRT (IDON1), IDON + 6
                         If (XDATT (IWRKT (ICRS)) < XWRK1) Then
                            IWRK = IWRKT (ICRS)
                            XWRK = XDATT (IWRK)
                            Do IDCR = ICRS1 - 1, 1, - 1
                               If (XWRK >= XDATT (IWRKT (IDCR))) Exit
                               IWRKT  (IDCR+1) = IWRKT (IDCR)
                            End Do
                            IWRKT (IDCR+1) = IWRK
                            IWRK1 = IWRKT (ICRS1)
                            XWRK1 = XDATT (IWRK1)
                         Else
                           If (ICRS2 < NORD) Then
                              IWRKT (ICRS1) = IWRKT (ICRS)
                              IWRK1 = IWRKT (ICRS1)
                              XWRK1 = XDATT (IWRK1)
                           Endif
                         End If
                         ICRS1 = MIN (NORD, ICRS1 + 1)
                         ICRS2 = MIN (NORD, ICRS2 + 1)
                      End Do
                   Else
                      Do ICRS = ISTRT (IDON1), IDON + 6
                         If (XDATT (IWRKT (ICRS)) >= XWRK1) Exit
                         IWRK = IWRKT (ICRS)
                         XWRK = XDATT (IWRK)
                         Do IDCR = ICRS1 - 1, 1, - 1
                               If (XWRK >= XDATT (IWRKT (IDCR))) Exit
                               IWRKT  (IDCR+1) = IWRKT (IDCR)
                         End Do
                         IWRKT (IDCR+1) = IWRK
                         IWRK1 = IWRKT (ICRS1)
                         XWRK1 = XDATT (IWRK1)
                      End Do
                   End If
                End Do
                ires_med = IWRK1
                Return
            Else
                ires_med = IMED7
                Return
            End If
         Else                       !      If (NLEQ > NMED)
!                                          Not enough high values
                XWRK1 = -XHUGE
                NORD = NLEQ - NEQU - NMED + 1
                IDON1 = 0
                ICRS1 = 1
                ICRS2 = 0
                Do IDON = 1, NTRI, 7
                   IDON1 = IDON1 + 1
                   If (ICRS2 < NORD) Then
!
                      Do ICRS = IDON, IENDT (IDON1)
                         If (XDATT(IWRKT (ICRS)) > XWRK1) Then
                            IWRK = IWRKT (ICRS)
                            XWRK = XDATT (IWRK)
                            IDCR = ICRS1 - 1
                            Do IDCR = ICRS1 - 1, 1, - 1
                               If (XWRK <= XDATT(IWRKT (IDCR))) Exit
                               IWRKT (IDCR+1) = IWRKT (IDCR)
                            End Do
                            IWRKT (IDCR+1) = IWRK
                            IWRK1 = IWRKT(ICRS1)
                            XWRK1 = XDATT(IWRK1)
                         Else
                            If (ICRS2 < NORD) Then
                               IWRKT (ICRS1) = IWRKT (ICRS)
                               IWRK1 = IWRKT(ICRS1)
                               XWRK1 = XDATT(IWRK1)
                            End If
                         End If
                         ICRS1 = MIN (NORD, ICRS1 + 1)
                         ICRS2 = MIN (NORD, ICRS2 + 1)
                      End Do
                   Else
                      Do ICRS = IENDT (IDON1), IDON, -1
                         If (XDATT(IWRKT (ICRS)) <= XWRK1) Exit
                         IWRK = IWRKT (ICRS)
                         XWRK = XDATT (IWRK)
                         IDCR = ICRS1 - 1
                         Do IDCR = ICRS1 - 1, 1, - 1
                               If (XWRK <= XDATT(IWRKT (IDCR))) Exit
                               IWRKT (IDCR+1) = IWRKT (IDCR)
                         End Do
                         IWRKT (IDCR+1) = IWRK
                         IWRK1 = IWRKT(ICRS1)
                         XWRK1 = XDATT(IWRK1)
                      End Do
                   Endif
                End Do
!
                ires_med = IWRK1
                Return
         End If
!
   END Subroutine d_med
!
Subroutine R_indmed (XDONT, INDM)
!  Returns index of median value of XDONT.
! __________________________________________________________
      Real, Dimension (:), Intent (In) :: XDONT
      Integer, Intent (Out) :: INDM
! __________________________________________________________
      Integer :: IDON
!
      Allocate (IDONT (SIZE(XDONT)))
      Do IDON = 1, SIZE(XDONT)
         IDONT (IDON) = IDON
      End Do
!
      Call r_med (XDONT, IDONT, INDM)
!
      Deallocate (IDONT)
End Subroutine R_indmed
   Recursive Subroutine r_med (XDATT, IDATT, ires_med)
!  Finds the index of the median of XDONT using the recursive procedure
!  described in Knuth, The Art of Computer Programming,
!  vol. 3, 5.3.3 - This procedure is linear in time, and
!  does not require to be able to interpolate in the
!  set as the one used in INDNTH. It also has better worst
!  case behavior than INDNTH, but is about 30% slower in
!  average for random uniformly distributed values.
! __________________________________________________________
      Real, Dimension (:), Intent (In) :: XDATT
      Integer, Dimension (:), Intent (In) :: IDATT
      Integer, Intent (Out) :: ires_med
! __________________________________________________________
!
      Real, Parameter :: XHUGE = HUGE (XDATT)
      Real :: XWRK, XWRK1, XMED7, XMAX, XMIN
!
      Integer, Dimension (7*(((Size (IDATT)+6)/7+6)/7)) :: ISTRT, IENDT, IMEDT
      Integer, Dimension (7*((Size(IDATT)+6)/7)) :: IWRKT
      Integer :: NTRI, NMED, NORD, NEQU, NLEQ, IMED, IDON, IDON1
      Integer :: IDEB, ITMP, IDCR, ICRS, ICRS1, ICRS2, IMAX, IMIN
      Integer :: IWRK, IWRK1, IMED1, IMED7, NDAT
!
      NDAT = Size (IDATT)
      NMED = (NDAT+1) / 2
      IWRKT = IDATT
!
!  If the number of values is small, then use insertion sort
!
     If (NDAT < 35) Then
!
!  Bring minimum to first location to save test in decreasing loop
!
         IDCR = NDAT
         If (XDATT (IWRKT (1)) < XDATT (IWRKT (IDCR))) Then
            IWRK = IWRKT (1)
         Else
            IWRK = IWRKT (IDCR)
            IWRKT (IDCR) = IWRKT (1)
         Endif
         XWRK = XDATT (IWRK)
         Do ITMP = 1, NDAT - 2
            IDCR = IDCR - 1
            IWRK1 = IWRKT (IDCR)
            XWRK1 = XDATT (IWRK1)
            If (XWRK1 < XWRK) Then
                IWRKT (IDCR) = IWRK
                XWRK = XWRK1
                IWRK = IWRK1
            Endif
         End Do
         IWRKT (1) = IWRK
!
! Sort the first half, until we have NMED sorted values
!
         Do ICRS = 3, NMED
            XWRK = XDATT (IWRKT (ICRS))
            IWRK = IWRKT (ICRS)
            IDCR = ICRS - 1
            Do
                  If (XWRK >= XDATT (IWRKT(IDCR))) Exit
                  IWRKT (IDCR+1) = IWRKT (IDCR)
                  IDCR = IDCR - 1
            End Do
            IWRKT (IDCR+1) = IWRK
         End Do
!
!  Insert any value less than the current median in the first half
!
         XWRK1 = XDATT (IWRKT (NMED))
         Do ICRS = NMED+1, NDAT
            XWRK = XDATT (IWRKT (ICRS))
            IWRK = IWRKT (ICRS)
            If (XWRK < XWRK1) Then
               IDCR = NMED - 1
               Do
                  If (XWRK >= XDATT (IWRKT(IDCR))) Exit
                  IWRKT (IDCR+1) = IWRKT (IDCR)
                  IDCR = IDCR - 1
               End Do
               IWRKT (IDCR+1) = IWRK
               XWRK1 = XDATT (IWRKT (NMED))
            End If
         End Do
         ires_med = IWRKT (NMED)
         Return
      End If
!
!  Make sorted subsets of 7 elements
!  This is done by a variant of insertion sort where a first
!  pass is used to bring the smallest element to the first position
!  decreasing disorder at the same time, so that we may remove
!  remove the loop test in the insertion loop.
!
      IMAX = 1
      IMIN = 1
      XMAX = XDATT (IWRKT(IMAX))
      XMIN = XDATT (IWRKT(IMIN))
      DO IDEB = 1, NDAT-6, 7
         IDCR = IDEB + 6
         If (XDATT (IWRKT(IDEB)) < XDATT (IWRKT(IDCR))) Then
            IWRK = IWRKT(IDEB)
         Else
            IWRK = IWRKT (IDCR)
            IWRKT (IDCR) = IWRKT(IDEB)
         Endif
         XWRK = XDATT (IWRK)
         Do ITMP = 1, 5
            IDCR = IDCR - 1
            IWRK1 = IWRKT (IDCR)
            XWRK1 = XDATT (IWRK1)
            If (XWRK1 < XWRK) Then
                IWRKT (IDCR) = IWRK
                IWRK = IWRK1
                XWRK = XWRK1
            Endif
         End Do
         IWRKT (IDEB) = IWRK
         If (XWRK < XMIN) Then
             IMIN = IWRK
             XMIN = XWRK
         End If
         Do ICRS = IDEB+1, IDEB+5
            IWRK = IWRKT (ICRS+1)
            XWRK = XDATT (IWRK)
            IDON = IWRKT(ICRS)
            If (XWRK < XDATT(IDON)) Then
               IWRKT (ICRS+1) = IDON
               IDCR = ICRS
               IWRK1 = IWRKT (IDCR-1)
               XWRK1 = XDATT (IWRK1)
               Do
                  If (XWRK >= XWRK1) Exit
                  IWRKT (IDCR) = IWRK1
                  IDCR = IDCR - 1
                  IWRK1 = IWRKT (IDCR-1)
                  XWRK1 = XDATT (IWRK1)
               End Do
               IWRKT (IDCR) = IWRK
            EndIf
         End Do
         If (XWRK > XMAX) Then
             IMAX = IWRK
             XMAX = XWRK
         End If
      End Do
!
!  Add-up alternatively MAX and MIN values to make the number of data
!  an exact multiple of 7.
!
      IDEB = 7 * (NDAT/7)
      NTRI = NDAT
      If (IDEB < NDAT) Then
!
         Do ICRS = IDEB+1, NDAT
            XWRK1 = XDATT (IWRKT (ICRS))
            IF (XWRK1 > XMAX) Then
               IMAX = IWRKT (ICRS)
               XMAX = XWRK1
            End If
            IF (XWRK1 < XMIN) Then
               IMIN = IWRKT (ICRS)
               XMIN = XWRK1
            End If
         End Do
         IWRK1 = IMAX
         Do ICRS = NDAT+1, IDEB+7
               IWRKT (ICRS) = IWRK1
               If (IWRK1 == IMAX) Then
                  IWRK1 = IMIN
               Else
                  NMED = NMED + 1
                  IWRK1 = IMAX
               End If
         End Do
!
         Do ICRS = IDEB+2, IDEB+7
            IWRK = IWRKT (ICRS)
            XWRK = XDATT (IWRK)
            Do IDCR = ICRS - 1, IDEB+1, - 1
               If (XWRK >= XDATT (IWRKT(IDCR))) Exit
               IWRKT (IDCR+1) = IWRKT (IDCR)
            End Do
            IWRKT (IDCR+1) = IWRK
         End Do
!
         NTRI = IDEB+7
      End If
!
!  Make the set of the indices of median values of each sorted subset
!
         IDON1 = 0
         Do IDON = 1, NTRI, 7
            IDON1 = IDON1 + 1
            IMEDT (IDON1) = IWRKT (IDON + 3)
         End Do
!
!  Find XMED7, the median of the medians
!
         Call r_med (XDATT, IMEDT(1:IDON1), IMED7)
         XMED7 = XDATT (IMED7)
!
!  Count how many values are not higher than (and how many equal to) XMED7
!  This number is at least 4 * 1/2 * (N/7) : 4 values in each of the
!  subsets where the median is lower than the median of medians. For similar
!  reasons, we also have at least 2N/7 values not lower than XMED7. At the
!  same time, we find in each subset the index of the last value < XMED7,
!  and that of the first > XMED7. These indices will be used to restrict the
!  search for the median as the Kth element in the subset (> or <) where
!  we know it to be.
!
         IDON1 = 1
         NLEQ = 0
         NEQU = 0
         Do IDON = 1, NTRI, 7
            IMED = IDON+3
            If (XDATT (IWRKT (IMED)) > XMED7) Then
                  IMED = IMED - 2
                  If (XDATT (IWRKT (IMED)) > XMED7) Then
                     IMED = IMED - 1
                  Else If (XDATT (IWRKT (IMED)) < XMED7) Then
                     IMED = IMED + 1
                  Endif
            Else If (XDATT (IWRKT (IMED)) < XMED7) Then
                  IMED = IMED + 2
                  If (XDATT (IWRKT (IMED)) > XMED7) Then
                     IMED = IMED - 1
                  Else If (XDATT (IWRKT (IMED)) < XMED7) Then
                     IMED = IMED + 1
                  Endif
            Endif
            If (XDATT (IWRKT (IMED)) > XMED7) Then
               NLEQ = NLEQ + IMED - IDON
               IENDT (IDON1) = IMED - 1
               ISTRT (IDON1) = IMED
            Else If (XDATT (IWRKT (IMED)) < XMED7) Then
               NLEQ = NLEQ + IMED - IDON + 1
               IENDT (IDON1) = IMED
               ISTRT (IDON1) = IMED + 1
            Else                    !       If (XDATT (IWRKT (IMED)) == XMED7)
               NLEQ = NLEQ + IMED - IDON + 1
               NEQU = NEQU + 1
               IENDT (IDON1) = IMED - 1
               Do IMED1 = IMED - 1, IDON, -1
                  If (XDATT (IWRKT (IMED1)) == XMED7) Then
                     NEQU = NEQU + 1
                     IENDT (IDON1) = IMED1 - 1
                  Else
                     Exit
                  End If
               End Do
               ISTRT (IDON1) = IMED + 1
               Do IMED1 = IMED + 1, IDON + 6
                  If (XDATT (IWRKT (IMED1)) == XMED7) Then
                     NEQU = NEQU + 1
                     NLEQ = NLEQ + 1
                     ISTRT (IDON1) = IMED1 + 1
                  Else
                     Exit
                  End If
               End Do
            Endif
            IDON1 = IDON1 + 1
         End Do
!
!  Carry out a partial insertion sort to find the Kth smallest of the
!  large values, or the Kth largest of the small values, according to
!  what is needed.
!
!
         If (NLEQ - NEQU + 1 <= NMED) Then
            If (NLEQ < NMED) Then   !      Not enough low values
                IWRK1 = IMAX
                XWRK1 = XDATT (IWRK1)
                NORD = NMED - NLEQ
                IDON1 = 0
                ICRS1 = 1
                ICRS2 = 0
                IDCR = 0
                Do IDON = 1, NTRI, 7
                   IDON1 = IDON1 + 1
                   If (ICRS2 < NORD) Then
                      Do ICRS = ISTRT (IDON1), IDON + 6
                         If (XDATT (IWRKT (ICRS)) < XWRK1) Then
                            IWRK = IWRKT (ICRS)
                            XWRK = XDATT (IWRK)
                            Do IDCR = ICRS1 - 1, 1, - 1
                               If (XWRK >= XDATT (IWRKT (IDCR))) Exit
                               IWRKT  (IDCR+1) = IWRKT (IDCR)
                            End Do
                            IWRKT (IDCR+1) = IWRK
                            IWRK1 = IWRKT (ICRS1)
                            XWRK1 = XDATT (IWRK1)
                         Else
                           If (ICRS2 < NORD) Then
                              IWRKT (ICRS1) = IWRKT (ICRS)
                              IWRK1 = IWRKT (ICRS1)
                              XWRK1 = XDATT (IWRK1)
                           Endif
                         End If
                         ICRS1 = MIN (NORD, ICRS1 + 1)
                         ICRS2 = MIN (NORD, ICRS2 + 1)
                      End Do
                   Else
                      Do ICRS = ISTRT (IDON1), IDON + 6
                         If (XDATT (IWRKT (ICRS)) >= XWRK1) Exit
                         IWRK = IWRKT (ICRS)
                         XWRK = XDATT (IWRK)
                         Do IDCR = ICRS1 - 1, 1, - 1
                               If (XWRK >= XDATT (IWRKT (IDCR))) Exit
                               IWRKT  (IDCR+1) = IWRKT (IDCR)
                         End Do
                         IWRKT (IDCR+1) = IWRK
                         IWRK1 = IWRKT (ICRS1)
                         XWRK1 = XDATT (IWRK1)
                      End Do
                   End If
                End Do
                ires_med = IWRK1
                Return
            Else
                ires_med = IMED7
                Return
            End If
         Else                       !      If (NLEQ > NMED)
!                                          Not enough high values
                XWRK1 = -XHUGE
                NORD = NLEQ - NEQU - NMED + 1
                IDON1 = 0
                ICRS1 = 1
                ICRS2 = 0
                Do IDON = 1, NTRI, 7
                   IDON1 = IDON1 + 1
                   If (ICRS2 < NORD) Then
!
                      Do ICRS = IDON, IENDT (IDON1)
                         If (XDATT(IWRKT (ICRS)) > XWRK1) Then
                            IWRK = IWRKT (ICRS)
                            XWRK = XDATT (IWRK)
                            IDCR = ICRS1 - 1
                            Do IDCR = ICRS1 - 1, 1, - 1
                               If (XWRK <= XDATT(IWRKT (IDCR))) Exit
                               IWRKT (IDCR+1) = IWRKT (IDCR)
                            End Do
                            IWRKT (IDCR+1) = IWRK
                            IWRK1 = IWRKT(ICRS1)
                            XWRK1 = XDATT(IWRK1)
                         Else
                            If (ICRS2 < NORD) Then
                               IWRKT (ICRS1) = IWRKT (ICRS)
                               IWRK1 = IWRKT(ICRS1)
                               XWRK1 = XDATT(IWRK1)
                            End If
                         End If
                         ICRS1 = MIN (NORD, ICRS1 + 1)
                         ICRS2 = MIN (NORD, ICRS2 + 1)
                      End Do
                   Else
                      Do ICRS = IENDT (IDON1), IDON, -1
                         If (XDATT(IWRKT (ICRS)) <= XWRK1) Exit
                         IWRK = IWRKT (ICRS)
                         XWRK = XDATT (IWRK)
                         IDCR = ICRS1 - 1
                         Do IDCR = ICRS1 - 1, 1, - 1
                               If (XWRK <= XDATT(IWRKT (IDCR))) Exit
                               IWRKT (IDCR+1) = IWRKT (IDCR)
                         End Do
                         IWRKT (IDCR+1) = IWRK
                         IWRK1 = IWRKT(ICRS1)
                         XWRK1 = XDATT(IWRK1)
                      End Do
                   Endif
                End Do
!
                ires_med = IWRK1
                Return
         End If
!
   END Subroutine r_med
Subroutine I_indmed (XDONT, INDM)
!  Returns index of median value of XDONT.
! __________________________________________________________
      Integer, Dimension (:), Intent (In) :: XDONT
      Integer, Intent (Out) :: INDM
! __________________________________________________________
      Integer :: IDON
!
      Allocate (IDONT (SIZE(XDONT)))
      Do IDON = 1, SIZE(XDONT)
         IDONT (IDON) = IDON
      End Do
!
      Call i_med (XDONT, IDONT, INDM)
!
      Deallocate (IDONT)
End Subroutine I_indmed
   Recursive Subroutine i_med (XDATT, IDATT, ires_med)
!  Finds the index of the median of XDONT using the recursive procedure
!  described in Knuth, The Art of Computer Programming,
!  vol. 3, 5.3.3 - This procedure is linear in time, and
!  does not require to be able to interpolate in the
!  set as the one used in INDNTH. It also has better worst
!  case behavior than INDNTH, but is about 30% slower in
!  average for random uniformly distributed values.
! __________________________________________________________
      Integer, Dimension (:), Intent (In) :: XDATT
      Integer, Dimension (:), Intent (In) :: IDATT
      Integer, Intent (Out) :: ires_med
! __________________________________________________________
!
      Integer, Parameter :: XHUGE = HUGE (XDATT)
      Integer :: XWRK, XWRK1, XMED7, XMAX, XMIN
!
      Integer, Dimension (7*(((Size (IDATT)+6)/7+6)/7)) :: ISTRT, IENDT, IMEDT
      Integer, Dimension (7*((Size(IDATT)+6)/7)) :: IWRKT
      Integer :: NTRI, NMED, NORD, NEQU, NLEQ, IMED, IDON, IDON1
      Integer :: IDEB, ITMP, IDCR, ICRS, ICRS1, ICRS2, IMAX, IMIN
      Integer :: IWRK, IWRK1, IMED1, IMED7, NDAT
!
      NDAT = Size (IDATT)
      NMED = (NDAT+1) / 2
      IWRKT = IDATT
!
!  If the number of values is small, then use insertion sort
!
     If (NDAT < 35) Then
!
!  Bring minimum to first location to save test in decreasing loop
!
         IDCR = NDAT
         If (XDATT (IWRKT (1)) < XDATT (IWRKT (IDCR))) Then
            IWRK = IWRKT (1)
         Else
            IWRK = IWRKT (IDCR)
            IWRKT (IDCR) = IWRKT (1)
         Endif
         XWRK = XDATT (IWRK)
         Do ITMP = 1, NDAT - 2
            IDCR = IDCR - 1
            IWRK1 = IWRKT (IDCR)
            XWRK1 = XDATT (IWRK1)
            If (XWRK1 < XWRK) Then
                IWRKT (IDCR) = IWRK
                XWRK = XWRK1
                IWRK = IWRK1
            Endif
         End Do
         IWRKT (1) = IWRK
!
! Sort the first half, until we have NMED sorted values
!
         Do ICRS = 3, NMED
            XWRK = XDATT (IWRKT (ICRS))
            IWRK = IWRKT (ICRS)
            IDCR = ICRS - 1
            Do
                  If (XWRK >= XDATT (IWRKT(IDCR))) Exit
                  IWRKT (IDCR+1) = IWRKT (IDCR)
                  IDCR = IDCR - 1
            End Do
            IWRKT (IDCR+1) = IWRK
         End Do
!
!  Insert any value less than the current median in the first half
!
         XWRK1 = XDATT (IWRKT (NMED))
         Do ICRS = NMED+1, NDAT
            XWRK = XDATT (IWRKT (ICRS))
            IWRK = IWRKT (ICRS)
            If (XWRK < XWRK1) Then
               IDCR = NMED - 1
               Do
                  If (XWRK >= XDATT (IWRKT(IDCR))) Exit
                  IWRKT (IDCR+1) = IWRKT (IDCR)
                  IDCR = IDCR - 1
               End Do
               IWRKT (IDCR+1) = IWRK
               XWRK1 = XDATT (IWRKT (NMED))
            End If
         End Do
         ires_med = IWRKT (NMED)
         Return
      End If
!
!  Make sorted subsets of 7 elements
!  This is done by a variant of insertion sort where a first
!  pass is used to bring the smallest element to the first position
!  decreasing disorder at the same time, so that we may remove
!  remove the loop test in the insertion loop.
!
      IMAX = 1
      IMIN = 1
      XMAX = XDATT (IWRKT(IMAX))
      XMIN = XDATT (IWRKT(IMIN))
      DO IDEB = 1, NDAT-6, 7
         IDCR = IDEB + 6
         If (XDATT (IWRKT(IDEB)) < XDATT (IWRKT(IDCR))) Then
            IWRK = IWRKT(IDEB)
         Else
            IWRK = IWRKT (IDCR)
            IWRKT (IDCR) = IWRKT(IDEB)
         Endif
         XWRK = XDATT (IWRK)
         Do ITMP = 1, 5
            IDCR = IDCR - 1
            IWRK1 = IWRKT (IDCR)
            XWRK1 = XDATT (IWRK1)
            If (XWRK1 < XWRK) Then
                IWRKT (IDCR) = IWRK
                IWRK = IWRK1
                XWRK = XWRK1
            Endif
         End Do
         IWRKT (IDEB) = IWRK
         If (XWRK < XMIN) Then
             IMIN = IWRK
             XMIN = XWRK
         End If
         Do ICRS = IDEB+1, IDEB+5
            IWRK = IWRKT (ICRS+1)
            XWRK = XDATT (IWRK)
            IDON = IWRKT(ICRS)
            If (XWRK < XDATT(IDON)) Then
               IWRKT (ICRS+1) = IDON
               IDCR = ICRS
               IWRK1 = IWRKT (IDCR-1)
               XWRK1 = XDATT (IWRK1)
               Do
                  If (XWRK >= XWRK1) Exit
                  IWRKT (IDCR) = IWRK1
                  IDCR = IDCR - 1
                  IWRK1 = IWRKT (IDCR-1)
                  XWRK1 = XDATT (IWRK1)
               End Do
               IWRKT (IDCR) = IWRK
            EndIf
         End Do
         If (XWRK > XMAX) Then
             IMAX = IWRK
             XMAX = XWRK
         End If
      End Do
!
!  Add-up alternatively MAX and MIN values to make the number of data
!  an exact multiple of 7.
!
      IDEB = 7 * (NDAT/7)
      NTRI = NDAT
      If (IDEB < NDAT) Then
!
         Do ICRS = IDEB+1, NDAT
            XWRK1 = XDATT (IWRKT (ICRS))
            IF (XWRK1 > XMAX) Then
               IMAX = IWRKT (ICRS)
               XMAX = XWRK1
            End If
            IF (XWRK1 < XMIN) Then
               IMIN = IWRKT (ICRS)
               XMIN = XWRK1
            End If
         End Do
         IWRK1 = IMAX
         Do ICRS = NDAT+1, IDEB+7
               IWRKT (ICRS) = IWRK1
               If (IWRK1 == IMAX) Then
                  IWRK1 = IMIN
               Else
                  NMED = NMED + 1
                  IWRK1 = IMAX
               End If
         End Do
!
         Do ICRS = IDEB+2, IDEB+7
            IWRK = IWRKT (ICRS)
            XWRK = XDATT (IWRK)
            Do IDCR = ICRS - 1, IDEB+1, - 1
               If (XWRK >= XDATT (IWRKT(IDCR))) Exit
               IWRKT (IDCR+1) = IWRKT (IDCR)
            End Do
            IWRKT (IDCR+1) = IWRK
         End Do
!
         NTRI = IDEB+7
      End If
!
!  Make the set of the indices of median values of each sorted subset
!
         IDON1 = 0
         Do IDON = 1, NTRI, 7
            IDON1 = IDON1 + 1
            IMEDT (IDON1) = IWRKT (IDON + 3)
         End Do
!
!  Find XMED7, the median of the medians
!
         Call i_med (XDATT, IMEDT(1:IDON1), IMED7)
         XMED7 = XDATT (IMED7)
!
!  Count how many values are not higher than (and how many equal to) XMED7
!  This number is at least 4 * 1/2 * (N/7) : 4 values in each of the
!  subsets where the median is lower than the median of medians. For similar
!  reasons, we also have at least 2N/7 values not lower than XMED7. At the
!  same time, we find in each subset the index of the last value < XMED7,
!  and that of the first > XMED7. These indices will be used to restrict the
!  search for the median as the Kth element in the subset (> or <) where
!  we know it to be.
!
         IDON1 = 1
         NLEQ = 0
         NEQU = 0
         Do IDON = 1, NTRI, 7
            IMED = IDON+3
            If (XDATT (IWRKT (IMED)) > XMED7) Then
                  IMED = IMED - 2
                  If (XDATT (IWRKT (IMED)) > XMED7) Then
                     IMED = IMED - 1
                  Else If (XDATT (IWRKT (IMED)) < XMED7) Then
                     IMED = IMED + 1
                  Endif
            Else If (XDATT (IWRKT (IMED)) < XMED7) Then
                  IMED = IMED + 2
                  If (XDATT (IWRKT (IMED)) > XMED7) Then
                     IMED = IMED - 1
                  Else If (XDATT (IWRKT (IMED)) < XMED7) Then
                     IMED = IMED + 1
                  Endif
            Endif
            If (XDATT (IWRKT (IMED)) > XMED7) Then
               NLEQ = NLEQ + IMED - IDON
               IENDT (IDON1) = IMED - 1
               ISTRT (IDON1) = IMED
            Else If (XDATT (IWRKT (IMED)) < XMED7) Then
               NLEQ = NLEQ + IMED - IDON + 1
               IENDT (IDON1) = IMED
               ISTRT (IDON1) = IMED + 1
            Else                    !       If (XDATT (IWRKT (IMED)) == XMED7)
               NLEQ = NLEQ + IMED - IDON + 1
               NEQU = NEQU + 1
               IENDT (IDON1) = IMED - 1
               Do IMED1 = IMED - 1, IDON, -1
                  If (XDATT (IWRKT (IMED1)) == XMED7) Then
                     NEQU = NEQU + 1
                     IENDT (IDON1) = IMED1 - 1
                  Else
                     Exit
                  End If
               End Do
               ISTRT (IDON1) = IMED + 1
               Do IMED1 = IMED + 1, IDON + 6
                  If (XDATT (IWRKT (IMED1)) == XMED7) Then
                     NEQU = NEQU + 1
                     NLEQ = NLEQ + 1
                     ISTRT (IDON1) = IMED1 + 1
                  Else
                     Exit
                  End If
               End Do
            Endif
            IDON1 = IDON1 + 1
         End Do
!
!  Carry out a partial insertion sort to find the Kth smallest of the
!  large values, or the Kth largest of the small values, according to
!  what is needed.
!
!
         If (NLEQ - NEQU + 1 <= NMED) Then
            If (NLEQ < NMED) Then   !      Not enough low values
                IWRK1 = IMAX
                XWRK1 = XDATT (IWRK1)
                NORD = NMED - NLEQ
                IDON1 = 0
                ICRS1 = 1
                ICRS2 = 0
                IDCR = 0
                Do IDON = 1, NTRI, 7
                   IDON1 = IDON1 + 1
                   If (ICRS2 < NORD) Then
                      Do ICRS = ISTRT (IDON1), IDON + 6
                         If (XDATT (IWRKT (ICRS)) < XWRK1) Then
                            IWRK = IWRKT (ICRS)
                            XWRK = XDATT (IWRK)
                            Do IDCR = ICRS1 - 1, 1, - 1
                               If (XWRK >= XDATT (IWRKT (IDCR))) Exit
                               IWRKT  (IDCR+1) = IWRKT (IDCR)
                            End Do
                            IWRKT (IDCR+1) = IWRK
                            IWRK1 = IWRKT (ICRS1)
                            XWRK1 = XDATT (IWRK1)
                         Else
                           If (ICRS2 < NORD) Then
                              IWRKT (ICRS1) = IWRKT (ICRS)
                              IWRK1 = IWRKT (ICRS1)
                              XWRK1 = XDATT (IWRK1)
                           Endif
                         End If
                         ICRS1 = MIN (NORD, ICRS1 + 1)
                         ICRS2 = MIN (NORD, ICRS2 + 1)
                      End Do
                   Else
                      Do ICRS = ISTRT (IDON1), IDON + 6
                         If (XDATT (IWRKT (ICRS)) >= XWRK1) Exit
                         IWRK = IWRKT (ICRS)
                         XWRK = XDATT (IWRK)
                         Do IDCR = ICRS1 - 1, 1, - 1
                               If (XWRK >= XDATT (IWRKT (IDCR))) Exit
                               IWRKT  (IDCR+1) = IWRKT (IDCR)
                         End Do
                         IWRKT (IDCR+1) = IWRK
                         IWRK1 = IWRKT (ICRS1)
                         XWRK1 = XDATT (IWRK1)
                      End Do
                   End If
                End Do
                ires_med = IWRK1
                Return
            Else
                ires_med = IMED7
                Return
            End If
         Else                       !      If (NLEQ > NMED)
!                                          Not enough high values
                XWRK1 = -XHUGE
                NORD = NLEQ - NEQU - NMED + 1
                IDON1 = 0
                ICRS1 = 1
                ICRS2 = 0
                Do IDON = 1, NTRI, 7
                   IDON1 = IDON1 + 1
                   If (ICRS2 < NORD) Then
!
                      Do ICRS = IDON, IENDT (IDON1)
                         If (XDATT(IWRKT (ICRS)) > XWRK1) Then
                            IWRK = IWRKT (ICRS)
                            XWRK = XDATT (IWRK)
                            IDCR = ICRS1 - 1
                            Do IDCR = ICRS1 - 1, 1, - 1
                               If (XWRK <= XDATT(IWRKT (IDCR))) Exit
                               IWRKT (IDCR+1) = IWRKT (IDCR)
                            End Do
                            IWRKT (IDCR+1) = IWRK
                            IWRK1 = IWRKT(ICRS1)
                            XWRK1 = XDATT(IWRK1)
                         Else
                            If (ICRS2 < NORD) Then
                               IWRKT (ICRS1) = IWRKT (ICRS)
                               IWRK1 = IWRKT(ICRS1)
                               XWRK1 = XDATT(IWRK1)
                            End If
                         End If
                         ICRS1 = MIN (NORD, ICRS1 + 1)
                         ICRS2 = MIN (NORD, ICRS2 + 1)
                      End Do
                   Else
                      Do ICRS = IENDT (IDON1), IDON, -1
                         If (XDATT(IWRKT (ICRS)) <= XWRK1) Exit
                         IWRK = IWRKT (ICRS)
                         XWRK = XDATT (IWRK)
                         IDCR = ICRS1 - 1
                         Do IDCR = ICRS1 - 1, 1, - 1
                               If (XWRK <= XDATT(IWRKT (IDCR))) Exit
                               IWRKT (IDCR+1) = IWRKT (IDCR)
                         End Do
                         IWRKT (IDCR+1) = IWRK
                         IWRK1 = IWRKT(ICRS1)
                         XWRK1 = XDATT(IWRK1)
                      End Do
                   Endif
                End Do
!
                ires_med = IWRK1
                Return
         End If
!
   END Subroutine i_med
end module m_indmed


c     prog2
c     c.l.lawson and r.j.hanson, jet propulsion laboratory, 1973 jun 12
c     to appear in 'solving least squares problems', prentice-hall, 1974
c	 demonstrate algorithm	hfti  for solving least squares problems
c     and algorithm  cov  for computing the associated unscaled
c     covariance matrix.
c
      dimension a(8,8),h(8),b(8),g(8)
      real gen,anoise
      integer ip(8)
      double precision sm
      data mda /8/
c
	  do 180 noise=1,2
	  anorm=500.
	  anoise=0.
	  tau=.5
	  if (noise.eq.1) go to 10
	  anoise=1.e-4
	  tau=anorm*anoise*10.
   10	  continue
c     initialize the data generation function
c    ..
	  dummy=gen(-1.)
	  write (6,230)
	  write (6,240) anoise,anorm,tau
c
	      do 180 mn1=1,6,5
	      mn2=mn1+2
		  do 180 m=mn1,mn2
		      do 180 n=mn1,mn2
		      write (6,250) m,n
c     generate data
c    ..
			  do 20 i=1,m
			      do 20 j=1,n
   20			      a(i,j)=gen(anoise)
			  do 30 i=1,m
   30			  b(i)=gen(anoise)
c
c     ****** call hfti	 ******
c
		      call hfti(a,mda,m,n,b,1,1,tau,krank,srsmsq,h,g,ip)
c
c
		      write (6,260) krank
		      write (6,200) (i,b(i),i=1,n)
		      write (6,190) srsmsq
		      if (krank.lt.n) go to 180
c     ******  algorithm cov bigins here  ******
c    ..
			  do 40 j=1,n
   40			  a(j,j)=1./a(j,j)
		      if (n.eq.1) go to 70
		      nm1=n-1
			  do 60 i=1,nm1
			  ip1=i+1
			      do 60 j=ip1,n
			      jm1=j-1
			      sm=0.d0
				  do 50 l=i,jm1
   50				  sm=sm+a(i,l)*dble(a(l,j))
   60			      a(i,j)=-sm*a(j,j)
c    ..
c     the upper triangle of a has been inverted
c     upon itself.
   70			  do 90 i=1,n
			      do 90 j=i,n
			      sm=0.d0
				  do 80 l=j,n
   80				  sm=sm+a(i,l)*dble(a(j,l))
   90			      a(i,j)=sm
		      if (n.lt.2) go to 160
			  do 150 ii=2,n
			  i=n+1-ii
			  if (ip(i).eq.i) go to 150
			  k=ip(i)
			  tmp=a(i,i)
			  a(i,i)=a(k,k)
			  a(k,k)=tmp
			  if (i.eq.1) go to 110
			      do 100 l=2,i
			      tmp=a(l-1,i)
			      a(l-1,i)=a(l-1,k)
  100			      a(l-1,k)=tmp
  110			  ip1=i+1
			  km1=k-1
			  if (ip1.gt.km1) go to 130
			      do 120 l=ip1,km1
			      tmp=a(i,l)
			      a(i,l)=a(l,k)
  120			      a(l,k)=tmp
  130			  if (k.eq.n) go to 150
			  kp1=k+1
			      do 140 l=kp1,n
			      tmp=a(i,l)
			      a(i,l)=a(k,l)
  140			      a(k,l)=tmp
  150			  continue
  160		      continue
c    ..
c     covariance has been computed and repermuted.
c     the upper triangular part of the
c     symmetric matrix (a**t*a)**(-1) has
c     replaced the upper triangular part of
c     the a array.
		      write (6,210)
			  do 170 i=1,n
  170			  write (6,220) (i,j,a(i,j),j=i,n)
  180		      continue
      stop
  190 format (1h0,8x,17hresidual length =,e12.4)
  200 format (1h0,8x,34hestimated parameters,  x=a**(+)*b,,22h computed
     1by 'hfti'   //(9x,i6,e16.8,i6,e16.8,i6,e16.8,i6,e16.8,i6,e16.8))
  210 format (1h0,8x,31hcovariance matrix (unscaled) of,22h estimated pa
     1rameters.,19h computed by 'cov'./1x)
  220 format (9x,2i3,e16.8,2i3,e16.8,2i3,e16.8,2i3,e16.8,2i3,e16.8)
  230 format (52h1 prog2.     this program demonstates the algorithms,16
     1h hfti  and  cov.)
  240 format (1h0,54hthe relative noise level of the generated data will
     1 be,e16.4/33h0the matrix norm is approximately,e12.4/43h0the absol
     2ute pseudorank tolerance, tau, is,e12.4)
  250 format (1h0////9h0   m   n/1x,2i4)
  260 format (1h0,8x,12hpseudorank =,i4)
      end


subroutine report(x, n)
   use stats
   implicit none
   ! dummy arguments
   integer, intent(in) :: n
   real, dimension(n), intent(in) :: x
   ! processing
   write (*,*) 'n = ', n
   write (*,*) 'minimum = ', minval(x, 1)
   write (*,*) 'maximum = ', maxval(x, 1)
   write (*,*) 'mean = ', mean(x, n)
   write (*,*) 'median = ', median(x, n)
   write (*,*) 'population variance = ', popvar(x, n)
   write (*,*) 'sample variance = ', samvar(x, n)
   write (*,*) 'population standard deviation = ', popstd(x, n)
   write (*,*) 'sample standard deviation = ', samstd(x, n)
   write (*,*) 'median deviation = ', median_deviation(x, n)
   write (*,*) 'mean deviation = ', mean_deviation(x, n)
   write (*,*) 'skewness = ', skewness(x, n)
   write (*,*) 'nonparametric skew = ', nonparametric_skew(x, n)
end subroutine report


program euler_201
   use EulerCommon
   implicit none
   integer(int64), parameter :: kmax=100
   integer(int64), dimension(kmax) :: sq
   integer(int64) :: i, k, tot, ctr=0, one=1, zero=0
   integer(int64) :: max_sum
   type dictionary
      integer(int64) :: key,val
   end type dictionary
   type(dictionary), allocatable :: sums(:)
   real(dp) :: stt, fin
   call cpu_time(stt)

   ! set squares
   do i=1,kmax
      sq(i) = i*i
   end do !- i
   max_sum = sum(sq(:50))*1.06

   ! set the sums
   allocate(sums(1))
   sums(1)%key = 0
   sums(1)%val = 0

   ctr = zero

   call explore(one,zero,zero)

   tot = 0
   do i=1,size(sums)
      if (sums(i)%val == one) tot = tot + one
   end do !- i
   call cpu_time(fin)
   print *,tot*sum(sq)
   print '("took ",f0.6," seconds")',fin-stt

contains
   recursive subroutine explore(start, curr_sum, lev)
      integer(int64), intent(in) :: start, curr_sum, lev
      integer(int64) :: m, p_ct, m1, cm, l1

      ! step 1: check something
      if (???) then
         call ???
         ctr = ctr + one
         return
      end if

      ! explore somre more
      do m=start,kmax
         cm = curr_sum + m*m
         if (cm > max_sum) return

         p_ct = ctr
         m1 = m + one
         l1 = lev + one
         call explore(m1, cm, l1)
         if (???) exit
      end do !- m
   end subroutine explore

! removed two procedures since solutions should not be full for some of the more difficult ones....
end program euler_201


 SUBROUTINE build_coeff (ETA, N, Hs, Tp, DELT, SEED, seed2, i_spec,gamma)
!
! This subroutine returns Z(w), the Fourier transform of
! the wave elevation, zeta(t).  The coefficients are based on
! either a P-M or a JONSWAP spectrum, depending on i_spec.
!
   IMPLICIT none
   integer, parameter :: long=selected_real_kind(12,99)
   INTEGER SEED, seed2, i_spec, n, i
   REAL gasdev, ran1_b
   REAL(kind=long) :: Hs, Tp, pi, delt, df, cst, freq, spec,           &
        pm_spectrum, jonswap_spectrum, zero=0._long,          &
        one=1._long, two=2._long, four=4._long, half=.5_long,          &
        twopi, ran1, psi, mag, gamma
   REAL(kind=long) :: ETA(n) ! GD : modif so that types are compatible... n has to be a power of 2
   COMPLEX(kind=long) :: phase
   EXTERNAL gasdev, ran1_b, pm_spectrum, jonswap_spectrum

   pi = acos(-one)
   twopi = two * pi
   df = one / (n * delt)
   cst = sqrt(df)

! Take care of zero and Nyquist frequencies.

   eta (1) = zero
   eta (2) = zero
   open(unit=78,file='spectrum',status='unknown')
   write(78,79)
79 format('# Spectrum for the random wave wavemaker signal. f, T, S(f)')

! Build the Fourier coefficients using the chosen Spectrum and a random
! phase.

   DO  i = 2, n / 2
      freq = (i - 1) * df
      psi=ran1_b(seed2)
!
! Choose here whether the Fourier amplitudes should be exactly on the spectrum
! or Gaussianly distributed around the spectral value.
!
      mag=one
!      mag=gasdev(seed)  ! This will give a Guassian distribution of magnitude.
!
      phase=mag*cmplx(cos(twopi*psi),sin(twopi*psi))

! Get the wave spectrum value at this frequency.
      IF(i_spec==0)THEN
         spec= pm_spectrum(freq, Hs, Tp)
      ELSE
         spec= jonswap_spectrum(freq, Hs, Tp,gamma)
      ENDIF

      write(78,*)freq,1/freq,spec

      !eta (i)   = sqrt (two * spec) * cst * phase
      ! Real part
      eta (2*i-1) = REAL(sqrt (two * spec) * cst * phase)
      ! Imaginary part
      eta (2*i)   = AIMAG(sqrt (two * spec) * cst * phase)

   END DO

   close(78)

   RETURN
 END SUBROUTINE BUILD_COEFF


C     Fortranification of AMIDOL's SIR-Gillespie.py
********************************************************************************
      module update_mvar
         implicit none
      contains
         subroutine update_mean_var(MeanS, VarS, k, n, runs)
         integer, parameter :: Tmax = 100
         double precision, dimension(0:Tmax) :: MeanS, VarS
         integer k, n, runs

         MeanS(k) = MeanS(k) + (n - MeanS(k))/(runs+1)
         VarS(k) = VarS(k) + runs/(runs+1) * (n-MeanS(k))*(n-MeanS(k))
         end subroutine update_mean_var
      end module update_mvar

********************************************************************************
C     Variables:
C     beta     Rate of infection
C     gamma    Rate of recovery from an infection
C     rho      Basic reproduction Number
C
C     State Variables: S, I, R
C     S - Susceptible population
C     I - Infected population
C     R - Recovered population
C     n_S      current number of susceptible members
C     n_I      current number of infected members
C     n_R      current number of recovered members
C     S0       initial value of S
C     I0       initial value of I
C     R0       initial value of R
C     MeanS    Measures of Mean for S
C     MeanI    Measures of Mean for I
C     MeanR    Measures of Mean for R
C     VarS     Measures of Variance for S
C     VarI     Measures of Variance for I
C     VarR     Measures of Variance for R
C
C     rateInfect    Current state dependent rate of infection
C     rateRecover   Current state dependent rate of recovery
C     totalRates    Sum of total rates; taking advantage of Markovian identities
C                       to improve performance.
C
C     Tmax          Maximum time for the simulation
C     t             Initial time for the simulation
C     totalRuns     Total number of trajectories to generate for the analysis
C     dt       next inter-event time
********************************************************************************
      module mod_gillespie
          use update_mvar
      contains
          subroutine gillespie(S0, I0, R0, MeanS, MeanI, MeanR, VarS,
     &                         VarI, VarR)
          integer S0, I0, R0
          integer, parameter :: Tmax = 100
          integer, parameter :: total_runs = 1000
          double precision, parameter :: gamma = 1.0/3.0
          double precision, parameter :: rho = 2.0
          double precision, parameter :: beta = rho * gamma !
          double precision, dimension(0:Tmax) :: MeanS, MeanI, MeanR
          double precision, dimension(0:Tmax) :: VarS, VarI, VarR
          integer, dimension(0:Tmax) :: samples

          integer i, runs, n_S, n_I, n_R, sample_idx, sample
          double precision rateInfect, rateRecover, totalRates, dt, t

          do i = 0, Tmax    ! Initialize the mean and variance arrays
             MeanS(i) = 0
             MeanI(i) = 0.0
             MeanR(i) = 0.0

             VarS(i) = 0.0
             VarI(i) = 0.0
             VarR(i) = 0.0

             samples(i) = i
          end do

          do runs = 0, total_runs-1
             t = 0.0    ! Restart the event clock

             n_S = S0
             n_I = I0
             n_R = R0

             ! main Gillespie loop
             sample_idx = 0
             do while (t .le. Tmax .and. n_I .gt. 0)
                rateInfect = beta * n_S * n_I / (n_S + n_I + n_R)
                rateRecover = gamma * n_I
                totalRates = rateInfect + rateRecover

                dt = -log(1.0-rand())/totalRates  ! next inter-event time
                t = t + dt          !  Advance the system clock

                ! Calculate all measures up to the current time t using
                ! Welford's one pass algorithm
                do while (sample_idx < Tmax .and.
     &                    t > samples(sample_idx))
                   sample = samples(sample_idx)
                   call update_mean_var(MeanS, VarS, sample, n_S, runs)
                   call update_mean_var(MeanI, VarI, sample, n_I, runs)
                   call update_mean_var(MeanR, VarR, sample, n_R, runs)
                   sample_idx = sample_idx+1
                end do

                ! Determine which event fired.  With probability rateInfect/totalRates
                ! the next event is infection.
                if (rand() < (rateInfect/totalRates)) then
                    ! Delta for infection
                    n_S = n_S - 1
                    n_I = n_I + 1
                ! Determine the event fired.  With probability rateRecover/totalRates
                ! the next event is recovery.
                else
                    ! Delta for recovery
                    n_I = n_I - 1
                    n_R = n_R + 1
                endif
             end do

             ! After all events have been processed, clean up by evaluating all remaining measures.
             do while (sample_idx < Tmax)
                sample = samples(sample_idx)
                call update_mean_var(MeanS, VarS, sample, n_S, runs)
                call update_mean_var(MeanI, VarI, sample, n_I, runs)
                call update_mean_var(MeanR, VarR, sample, n_R, runs)
                sample_idx = sample_idx + 1
             end do
          end do

          end subroutine gillespie
      end module mod_gillespie

      program main
      use mod_gillespie
      integer, parameter :: S0 = 500, I0 = 10, R0 = 0, Tmax = 100
      double precision, dimension(0:Tmax) :: MeanS, MeanI, MeanR
      double precision, dimension(0:Tmax) :: VarS, VarI, VarR

      call gillespie(S0, I0, R0, MeanS, MeanI, MeanR, VarS, VarI, VarR)

      end program main


! Complex error function / Faddeyeva function w(z)

module z_erf

contains

subroutine wofz_f90(zIn,zOut,flag)

!  algorithm 680, collected algorithms from acm.
!  this work published in transactions on mathematical software,
!  vol. 16, no. 1, pp. 47.
!
!  given a complex number z = (xi,yi), this subroutine computes
!  the value of the faddeeva-function w(z) = exp(-z**2)*erfc(-i*z),
!  where erfc is the complex complementary error-function and i
!  means sqrt(-1).
!  the accuracy of the algorithm for z in the 1st and 2nd quadrant
!  is 14 significant digits; in the 3rd and 4th it is 13 significant
!  digits outside a circular region with radius 0.126 around a zero
!  of the function.
!  all real variables in the program are double precision.
!
!  the code contains a few compiler-dependent parameters :
!     rmaxreal = the maximum value of rmaxreal equals the root of
!                rmax = the largest number which can still be
!                implemented on the computer in double precision
!                floating-point arithmetic
!     rmaxexp  = ln(rmax) - ln(2)
!     rmaxgoni = the largest possible argument of a double precision
!                goniometric function (cos, sin, ...)
!  the reason why these parameters are needed as they are defined will
!  be explained in the code by means of comments
!
!
!  parameter list
!     xi     = real      part of z
!     yi     = imaginary part of z
!     u      = real      part of w(z)
!     v      = imaginary part of w(z)
!     flag   = an error flag indicating whether overflow will
!              occur or not; type logical;
!              the values of this variable have the following
!              meaning :
!              flag=.false. : no error condition
!              flag=.true.  : overflow will occur, the routine
!                             becomes inactive
!  xi, yi      are the input-parameters
!  u, v, flag  are the output-parameters
!
!  furthermore the parameter factor equals 2/sqrt(pi)
!
!  the routine is not underflow-protected but any variable can be
!  put to 0 upon underflow;
!
!  reference - gpm poppe, cmj wijers; more efficient computation of
!  the complex error-function, acm trans. math. software (1990)
!  vol. 16, no. 1, pp. 47.

implicit none
integer, parameter :: DBL = selected_real_kind(p=13,r=200)
complex(kind=DBL), intent(in) :: zIn
complex(kind=DBL), intent(out) :: zOut
logical, intent(out) :: flag

real(kind=DBL) :: c, daux, h, h2=0, qlambda=0, qrho,&
    rx, ry, sx,&
    sy, tx, ty, u, u1, u2, v
real(kind=DBL) :: v1, v2, w1, x, xabs, xabsq, xaux, xi,&
    xquad, xsum, y, yabs, yi, yquad, ysum
integer :: i, j, kapn, n, np1, nu
logical :: a, b
real(kind=DBL), parameter :: &
    factor=1.12837916709551257388d0, &
    rmaxreal=0.5d+154,&
    rmaxexp=708.503061461606d0,&
    rmaxgoni=3.53711887601422d+15

!xi = realpart(zIn)
!yi = imagpart(zIn)
xi = real(real(zIn))
yi = real(aimag(zIn))

flag = .false.
xabs = abs(xi)
yabs = abs(yi)
x = xabs/6.3
y = yabs/4.4

! The following if-statement protects
! qrho = (x**2 + y**2) against overflow

overflowLabel1: &
if ( (xabs.gt.rmaxreal) .or. (yabs.gt.rmaxreal) ) then

   flag = .true.

else

    qrho = x**2 + y**2

    xabsq = xabs**2
    xquad = xabsq - yabs**2
    yquad = 2*xabs*yabs

    a = qrho.lt.0.085264d0

    qrhoBreakdown: &
    if ( a ) then

        !  if (qrho.lt.0.085264d0) then the faddeeva-function is evaluated
        !  using a power-series (abramowitz/stegun, equation (7.1.5), p.297)
        !  n is the minimum number of terms needed to obtain the required
        !  accuracy

        qrho = (1-0.85*y)*sqrt(qrho)
        n = nint(6+72*qrho)
        j = 2*n + 1
        xsum = 1.0/j
        ysum = 0.0d0

        do i = n , 1 , -1
           j = j - 2
           xaux = (xsum*xquad-ysum*yquad)/i
           ysum = (xsum*yquad+ysum*xquad)/i
           xsum = xaux + 1.0/j
        enddo

        u1 = -factor*(xsum*yabs+ysum*xabs) + 1.0
        v1 = factor*(xsum*xabs-ysum*yabs)
        daux = exp(-xquad)
        u2 = daux*cos(yquad)
        v2 = -daux*sin(yquad)

        u = u1*u2 - v1*v2
        v = u1*v2 + v1*u2

    else

    !  if (qrho.gt.1.o) then w(z) is evaluated using the laplace
    !  continued fraction
    !  nu is the minimum number of terms needed to obtain the required
    !  accuracy
    !
    !  if ((qrho.gt.0.085264d0).and.(qrho.lt.1.0)) then w(z) is evaluated
    !  by a truncated taylor expansion, where the laplace continued fraction
    !  is used to calculate the derivatives of w(z)
    !  kapn is the minimum number of terms in the taylor expansion needed
    !  to obtain the required accuracy
    !  nu is the minimum number of terms of the continued fraction needed
    !  to calculate the derivatives with the required accuracy

        if ( qrho.gt.1.0 ) then

            h       = 0.0d0
            kapn    = 0
            qrho    = sqrt(qrho)
            nu      = int(3+(1442/(26*qrho+77)))

        else

            qrho    = (1-y)*sqrt(1-qrho)
            h       = 1.88*qrho
            h2      = 2*h
            kapn    = nint(7+34*qrho)
            nu      = nint(16+26*qrho)

        endif

        b = (h.gt.0.0)

        if ( b ) qlambda = h2**kapn

        rx = 0.0
        ry = 0.0
        sx = 0.0
        sy = 0.0

        do n = nu, 0, -1

           np1  = n + 1
           tx   = yabs + h + np1*rx
           ty   = xabs - np1*ry
           c    = 0.5/(tx**2+ty**2)
           rx   = c*tx
           ry   = c*ty

           if ( (b) .and. (n.le.kapn) ) then

              tx = qlambda + sx
              sx = rx*tx - ry*sy
              sy = ry*tx + rx*sy
              qlambda = qlambda/h2

           endif

        enddo

        if ( h.eq.0.0 ) then
           u = factor*rx
           v = factor*ry
        else
           u = factor*sx
           v = factor*sy
        endif

        if ( yabs.eq.0.0 ) u = exp(-xabs**2)

    endif qrhoBreakdown

    ! Evaluation of w(z) in the other quadrants

    yiLTzero: &
    if ( yi.lt.0.0 ) then

        aLabel2: &
        if ( a ) then

            u2 = 2*u2
            v2 = 2*v2

        else

            xquad = -xquad

            ! The following if-statement protects 2*exp(-z**2)
            ! against overflow

            overflowLabel: &
            if ( (yquad.gt.rmaxgoni) .or. (xquad.gt.rmaxexp) ) then

                flag = .true.
                zOut = cmplx(u,v,DBL)
                return

            else

                w1 = 2*exp(xquad)
                u2 = w1*cos(yquad)
                v2 = -w1*sin(yquad)

            endif overflowLabel

        endif aLabel2

        u = u2 - u
        v = v2 - v

        if ( xi.gt.0.0 ) v = -v

        else
            if ( xi.lt.0.0 ) v = -v

        endif yiLTzero

    zOut = cmplx(u,v,DBL)
    return

endif overflowLabel1

end subroutine wofz_f90

end module z_erf


submodule(euler_interface_m) euler_prob_0060_m
    implicit none

contains

    module character(len=20) function euler0060()
        integer(int64) :: input_arr(2)

        input_arr = [5000000_int64, 1060_int64]
        write (euler0060, "(i20)") ans(input_arr)
    end function euler0060

    integer(int64) function ans(n)
        use euler_primes_m, only: sieve_of_Eratosthenes
        implicit none

        integer(int64), intent(in) :: n(2)
        integer(int64) :: i, k, flags(2)
        logical, allocatable :: isprime(:), conc_is_prime(:, :)
        integer(int64), allocatable :: primes(:), test_pair(:), idx(:)
        logical :: prime_pair_found, next_permutation_avail, checked

        call sieve_of_Eratosthenes(n(1), isprime)
        allocate (primes(count(isprime)))
        k = 1
        do i = 0, size(isprime) - 1
            if (isprime(i)) then
                primes(k) = i
                k = k + 1
            end if
        end do

        k = 5
        allocate (idx(k))
        idx = [2, 3, 4, 5, 6]
        prime_pair_found = .false.
        next_permutation_avail = .true.
        flags = [1, 2]

        allocate (conc_is_prime(n(2), n(2)))
        conc_is_prime = .true.

        do while (next_permutation_avail)
            checked = checked_before(idx, conc_is_prime, flags)
            if (checked) then
                next_permutation_avail = next_combination(k, n(2), flags, idx)
                cycle
            end if

            test_pair = primes(idx)
            prime_pair_found = is_prime_pair(test_pair, isprime, flags)
            if (prime_pair_found) exit
            call gen_label(flags, idx, conc_is_prime)
            next_permutation_avail = next_combination(k, n(2), flags, idx)
        end do

        ans = sum(primes(idx))
    end function

    function concatenate(arr) result(ab)
        integer(int64), intent(in) :: arr(:)
        integer(int64) :: ab, pow

        pow = digs_of_int(arr(2))
        ab = arr(1)*10**pow + arr(2)
    end function concatenate

    function checked_before(test_idx, conc_is_prime, flags) result(ret)
        integer(int64), intent(in) :: test_idx(:)
        logical, intent(in) :: conc_is_prime(:, :)
        integer(int64), intent(inout) :: flags(2)
        logical :: ret, next_avail
        integer(int64) :: k, n, idx(2)

        k = 2
        n = size(test_idx)
        idx = [1, 2]
        ret = .false.
        next_avail = .true.

        do while (next_avail)
            associate (x => test_idx(idx(1)), y => test_idx(idx(2)), &
                       s => size(conc_is_prime(1, :)))
                if (x < s .and. y < s) then
                    if (.not. conc_is_prime(x, y)) then
                        ret = .true.
                        flags = idx
                        return
                    end if
                end if
            end associate
            call next_permutation(k, n, idx, next_avail)
            ! next_avail = next_permutation(k, n, idx)
        end do
    end function checked_before

    subroutine gen_label(flags, idx, conc_is_prime)
        integer(int64), intent(in) :: flags(2), idx(:)
        logical, intent(inout) :: conc_is_prime(:, :)

        associate (x => idx(flags(1)), y => idx(flags(2)), &
                   s => size(conc_is_prime(1, :)))
            if (x < s .and. y < s) then
                if (conc_is_prime(x, y)) then
                    conc_is_prime(x, y) = .false.
                    conc_is_prime(y, x) = .false.
                end if
            end if
        end associate
    end subroutine gen_label

    function next_combination(k, n, flags, idx) result(ret)
        integer(int64), intent(in) :: k, n, flags(2)
        integer(int64), intent(inout) :: idx(:)
        logical :: ret
        integer(int64) :: i, end_arr(k), flag

        flag = max(flags(1), flags(2))
        if (flag == k .or. flag == 0_int64) then
            ! ret = next_permutation(k, n, idx)
            call next_permutation(k, n, idx, ret)
            return
        end if

        end_arr = [(i, i=n - k + 1, n)]
        ret = .true.
        if (all(idx == end_arr)) then
            ret = .false.
            return
        end if

        if (idx(size(idx)) == n) then
            ! ret = next_permutation(k, n, idx)
            call next_permutation(k, n, idx, ret)
        else
            idx(flag:k) = [(idx(flag) + i, i=1, k - flag + 1)]
        end if
    end function next_combination

    function is_prime_pair(test_pair, isprime, flag) result(try_succeed)
        use euler_primes_m, only: is_prime
        implicit none

        integer(int64), intent(in) :: test_pair(:)
        logical, allocatable, intent(in) :: isprime(:)
        integer(int64), intent(out) :: flag(2)
        integer(int64) :: k, n, idx(2)
        logical :: avail, try_succeed

        k = 2
        n = size(test_pair)

        try_succeed = .true.
        idx = [1, 2]
        avail = .true.
        flag = 0

        do while (avail)
            associate (ab => concatenate(test_pair(idx)), &
                       ba => concatenate(test_pair(idx(2:1:-1))))
                if (ab <= size(isprime)) then
                    if (.not. isprime(ab)) then
                        flag = idx
                        try_succeed = .false.
                        return
                    end if
                else
                    if (.not. is_prime(ab)) then
                        flag = idx
                        try_succeed = .false.
                        return
                    end if
                end if

                if (ba <= size(isprime)) then
                    if (.not. isprime(ba)) then
                        flag = idx(2:1:-1)
                        try_succeed = .false.
                        return
                    end if
                else
                    if (.not. is_prime(ba)) then
                        flag = idx(2:1:-1)
                        try_succeed = .false.
                        return
                    end if
                end if
                call next_permutation(k, n, idx, avail)
                ! avail = next_permutation(k, n, idx)
            end associate
        end do
    end function is_prime_pair

end submodule euler_prob_0060_m


      SUBROUTINE ALG01 (XDATA,YDATA,NDATA,XIN,YOUT,SLOPE,NXY,NTYPE,NWOT)
C
      REAL      M
C
      DIMENSION XDATA(2),YDATA(2),XIN(1),YOUT(1),SLOPE(1),A(21),B(21),
     1          D(21),M(21)
C
      IF (NTYPE.EQ.1.OR.NDATA.LT.3) GO TO 210
      A(1)=1.0
      B(1)=0.0
      D(1)=0.0
      N=NDATA-1
      DO 110 I=2,N
      A(I)=(XDATA(I+1)-XDATA(I-1))/3.0-(XDATA(I)-XDATA(I-1))*B(I-1)/(6.0
     1*A(I-1))
      B(I)=(XDATA(I+1)-XDATA(I))/6.0
 110  D(I)=(YDATA(I+1)-YDATA(I))/(XDATA(I+1)-XDATA(I))-(YDATA(I)-YDATA(I
     1-1))/(XDATA(I)-XDATA(I-1))-(XDATA(I)-XDATA(I-1))*D(I-1)/(6.0*A(I-1
     2))
      A(NDATA)=0.0
      B(NDATA)=1.0
      D(NDATA)=0.0
      M(NDATA)=A(NDATA)*D(N)/(A(NDATA)*B(N)-A(N)*B(NDATA))
      DO 120 II=2,NDATA
      I=NDATA+1-II
 120  M(I)=(D(I)-B(I)*M(I+1))/A(I)
      ASSIGN 150 TO IY
      IF (NWOT.EQ.1) ASSIGN 160 TO IY
      ASSIGN 160 TO ISLOPE
      IF (NWOT.EQ.0) ASSIGN 200 TO ISLOPE
      J=2
      DO 200 I=1,NXY
      IF (XIN(I).LT.XDATA(1)) GO TO 170
      IF (XIN(I).GT.XDATA(NDATA)) GO TO 180
 130  IF (XIN(I).LE.XDATA(J)) GO TO 140
      J=J+1
      GO TO 130
 140  DX=XDATA(J)-XDATA(J-1)
      GO TO IY, (150,160)
 150  YOUT(I)=M(J-1)/(6.0*DX)*(XDATA(J)-XIN(I))**3+M(J)/(6.0*DX)*(XIN(I)
     1-XDATA(J-1))**3+(XDATA(J)-XIN(I))*(YDATA(J-1)/DX-M(J-1)/6.0*DX)+(X
     2IN(I)-XDATA(J-1))*(YDATA(J)/DX-M(J)/6.0*DX)
      GO TO ISLOPE, (160,200)
 160  SLOPE(I)=(-M(J-1)*(XDATA(J)-XIN(I))**2/2.0+M(J)*(XIN(I)-XDATA(J-1)
     1)**2/2.0+YDATA(J)-YDATA(J-1))/DX-(M(J)-M(J-1))/6.0*DX
      GO TO 200
 170  JP=1
      KP=2
      GO TO 190
 180  JP=NDATA
      KP=N
 190  YPRIME=(YDATA(KP)-YDATA(JP))/(XDATA(KP)-XDATA(JP))-M(KP)/6.0*(XDAT
     1A(KP)-XDATA(JP))
      IF (NWOT.NE.1) YOUT(I)=YDATA(JP)+(XIN(I)-XDATA(JP))*YPRIME
      IF (NWOT.NE.0) SLOPE(I)=YPRIME
 200  CONTINUE
      RETURN
 210  IF (NDATA.NE.1) GO TO 230
      DO 220 I=1,NXY
 220  YOUT(I)=YDATA(1)
      RETURN
 230  IF (NWOT.EQ.1) GO TO 254
      J=2
      DO 250 I=1,NXY
 240  IF (XIN(I).LE.XDATA(J).OR.J.EQ.NDATA) GO TO 250
      J=J+1
      GO TO 240
 250  YOUT(I)=YDATA(J-1)+(YDATA(J)-YDATA(J-1))/(XDATA(J)-XDATA(J-1))*(XI
     1N(I)-XDATA(J-1))
      IF (NWOT.NE.2) RETURN
 254  YPRIME=(YDATA(2)-YDATA(1))/(XDATA(2)-XDATA(1))
      DO 260 I=1,NXY
 260  SLOPE(I)=YPRIME
      RETURN
      END