c     Fortran translation (Heh!) of test15 in quadpack-tests.lisp.
      program test15
      implicit none
      double precision alpha
      integer key

      print *, 'Test 15'
      print *
      print *, ' integrate(x^2*exp(-2^(-alpha)*x),x,0,b)'
      print *, '  = (1+eps)*2^(3*alpha+1)'

      print *
      print *
      print *, 'QAG'
      print 9000
      do 20 alpha = 0d0,6d0
         call qqag(alpha)
   20 continue
      print *
      print *, 'QAGI'
      print 9000
      do 50 alpha = 0d0, 6d0
         call qqagi(alpha)
   50 continue
 9000 format('alpha   est result              est abserr             nev
     &al    ier   true answer            true abs err')
      end
      double precision function soln(alpha, limit)
      double precision pi
      parameter (pi = 3.141592653589793d0)
      double precision alpha, a2, tmp, limit

      if (limit .gt. 0) then
         a2 = 2**alpha
         tmp = exp(-limit/a2)*(limit**2 + 2*a2*limit + 2*a2)
      else
         tmp = 0
      endif
      soln = 2**(1+3*alpha) - tmp
      return
      end

      double precision function f(x)
      double precision x, tmp
      double precision alfa

      common /param/ alfa
      f = x*x*exp(-x*2**(-alfa))
      return
      end

      subroutine qqag(alpha)
      integer limit, lenw
      parameter (limit = 200, maxp1 = 100, leniw = limit, limlst = 10)
      parameter (lenw = 2*leniw + maxp1*25)

      double precision alpha
      double precision alfa
      common /param/alfa

      integer iwork(leniw)
      double precision work(lenw)
      double precision f, soln
      external f

      double precision result, abserr
      integer neval, ier, last

      alfa = alpha
      last = 0
      call dqag(f, 0d0, 40*2**alpha, 0d0, 1d-8, 6,
     $     result, abserr, neval, ier,
     $     limit, lenw, last, iwork, work)
      print 9000, alpha, result, abserr, neval, ier,
     $     soln(alpha, 40*2**alpha),
     $     abs(soln(alpha,40*2**alpha) - result)
      return
 9000 format(f5.1, 2(2x, 1pe22.15), 2(2x,i5), 2x, 1pe22.15, 1x, 1pe10.3)
      end

      subroutine qqagi(alpha)
      integer leniw, limit, lenw, maxp1
      parameter (limit = 200, leniw = limit, maxp1 = 100)
      parameter (lenw = 2*leniw+25*maxp1)

      double precision alpha
      double precision alfa
      common /param/alfa

      integer iwork(leniw)
      double precision work(lenw)
      double precision f, soln
      external f

      double precision result, abserr
      integer neval, ier, last

      alfa = alpha

      call dqagi(f, 0d0, 1, 0d0, 1d-8,
     $     result, abserr, neval, ier,
     $     limit, lenw, last, iwork, work)
      print 9000, alpha, result, abserr, neval, ier, soln(alpha,0d0),
     $     abs(soln(alpha,0d0) - result)
      return
 9000 format(f5.1, 2(2x, 1pe22.15), 2(2x,i5), 2x, 1pe22.15, 1x, 1pe10.3)
      end


      subroutine fast (b, n)
c
c replaces the real vector b(k), for k=1, 2, ...., n.
c with its finite descrete fourier transform.
c
c the dc term is returned in location b(1) with b(2) set to 0.
c thereafter the jth harmonic is returned as a complex number
c stored as b(2*j+1) + i b(2*j+2).
c the n/2 harmonic is returned in b(n+1) with b(n+2) set to 0.
c hence, b must be dimensioned to size n + 2.
c the subroutine is called as  fast(b, n) where n=2**m and
c b is the real array described above.
c
c  author: g. d. bergland and m. t. dolan
c          bell lab., murray hill, nj 07974.
c
c  reference: program for digital signal processing,
c             (ed., digital signal processing committee, ieee
c             acoustics, speech, and signal processing society)
c             ieee press, new york, 1979.
c
c
      dimension b(2)
      common /cons/ pii, p7, p7two, c22, s22, pi2
c
c iw is a machine dependent write device number
c
      iw = 6
c
      pii = 4.0*atan(1.0)
      pi8 = pii/8.0
      p7  = 1.0/sqrt(2.0)
      p7two = 2.0*p7
      c22 = cos(pi8)
      s22 = sin(pi8)
      pi2 = 2.0*pii
      do 10 i=1, 25
        m = i
        nt = 2**i
        if (n.eq.nt)  go to 20
  10  continue
      write (iw,9999)
9999  format ( 33h n is not a power of two for fast )
      stop
  20  n4pow = m/2
c
c do a radix 2 iteration first if one is required
c
      if (m-n4pow*2)  40, 40, 30
  30  nn = 2
      int = n/nn
      call fr2tr (int, b(1), b(int+1))
      go to 50
  40  nn = 1
c
c perform radix 4 iterations.
c
  50  if (n4pow .eq. 0)  go to 70
      do 60 it=1, n4pow
        nn = nn*4
        int = n/nn
        call fr4tr (int, nn, b(1), b(int+1), b(2*int+1), b(3*int+1),
     *              b(1), b(int+1), b(2*int+1), b(3*int+1))
  60  continue
c
c perform in-place reordering.
c
  70  call ford1 (m, b)
      call ford2 (m, b)
      t = b(2)
      b(2) = 0.0
      b(n+1) = t
      b(n+2) = 0.0
      do 80 it=4, n, 2
        b(it) = -b(it)
  80  continue
      return
      end
      subroutine fsst (b, n)
c
c fourier synthesis subroutine.
c
c this subroutine synthesizes the real vector b(k), for
c k=1, 2, ..., n. from the fourier coefficients stored in the
c b array of size  n + 2.  the dc term is in b(1) with b(2) equal
c to 0.  the jth harmonic is stored as b(2*j+1) + i b(2*j+2).
c the n/2 harmonic is in b(n+1) with b(n+2) equal to 0.
c the subroutine is called as  fsst(b, n) where n=2**m and
c b is the real array discussed above.
c
      dimension b(2)
      common /cons/ pii, p7, p7two, c22, s22, pi2
c
c iw is a machine dependent write device number
c
      iw = 6
c
      pii = 4.0*atan(1.0)
      pi8 = pii/8.0
      p7  = 1.0/sqrt(2.0)
      p7two = 2.0*p7
      c22 = cos(pi8)
      s22 = sin(pi8)
      pi2 = 2.0*pii
      do 10 i=1, 25
        m = i
        nt = 2**i
        if (n.eq.nt)  go to 20
  10  continue
      write (iw,9999)
9999  format ( 33h n is not a power of two for fast )
      stop
  20  b(2) = b(n+1)
      do 30 i=4, n, 2
        b(i) = -b(i)
  30  continue
c
c scale the input by n.
c
      do 40 i=1,n
        b(i) = b(i)/float(n)
  40  continue
      n4pow = m/2
c
c scramble the inputs.
c
      call ford2 (m, b)
      call ford1 (m, b)
      if (n4pow .eq. 0)  go to 60
      nn = 4*n
      do 50 it=1, n4pow
        nn = nn/4
        int = n/nn
        call fr4syn (int, nn, b(1), b(int+1), b(2*int+1), b(3*int+1),
     *              b(1), b(int+1), b(2*int+1), b(3*int+1))
  50  continue
c
c do a radix 2 iteration if one is required.
c
  60  if (m-n4pow*2)  80, 80, 70
  70  int = n/2
      call fr2tr (int, b(1), b(int+1))
  80  return
      end
      subroutine fr2tr (int, b0, b1)
c
c radix 2 iteration subroutine.
c
      dimension b0(2), b1(2)
      do 10 k=1, int
        t = b0(k) + b1(k)
        b1(k) = b0(k) - b1(k)
        b0(k) = t
  10  continue
      return
      end
      subroutine fr4tr (int, nn, b0, b1, b2, b3, b4, b5, b6, b7)
c
c radix 4 iteration subroutine.
c
      dimension l(15), b0(2),b1(2),b2(2),b3(2),b4(2),b5(2),b6(2),b7(2)
      common /cons/pii, p7, p7two, c22, s22, pi2
      equivalence (l15,l(1)), (l14,l(2)), (l13,l(3)), (l12,l(4)),
     *  (l11,l(5)), (l10,l(6)), (l9,l(7)), (l8,l(8)), (l7,l(9)),
     *  (l6,l(10)), (l5,l(11)), (l4,l(12)), (l3,l(13)), (l2,l(14)),
     *  (l1,l(15))
c
c jthet is a reversed binary counter. jr steps two at a time to
c locate the real parts of intermediate results, and ji locates
c the imaginary part corresponding to jr.
c
      l(1) = nn/4
      do 40 k=2, 15
        if (l(k-1)-2)  10, 20, 30
  10    l(k-1) = 2
  20    l(k) = 2
        go to 40
  30    l(k) = l(k-1)/2
  40  continue
c
      piovn = pii/float(nn)
      ji = 3
      jl = 2
      jr = 2
c
      do 120 j1=2,  l1, 2
      do 120 j2=j1, l2, l1
      do 120 j3=j2, l3, l2
      do 120 j4=j3, l4, l3
      do 120 j5=j4, l5, l4
      do 120 j6=j5, l6, l5
      do 120 j7=j6, l7, l6
      do 120 j8=j7, l8, l7
      do 120 j9=j8, l9, l8
      do 120 j10=j9, l10, l9
      do 120 j11=j10, l11, l10
      do 120 j12=j11, l12, l11
      do 120 j13=j12, l13, l12
      do 120 j14=j13, l14, l13
      do 120 jthet=j14, l15, l14
        th2 = jthet - 2
        if (th2)  50, 50, 90
  50    do 60 k=1, int
          t0 = b0(k) + b2(k)
          t1 = b1(k) + b3(k)
          b2(k) = b0(k) - b2(k)
          b3(k) = b1(k) - b3(k)
          b0(k) = t0 + t1
          b1(k) = t0 - t1
  60    continue
c
        if (nn-4)  120, 120, 70
  70    k0 = int*4 + 1
        kl = k0 + int - 1
        do 80 k=k0, kl
          pr = p7*(b1(k) - b3(k))
          pi = p7*(b1(k) + b3(k))
          b3(k) = b2(k) + pi
          b1(k) = pi - b2(k)
          b2(k) = b0(k) - pr
          b0(k) = b0(k) + pr
  80    continue
        go to 120
c
  90    arg = th2*piovn
        c1 = cos(arg)
        s1 = sin(arg)
        c2 = c1**2 - s1**2
        s2 = c1*s1 + c1*s1
        c3 = c1*c2 - s1*s2
        s3 = c2*s1 + s2*c1
c
        int4 = int*4
        j0 = jr*int4 + 1
        k0 = ji*int4 + 1
        jlast = j0 + int - 1
        do 100 j=j0, jlast
          k = k0 + j - j0
          r1 = b1(j)*c1 - b5(k)*s1
          r5 = b1(j)*s1 + b5(k)*c1
          t2 = b2(j)*c2 - b6(k)*s2
          t6 = b2(j)*s2 + b6(k)*c2
          t3 = b3(j)*c3 - b7(k)*s3
          t7 = b3(j)*s3 + b7(k)*c3
          t0 = b0(j) + t2
          t4 = b4(k) + t6
          t2 = b0(j) - t2
          t6 = b4(k) - t6
          t1 = r1 + t3
          t5 = r5 + t7
          t3 = r1 - t3
          t7 = r5 - t7
          b0(j) = t0 + t1
          b7(k) = t4 + t5
          b6(k) = t0 - t1
          b1(j) = t5 - t4
          b2(j) = t2 - t7
          b5(k) = t6 + t3
          b4(k) = t2 + t7
          b3(j) = t3 - t6
 100    continue
c
        jr = jr + 2
        ji = ji - 2
        if (ji-jl)  110, 110, 120
 110    ji = 2*jr - 1
        jl = jr
 120  continue
      return
      end
      subroutine fr4syn (int, nn, b0, b1, b2, b3, b4, b5, b6, b7)
c
c radix 4 synthesis.
c
      dimension l(15), b0(2),b1(2),b2(2),b3(2),b4(2),b5(2),b6(2),b7(2)
      common /cons/pii, p7, p7two, c22, s22, pi2
      equivalence (l15,l(1)), (l14,l(2)), (l13,l(3)), (l12,l(4)),
     *  (l11,l(5)), (l10,l(6)), (l9,l(7)), (l8,l(8)), (l7,l(9)),
     *  (l6,l(10)), (l5,l(11)), (l4,l(12)), (l3,l(13)), (l2,l(14)),
     *  (l1,l(15))
c
      l(1) = nn/4
      do 40 k=2, 15
        if (l(k-1)-2)  10, 20, 30
  10    l(k-1) = 2
  20    l(k) = 2
        go to 40
  30    l(k) = l(k-1)/2
  40  continue
c
      piovn = pii/float(nn)
      ji = 3
      jl = 2
      jr = 2
c
      do 120 j1=2,  l1, 2
      do 120 j2=j1, l2, l1
      do 120 j3=j2, l3, l2
      do 120 j4=j3, l4, l3
      do 120 j5=j4, l5, l4
      do 120 j6=j5, l6, l5
      do 120 j7=j6, l7, l6
      do 120 j8=j7, l8, l7
      do 120 j9=j8, l9, l8
      do 120 j10=j9, l10, l9
      do 120 j11=j10, l11, l10
      do 120 j12=j11, l12, l11
      do 120 j13=j12, l13, l12
      do 120 j14=j13, l14, l13
      do 120 jthet=j14, l15, l14
        th2 = jthet - 2
        if (th2)  50, 50, 90
  50    do 60 k=1, int
          t0 = b0(k) + b1(k)
          t1 = b0(k) - b1(k)
          t2 = b2(k)*2.0
          t3 = b3(k)*2.0
          b0(k) = t0 + t2
          b2(k) = t0 - t2
          b1(k) = t1 + t3
          b3(k) = t1 -t3
  60    continue
c
        if (nn-4)  120, 120, 70
  70    k0 = int*4 + 1
        kl = k0 + int - 1
        do 80 k=k0, kl
          t2 = b0(k) - b2(k)
          t3 = b1(k) + b3(k)
          b0(k) = (b0(k) + b2(k))*2.0
          b2(k) = (b3(k) - b1(k))*2.0
          b1(k) = (t2 + t3)*p7two
          b3(k) = (t3 - t2)*p7two
  80    continue
        go to 120
c
  90    arg = th2*piovn
        c1 = cos(arg)
        s1 = -sin(arg)
        c2 = c1**2 - s1**2
        s2 = c1*s1 + c1*s1
        c3 = c1*c2 - s1*s2
        s3 = c2*s1 + s2*c1
c
        int4 = int*4
        j0 = jr*int4 + 1
        k0 = ji*int4 + 1
        jlast = j0 + int - 1
        do 100 j=j0, jlast
          k = k0 + j - j0
          t0 = b0(j) + b6(k)
          t1 = b7(k) - b1(j)
          t2 = b0(j) - b6(k)
          t3 = b7(k) + b1(j)
          t4 = b2(j) + b4(k)
          t5 = b5(k) - b3(j)
          t6 = b5(k) + b3(j)
          t7 = b4(k) - b2(j)
          b0(j) = t0 + t4
          b4(k) = t1 + t5
          b1(j) = (t2 + t6)*c1 - (t3 + t7)*s1
          b5(k) = (t2 + t6)*s1 + (t3 + t7)*c1
          b2(j) = (t0 - t4)*c2 - (t1 - t5)*s2
          b6(k) = (t0 - t4)*s2 + (t1 - t5)*c2
          b3(j) = (t2 - t6)*c3 - (t3 - t7)*s3
          b7(k) = (t2 - t6)*s3 + (t3 - t7)*c3
 100    continue
c
        jr = jr + 2
        ji = ji - 2
        if (ji-jl)  110, 110, 120
 110    ji = 2*jr - 1
        jl = jr
 120  continue
      return
      end
      subroutine ford1 (m, b)
c
c in-place reordering subroutine.
c
      dimension b(2)
c
      k = 4
      kl = 2
      n = 2**m
      do 40 j=4, n, 2
        if (k-j)  20, 20, 10
  10    t = b(j)
        b(j) = b(k)
        b(k) = t
  20    k = k - 2
        if (k-kl)  30, 30, 40
  30    k = 2*j
        kl = j
  40  continue
      return
      end
      subroutine ford2 (m, b)
c
c in-place reordering subroutine.
c
      dimension l(15), b(2)
      equivalence (l15,l(1)), (l14,l(2)), (l13,l(3)), (l12,l(4)),
     *    (l11,l(5)), (l10,l(6)), (l9,l(7)), (l8,l(8)), (l7,l(9)),
     *    (l6,l(10)), (l5,l(11)), (l4,l(12)), (l3,l(13)), (l2,l(14)),
     *    (l1,l(15))
      n = 2**m
      l(1) = n
      do 10 k=2, m
      l(k) = l(k-1)/2
  10  continue
      do 20 k=m, 14
        l(k+1) = 2
  20  continue
      ij = 2
      do 40 j1=2,  l1, 2
      do 40 j2=j1, l2, l1
      do 40 j3=j2, l3, l2
      do 40 j4=j3, l4, l3
      do 40 j5=j4, l5, l4
      do 40 j6=j5, l6, l5
      do 40 j7=j6, l7, l6
      do 40 j8=j7, l8, l7
      do 40 j9=j8, l9, l8
      do 40 j10=j9, l10, l9
      do 40 j11=j10, l11, l10
      do 40 j12=j11, l12, l11
      do 40 j13=j12, l13, l12
      do 40 j14=j13, l14, l13
      do 40 ji=j14, l15, l14
        if (ij-ji)  30, 40, 40
  30    t = b(ij-1)
        b(ij-1) = b(ji-1)
        b(ji-1) = t
        t = b(ij)
        b(ij) = b(ji)
        b(ji) = t
  40    ij = ij + 2
      return
      end


subroutine filter2(x,sx,nel,n,y,sy)

! Apply a boxcar filter n+1 pixels wide to a vector x.
! The routine uses linear propagation of errors to derive the errors
! in the smoothed vector from the  errors provided for the original
! data.
!
!
!	IN:	x	Input vector
!		sx	Errors in input vector
!		nel	number of points in the input vectors
!		n	n/2 pixels will be used on each side for even n
!					if not, n/2+1 on the left,
!					and n/2 on the right
!
!	OUT:	y	Output vector
!		sy	Resulting vector
!
!

use share, only: dp

implicit none

!input/output
integer, intent(in)	:: nel,n
real(dp), intent(in)	:: x(nel),sx(nel) !input vector (data and errors)
real(dp), intent(out)	:: y(nel),sy(nel) !output vectors (smooth data and errors)

!locals
integer			:: j,taco,n2,n2t
real(dp)		:: sx2(nel+n)	!=sx**2
real(dp)		:: xx(nel+n),sxx2(nel+n) !tmp copies of x and sx2 with the
					!extreme values replicated as needed

taco=0
if (n/2. > floor(n/2.)) taco=1
n2=n/2
n2t=n2+taco

do j=1,nel
	sx2(j)=sx(j)*sx(j)
enddo

xx(1:n2t)=x(1)
xx(n2t+1:n2t+nel)=x(1:nel)
xx(n2t+nel+1:n2t+nel+n2)=x(nel)

sxx2(1:n2t)=sx2(1)
sxx2(n2t+1:n2t+nel)=sx2(1:nel)
sxx2(n2t+nel+1:n2t+nel+n2)=sx2(nel)

do j=1,nel
	y(j)=sum(xx(j:j+n2t+n2))/(n+1._dp)
	sy(j)=sqrt(sum(sxx2(j:j+n2t+n2)))/(n+1._dp)
enddo

end subroutine filter2


! -*- f95 -*-

! Copyright (c) 2021. Pfizer Inc. All rights reserved.

subroutine mov_moments_1(n, x, wlen, skip, mean) bind(C, name="mov_moments_1")
    use, intrinsic :: iso_c_binding
    implicit none
    integer(c_long), intent(in) :: n, wlen, skip
    real(c_double), intent(in) :: x(n)
    real(c_double), intent(out) :: mean((n-wlen)/skip+1)
    ! local
    integer(c_long) :: i, j
    real(c_double) :: m1(n)

    m1(1) = x(1)

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

    j = 2_c_long
    mean(1) = m1(wlen)

    do i=wlen+skip, n, skip
        mean(j) = m1(i) - m1(i-wlen)
        j = j + 1
    end do

    mean = mean / wlen
end subroutine

subroutine mov_moments_2(n, x, wlen, skip, mean, sd) bind(C, name="mov_moments_2")
    use, intrinsic :: iso_c_binding
    implicit none
    integer(c_long), intent(in) :: n, wlen, skip
    real(c_double), intent(in) :: x(n)
    real(c_double), intent(out) :: mean((n-wlen)/skip+1)
    real(c_double), intent(out) :: sd((n-wlen)/skip+1)
    ! local
    integer(c_long) :: i, j
    real(c_double) :: m1(n), m2(n)
    real(c_double) :: delta, delta_n, term1
    integer(c_long) :: na, nb

    m1(1) = x(1)
    m2(1) = 0._c_double

    do i=2, n
        delta = x(i) - m1(i-1) / (i-1)
        delta_n = delta / i
        term1 = delta * delta_n * (i-1)

        m1(i) = m1(i-1) + x(i)
        m2(i) = m2(i-1) + term1
    end do

    j = 2_c_long
    mean(1) = m1(wlen)
    sd(1) = m2(wlen)

    do i=wlen+skip, n, skip
        na = wlen
        nb = i-wlen

        delta = m1(nb) / nb - (m1(i) - m1(nb)) / wlen

        mean(j) = m1(i) - m1(nb)
        sd(j) = m2(i) - m2(nb) - delta**2 * na * nb / i

        j = j + 1
    end do

    ! NOTE: currently, sd = M2, skew = M3, kurt = M4, so this order of computation matters
    mean = mean / wlen
    sd = sqrt(sd / (wlen - 1))

end subroutine

! =======================================================
! computation of moving statistical moments
!
! Inputs
!    n : int
!         Number of samples in x
!    x : array
!         1D array of samples to compute the moments for
!    wlen : int
!         Number of samples in each window
!    skip : int
!         Number of samples to skip for the start of each window
!
! Outputs
!    mean : array((n-wlen)/skip + 1)
!         Computed moving mean
subroutine moving_moments_1(n, x, wlen, skip, mean) bind(C, name="moving_moments_1")
    use, intrinsic :: iso_c_binding
    implicit none
    integer(c_long), intent(in) :: n, wlen, skip
    real(c_double), intent(in) :: x(n)
    real(c_double), intent(out) :: mean((n-wlen)/skip+1)
    ! local
    integer(c_long) :: i, j, k
    real(c_double) :: m1(0:wlen)

    if ((skip < wlen) .AND. (mod(wlen, skip) == 0)) then
        m1(0) = 0._c_double
        do i = 1, wlen
            m1(i) = m1(i - 1) + x(i)
        end do

        mean(1) = m1(wlen)
        do k = 2, (n - wlen) / skip + 1
            i = wlen + 1 + (k - 2) * skip
            mean(k) = mean(k - 1) + sum(x(i:i + skip - 1))
        end do

        mean(2 + (wlen - skip) / skip + 1:) = mean(2 + (wlen - skip) / skip + 1:) - mean(2:size(mean) - (wlen - skip) / skip - 1)
        mean(2:2 + (wlen - skip) / skip) = mean(2:2 + (wlen - skip) / skip) - m1(skip:wlen:skip)

    else if (skip < wlen) then
        m1(0) = 0._c_double
        do i = 1, wlen
            m1(i) = m1(i - 1) + x(i)
        end do

        mean(1) = m1(wlen)
        k = 2_c_long

        do i = wlen + skip, n, skip
!            m1(0:wlen - skip) = m1(skip:wlen)
            m1 = eoshift(m1, shift=skip)

            do j = wlen - skip + 1, wlen
                m1(j) = m1(j - 1) + x(i - wlen + j)
            end do
            mean(k) = m1(wlen) - m1(0)
            k = k + 1
        end do
    else
        do k = 1, (n - wlen) / skip + 1
            mean(k) = x((k - 1) * skip + 1)

            do j = 2, wlen
                mean(k) = mean(k) + x((k - 1) * skip + j)
            end do
        end do
    end if

    mean = mean / wlen
end subroutine

! =======================================================
! computation of moving statistical moments
!
! Inputs
!    n : int
!         Number of samples in x
!    x : array
!         1D array of samples to compute the moments for
!    wlen : int
!         Number of samples in each window
!    skip : int
!         Number of samples to skip for the start of each window
!
! Outputs
!    mean : array((n-wlen)/skip + 1)
!         Computed moving mean
!    sd : array((n-wlen)/skip + 1)
!         Computed moving standard deviation
subroutine moving_moments_2(n, x, wlen, skip, mean, sd) bind(C, name="moving_moments_2")
    use, intrinsic :: iso_c_binding
    implicit none
    integer(c_long), intent(in) :: n, wlen, skip
    real(c_double), intent(in) :: x(n)
    real(c_double), intent(out) :: mean((n-wlen)/skip+1)
    real(c_double), intent(out) :: sd((n-wlen)/skip+1)
    ! local
    integer(c_long) :: i, j, k
    real(c_double) :: m1(0:n), m2(0:n)
    real(c_double) :: delta, delta_n, term1, tm1

    if ((skip < wlen) .AND. (mod(wlen, skip) == 0)) then
        m1(1) = x(1)
        m2(1) = 0._c_double

        do i=2, wlen
            delta = x(i) - m1(i - 1) / (i - 1)
            delta_n = delta / i
            term1 = delta * delta_n * (i - 1)

            m1(i) = m1(i - 1) + x(i)
            m2(i) = m2(i - 1) + term1
        end do

        mean(1) = m1(wlen)
        sd(1) = m2(wlen)
        do k = 2, (n - wlen) / skip + 1
            i = wlen + 1 + (k - 2) * skip
            mean(k) = mean(k - 1) + sum(x(i:i + skip - 1))
            sd(k) = sd(k - 1)
            ! this accomplishes same as the sum function for mean
            tm1 = mean(k - 1)
            do j = i, i + skip - 1
                delta = x(j) - tm1 / (j - 1)
                delta_n = delta / j
                term1 = delta * delta_n * (j - 1)

                sd(k) = sd(k) + term1
                tm1 = tm1 + x(j)
            end do
        end do

        ! this loop has to go backwards so we don't modify values we need later
        j = size(mean) - (wlen - skip) / skip - 1
        do i = size(mean), 2 + (wlen - skip) / skip + 1, -1
            delta = mean(j) / ((i - 1) * skip) - (mean(i) - mean(j)) / wlen

            sd(i) = sd(i) - sd(j) - delta**2 * wlen * ((i - 1) * skip) / ((i - 1) * skip + wlen)
            mean(i) = mean(i) - mean(j)
            j = j - 1
        end do
        j = skip
        do i = 2, 2 + (wlen - skip) / skip
            delta = m1(j) / ((i - 1) * skip) - (mean(i) - m1(j)) / wlen

            sd(i) = sd(i) - m2(j) - delta**2 * wlen * ((i - 1) * skip) / ((i - 1) * skip + wlen)
            mean(i) = mean(i) - m1(j)
            j = j + skip
        end do

    else if (skip < wlen) then
        m1(1) = x(1)
        m2(0:1) = 0._c_double
        do i=2, wlen
            delta = x(i) - m1(i - 1) / (i - 1)
            delta_n = delta / i
            term1 = delta * delta_n * (i - 1)

            m1(i) = m1(i - 1) + x(i)
            m2(i) = m2(i - 1) + term1
        end do

        mean(1) = m1(wlen)
        sd(1) = m2(wlen)
        k = 2_c_long

        do i = wlen + skip, n, skip
            m1(0:wlen - skip) = m1(skip:wlen)
            m2(0:wlen - skip) = m2(skip:wlen)

            do j = wlen - skip + 1, wlen
                delta = x(i - wlen + j) - m1(j - 1) / (i - wlen + j - 1)
                delta_n = delta / (i - wlen + j)
                term1 = delta * delta_n * (i - wlen + j - 1)

                m1(j) = m1(j - 1) + x(i - wlen + j)
                m2(j) = m2(j - 1) + term1
            end do
            delta = m1(0) / (i - wlen) - (m1(wlen) - m1(0)) / wlen

            mean(k) = m1(wlen) - m1(0)
            sd(k) = m2(wlen) - m2(0) - delta**2 * wlen * (i - wlen) / i
            k = k + 1
        end do
    else
        do k = 1, (n - wlen) / skip + 1
            mean(k) = x((k - 1) * skip + 1)
            sd(k) = 0._c_double

            do j = 2, wlen
                delta = x((k - 1) * skip + j) - mean(k) / (j - 1)
                delta_n = delta / j
                term1 = delta * delta_n * (j - 1)

                mean(k) = mean(k) + x((k - 1) * skip + j)
                sd(k) = sd(k) + term1
            end do
        end do
    end if

    mean = mean / wlen
    sd = sqrt(sd / (wlen - 1))
end subroutine

! =======================================================
! computation of moving statistical moments
!
! Inputs
!    n : int
!         Number of samples in x
!    x : array
!         1D array of samples to compute the moments for
!    wlen : int
!         Number of samples in each window
!    skip : int
!         Number of samples to skip for the start of each window
!
! Outputs
!    mean : array((n-wlen)/skip + 1)
!         Computed moving mean
!    sd : array((n-wlen)/skip + 1)
!         Computed moving standard deviation
!    skew : array((n-wlen)/skip + 1)
!         Computed moving skewness
subroutine moving_moments_3(n, x, wlen, skip, mean, sd, skew) bind(C, name="moving_moments_3")
    use, intrinsic :: iso_c_binding
    implicit none
    integer(c_long), intent(in) :: n, wlen, skip
    real(c_double), intent(in) :: x(n)
    real(c_double), intent(out) :: mean((n-wlen)/skip+1)
    real(c_double), intent(out) :: sd((n-wlen)/skip+1)
    real(c_double), intent(out) :: skew((n-wlen)/skip+1)
    ! local
    integer(c_long) :: i, j
    real(c_double) :: m1(n), m2(n), m3(n)
    real(c_double) :: delta, delta_n, delta_n2, term1
    integer(c_long) :: na, nb

    m1(1) = x(1)
    m2(1) = 0._c_double
    m3(1) = 0._c_double

    do i=2, n
        delta = x(i) - m1(i-1) / (i-1)
        delta_n = delta / i
        delta_n2 = delta_n**2
        term1 = delta * delta_n * (i-1)

        m1(i) = m1(i-1) + x(i)
        m2(i) = m2(i-1) + term1
        m3(i) = m3(i-1) + term1 * delta_n * (i-2) - 3 * delta_n * m2(i-1)
    end do

    j = 2_c_long
    mean(1) = m1(wlen)
    sd(1) = m2(wlen)
    skew(1) = m3(wlen)

    do i=wlen+skip, n, skip
        na = wlen
        nb = i-wlen

        delta = m1(nb) / nb - (m1(i) - m1(nb)) / wlen

        mean(j) = m1(i) - m1(nb)
        sd(j) = m2(i) - m2(nb) - delta**2 * na * nb / i

        skew(j) = m3(i) - m3(nb) - delta**3 * na * nb * (2 * na - i) / i**2 - 3 * delta * (na * m2(nb) - nb * sd(j)) / i

        j = j + 1
    end do

    ! NOTE: currently, sd = M2, skew = M3, kurt = M4, so this order of computation matters
    mean = mean / wlen
    skew = sqrt(real(wlen)) * skew / sd**(3._c_double / 2._c_double)
    sd = sqrt(sd / (wlen - 1))

end subroutine

! =======================================================
! computation of moving statistical moments
!
! Inputs
!    n : int
!         Number of samples in x
!    x : array
!         1D array of samples to compute the moments for
!    wlen : int
!         Number of samples in each window
!    skip : int
!         Number of samples to skip for the start of each window
!
! Outputs
!    mean : array((n-wlen)/skip + 1)
!         Computed moving mean
!    sd : array((n-wlen)/skip + 1)
!         Computed moving standard deviation
!    skew : array((n-wlen)/skip + 1)
!         Computed moving skewness
!    kurt : array((n-wlen)/skip + 1)
!         Computed moving kurtosis
subroutine moving_moments_4(n, x, wlen, skip, mean, sd, skew, kurt) bind(C, name="moving_moments_4")
    use, intrinsic :: iso_c_binding
    implicit none
    integer(c_long), intent(in) :: n, wlen, skip
    real(c_double), intent(in) :: x(n)
    real(c_double), intent(out) :: mean((n-wlen)/skip+1)
    real(c_double), intent(out) :: sd((n-wlen)/skip+1)
    real(c_double), intent(out) :: skew((n-wlen)/skip+1)
    real(c_double), intent(out) :: kurt((n-wlen)/skip+1)
    ! local
    integer(c_long) :: i, j
    real(c_double) :: m1(n), m2(n), m3(n), m4(n)
    real(c_double) :: delta, delta_n, delta_n2, term1
    integer(c_long) :: na, nb

    m1(1) = x(1)
    m2(1) = 0._c_double
    m3(1) = 0._c_double
    m4(1) = 0._c_double

    do i=2, n
        delta = x(i) - m1(i-1) / (i-1)
        delta_n = delta / i
        delta_n2 = delta_n**2
        term1 = delta * delta_n * (i-1)

        m1(i) = m1(i-1) + x(i)
        m2(i) = m2(i-1) + term1
        m3(i) = m3(i-1) + term1 * delta_n * (i-2) - 3 * delta_n * m2(i-1)
        m4(i) = m4(i-1) + term1 * delta_n2 * (i*i - 3*i + 3) + 6 * delta_n2 * m2(i-1) - 4 * delta_n * m3(i-1)
    end do

    j = 2_c_long
    mean(1) = m1(wlen)
    sd(1) = m2(wlen)
    skew(1) = m3(wlen)
    kurt(1) = m4(wlen)

    do i=wlen+skip, n, skip
        na = wlen
        nb = i-wlen

        delta = m1(nb) / nb - (m1(i) - m1(nb)) / wlen

        mean(j) = m1(i) - m1(nb)
        sd(j) = m2(i) - m2(nb) - delta**2 * na * nb / i

        skew(j) = m3(i) - m3(nb) - delta**3 * na * nb * (2 * na - i) / i**2 - 3 * delta * (na * m2(nb) - nb * sd(j)) / i

        kurt(j) = m4(i) - m4(nb) - delta**4 * na * nb * (na**2 - na*nb + nb**2) / i**3 - 6 * delta**2 * (na**2 * m2(i-wlen) &
        + nb**2 * sd(j)) / i**2 - 4 * delta * (na * m3(i-wlen) - nb * skew(j)) / i

        j = j + 1
    end do

    ! NOTE: currently, sd = M2, skew = M3, kurt = M4, so this order of computation matters
    mean = mean / wlen
    skew = sqrt(real(wlen)) * skew / sd**(3._c_double / 2._c_double)
    kurt = wlen * kurt / sd**2 - 3
    sd = sqrt(sd / (wlen - 1))

end subroutine


! examples/Fortran/ssmfe/precond_core.f90
! Laplacian on a square grid (using SPRAL_SSMFE_CORE routines)
program ssmfe_core_precond_example
  use spral_random
  use spral_ssmfe_core
  use laplace2d ! implement Laplacian and preconditioners
  implicit none

  integer, parameter :: wp = kind(0d0) ! working precision is double

  integer, parameter :: l   = 20    ! grid points along each side
  integer, parameter :: n   = l*l   ! problem size
  integer, parameter :: nep = 5     ! eigenpairs wanted
  integer, parameter :: m = 3       ! dimension of the iterated subspace
  real(wp), parameter :: tol = 1e-6 ! eigenvector tolerance

  type(random_state) :: state       ! PRNG state

  real(wp), external :: dnrm2, ddot ! BLAS functions

  integer :: ncon                 ! number of converged eigenpairs
  integer :: i, j, k
  integer :: ind(m)               ! permutation index
  real(wp) :: s
  real(wp) :: lambda(n)           ! eigenvalues
  real(wp) :: X(n, n)             ! eigenvectors
  real(wp) :: lmd(m)              ! work array
  real(wp) :: rr(2*m, 2*m, 3)     ! work array
  real(wp) :: W(n, m, 0:5)        ! work array
  real(wp) :: U(n, m)             ! work array
  type(ssmfe_rcid        ) :: rci       ! reverse communication data
  type(ssmfe_core_options) :: options   ! options
  type(ssmfe_core_keep   ) :: keep      ! private data
  type(ssmfe_inform      ) :: inform    ! information

  ! Initialize W to lin indep vectors by randomizing
  do i=1,n
    do j=1,m
      W(i,j,0) = random_real(state, positive=.true.)
    end do
  end do

  ncon = 0
  rci%job = 0
  do ! reverse communication loop
!    call ssmfe( rci, 0, nep, 0, m, lmd, rr, ind, keep, options, inform )
!    call ssmfe( rci, 0, 0, nep, m, lmd, rr, ind, keep, options, inform )
    call ssmfe_largest( rci, 0, nep, m, lmd, rr, ind, keep, options, inform )
    select case ( rci%job )
    case ( 1 )
      call apply_laplacian &
        ( l, l, rci%nx, W(1 : n, rci%jx : rci%jx + rci%nx - 1, rci%kx), &
          W(1 : n, rci%jy : rci%jy + rci%nx - 1, rci%ky ) )
      call dscal( n*rci%nx, -1.0D0, W(1, rci%jy, rci%ky), 1 )
    case ( 2 )
      call dcopy( n*rci%nx, W(1, rci%jx, rci%kx), 1, W(1, rci%jy, rci%ky), 1 )
!      call apply_gauss_seidel_step &
!        ( l, l, rci%nx, W(1 : n, rci%jx : rci%jx + rci%nx - 1, rci%kx), &
!          W(1 : n, rci%jy : rci%jy + rci%nx - 1, rci%ky ) )
    case ( 999 )
      print *, rci%i, rci%j, rci%k
      exit
    case ( 4 )
      print *, 'iteration', inform%iteration
      do j = 1, m
        print '(e14.7, 2e10.1)', lmd(j), inform%residual_norms(j), inform%err_X(j)
        if ( inform%converged(j) /= 0 ) then
          cycle
        else if ( inform%err_X(j) > 0 .and. inform%err_X(j) < tol ) then
          inform%converged(j) = 1
        end if
      end do
    case ( 5 )
      if ( rci%i < 0 ) cycle
      do k = 0, rci%nx - 1
        j = ncon + k + 1
        lambda(j) = lmd(rci%jx + k)
        call dcopy( n, W(1, rci%jx + k, 0), 1, X(1, j), 1 )
      end do
      ncon = ncon + rci%nx
!      if ( ncon > 0 .or. inform%iteration > 250 ) exit
      if ( ncon >= nep .or. inform%iteration > 10 ) exit
    case ( 11 )
      if ( rci%i == 0 ) then
        if ( rci%kx /= rci%ky .or. rci%jx > rci%jy ) then
          call dcopy &
            ( n * rci%nx, W(1, rci%jx, rci%kx), 1, W(1, rci%jy, rci%ky), 1 )
        else if ( rci%jx < rci%jy ) then
          do j = rci%nx - 1, 0, -1
            call dcopy &
              ( n, W(1, rci%jx + j, rci%kx), 1, W(1, rci%jy + j, rci%ky), 1 )
          end do
        end if
      else
        do i = 1, n
          do j = 1, rci%nx
            U(i, j) = W(i, ind(j), rci%kx)
          end do
          do j = 1, rci%nx
            W(i, j, rci%kx) = U(i, j)
          end do
          if ( rci%ky /= rci%kx ) then
            do j = 1, rci%nx
              U(i, j) = W(i, ind(j), rci%ky)
            end do
            do j = 1, rci%nx
              W(i, j, rci%ky) = U(i, j)
            end do
          end if
        end do
      end if
    case ( 12 )
      do i = 0, rci%nx - 1
        rr(rci%i + i, rci%j + i, rci%k) = &
          ddot(n, W(1, rci%jx + i, rci%kx), 1, W(1, rci%jy + i, rci%ky), 1)
      end do
    case ( 13 )
      do i = 0, rci%nx - 1
        if ( rci%kx == rci%ky ) then
          s = dnrm2(n, W(1, rci%jx + i, rci%kx), 1)
          if ( s > 0 ) &
            call dscal( n, 1/s, W(1, rci%jx + i, rci%kx), 1 )
        else
          s = sqrt(abs(ddot &
            (n, W(1, rci%jx + i, rci%kx), 1, W(1, rci%jy + i, rci%ky), 1)))
          if ( s > 0 ) then
            call dscal( n, 1/s, W(1, rci%jx + i, rci%kx), 1 )
            call dscal( n, 1/s, W(1, rci%jy + i, rci%ky), 1 )
          else
            call dcopy( n, 0.0D0, 0, W(1, rci%jy + i, rci%ky), 1 )
          end if
        end if
      end do
    case ( 14 )
      do i = 0, rci%nx - 1
        s = -rr(rci%i + i, rci%j + i, rci%k)
        call daxpy&
          ( n, s, W(1, rci%jx + i, rci%kx), 1, W(1, rci%jy + i, rci%ky), 1 )
      end do
    case ( 15 )
      if ( rci%nx > 0 .and. rci%ny > 0 ) &
        call dgemm &
          ( 'T', 'N', rci%nx, rci%ny, n, &
            rci%alpha, W(1, rci%jx, rci%kx), n, W(1, rci%jy, rci%ky), n, &
            rci%beta, rr(rci%i, rci%j, rci%k), 2*m )
    case ( 16, 17 )
      if ( rci%ny < 1 ) cycle
      if ( rci%nx < 1 ) then
        if ( rci%job == 17 ) cycle
        if ( rci%beta == 1.0D0 ) cycle
        do j = rci%jy, rci%jy + rci%ny - 1
          call dscal( n, rci%beta, W(1, j, rci%ky), 1 )
        end do
        cycle
      end if
      if ( rci%job == 17 ) then
        call dgemm &
          ( 'N', 'N', n, rci%ny, rci%nx, &
            1.0D0, W(1, rci%jx, rci%kx), n, rr(rci%i, rci%j, rci%k), 2*m, &
            0.0D0, W(1, rci%jy, rci%ky), n )
        call dcopy &
          ( n * rci%ny, W(1, rci%jy, rci%ky), 1, W(1, rci%jx, rci%kx), 1 )
      else
        call dgemm &
          ( 'N', 'N', n, rci%ny, rci%nx, &
            rci%alpha, W(1, rci%jx, rci%kx), n, rr(rci%i, rci%j, rci%k), 2*m, &
            rci%beta, W(1, rci%jy, rci%ky), n )
      end if
    case ( 21, 22 )
      if ( ncon > 0 ) then
        call dgemm &
          ( 'T', 'N', ncon, rci%nx, n, &
            1.0D0, X, n, W(1, rci%jy, rci%ky), n, 0.0D0, U, n )
        call dgemm &
          ( 'N', 'N', n, rci%nx, ncon, &
            -1.0D0, X, n, U, n, 1.0D0, W(1, rci%jx, rci%kx), n )
      end if
    case ( :-1 )
      exit
    end select
  end do
  print '(i3, 1x, a, 1x, i3, 1x, a)', ncon, 'eigenpairs converged in', inform%iteration, 'iterations'
  print '(1x, a, i1, a, es14.7)', &
    ('lambda(', i, ') = ', lambda(i), i = 1, ncon)
  call ssmfe_free( keep, inform )
end program ssmfe_core_precond_example


C................................................................       DFS   10
      SUBROUTINE DFSUB(X, Z, DF)                                        DFS   20
      implicit real*8 (a-h, o-z)
      REAL*8 Z(1), DF(2,1)
      COMMON /p3/ EN, S, EL, CONS
      DF(1,1) = -EL*(EN-1.)*Z(4) + EL**2*S
      DF(1,2) = -EL*CONS*Z(3)
      DF(1,3) = -EL*CONS*Z(2)
      DF(1,4) = -EL*(EN-1.)*Z(1)
      DF(1,5) = 0.
      DF(2,1) = -EL**3*2.*Z(1)
      DF(2,2) = 0.
      DF(2,3) = -EL*CONS*Z(5)
      DF(2,4) = -EL*EN*2.*Z(4) + EL**2*S
      DF(2,5) = -EL*CONS*Z(3)
      RETURN
      END


c do continuum subtraction with a moving average after sigma clipping

      subroutine contsubavgclip(spec,nsp,dw,wrad)
c spec is the array, nsp the dimension,
c dw the array spacing in wavelength or log w.l.
c wrad the radius of the window in wl or log wl space

      parameter(NSIGCLIP=3.0)
      parameter(IALGOR=1)

      real spec(nsp)
      real specout(nsp)
      real swork(nsp)

      include 'pcredshift.h'

      nrad = int(wrad/dw)
      if (nrad .lt. 1) nrad=1

      ngood1 = 0
      sum = 0.0
      sumsq=0.0
      do i=1,nsp
         if(spec(nsp) .gt. bad) then
            ngood1=ngood1+1
            sum = sum + spec(nsp)
            sumsq = sumsq + spec(nsp)*spec(nsp)
         end if
      end do
      if (ngood1 .lt. 1) then
         return
      end if
      avg = sum/ngood1
      rms = sqrt(sumsq/ngood1 - avg*avg)
      clipmin = avg - NSIGCLIP*rms
      clipmax = avg + NSIGCLIP*rms

c choose the way of doing it
      if (IALGOR .eq. 1) then
         go to 100
c      else if (IALGOR .eq. 2) then
      else
         go to 200
      end if

c  try 1 this is the direct but inefficient way

 100  continue

      do i = 1,nsp
         jmin = max(1,min(nsp,i-nrad))
         jmax = max(1,min(nsp,i+nrad))
         np = 0
         sum = 0.0
         do j=jmin,jmax
            if (spec(j) .gt. bad .and. spec(j) .gt. clipmin
     $           .and. spec(j) .lt. clipmax) then
               np = np+1
               sum = sum+spec(j)
            end if
         end do
         specout(i) = sum/np
      end do

      go to 600

c try 2

 200  continue

c i is the central point in the spectral arrray
c jmin,jmax are the indexes of the window ends in the spectral array
c npmin, npmax are the window ends in the work array
      i=1
      jmin = 1
      jmax = max(1,min(nsp,i+nrad))
      npmin = 1
      npmax = 0
c compute the mean in the window around the first point
      sum = 0.0
      np = 0
      do j=jmin,jmax
         if(spec(j) .gt. bad .and. spec(j) .gt. clipmin
     $        .and. spec(j) .lt. clipmax) then
            npmax=npmax+1
c            np = np + 1
            sum = sum + spec(j)
         end if
      end do

 220  continue
      np = npmax-npmin+1
      specout(i) = sum/np

c increment the point under consideration
      i=i+1
c if we've reached the end, bail
      if(i .gt. nsp) go to 230
c move the window
      jminold = jmin
      jmaxold = jmax
      jmin = max(1,min(nsp,i-nrad)
      jmax = max(1,min(nsp,i+nrad)
c  if we are eliminating a point at the low end
      if (jmin .gt. jminold .and. spec(jminold) .gt. bad
     $     .and. spec(jminold) .gt. clipmin
     $        .and. spec(jminold) .lt. clipmax) then
         npmin=npmin+1
c         np = np-1
         sum = sum - spec(jminold)
      end if
c  if we are adding a point at the high end
      if (jmax .gt. jmaxold .and. spec(jmax) .gt. bad
     $     .and. spec(jmax) .gt. clipmin
     $     .and. spec(jmax) .lt. clipmax) then
         npmax = npmax+1
c         np = np+1
         sum = sum + spec(jmax)
      end if

c  go back to compute the mean
      go to 220

 230  continue
      go to 600

 600  continue

c  do actual subtraction
      do i=1,nsp
         if (spec(i) .gt. bad) spec(i) = spec(i) - specout(i)
      end do

      return
      end


!##############################################################################
!# ****************************************************************************
!# <name> optc </name>
!# ****************************************************************************
!#
!# <purpose>
!# This program is a simple test program for discretising a
!# stationary and nonstationary Navier-Stokes optimal control problem
!#
!#  $$ min J(y,u) = 1/2||y-z||_{L^2} + \gamma/2||y(T)-z(T)||_{L^2} + \alpha/2||u||^2 $$
!#
!#  $$- \nu Delta(y) + y*\Nabla(y) + \Nabla p = f $$
!#  $$ \Nabla \cdot y = 0$$
!#  $$- \nu Delta(\lambda) - y*\Nabla(\lambda) + (\Nabla y)^t\lambda + \Nabla \xi = y-z $$
!#  $$ \Nabla \cdot \lambda = 0$$
!#
!#
!# on a 2D domain for a 2D function $y=(y_1,y_2)$, a pressure $p$,
!# a dual velocity $\lambda$ and a dual pressure $\xi$. $u$ is the control
!# and $z$ a desired flow field.
!#
!# on a 2D domain for a 2D velocity function $y=(y_1,y_2)$, a pressure $p$,
!# a 2D dual velocity $\lambda=(\lambda_1,\lambda_2)$ and a dual pressure
!# $\xi$.
!#
!# A linear block system with 6 solution components is set up,
!# discretised and solved.
!#
!# </purpose>
!##############################################################################

program cc2doptc

  use main_program

  implicit none

  call main_optc()

end program


C FWEHNA.F - Gateway function for SLICOT model reduction routine
C            AB09JD.F.
C
C RELEASE 2.0 of SLICOT Model and Controller Reduction Toolbox.
C Based on SLICOT RELEASE 5.7. Copyright (c) 2002-2020 NICONET e.V.
C
C Matlab call:
C   [Ar,Br,Cr,Dr,HSV,info] = FWEHNA(meth,A,B,C,D,V,W,tol,discr,ord,alpha)
C
C Purpose:
C   To compute a reduced order model (Ar,Br,Cr,Dr) for an original
C   state-space representation (A,B,C,D) by using the frequency
C   weighted optimal Hankel-norm approximation method.
C   The Hankel norm of the weighted error
C
C         op(V)*(G-Gr)*op(W)
C
C   is minimized, where G and Gr are the transfer-function matrices
C   of the original and reduced systems, respectively, V and W
C   are invertible transfer-function matrices of the left and right
C   frequency weights, and op(X) denotes X, conj(X), inv(X), or
C   conj(inv(X)). V and W are specified by their state space
C   realizations (AV,BV,CV,DV) and (AW,BW,CW,DW), respectively.
C   When minimizing the weighted error V*(G-Gr)*W, V and W must have
C   poles distinct from those of G.
C   When minimizing conj(V)*(G-Gr)*conj(W), conj(V) and conj(W) must
C   have poles distinct from those of G.
C   Additionally, V and W must be invertible transfer-function matrices.
C   If the original system is unstable, then the frequency-weighted
C   Hankel-norm approximation is computed only for the
C   alpha-stable part of the system.
C   The order of the reduced model is determined either by the number
C   of frequency-weighted Hankel-singular values HSV greater than tol or
C   by the desired order ord.
C
C Input parameters:
C   meth  - method flag of decimal form ijk, where:
C             i = 1 : op(V) = V;
C             i = 2 : op(V) = conj(V);
C             i = 3 : op(V) = inv(V);
C             i = 4 : op(V) = conj(inv(V));
C             j = 1 : op(W) = W;
C             j = 2 : op(W) = conj(W);
C             j = 3 : op(W) = inv(W);
C             j = 4 : op(W) = conj(inv(W));
C             k = 1 : if possible, use standard inverse based method;
C             k = 2 : use inverse free method;
C             k = 3 : use an automatic method.
C   A,B,
C   C,D   - state-space system matrices of size N-by-N, N-by-M, P-by-N,
C           and P-by-M, respectively.
C   V     - (optional) contains the system matrix [AV BV; CV DV] of
C           the left weighting.
C   W     - (optional) contains the system matrix [AW BW; CW DW] of
C           the right weighting.
C   tol   - (optional) tolerance vector for determining the order of
C           reduced system, of the form [tol1, tol2], where:
C             tol1 specifies the tolerance for model reduction.
C                  Default: tol1 = NS*epsilon_machine*Hankel_norm(G1s),
C                  where Hankel_norm(G1s) is the Hankel-norm of the
C                  projection G1s of op(V)*G1*op(W) (see AB09JD,
C                  Section METHOD) and NS is the order of G1s.
C             tol2 specifies the tolerance for computing a minimal
C                  realization of the alpha-stable part of the
C                  weighted original system.
C                  Default: tol2 = NS*epsilon_machine*Hankel_norm(G1s).
C   discr - (optional) type of system:
C              = 0 : continuous-time (default);
C              = 1 : discrete-time.
C   ord   - (optional) desired order of reduced system.
C             Default: ord = -1 (order determined automatically).
C   alpha - (optional) stability boundary for the eigenvalues of A.
C             Default:    -sqrt(epsilon_machine)  for continuous-time;
C                      1.0-sqrt(epsilon_machine)  for discrete-time.
C
C Output parameters:
C   Ar, Br,
C   Cr, Dr - state-space matrices of the reduced system Gr.
C   HSV    - Hankel singular values of the projection G1s of
C            op(V)*G1*op(W) (see AB09JD, Section METHOD),
C            where G1 is the alpha-stable part of G.
C   info   - warning message code:
C            info = 1 - selected order greater than the order
C                       of a minimal realization;
C            info = 2 - selected order less than the order of
C                       the unstable part.
C
C Contributors:
C   D. Sima, University of Bucharest, and
C   A. Varga, German Aerospace Center,
C   DLR Oberpfaffenhofen, March 2001.
C
C Revisions:
C   V. Sima, Research Institute for Informatics, Bucharest, June 2001,
C   March 2005, Apr. 2009, Dec. 2012.
C
C  *********************************************************************
C
      SUBROUTINE MEXFUNCTION( NLHS, PLHS, NRHS, PRHS )
C
C .. Parameters ..
      DOUBLE PRECISION  ONE, ZERO
      PARAMETER         ( ONE = 1.0D0, ZERO = 0.0D0 )
C
C .. Mex-file interface parameters ..
      INTEGER           PLHS(*), PRHS(*)
      INTEGER*4         NLHS, NRHS
C
C .. Mex-file integer functions ..
      INTEGER           mxCreateDoubleMatrix, mxGetPr
      INTEGER*4         mxGetM, mxGetN, mxIsNumeric, mxIsComplex
C
C .. Scalar parameters used by SLICOT subroutines ..
      CHARACTER         DICO, EQUIL, JOBINV, JOBV, JOBW, ORDSEL
      INTEGER           INFO, IWARN, LDA, LDB, LDC, LDD, LDV, LDW,
     $                  LDWORK, M, N, NR, NS, NV, NW, P
      DOUBLE PRECISION  ALPHA, TOL1, TOL2
C
C .. Allocatable arrays ..
C !Fortran 90/95 (Fixed dimensions should be used with Fortran 77.)
      DOUBLE PRECISION, ALLOCATABLE:: A(:,:),   B(:,:), C(:,:), D(:,:),
     $                                DWORK(:), HSV(:), V(:,:), W(:,:)
      INTEGER, ALLOCATABLE::          IWORK(:)
C
C .. Local variables and constant dimension arrays ..
      CHARACTER*120     TEXT
      LOGICAL           DISCR, LEFTW, RIGHTW
      INTEGER           I, J, LW, LWI, M1, METH, N1, N2, N3,
     $                  NV1, NVP, NVP1, NW1, NWM, NWM1, P1
      DOUBLE PRECISION  DUM, TOL(2)
C
C .. External functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH
      EXTERNAL          DLAMCH, LSAME
C
C .. External Subroutines ..
      EXTERNAL          AB09JD, DLACPY
C
C .. Intrinsic functions ..
      INTRINSIC         MAX, MIN, SQRT
C
C Check for proper number of arguments.
C
      IF( NRHS.LT.5 ) THEN
         CALL mexErrMsgTxt
     $        ( 'FWEHNA requires at least 5 input arguments' )
      ELSE IF( NLHS.GT.6 ) THEN
         CALL mexErrMsgTxt
     $        ( 'FWEHNA requires at most 6 output arguments' )
      END IF
C
C Check dimensions of input parameters and read/set scalar parameters.
C
C   meth = i*100+j*10+k
C
      IF( mxGetM( PRHS(1) ).NE.1 .OR. mxGetN( PRHS(1) ).NE.1 ) THEN
         CALL mexErrMsgTxt( 'METH must be a scalar' )
      END IF
      IF( mxIsNumeric( PRHS(1) ).EQ.0 .OR.
     $    mxIsComplex( PRHS(1) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'METH must be an integer scalar' )
      END IF
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(1) ), DUM, 1 )
      METH = DUM
      I = METH/100
      METH = METH - I*100
      J = METH/10
      METH = METH - J*10
      IF( METH.LT.1 .OR. METH.GT.3 .OR. I.LT.1 .OR. I.GT.4
     $    .OR. J.LT.1 .OR. J.GT.4 ) THEN
         CALL mexErrMsgTxt( 'Invalid value for METH ' )
      END IF
      IF( I.EQ.1 ) THEN
         JOBV = 'V'
      ELSE IF( I.EQ.2 ) THEN
         JOBV = 'C'
      ELSE IF( I.EQ.3 ) THEN
         JOBV = 'I'
      ELSE
         JOBV = 'R'
      END IF
      IF( J.EQ.1 ) THEN
         JOBW = 'W'
      ELSE IF( J.EQ.2 ) THEN
         JOBW = 'C'
      ELSE IF( J.EQ.3 ) THEN
         JOBW = 'I'
      ELSE
         JOBW = 'R'
      END IF
      IF( METH.EQ.1 ) THEN
         JOBINV = 'I'
      ELSE IF( METH.EQ.2 ) THEN
         JOBINV = 'N'
      ELSE
         JOBINV = 'A'
      END IF
C
C   A(NxN), B(NxM), C(PxN), D(PxM)
C
      N  = mxGetM( PRHS(2) )
      M  = mxGetN( PRHS(3) )
      P  = mxGetM( PRHS(4) )
      N1 = mxGetN( PRHS(2) )
      N2 = mxGetM( PRHS(3) )
      N3 = mxGetN( PRHS(4) )
      P1 = mxGetM( PRHS(5) )
      M1 = mxGetN( PRHS(5) )
C
      IF( N1.NE.N ) THEN
         CALL mexErrMsgTxt
     $        ( 'A must be a square matrix' )
      END IF
      IF( N2.NE.N ) THEN
         CALL mexErrMsgTxt
     $        ( 'B must have the same row dimension as A' )
      END IF
      IF( N3.NE.N ) THEN
         CALL mexErrMsgTxt
     $        ( 'C must have the same column dimension as A' )
      END IF
      IF( P1.NE.P ) THEN
         CALL mexErrMsgTxt
     $        ( 'D must have the same row dimension as C' )
      END IF
      IF( M1.NE.M ) THEN
         CALL mexErrMsgTxt
     $        ( 'D must have the same column dimension as B' )
      END IF
      IF( mxIsNumeric( PRHS(2) ).EQ.0 .OR.
     $    mxIsComplex( PRHS(2) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'A must be a real matrix' )
      END IF
      IF( mxIsNumeric( PRHS(3) ).EQ.0 .OR.
     $    mxIsComplex( PRHS(3) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'B must be a real matrix' )
      END IF
      IF( mxIsNumeric( PRHS(4) ).EQ.0 .OR.
     $    mxIsComplex( PRHS(4) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'C must be a real matrix' )
      END IF
      IF( mxIsNumeric( PRHS(5) ).EQ.0 .OR.
     $    mxIsComplex( PRHS(5) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'D must be a real matrix' )
      END IF
      IF( M.LE.0 ) THEN
         CALL mexErrMsgTxt( 'The system has no inputs' )
      END IF
      IF( P.LE.0 ) THEN
         CALL mexErrMsgTxt( 'The system has no outputs' )
      END IF
C
C   AV(NVxNV), BV(NVxP), CV(PxNV), DV(PxP)
C
      NV = 0
      LEFTW = .FALSE.
      IF( NRHS.GT.5 ) THEN
         NVP  = mxGetM( PRHS(6) )
         NVP1 = mxGetN( PRHS(6) )
         IF( NVP1.NE.NVP ) THEN
            CALL mexErrMsgTxt
     $          ( 'V must be a square matrix' )
         END IF
         IF( mxIsNumeric( PRHS(6) ).EQ.0 .OR.
     $       mxIsComplex( PRHS(6) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'V must be a real matrix' )
         END IF
         IF( NVP.GT.0 ) THEN
            NV = NVP - P
            IF( NV.LT.0 ) THEN
               CALL mexErrMsgTxt( 'V incompatible with the system' )
            END IF
         END IF
         LEFTW = NVP.GT.0
      END IF
      IF( .NOT.LEFTW ) JOBV = 'N'
C
C   AW(NWxNW), BW(NWxM), CW(MxNW), DW(MxM)
C
      NW = 0
      RIGHTW = .FALSE.
      IF( NRHS.GT.6 ) THEN
         NWM  = mxGetM( PRHS(7) )
         NWM1 = mxGetN( PRHS(7) )
         IF( NWM1.NE.NWM ) THEN
            CALL mexErrMsgTxt
     $          ( 'W must be a square matrix' )
         END IF
         IF( mxIsNumeric( PRHS(7) ).EQ.0 .OR.
     $       mxIsComplex( PRHS(7) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'W must be a real matrix' )
         END IF
         IF( NWM.GT.0 ) THEN
            NW = NWM - M
            IF( NW.LT.0 ) THEN
               CALL mexErrMsgTxt( 'W incompatible with the system' )
            END IF
         END IF
         RIGHTW = NWM.GT.0
      END IF
      IF( .NOT.RIGHTW ) JOBW = 'N'
C
C   tol(1x2)
C
      TOL1 = ZERO
      TOL2 = ZERO
      IF( NRHS.GT.7 ) THEN
         I = mxGetM( PRHS(8) )*mxGetN( PRHS(8) )
         IF( I.GT.2 ) THEN
            CALL mexErrMsgTxt
     $           ( 'TOL must be a vector with at most 2 elements' )
         END IF
         IF( mxIsNumeric( PRHS(8) ).EQ.0 .OR.
     $       mxIsComplex( PRHS(8) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'TOL must be a real vector' )
         END IF
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(8) ), TOL, I )
         IF( I.GT.0 ) TOL1 = TOL(1)
         IF( I.GT.1 ) TOL2 = TOL(2)
      END IF
C
C   discr
C
      DICO = 'C'
      IF( NRHS.GT.8 ) THEN
         IF( mxGetM( PRHS(9) ).NE.1 .OR. mxGetN( PRHS(9) ).NE.1 ) THEN
            CALL mexErrMsgTxt( 'DISCR must be a scalar' )
         END IF
         IF( mxIsNumeric( PRHS(9) ).EQ.0 .OR.
     $       mxIsComplex( PRHS(9) ).EQ.1 ) THEN
           CALL mexErrMsgTxt( 'DISCR must be an integer scalar 0 or 1' )
         END IF
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(9) ), DUM, 1 )
         IF( DUM.NE.ZERO ) DICO = 'D'
      END IF
      DISCR = LSAME( DICO, 'D' )
C
C   ord
C
      ORDSEL = 'A'
      NR = 0
      IF( NRHS.GT.9 ) THEN
         IF( mxGetM( PRHS(10) ).NE.1 .OR. mxGetN( PRHS(10) ).NE.1 ) THEN
            CALL mexErrMsgTxt( 'ORD must be a scalar' )
         END IF
         IF( mxIsNumeric( PRHS(10) ).EQ.0 .OR.
     $       mxIsComplex( PRHS(10) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'ORD must be an integer scalar' )
         END IF
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(10) ), DUM, 1 )
         IF( DUM.GE.ZERO ) THEN
            ORDSEL = 'F'
            NR = DUM
            NR = MIN( N, NR )
         END IF
      END IF
C
C   alpha
C
      IF( NRHS.GT.10 ) THEN
         IF( mxGetM( PRHS(11) ).NE.1 .OR. mxGetN( PRHS(11) ).NE.1 ) THEN
            CALL mexErrMsgTxt( 'ALPHA must be a scalar' )
         END IF
         IF( mxIsNumeric( PRHS(11) ).EQ.0 .OR.
     $       mxIsComplex( PRHS(11) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'ALPHA must be a real scalar' )
         END IF
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(11) ), ALPHA, 1 )
         IF( DISCR ) THEN
            IF( ALPHA.EQ.ONE )  ALPHA = ONE - SQRT( DLAMCH( 'E' ) )
         ELSE
            IF( ALPHA.EQ.ZERO ) ALPHA = -SQRT( DLAMCH( 'E' ) )
         END IF
      ELSE
         ALPHA = -SQRT( DLAMCH( 'E' ) )
         IF( DISCR ) ALPHA = ONE + ALPHA
      END IF
C
C Determine the lenghts of working arrays.
C
      LW  = 1
      LWI = MAX( 1, M )
      IF( DISCR )
     $   LWI = MAX( LWI, N )
      IF( LEFTW ) THEN
         NVP = NV + P
         LW  = MAX( LW, 2*NVP*( NVP + P ) + P*P +
     $              MAX( 2*NVP*NVP + MAX( 11*NVP + 16, P*NVP ),
     $                   NVP*N + MAX( NVP*N+N*N, P*N, P*M ) ) )
         LWI = MAX( LWI, 2*P, NVP+N+6, 2*NV+P+2 )
      END IF
      IF( RIGHTW ) THEN
         NWM = NW + M
         LW  = MAX( LW, 2*NWM*( NWM + M ) + M*M +
     $              MAX( 2*NWM*NWM + MAX( 11*NWM + 16, M*NWM ),
     $                   NWM*N + MAX( NWM*N+N*N, M*N, P*M ) ) )
         LWI = MAX( LWI, 2*M, NWM+N+6, 2*NW+M+2 )
      END IF
      LW = MAX( LW, N*( 2*N + MAX( N, M, P ) + 5 ) + ( N*( N + 1 ) )/2 )
      LW = MAX( LW, N*( M + P + 2 ) + 2*M*P + MIN( N, M ) +
     $                             MAX ( 3*M + 1, MIN( N, M ) + P ) )
      LDWORK = LW
C
      LDA = MAX( 1, N )
      LDB = MAX( 1, N )
      LDC = MAX( 1, P )
      LDD = MAX( 1, P )
      LDV = MAX( 1, NVP )
      LDW = MAX( 1, NWM )
C
C Allocate variable dimension local arrays.
C !Fortran 90/95
      ALLOCATE ( A( LDA, MAX( 1, N ) ), B( LDB, MAX( 1, M ) ),
     $           C( LDC, MAX( 1, N ) ), D( LDD, MAX( 1, M ) ),
     $           V( LDV, MAX( 1, NVP ) ), W( LDW, MAX( 1, NWM ) ),
     $           DWORK( LDWORK ), HSV( MAX( 1, N ) ),
     $           IWORK( LWI ) )
C
C Copy inputs from MATLAB workspace to locally allocated arrays.
C
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(2) ), A, N*N )
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(3) ), B, N*M )
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(4) ), C, P*N )
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(5) ), D, P*M )
      IF( NVP.GT.0 )
     $   CALL mxCopyPtrToReal8( mxGetPr( PRHS(6) ), V, NVP*NVP )
      IF( NWM.GT.0 )
     $   CALL mxCopyPtrToReal8( mxGetPr( PRHS(7) ), W, NWM*NWM )
C
C Do the actual computations.
C
      EQUIL = 'S'
C
C Frequency-weighted Hankel-Norm Approximation.
C
      NV1 = NV + 1
      NW1 = NW + 1
      CALL AB09JD( JOBV, JOBW, JOBINV, DICO, EQUIL, ORDSEL, N, NV, NW,
     $             M, P, NR, ALPHA, A, LDA, B, LDB, C, LDC, D, LDD,
     $             V, LDV, V(1,NV1), LDV, V(NV1,1), LDV, V(NV1,NV1),
     $             LDV, W, LDW, W(1,NW1), LDW, W(NW1,1), LDW,
     $             W(NW1,NW1), LDW, NS, HSV, TOL1, TOL2, IWORK, DWORK,
     $             LDWORK, IWARN, INFO )
C
C Copy output to MATLAB workspace.
C
      IF( INFO.EQ.0 ) THEN
         IF( NLHS.GE.1 ) THEN
            PLHS(1) = mxCreateDoubleMatrix( NR, NR, 0 )
            IF( NR.LT.N .AND. NR.GT.0 )
     $         CALL DLACPY( 'F', NR, NR, A, LDA, A, NR )
            CALL mxCopyReal8ToPtr( A, mxGetPr( PLHS(1) ), NR*NR )
         END IF
         IF( NLHS.GE.2 ) THEN
            PLHS(2) = mxCreateDoubleMatrix( NR, M, 0 )
            IF( NR.LT.N .AND. NR.GT.0 )
     $         CALL DLACPY( 'F', NR, M, B, LDB, B, NR )
            CALL mxCopyReal8ToPtr( B, mxGetPr( PLHS(2) ), NR*M )
         END IF
         IF( NLHS.GE.3 ) THEN
            PLHS(3) = mxCreateDoubleMatrix( P, NR, 0 )
            CALL mxCopyReal8ToPtr( C, mxGetPr( PLHS(3) ), P*NR )
         END IF
         IF( NLHS.GE.4 ) THEN
            PLHS(4) = mxCreateDoubleMatrix( P, M, 0 )
            CALL mxCopyReal8ToPtr( D, mxGetPr( PLHS(4) ), P*M )
         END IF
C
         IF( NLHS.GE.5 ) THEN
            PLHS(5) = mxCreateDoubleMatrix( NS, 1, 0 )
            CALL mxCopyReal8ToPtr( HSV, mxGetPr( PLHS(5) ), NS )
         END IF
         IF( NLHS.GE.6 ) THEN
            PLHS(6) = mxCreateDoubleMatrix( 1, 1, 0 )
            HSV(1) = IWARN
            CALL mxCopyReal8ToPtr( HSV, mxGetPr( PLHS(6) ), 1 )
         END IF
C
      END IF
C
C Deallocate local arrays.
C !Fortran 90/95
C
      DEALLOCATE ( A, B, C, D, V, W, HSV, IWORK, DWORK )
C
C Error handling.
C
      IF( INFO.NE.0 ) THEN
         WRITE( TEXT,'( " INFO = ", I4, " ON EXIT FROM AB09JD" )' ) INFO
         CALL mexErrMsgTxt( TEXT )
      END IF
C
      RETURN
C *** Last line of FWEHNA ***
      END


! ---- Monte Carlo integration

    program MonteCarlo

    use sci
    use Monte
    use AQP

    implicit real*8(a-h, o-z)

    integer (kind = 8) adjustInterval
    integer (kind = 8) thermSteps

    real*8, dimension(ndim) :: x

    real*8 gasdev

    call map()

! --- Monte Carlo parameters

    MCSteps = 2000000

    print *, 'Monte Carlo for Gaussian integration'
    print *, '-----------------------------------'

    !xmax = 6d0
    !xmin = -6d0
    !dx = (xmax-xmin)/nx

    delta = 1.0 ! jump size
    idum = 11

! --- initialize the random walkers
    call random_number(x)

    print *,'initial sampling point', x

    !rho = 0d0

! perform 20% of MCSteps as thermalization steps
! and adjust step size so acceptance ratio ~50%

    thermSteps = int(0.2 * MCSteps)
    adjustInterval = int(0.1 * thermSteps) + 1
    nAccept = 0

    print *, ' Performing thermalization steps ...', thermSteps

    do i=1, thermSteps

        call MetropolisStep(x)

        if(mod(i+1, adjustInterval) == 0) then

            delta = delta * dble(nAccept) / (0.5 * dble(adjustInterval))
            nAccept = 0

        endif

    enddo

    print *, ' Adjusted Gaussian step size ', delta

! --- production steps

    nAccept = 0  ! accumulator for number of accepted steps
    eSum = 0.
    eSqdSum = 0.
    envSum = 0.0
    enkSum = 0d0
    envpSum = 0.0
    enkpSum = 0.0
    rDpSum = 0.0

    nAccept = 0
    print *, " Performing production steps ...", MCSteps

    do i=1, MCSteps
    !MonteCarloStep()
        call MetropolisStep(x)
    enddo

! --- compute and print energy

    pAve = eSum / MCSteps

    envAve = envSum / MCSteps

    enkAve = enkSum / MCSteps

    rDpAve = rDpSum / MCSteps

    eVar = eSqdSum / MCSteps - eAve * eAve

    error = sqrt(eVar / MCSteps)

    write(6, 1012)  pAve, error, envAve, enkAve, enkAve+envAve
1012 format('Permutation overlap = ',f14.8, ' +/- ', f14.8/, &
             'Pontential energy = ', f14.7/, &
             'Kinenticl energy = ',f14.7/, &
             'Total energy = ',f14.7)

    envSym = (envAve+envpAve)/(1d0+pAve)
    enkSym = (enkAve+enkpAve+rDpAve)/(1d0+pAve)

    write(6, 1013) eVar, envSym, envSym-envAve, enkSym, enkSym-enkAve, enkSym+envSym
1013 format('Variance = ',f14.8/  &
            'Corrected potential energy = ',f14.7/,  'Correction = ', f14.7/ &
            'Corrected kinentic energy = ',f14.7/, 'Correction = ',f14.7/, &
            'Corrected total energy = ',f14.7)

! --- write wave function squared in file
    !open(100, file = "psiSqd.data")

!    psiNorm = sum(rho) * dx
!    do i=1,nx
!        z = xmin + i * dx
!        write(100, *) z, rho(i) / psiNorm
!    enddo

    stop
    end program
 ! ---------------------------

    subroutine prob(y, x, a)

    use Monte
    use AQP

    implicit real*8(a-h, o-z)

    real*8, dimension(ndim) :: x,y

! --- trial function is exp(-alpha1*x1^2-alpha2*x2^2)
! --- compute the ratio of rho(x') / rho(x)

    ax = 1.0
    ay = 1.0

    z0 = psiSqd(x)
    z1 = psiSqd(y)

    a = z1/z0

    end subroutine

! --- compute the local energy

    subroutine local(x,z,env,enk,rDp)

    use sci, only : pi

    use Monte, only : ndim

    use AQP

    implicit real*8(a-h, o-z)

    real*8, dimension(ndim) :: x, am, dp

    am = 4.d0

    x1 = x(1)
    x2 = x(2)

    ni = 1
    nj = 2

    aij = ra(ni)-ra(nj)
    cij = rc(ni)-rc(nj)
    dij = rd(ni)-rd(nj)

    z = aij*(x(2)-x(1)) + cij * (x2**3 - x1**3)/3d0 + dij * (x2**4-x1**4)/4d0 + &
        (rb(1,1) - rb(2,2)) * (x2**2-x1**2)/2d0

    if(ndim .gt. 2) then
        do k=3,ndim
            z = z + (rb(1,k) - rb(2,k))*(x(2)-x(1))*x(k)
        enddo
    endif

    z = exp(z)

    rDp = 0d0

    ! potential energy

    call potential(x,env)

     dp(1) = -aij - cij*x1**2- dij*x1**3 - (rb(1,1)-rb(2,2))*x(1)

     dp(2) =  aij + cij*x2**2 + dij*x2**3 + (rb(1,1)-rb(2,2))*x(2)

    if(ndim .gt. 2) then
        do k=3,ndim
            dp(k) = (rb(1,k)-rb(2,k))*(x(2)-x(1))
        enddo
     endif

    ! kinetic energy
    enk = 0d0

    do j=1,ndim
      rj = 0d0
      rj = rj + ra(j) + rc(j)*x(j)**2 + rd(j)*x(j)**3
      do k=1,ndim
        rj = rj + rb(j,k)*x(k)
      enddo

      enk = enk + rj**2/2d0/am(j)

      rDp = rDp + rj*dp(j) ! r_mu * \grad_mu poly

    enddo

    return
    end subroutine

! --- potential energy
    subroutine potential(x,env)

    use Monte, only : ndim
    implicit real*8(a-h,o-z)

    real*8, dimension(ndim) :: x

    R0 = 1.5d0
    env = (x(1)+x(2))**2/2d0 + (abs(x(1)-x(2))-R0)**2/2d0

    return
    end subroutine

! ---------------------------------
! --- Metropolis Scheme
! ---------------------------------
    subroutine MetropolisStep(x)

    use Monte

    implicit real*8(a-h, o-z)

    real*8, dimension(ndim) :: x,y

    real*8 gasdev
    !real*8 rho(nx)

    ! chose a walker at random
    ! n = int(np.random.rand() * N)

    ! make a trial move
    do j=1,ndim
        y(j) = x(j) + delta * gasdev(idum)
    enddo

    ! Metropolis test
    call prob(y,x,a)

    if (a > rand(0)) then

        x = y
        nAccept = nAccept + 1
    endif

    ! accumulate local functions
    call local(x,p,env,enk,rDp)
    eSum = eSum + p
    eSqdSum = eSqdSum +  p * p
    envSum = envSum + env ! <V>
    enkSum = enkSum + enk ! <K>
    envpSum = envpSum + p*env ! <VP>
    enkpSum = enkpSum + p*enk ! <KP>
    rDpSum = rDpSum + rDp  ! < dpsi/psi * dPoly * exp(Poly) >

    !i = int((x - xmin) / dx)
    !if(i .ge. 0 .and. i < nx) then
    !    rho(i) = rho(i) + 1
    !endif

    return
    end subroutine

! --- compute psiSqd from the linear-fitting coefficients of r

    double precision function psiSqd(x)

    use Monte, only: ndim

    use AQP

    implicit real*8(a-h, o-z)

    real*8, dimension(ndim) :: x

      z = 0d0
      do j=1,ndim
        z = z + ra(j)*x(j) + rb(j,j)/2d0 * x(j)**2 + rc(j)/3d0 * x(j)**3 + rd(j)/4d0 * x(j)**4
      enddo
      do j=1,ndim
        do k=j+1,ndim
          z = z + rb(j,k)*x(j)*x(k)
        enddo
       enddo

      psiSqd = exp(2.0 * z)

      return

    end function

! --- map fitting coefficients cr,cr2 to {a,b,c,d}, which are coefficients written in
!     non-displaced Cartesian coordinates
    subroutine map()
    use Monte, only: ndim
    use AQP

    implicit real*8(a-h, o-z)

    real (kind = 8 ) cr(ndim+1,ndim),cr2(4,ndim)

    real (kind = 8), dimension(ndim,ndim) :: beta, delta
    real (kind = 8), dimension(ndim) :: alfa, gama, rho

    real (kind = 8), dimension(ndim) :: q
    real (kind = 8), dimension(ndim) :: dp

! --- choose pair of atoms to exchange

      ni = 1
      nj = 2

! --- read fitting coefficients to get analytical wavefunction

      open(11, file = 'linearFit.data')
      do k=1,ndim+1
        read(11,*) (cr(k,j),j=1,ndim)
      enddo

      open(12, file = 'cubicFit.data')
      do j=1,4
        read(12,*) (cr2(j,k),k=1,ndim)
      enddo

      close(11)
      close(12)

      write(6,*) 'Finish reading files.'

! -- no need to translate coordinates
!      do i=1,ntraj
!      do j=1,ndim
!        x(j,i) = u(j,i) + xtal(j,1)
!      enddo
!      enddo

      delta = 0d0
      do k=1,ndim
        delta(k,k) = 1d0
      enddo

      do k=1,ndim
        alfa(k) = cr(ndim+1,k)+cr2(4,k)
        gama(k) = cr2(2,k)
        rho(k) = cr2(3,k)
      enddo

      do k=1,ndim
      do j=1,ndim
        beta(j,k) = cr(k,j)
      enddo
      enddo

      do k=1,ndim
        beta(k,k) = beta(k,k) + cr2(1,k)
      enddo

! --- q(ndim) optimal Cartesian coordinates

      ra = 0d0

    q = 0d0 ! no translation, use when the coordinates used in trajectory code is displaced-Cartesian

      do k=1,ndim
      do m = 1,ndim
        ra(k) = ra(k)- beta(k,m)*q(m)
      enddo
      enddo

      do k=1,ndim
        ra(k) = ra(k) + alfa(k) + gama(k)*q(k)**2
        rc(k) = gama(k) - 3d0*rho(k)**2*q(k)
        rd(k) =  rho(k)
      enddo

      do k=1,ndim
      do m=1,ndim
        rb(k,m) = beta(k,m)
      enddo
      enddo

      do k=1,ndim
        rb(k,k) = rb(k,k) - 2d0*gama(k)*q(k) + 3d0*rho(k)*q(k)**2
      enddo

    return
    end subroutine


    MODULE cdf_t_mod
! ----------------------------------------------------------------------

!                                cdf_t_mod
!                                *=*=*=*=*

!  -  SUBROUTINE CDF_T( WHICH, CUM, CCUM, T, DF,   STATUS, CHECK_INPUT )
!  -  REAL (dpkind) FUNCTION CUM_T(T, DF, STATUS, CHECK_INPUT)
!  -  REAL (dpkind) FUNCTION CCUM_T(T, DF, STATUS, CHECK_INPUT)
!  -  REAL (dpkind) FUNCTION INV_T(CUM, CCUM, T, DF, STATUS, CHECK_INPUT)

!                             The Distribution
!                             ================

! The density is proportional to:

!                            [      2 ]
!                            [     T  ](DF+1)/2
!                            [ 1 + -- ]
!                            [     DF ]

!                                Arguments
!                                =========

!  - INTEGER, INTENT(IN) :: WHICH. Integer indicating which of the next
!    arguments is to be calculated.
!  Input Range: [ 1:3 ]
!     1.  CUM and CCUM
!     2.  T
!     3.  DF
!  - REAL (dpkind), OPTIONAL :: CUM. The CDF of the noncentral t
!    distribution.
!  Range: [ 10^-10:1-10^-10 ]
!  - REAL (dpkind), OPTIONAL :: CCUM. One minus the CDF of the noncentral
!    t distribution.
!  Range: [ 10^-10:1-10^-10 ]
!  - REAL (dpkind) :: T. The upper limit of integration of the noncentral
!    t density. The lower limit is -oo.
!  Range: [ -10^100:10^100 ]
!  - REAL (dpkind) :: DF. The degrees of freedom.
!  Range: [ 10^-3:10^10 ]
!  - INTEGER, OPTIONAL, INTENT(OUT) :: STATUS. Return code. Possible values:
!      0 Problem solved successfully
!     -1 WHICH outside input range
!     -2 CUM outside range
!     -3 CCUM outside range
!     -4 T outside range
!     -5 DF outside range
!      3 CUM + CCUM is not nearly one
!     10 can not solve cdf_beta in local_cum_t
!    -50 Answer (if any) is BELOW the LOWER search bound
!     50 Answer (if any) is ABOVE the UPPER search bound
!  - LOGICAL, INTENT(IN), OPTIONAL :: CHECK_INPUT. If PRESENT and .TRUE.
!    input argument values are not checked for validity.
! ----------------------------------------------------------------------
! .. Use Statements ..
      USE biomath_constants_mod
      USE biomath_mathlib_mod
      USE cdf_aux_mod
! ..
! .. Default Accessibility ..
      PRIVATE
! ..
! .. Public Statements ..
      PUBLIC :: ccum_t, cdf_t, cum_t, inv_t
! ..
    CONTAINS

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

      FUNCTION ccum_t(t,df,status,check_input)
! .. Function Return Value ..
        REAL (dpkind) :: ccum_t
! ..
! .. Scalar Arguments ..
        REAL (dpkind), INTENT (IN) :: df, t
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
        CALL cdf_t(which=1,ccum=ccum_t,t=t,df=df,status=status, &
          check_input=check_input)

        RETURN

      END FUNCTION ccum_t

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

      SUBROUTINE cdf_t(which,cum,ccum,t,df,status,check_input)
! .. Use Statements ..
        USE zero_finder
! ..
! .. Scalar Arguments ..
        REAL (dpkind), OPTIONAL :: ccum, cum
        REAL (dpkind) :: df, t
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        INTEGER, INTENT (IN) :: which
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
! .. Local Structures ..
        TYPE (zf_locals) :: local
! ..
! .. Local Scalars ..
        REAL (dpkind) :: fx, local_ccum, local_cum, try_ccum, try_cum
        INTEGER :: zf_status
        LOGICAL :: has_status, local_check_input, match_cum
! ..
! .. Intrinsic Functions ..
        INTRINSIC PRESENT
! ..
! .. Local Arrays ..
        REAL (dpkind) :: params(6)
! ..
        has_status = PRESENT(status)

! status = 0 means NO error

        IF (has_status) THEN
          status = 0
        END IF

        CALL check_complements(cum,ccum,the_t%name,'cum','ccum', &
          local_cum,local_ccum,set_values=(which/=1),bad_status=3, &
          status=status)

        IF (has_status) THEN
          IF (status/=0) THEN
            RETURN
          END IF
        END IF

        params(1) = local_cum
        params(2) = local_ccum
        params(3) = t
        params(4) = df

        IF (PRESENT(check_input)) THEN
          local_check_input = check_input
        ELSE
          local_check_input = .TRUE.
        END IF

        IF (local_check_input) THEN
          CALL validate_parameters(the_t,which,params,status)

          IF (has_status) THEN
            IF (status/=0) THEN
              RETURN
            END IF
          END IF
        END IF

! ++++++++++          ++++++++++          ++++++++++
! Compute the Answers
! ++++++++++          ++++++++++          ++++++++++

        IF (which>1) match_cum = (local_cum<=half)

        SELECT CASE (which)
        CASE (1)

! Solve for cum and ccum

          CALL local_cum_t(t,df,local_cum,local_ccum,status)

          IF (PRESENT(cum)) cum = local_cum
          IF (PRESENT(ccum)) ccum = local_ccum

        CASE (2)

! Solve for t

! Get start value of t
          t = dt1(local_cum,local_ccum,df)

          zf_status = 0

          CALL cdf_set_zero_finder(the_t,3,local)

          DO
            CALL rc_step_zf(zf_status,t,fx,local)

            IF (zf_status/=1) EXIT

            CALL local_cum_t(t,df,try_cum,try_ccum,status)

            IF (has_status) THEN
              IF (status/=0) THEN
                RETURN
              END IF
            END IF

            IF (match_cum) THEN
              fx = try_cum - local_cum
            ELSE
              fx = try_ccum - local_ccum
            END IF
          END DO

        CASE (3)

! Solve for df (degrees of freedom)

          df = five
          zf_status = 0

          CALL cdf_set_zero_finder(the_t,4,local)

          DO
            CALL rc_step_zf(zf_status,df,fx,local)

            IF (zf_status/=1) EXIT

            CALL local_cum_t(t,df,try_cum,try_ccum,status)

            IF (has_status) THEN
              IF (status/=0) THEN
                RETURN
              END IF
            END IF

            IF (match_cum) THEN
              fx = try_cum - local_cum
            ELSE
              fx = try_ccum - local_ccum
            END IF

          END DO

        END SELECT

        IF (has_status) THEN
! Set the status of the zero finder
          CALL cdf_finalize_status(local,status)
        END IF

        RETURN

      END SUBROUTINE cdf_t

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

      FUNCTION cum_t(t,df,status,check_input)
! .. Function Return Value ..
        REAL (dpkind) :: cum_t
! ..
! .. Scalar Arguments ..
        REAL (dpkind), INTENT (IN) :: df, t
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
        CALL cdf_t(which=1,cum=cum_t,t=t,df=df,status=status, &
          check_input=check_input)

        RETURN

      END FUNCTION cum_t

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

      FUNCTION dt1(p,q,df)
!**********************************************************************
!     Double precision Initalize Approximation to
!           INVerse of the cumulative T distribution
!                              Function
!     Returns  the  inverse   of  the T   distribution   function, i.e.,
!     the integral from 0 to INVT of the T density is P. This is an
!     initial approximation.
!                              Arguments
!     P --> The p-value whose inverse from the T distribution is
!           desired.
!     Q --> 1-P.
!     DF --> Degrees of freedom of the T distribution.
!                              Method
!     Formula (26.7.5) from Abramowitz and Stegun is used to compute
!     the asymptotic expansion for the inverse function.
!**********************************************************************
! .. Use Statements ..
        USE cdf_normal_mod
! ..
! .. Function Return Value ..
        REAL (dpkind) :: dt1
! ..
! .. Scalar Arguments ..
        REAL (dpkind), INTENT (IN) :: df, p, q
! ..
! .. Local Scalars ..
        REAL (dpkind) :: denpow, sum, term, x, xp, xx
        INTEGER :: i, ideg
! ..
! .. Intrinsic Functions ..
        INTRINSIC ABS, RESHAPE
! ..
! .. Parameters ..
        REAL (dpkind), PARAMETER :: coef(5,4) = RESHAPE((/one,one,zero, &
          zero,zero,three,16.0_dpkind,five,zero,zero,-15.0_dpkind, &
          17.0_dpkind,19.0_dpkind,three,zero,-945.0_dpkind, &
          -1920.0_dpkind,1482.0_dpkind,776.0_dpkind,79.0E0_dpkind/), &
          shape=(/5,4/))
        REAL (dpkind), PARAMETER :: denom(4) = (/ four, 96.0_dpkind, &
          384.0_dpkind, 92160.0_dpkind/)
! ..
        x = ABS(inv_normal(cum=p,check_input=.FALSE.))

        xx = x*x
        sum = x
        denpow = one

! DMS ideg(i) = i+1

        DO i = 1, 4
          ideg = i + 1
          term = x*evaluate_polynomial(coef(1:5,i),xx)
          denpow = denpow*df
          sum = sum + term/(denpow*denom(i))
        END DO

        IF (p<half) THEN
          xp = -sum
        ELSE
          xp = sum
        END IF

        dt1 = xp

        RETURN

      END FUNCTION dt1

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

      FUNCTION inv_t(cum,ccum,df,status,check_input)
! Solves the INVERSE Poisson problem:
! Given cum (or/and ccum), and df, computes t.
! .. Function Return Value ..
        REAL (dpkind) :: inv_t
! ..
! .. Scalar Arguments ..
        REAL (dpkind), OPTIONAL :: ccum, cum
        REAL (dpkind), INTENT (IN) :: df
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
        CALL cdf_t(which=2,cum=cum,ccum=ccum,t=inv_t,df=df,status=status, &
          check_input=check_input)

        RETURN

      END FUNCTION inv_t

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

      SUBROUTINE local_cum_t(t,df,cum,ccum,status)
!----------------------------------------------------------------------

!                              Function

!     Computes the integral from -infinity to T of the t-density.
!     t --> Upper limit of integration of the t-density.
!     df --> Degrees of freedom of the t-distribution
!     cum<-- Cumulative t-distribution.
!     ccum <-- Compliment of Cumulative t-distribution.
!     status <-- status of the computation.
!                Set to 10 if cdf_beta has no answer.

!                         Method

!     Formula  26.5.27  of   Abramowitz   and  Stegun,   Handbook   of
!     Mathematical Functions  (1966) is used to reduce the computation
!     of the cumulative distribution function to that of an incomplete
!     beta.
!------------------------------------------------------------------
! .. Use Statements ..
        USE cdf_beta_mod
! ..
! .. Scalar Arguments ..
        REAL (dpkind), INTENT (OUT) :: ccum, cum
        REAL (dpkind), INTENT (IN) :: df, t
        INTEGER, OPTIONAL, INTENT (OUT) :: status
! ..
! .. Local Scalars ..
        REAL (dpkind) :: a, dfptt, oma, tt, xx, yy
        INTEGER :: beta_status
! ..
! .. Intrinsic Functions ..
        INTRINSIC PRESENT
! ..
        tt = t*t
        dfptt = df + tt
        xx = df/dfptt
        yy = tt/dfptt

        CALL cdf_beta(1,a,oma,xx,yy,half*df,half,status=beta_status)

        IF (beta_status/=0) THEN
! cdf_beta has NO answer.

          IF (PRESENT(status)) THEN
            status = 10

            RETURN
          ELSE
            WRITE (*,*) 'Error in local_cum_t call to cdf_beta'
            WRITE (*,*) 'Status: ', beta_status

            STOP 'Error in local_cum_t call to cdf_beta'
          END IF
        END IF

        IF (t<=zero) THEN
          cum = half*a
          ccum = oma + cum
        ELSE
          ccum = half*a
          cum = oma + ccum
        END IF

        RETURN

      END SUBROUTINE local_cum_t

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

    END MODULE cdf_t_mod


module test_utils
  use numeric_kinds, only: dp

  use davidson_free, only: free_matmul
  use array_utils, only: generate_diagonal_dominant

  implicit none

contains

  function apply_mtx_to_vect(input_vect) result (output_vect)
    !> \brief Function to compute the optional mtx on the fly
    !> \param[in] i column/row to compute from mtx
    !> \param vec column/row from mtx

    real (dp), dimension(:,:), intent(in) :: input_vect
    real (dp), dimension(size(input_vect,1),size(input_vect,2)) :: output_vect

    output_vect = free_matmul(compute_matrix_on_the_fly,input_vect)

  end function apply_mtx_to_vect

  function apply_stx_to_vect(input_vect) result (output_vect)
    !> \brief Function to compute the optional mtx on the fly
    !> \param[in] i column/row to compute from mtx
    !> \param vec column/row from mtx

    real (dp), dimension(:,:), intent(in) :: input_vect
    real (dp), dimension(size(input_vect,1),size(input_vect,2)) :: output_vect

    output_vect = free_matmul(compute_stx_on_the_fly,input_vect)

  end function apply_stx_to_vect

  function compute_matrix_on_the_fly(i, dim) result (vector)
    !> \param[in] i index of the i-th column
    !> \param[in] dim dimension of the resulting column
    !> \return the i-th column of a square matrix of dimension dim

    integer, intent(in) :: i, dim
    real(dp), dimension(dim) :: vector

    ! call expensive function
    vector = expensive_function_1(i, dim)

    ! set the diagonal value
    vector(i) = vector(i) + real(i)

  end function compute_matrix_on_the_fly

  function compute_stx_on_the_fly(i, dim) result (vector)
    !> \param[in] i index of the i-th column
    !> \param[in] dim dimension of the resulting column
    !> \return the i-th column of a square matrix of dimension dim

    integer, intent(in) :: i, dim
    real(dp), dimension(dim) :: vector

    ! call expensive function
    vector = expensive_function_2(i, dim)

    ! Set diagonal value equal to 1
    vector(i) = 1d0

  end function compute_stx_on_the_fly

  function expensive_function_1(i, dim) result (vector)
    !> expensive function to test matrix free version

    integer, intent(in) :: i, dim
    real(dp), dimension(dim) :: vector

    ! local variable
    integer :: j
    real(dp) :: x, y

    x = exp(real(i)/real(dim))

    do j=1,dim
       y = exp(real(j)/real(dim))
       if (j >= i) then
          vector(j) = cos(log(sqrt(atan2(x, y)))) * 1e-4
       else
          vector(j) = cos(log(sqrt(atan2(y, x)))) * 1e-4
       endif
    end do

  end function expensive_function_1

  function expensive_function_2(i, dim) result (vector)
    !> expensive function to test matrix free version

    integer, intent(in) :: i, dim
    real(dp), dimension(dim) :: vector

    ! local variable
    integer :: j
    real(dp) :: x, y

    x = exp(real(i)/real(dim))

    do j=1,dim
       y = exp(real(j)/real(dim))
       if (j >= i) then
          vector(j) = sin(log(sqrt(atan2(x, y)))) * 1e-4
       else
          vector(j) = sin(log(sqrt(atan2(y, x)))) * 1e-4
       endif
    end do

  end function expensive_function_2

  function read_matrix(path_file, dim) result(mtx)
    !> read a row-major square matrix from a file
    !> \param path_file: path to the file
    !> \param dim: dimension of the square matrix
    !> \return matrix

    character(len=*), intent(in) :: path_file
    integer, intent(in) :: dim
    real(dp), dimension(dim, dim) :: mtx
    integer :: i

    open(unit=3541, file=path_file, status="OLD")
    do i=1,dim
       read(3541, *) mtx(i, :)
    end do
    close(3541)

  end function read_matrix

  subroutine write_vector(path_file, vector)
    !> Write vector to path_file
    character(len=*), intent(in) :: path_file
    real(dp), dimension(:), intent(in) :: vector
    integer :: i

    open(unit=314, file=path_file, status="REPLACE")
    do i=1,size(vector)
       write(314, *) vector(i)
    end do
    close(314)

  end subroutine write_vector

  subroutine write_matrix(path_file, mtx)
    !> Write matrix to path_file
    character(len=*), intent(in) :: path_file
    real(dp), dimension(:, :), intent(in) :: mtx
    integer :: i, j

    open(unit=314, file=path_file, status="REPLACE")
    do i=1,size(mtx, 1)
       do j=1,size(mtx, 2)
          write(314, *) mtx(i, j)
       end do
    end do
    close(314)

  end subroutine write_matrix

end module test_utils