      subroutine dsel2(n,x,keys,k)
      integer n, k
      integer keys(n)
      double precision x(n)
c     **********
c
c     Subroutine dsel2
c
c     Given an array x of length n, this subroutine permutes
c     the elements of the array keys so that
c
c       abs(x(keys(i))) <= abs(x(keys(k))),  1 <= i <= k,
c       abs(x(keys(k))) <= abs(x(keys(i))),  k <= i <= n.
c
c     In other words, the smallest k elements of x in absolute value are
c     x(keys(i)), i = 1,...,k, and x(keys(k)) is the kth smallest element.
c
c     The subroutine statement is
c
c       subroutine dsel2(n,x,keys,k)
c
c     where
c
c       n is an integer variable.
c         On entry n is the number of keys.
c         On exit n is unchanged.
c
c       x is a double precision array of length n.
c         On entry x is the array to be sorted.
c         On exit x is unchanged.
c
c       keys is an integer array of length n.
c         On entry keys is the array of indices for x.
c         On exit keys is permuted so that the smallest k elements
c            of x in absolute value are x(keys(i)), i = 1,...,k, and
c            x(keys(k)) is the kth smallest element.
c
c       k is an integer.
c         On entry k specifes the kth largest element.
c         On exit k is unchanged.
c
c     MINPACK-2 Project. March 1998.
c     Argonne National Laboratory.
c     William D. Kastak, Chih-Jen Lin, and Jorge J. More'.
c
c     **********
      integer i, l, lc, lp, m, p, p1, p2, p3, u
      integer swap

      if (n .le. 1 .or. k .le. 0 .or. k .gt. n) return

      u = n
      l = 1
      lc = n
      lp = 2*n

c     Start of iteration loop.

      do while (l .lt. u)

c        Choose the partition as the median of the elements in
c        positions l+s*(u-l) for s = 0, 0.25, 0.5, 0.75, 1.
c        Move the partition element into position l.

         p1 = (u+3*l)/4
         p2 = (u+l)/2
         p3 = (3*u+l)/4

c        Order the elements in positions l and p1.

         if (dabs(x(keys(l))) .gt. dabs(x(keys(p1)))) then
            swap = keys(l)
            keys(l) = keys(p1)
            keys(p1) = swap
            end if

c        Order the elements in positions p2 and p3.

         if (dabs(x(keys(p2))) .gt. dabs(x(keys(p3)))) then
            swap = keys(p2)
            keys(p2) = keys(p3)
            keys(p3) = swap
            end if

c        Swap the larger of the elements in positions p1
c        and p3, with the element in position u, and reorder
c        the first two pairs of elements as necessary.

         if (dabs(x(keys(p3))) .gt. dabs(x(keys(p1)))) then
            swap = keys(p3)
            keys(p3) = keys(u)
            keys(u) = swap
            if (dabs(x(keys(p2))) .gt. dabs(x(keys(p3)))) then
               swap = keys(p2)
               keys(p2) = keys(p3)
               keys(p3) = swap
               end if
         else
            swap = keys(p1)
            keys(p1) = keys(u)
            keys(u) = swap
            if (dabs(x(keys(l))) .gt. dabs(x(keys(p1)))) then
               swap = keys(l)
               keys(l) = keys(p1)
               keys(p1) = swap
               end if
            end if

c        If we define a(i) = abs(x(keys(i)) for i = 1,..., n, we have
c        permuted keys so that
c
c          a(l) <= a(p1), a(p2) <= a(p3), max(a(p1),a(p3)) <= a(u).
c
c        Find the third largest element of the four remaining
c        elements (the median), and place in position l.

         if (dabs(x(keys(p1))) .gt. dabs(x(keys(p3)))) then
            if (dabs(x(keys(l))) .le. dabs(x(keys(p3)))) then
               swap = keys(l)
               keys(l) = keys(p3)
               keys(p3) = swap
               end if
         else
            if (dabs(x(keys(p2))) .le. dabs(x(keys(p1)))) then
               swap = keys(l)
               keys(l) = keys(p1)
               keys(p1) = swap
            else
               swap = keys(l)
               keys(l) = keys(p2)
               keys(p2) = swap
               end if
            end if

c        Partition the array about the element in position l.

         m = l
         do i = l+1, u
            if (dabs(x(keys(i))) .lt. dabs(x(keys(l))))then
               m = m + 1
               swap = keys(m)
               keys(m) = keys(i)
               keys(i) = swap
               end if
         end do

c        Move the partition element into position m.

         swap = keys(l)
         keys(l) = keys(m)
         keys(m) = swap

c        Adjust the values of l and u.

         if (k .ge. m) l = m + 1
         if (k .le. m) u = m - 1

c        Check for multiple medians if the length of the subarray
c        has not decreased by 1/3 after two consecutive iterations.

         if (3*(u-l) .gt. 2*lp .and. k .gt. m) then

c           Partition the remaining elements into those elements
c           equal to x(m), and those greater than x(m). Adjust
c           the values of l and u.

            p = m
            do i = m+1, u
               if (dabs(x(keys(i))) .eq. dabs(x(keys(m)))) then
                  p = p + 1
                  swap = keys(p)
                  keys(p) = keys(i)
                  keys(i) = swap
                  end if
            end do
            l = p + 1
            if (k .le. p) u = p - 1
            end if

c        Update the length indicators for the subarray.

         lp = lc
         lc = u-l

      end do

      return

      end


! { dg-do compile }
program a
   real x
   x = tiny(x) / huge(x)  ! { dg-warning "Arithmetic underflow" }
end program a


subroutine dpofa(a, lda, n, info)
    integer lda, n, info
    double precision a(lda, *)
    !
    !     dpofa factors a double precision symmetric positive definite
    !     matrix.
    !
    !     dpofa is usually called by dpoco, but it can be called
    !     directly with a saving in time if  rcond  is not needed.
    !     (time for dpoco) = (1 + 18/n)*(time for dpofa) .
    !
    !     on entry
    !
    !        a       double precision(lda, n)
    !                the symmetric matrix to be factored.  only the
    !                diagonal and upper triangle are used.
    !
    !        lda     integer
    !                the leading dimension of the array  a .
    !
    !        n       integer
    !                the order of the matrix  a .
    !
    !     on return
    !
    !        a       an upper triangular matrix  r  so that  a = trans(r)*r
    !                where  trans(r)  is the transpose.
    !                the strict lower triangle is unaltered.
    !                if  info .ne. 0 , the factorization is not complete.
    !
    !        info    integer
    !                = 0  for normal return.
    !                = k  signals an error condition.  the leading minor
    !                     of order  k  is not positive definite.
    !
    !     linpack.  this version dated 08/14/78 .
    !     cleve moler, university of new mexico, argonne national lab.
    !
    !     subroutines and functions
    !
    !     blas ddot
    !     fortran sqrt
    !
    !     internal variables
    !
    double precision ddot, t
    double precision s
    integer j, jm1, k
    !     begin block with ...exits to 40
    !
    !
    do 30 j = 1, n
        info = j
        s = 0.0d0
        jm1 = j - 1
        if (jm1 .lt. 1) go to 20
        do 10 k = 1, jm1
            t = a(k, j) - ddot(k - 1, a(1, k), 1, a(1, j), 1)
            t = t / a(k, k)
            a(k, j) = t
            s = s + t * t
        10       continue
        20       continue
        s = a(j, j) - s
        !     ......exit
        if (s .le. 0.0d0) go to 40
        a(j, j) = sqrt(s)
    30    continue
    info = 0
    40 continue
    return
end

!====================== The end of dpofa ===============================

subroutine dtrsl(t, ldt, n, b, job, info)
    integer ldt, n, job, info
    double precision t(ldt, *), b(*)
    !
    !
    !     dtrsl solves systems of the form
    !
    !                   t * x = b
    !     or
    !                   trans(t) * x = b
    !
    !     where t is a triangular matrix of order n. here trans(t)
    !     denotes the transpose of the matrix t.
    !
    !     on entry
    !
    !         t         double precision(ldt,n)
    !                   t contains the matrix of the system. the zero
    !                   elements of the matrix are not referenced, and
    !                   the corresponding elements of the array can be
    !                   used to store other information.
    !
    !         ldt       integer
    !                   ldt is the leading dimension of the array t.
    !
    !         n         integer
    !                   n is the order of the system.
    !
    !         b         double precision(n).
    !                   b contains the right hand side of the system.
    !
    !         job       integer
    !                   job specifies what kind of system is to be solved.
    !                   if job is
    !
    !                        00   solve t*x=b, t lower triangular,
    !                        01   solve t*x=b, t upper triangular,
    !                        10   solve trans(t)*x=b, t lower triangular,
    !                        11   solve trans(t)*x=b, t upper triangular.
    !
    !     on return
    !
    !         b         b contains the solution, if info .eq. 0.
    !                   otherwise b is unaltered.
    !
    !         info      integer
    !                   info contains zero if the system is nonsingular.
    !                   otherwise info contains the index of
    !                   the first zero diagonal element of t.
    !
    !     linpack. this version dated 08/14/78 .
    !     g. w. stewart, university of maryland, argonne national lab.
    !
    !     subroutines and functions
    !
    !     blas daxpy,ddot
    !     fortran mod
    !
    !     internal variables
    !
    double precision ddot, temp
    integer case, j, jj
    !
    !     begin block permitting ...exits to 150
    !
    !        check for zero diagonal elements.
    !
    do 10 info = 1, n
        !     ......exit
        if (t(info, info) .eq. 0.0d0) go to 150
    10    continue
    info = 0
    !
    !        determine the task and go to it.
    !
    case = 1
    if (mod(job, 10) .ne. 0) case = 2
    if (mod(job, 100) / 10 .ne. 0) case = case + 2
    go to (20, 50, 80, 110), case
    !
    !        solve t*x=b for t lower triangular
    !
    20    continue
    b(1) = b(1) / t(1, 1)
    if (n .lt. 2) go to 40
    do 30 j = 2, n
        temp = -b(j - 1)
        call daxpy(n - j + 1, temp, t(j, j - 1), 1, b(j), 1)
        b(j) = b(j) / t(j, j)
    30       continue
    40       continue
    go to 140
    !
    !        solve t*x=b for t upper triangular.
    !
    50    continue
    b(n) = b(n) / t(n, n)
    if (n .lt. 2) go to 70
    do 60 jj = 2, n
        j = n - jj + 1
        temp = -b(j + 1)
        call daxpy(j, temp, t(1, j + 1), 1, b(1), 1)
        b(j) = b(j) / t(j, j)
    60       continue
    70       continue
    go to 140
    !
    !        solve trans(t)*x=b for t lower triangular.
    !
    80    continue
    b(n) = b(n) / t(n, n)
    if (n .lt. 2) go to 100
    do 90 jj = 2, n
        j = n - jj + 1
        b(j) = b(j) - ddot(jj - 1, t(j + 1, j), 1, b(j + 1), 1)
        b(j) = b(j) / t(j, j)
    90       continue
    100       continue
    go to 140
    !
    !        solve trans(t)*x=b for t upper triangular.
    !
    110    continue
    b(1) = b(1) / t(1, 1)
    if (n .lt. 2) go to 130
    do 120 j = 2, n
        b(j) = b(j) - ddot(j - 1, t(1, j), 1, b(1), 1)
        b(j) = b(j) / t(j, j)
    120       continue
    130       continue
    140    continue
    150 continue
    return
end

!====================== The end of dtrsl ===============================


c       this file contains the following user-callable routines:
c
c
c       routine idd_snorm estimates the spectral norm
c       of a matrix specified by routines for applying the matrix
c       and its transpose to arbitrary vectors. This routine uses
c       the power method with a random starting vector.
c
c       routine idd_diffsnorm estimates the spectral norm
c       of the difference between two matrices specified by routines
c       for applying the matrices and their transposes
c       to arbitrary vectors. This routine uses
c       the power method with a random starting vector.
c
c       routine idd_enorm calculates the Euclidean norm of a vector.
c
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
c
c
        subroutine idd_snorm(m,n,matvect,p1t,p2t,p3t,p4t,
     1                       matvec,p1,p2,p3,p4,its,snorm,v,u)
c
c       estimates the spectral norm of a matrix a specified
c       by a routine matvec for applying a to an arbitrary vector,
c       and by a routine matvect for applying a^T
c       to an arbitrary vector. This routine uses the power method
c       with a random starting vector.
c
c       input:
c       m -- number of rows in a
c       n -- number of columns in a
c       matvect -- routine which applies the transpose of a
c                  to an arbitrary vector; this routine must have
c                  a calling sequence of the form
c
c                  matvect(m,x,n,y,p1t,p2t,p3t,p4t),
c
c                  where m is the length of x,
c                  x is the vector to which the transpose of a
c                  is to be applied,
c                  n is the length of y,
c                  y is the product of the transpose of a and x,
c                  and p1t, p2t, p3t, and p4t are user-specified
c                  parameters
c       p1t -- parameter to be passed to routine matvect
c       p2t -- parameter to be passed to routine matvect
c       p3t -- parameter to be passed to routine matvect
c       p4t -- parameter to be passed to routine matvect
c       matvec -- routine which applies the matrix a
c                 to an arbitrary vector; this routine must have
c                 a calling sequence of the form
c
c                 matvec(n,x,m,y,p1,p2,p3,p4),
c
c                 where n is the length of x,
c                 x is the vector to which a is to be applied,
c                 m is the length of y,
c                 y is the product of a and x,
c                 and p1, p2, p3, and p4 are user-specified parameters
c       p1 -- parameter to be passed to routine matvec
c       p2 -- parameter to be passed to routine matvec
c       p3 -- parameter to be passed to routine matvec
c       p4 -- parameter to be passed to routine matvec
c       its -- number of iterations of the power method to conduct
c
c       output:
c       snorm -- estimate of the spectral norm of a
c       v -- estimate of a normalized right singular vector
c            corresponding to the greatest singular value of a
c
c       work:
c       u -- must be at least m real*8 elements long
c
c       reference:
c       Kuczynski and Wozniakowski, "Estimating the largest eigenvalue
c            by the power and Lanczos algorithms with a random start,"
c            SIAM Journal on Matrix Analysis and Applications,
c            13 (4): 1992, 1094-1122.
c
        implicit none
        integer m,n,its,it,k
        real*8 snorm,enorm,p1t,p2t,p3t,p4t,p1,p2,p3,p4,u(m),v(n)
        external matvect,matvec
c
c
c       Fill the real and imaginary parts of each entry
c       of the initial vector v with i.i.d. random variables
c       drawn uniformly from [-1,1].
c
        call id_srand(n,v)
c
        do k = 1,n
          v(k) = 2*v(k)-1
        enddo ! k
c
c
c       Normalize v.
c
        call idd_enorm(n,v,enorm)
c
        do k = 1,n
          v(k) = v(k)/enorm
        enddo ! k
c
c
        do it = 1,its
c
c         Apply a to v, obtaining u.
c
          call matvec(n,v,m,u,p1,p2,p3,p4)
c
c         Apply a^T to u, obtaining v.
c
          call matvect(m,u,n,v,p1t,p2t,p3t,p4t)
c
c         Normalize v.
c
          call idd_enorm(n,v,snorm)
c
          if(snorm .gt. 0) then
c
            do k = 1,n
              v(k) = v(k)/snorm
            enddo ! k
c
          endif
c
          snorm = sqrt(snorm)
c
        enddo ! it
c
c
        return
        end
c
c
c
c
        subroutine idd_enorm(n,v,enorm)
c
c       computes the Euclidean norm of v, the square root
c       of the sum of the squares of the entries of v.
c
c       input:
c       n -- length of v
c       v -- vector whose Euclidean norm is to be calculated
c
c       output:
c       enorm -- Euclidean norm of v
c
        implicit none
        integer n,k
        real*8 enorm,v(n)
c
c
        enorm = 0
c
        do k = 1,n
          enorm = enorm+v(k)**2
        enddo ! k
c
        enorm = sqrt(enorm)
c
c
        return
        end
c
c
c
c
        subroutine idd_diffsnorm(m,n,matvect,p1t,p2t,p3t,p4t,
     1                           matvect2,p1t2,p2t2,p3t2,p4t2,
     2                           matvec,p1,p2,p3,p4,
     3                           matvec2,p12,p22,p32,p42,its,snorm,w)
c
c       estimates the spectral norm of the difference between matrices
c       a and a2, where a is specified by routines matvec and matvect
c       for applying a and a^T to arbitrary vectors,
c       and a2 is specified by routines matvec2 and matvect2
c       for applying a2 and (a2)^T to arbitrary vectors.
c       This routine uses the power method
c       with a random starting vector.
c
c       input:
c       m -- number of rows in a, as well as the number of rows in a2
c       n -- number of columns in a, as well as the number of columns
c            in a2
c       matvect -- routine which applies the transpose of a
c                  to an arbitrary vector; this routine must have
c                  a calling sequence of the form
c
c                  matvect(m,x,n,y,p1t,p2t,p3t,p4t),
c
c                  where m is the length of x,
c                  x is the vector to which the transpose of a
c                  is to be applied,
c                  n is the length of y,
c                  y is the product of the transpose of a and x,
c                  and p1t, p2t, p3t, and p4t are user-specified
c                  parameters
c       p1t -- parameter to be passed to routine matvect
c       p2t -- parameter to be passed to routine matvect
c       p3t -- parameter to be passed to routine matvect
c       p4t -- parameter to be passed to routine matvect
c       matvect2 -- routine which applies the transpose of a2
c                   to an arbitrary vector; this routine must have
c                   a calling sequence of the form
c
c                   matvect2(m,x,n,y,p1t2,p2t2,p3t2,p4t2),
c
c                   where m is the length of x,
c                   x is the vector to which the transpose of a2
c                   is to be applied,
c                   n is the length of y,
c                   y is the product of the transpose of a2 and x,
c                   and p1t2, p2t2, p3t2, and p4t2 are user-specified
c                   parameters
c       p1t2 -- parameter to be passed to routine matvect2
c       p2t2 -- parameter to be passed to routine matvect2
c       p3t2 -- parameter to be passed to routine matvect2
c       p4t2 -- parameter to be passed to routine matvect2
c       matvec -- routine which applies the matrix a
c                 to an arbitrary vector; this routine must have
c                 a calling sequence of the form
c
c                 matvec(n,x,m,y,p1,p2,p3,p4),
c
c                 where n is the length of x,
c                 x is the vector to which a is to be applied,
c                 m is the length of y,
c                 y is the product of a and x,
c                 and p1, p2, p3, and p4 are user-specified parameters
c       p1 -- parameter to be passed to routine matvec
c       p2 -- parameter to be passed to routine matvec
c       p3 -- parameter to be passed to routine matvec
c       p4 -- parameter to be passed to routine matvec
c       matvec2 -- routine which applies the matrix a2
c                  to an arbitrary vector; this routine must have
c                  a calling sequence of the form
c
c                  matvec2(n,x,m,y,p12,p22,p32,p42),
c
c                  where n is the length of x,
c                  x is the vector to which a2 is to be applied,
c                  m is the length of y,
c                  y is the product of a2 and x, and
c                  p12, p22, p32, and p42 are user-specified parameters
c       p12 -- parameter to be passed to routine matvec2
c       p22 -- parameter to be passed to routine matvec2
c       p32 -- parameter to be passed to routine matvec2
c       p42 -- parameter to be passed to routine matvec2
c       its -- number of iterations of the power method to conduct
c
c       output:
c       snorm -- estimate of the spectral norm of a-a2
c
c       work:
c       w -- must be at least 3*m+3*n real*8 elements long
c
c       reference:
c       Kuczynski and Wozniakowski, "Estimating the largest eigenvalue
c            by the power and Lanczos algorithms with a random start,"
c            SIAM Journal on Matrix Analysis and Applications,
c            13 (4): 1992, 1094-1122.
c
        implicit none
        integer m,n,its,lw,iu,lu,iu1,lu1,iu2,lu2,
     1          iv,lv,iv1,lv1,iv2,lv2
        real*8 snorm,p1t,p2t,p3t,p4t,p1t2,p2t2,p3t2,p4t2,
     1         p1,p2,p3,p4,p12,p22,p32,p42,w(3*m+3*n)
        external matvect,matvec,matvect2,matvec2
c
c
c       Allocate memory in w.
c
        lw = 0
c
        iu = lw+1
        lu = m
        lw = lw+lu
c
        iu1 = lw+1
        lu1 = m
        lw = lw+lu1
c
        iu2 = lw+1
        lu2 = m
        lw = lw+lu2
c
        iv = lw+1
        lv = n
        lw = lw+1
c
        iv1 = lw+1
        lv1 = n
        lw = lw+lv1
c
        iv2 = lw+1
        lv2 = n
        lw = lw+lv2
c
c
        call idd_diffsnorm0(m,n,matvect,p1t,p2t,p3t,p4t,
     1                      matvect2,p1t2,p2t2,p3t2,p4t2,
     2                      matvec,p1,p2,p3,p4,
     3                      matvec2,p12,p22,p32,p42,
     4                      its,snorm,w(iu),w(iu1),w(iu2),
     5                      w(iv),w(iv1),w(iv2))
c
c
        return
        end
c
c
c
c
        subroutine idd_diffsnorm0(m,n,matvect,p1t,p2t,p3t,p4t,
     1                            matvect2,p1t2,p2t2,p3t2,p4t2,
     2                            matvec,p1,p2,p3,p4,
     3                            matvec2,p12,p22,p32,p42,
     4                            its,snorm,u,u1,u2,v,v1,v2)
c
c       routine idd_diffsnorm serves as a memory wrapper
c       for the present routine. (Please see routine idd_diffsnorm
c       for further documentation.)
c
        implicit none
        integer m,n,its,it,k
        real*8 snorm,enorm,p1t,p2t,p3t,p4t,p1t2,p2t2,p3t2,p4t2,
     1         p1,p2,p3,p4,p12,p22,p32,p42,u(m),u1(m),u2(m),
     2         v(n),v1(n),v2(n)
        external matvect,matvec,matvect2,matvec2
c
c
c       Fill the real and imaginary parts of each entry
c       of the initial vector v with i.i.d. random variables
c       drawn uniformly from [-1,1].
c
        call id_srand(n,v)
c
        do k = 1,n
          v(k) = 2*v(k)-1
        enddo ! k
c
c
c       Normalize v.
c
        call idd_enorm(n,v,enorm)
c
        do k = 1,n
          v(k) = v(k)/enorm
        enddo ! k
c
c
        do it = 1,its
c
c         Apply a and a2 to v, obtaining u1 and u2.
c
          call matvec(n,v,m,u1,p1,p2,p3,p4)
          call matvec2(n,v,m,u2,p12,p22,p32,p42)
c
c         Form u = u1-u2.
c
          do k = 1,m
            u(k) = u1(k)-u2(k)
          enddo ! k
c
c         Apply a^T and (a2)^T to u, obtaining v1 and v2.
c
          call matvect(m,u,n,v1,p1t,p2t,p3t,p4t)
          call matvect2(m,u,n,v2,p1t2,p2t2,p3t2,p4t2)
c
c         Form v = v1-v2.
c
          do k = 1,n
            v(k) = v1(k)-v2(k)
          enddo ! k
c
c         Normalize v.
c
          call idd_enorm(n,v,snorm)
c
          if(snorm .gt. 0) then
c
            do k = 1,n
              v(k) = v(k)/snorm
            enddo ! k
c
          endif
c
          snorm = sqrt(snorm)
c
        enddo ! it
c
c
        return
        end


SUBROUTINE crs_trs (mjd, EOP_ar, iau_model, CRS2TRS, TRS2CRS, d_CRS2TRS, d_TRS2CRS)

! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! Subroutine:  crs_trs.f90
! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! Purpose:
!  ICRF-ITRF transformation matrix (direct/inverse) for position/velocity vectors
!  Earth Orientation Matrix based on the EOP data corrected due to tidal variations
!
! Remark:
!  The matrices required for the ICRF-ITRF direct and inverse transformation
!  are computed for the position and velocity vectors individually.
! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! Input arguments:
! - mjd:			Modified Julian Day number of the epoch (in TT scale)
! - iau_model:		Precession-Nutation model by International Astronomical Union (IAU)
!					IAU = 2 refers to the IAU 2000A model
!					IAU = 3 refers to the IAU 2006/2000A model
! - EOP_ar:			Array of the EOP values for the input epoch
!   				eop = [MJD xp yp UT1_UTC LOD dX dY]  1x6 matrix
!   				MJD:     MJD of the input epoch (in TT)
!   				x,y:     Polar motion coordinates (arcsec)
!   				UT1_UTC: Difference between UT1 and UTC (sec)
!   				LOD_cor: Length of Day (LOD)
!					dX,dY:   Corrections to Precession-Nutation model (arcsec)
!
! Output arguments:
! - CRS2TRS:		GCRS to ITRS transformation matrix
! - TRS2CRS:		ITRS to GCRS transformation matrix
! - d_CRS2TRS:		Derivative of GCRS to ITRS transformation matrix
! - d_TRS2CRS:		Derivative of ITRS to GCRS transformation matrix
! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! Dr. Thomas Papanikolaou, Geoscience Australia            December 2015
! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

      USE mdl_precision
      USE mdl_num
      use pod_yaml
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_d), INTENT(IN) :: mjd, EOP_ar(7)
      INTEGER (KIND = prec_int2), INTENT(IN) :: iau_model
! OUT
      REAL (KIND = prec_d), INTENT(OUT) :: CRS2TRS(3,3), TRS2CRS(3,3)
      REAL (KIND = prec_d), INTENT(OUT) :: d_CRS2TRS(3,3), d_TRS2CRS(3,3)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Called Functions (F77)
      DOUBLE PRECISION iau_S06, iau_ERA00, iau_ANP, iau_SP00
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_d) :: mjd_TT, mjd_GPS, mjd_TAI, mjd_UTC, mjd_UT1
      DOUBLE PRECISION TT1, TT2, TT1_UT1, TT2_UT1, TAI1, TAI2
      INTEGER (KIND = prec_int8) :: mjd_UTC_day

      DOUBLE PRECISION xp, yp, UT1_UTC, dX_eop, dY_eop
      DOUBLE PRECISION xp_rad, yp_rad, arcsec2rad, sp_iau00
      REAL (KIND = prec_d) :: X_iau00A,Y_iau00A,s_iau00A , X_iau06,Y_iau06,s_iau06
      REAL (KIND = prec_d) :: X_iau,Y_iau,s_iau , X_pn,Y_pn

      DOUBLE PRECISION RPOM(3,3), RPOM_T(3,3)
      DOUBLE PRECISION RC2I(3,3), RC2I_T(3,3)
      DOUBLE PRECISION R_era(3,3), era, R_era_n(3,3), era_n
      DOUBLE PRECISION Qt(3,3), Qt_inv(3,3), Rt(3,3), Rt_inv(3,3), Wt(3,3), Wt_inv(3,3)
      DOUBLE PRECISION GCRS2TIRS(3,3)
      DOUBLE PRECISION QR(3,3), Wi_Ri(3,3)
      DOUBLE PRECISION dtheta, P_dR (3,3), P_dR_T(3,3)
      DOUBLE PRECISION QP(3,3), QPR(3,3), QPRW(3,3), Ri_Qi(3,3), PT_Ri_Qi(3,3), Wi_PT_RiQi(3,3)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
      arcsec2rad = PI_global / (3600.0D0 * 180.0D0)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! EOP values
      xp = EOP_ar(2)
      yp = EOP_ar(3)
      UT1_UTC = EOP_ar(4)
      dX_eop = EOP_ar(6)
      dY_eop = EOP_ar(7)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Time Systems transformation
! ----------------------------------------------------------------------
      CALL time_TT (mjd , mjd_TT, mjd_GPS, mjd_TAI, mjd_UTC)
! ----------------------------------------------------------------------
! TT
      TT1 = 2400000.5D0
      TT2 = mjd_TT
! ----------------------------------------------------------------------
! TAI
      TAI1 = 2400000.5D0
      TAI2 = mjd_TAI
! ----------------------------------------------------------------------
! UTC
      mjd_UTC_day = IDINT(mjd_UTC)
! ----------------------------------------------------------------------
! UT1
      mjd_UT1 = mjd_UTC + UT1_UTC / 86400D0
      TT1_UT1 = 2400000.5D0
      TT2_UT1 = mjd_UT1
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! CIO based transformation
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Q(t)
! ----------------------------------------------------------------------
!-----------------------------------------------------------------------
! variable initialisation (X_iau, Y_iau, s_iau)
X_iau = 0.d0
Y_iau = 0.d0
s_iau = 0.d0

! ----------------------------------------------------------------------
! Precession-Nutation model:  X, Y (in radians)
! ----------------------------------------------------------------------
! 1. IAU 2000A
      if (iau_model == IAU2000) then
      CALL iau_XYS00A ( TT1, TT2, X_iau00A, Y_iau00A, s_iau00A )
      X_iau = X_iau00A
      Y_iau = Y_iau00A
      s_iau = s_iau00A
! ----------------------------------------------------------------------
! 2. IAU 2006/2000A
      else if (iau_model == IAU2006) then
      CALL iau_XY06 ( TT1, TT2, X_iau06, Y_iau06 )
! CIO locator s (in radians) | Function iau_S06
      s_iau06 = iau_S06 ( TT1, TT2, X_iau06, Y_iau06 )
!or   CALL XYS06A
      !PRINT *,"X,Y,s", X_iau06,Y_iau06,s_iau06
      X_iau = X_iau06
      Y_iau = Y_iau06
      s_iau = s_iau06
      end if
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! EOP: dX,dY (arcsec to radians)
      !dX_eop_rad =  dX_eop * arcsec2rad
      !dY_eop_rad =  dY_eop * arcsec2rad
      X_pn = X_iau + dX_eop * arcsec2rad
      Y_pn = Y_iau + dY_eop * arcsec2rad
! ----------------------------------------------------------------------
! Q(t)^-1
      CALL iau_C2IXYS ( X_pn, Y_pn, s_iau, RC2I )
      CALL iau_TR ( RC2I, RC2I_T )
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! R(t)
! ----------------------------------------------------------------------
!- ERA00: era (in radians)
      era = iau_ERA00 ( TT1_UT1, TT2_UT1 )
! ----------------------------------------------------------------------
! Rotation Matrices initialization: set them to singular I3x3
! R3(ERA)
      R_era(1,1) = 1D0
      R_era(1,2) = 0D0
      R_era(1,3) = 0D0
      R_era(2,1) = 0D0
      R_era(2,2) = 1D0
      R_era(2,3) = 0D0
      R_era(3,1) = 0D0
      R_era(3,2) = 0D0
      R_era(3,3) = 1D0
! R3(-ERA)
      R_era_n = R_era
! ----------------------------------------------------------------------
      !CALL iau_RZ ( PSI, R )
! R(t)^T = R3(ERA)
      CALL iau_RZ ( era, R_era )
! R(t) = R3(-ERA)
      era_n = -1.0D0 * era
      CALL iau_RZ ( era_n, R_era_n )
! ----------------------------------------------------------------------
      !PRINT *,"ERA", era
      !PRINT *,"R_era", R_era
      !PRINT *,"R_era_n", R_era_n

! ----------------------------------------------------------------------
! W(t)
! ----------------------------------------------------------------------
! xp, yp arcsec to radians
      xp_rad = xp * arcsec2rad
      yp_rad = yp * arcsec2rad
! ----------------------------------------------------------------------
! s': TIO locator (radians)
      sp_iau00 = iau_SP00 ( TT1, TT2 )
! ----------------------------------------------------------------------
! W(t)^-1
      call iau_POM00 ( xp_rad, yp_rad, sp_iau00, RPOM )
! W(t)
      CALL iau_TR ( RPOM, RPOM_T )
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Earth Orientation Matrix (EOM)
! ----------------------------------------------------------------------
! [GCRS] = Q(t) * R(t) * W(t) * [ITRS] = EOM * {ITRS}
! ----------------------------------------------------------------------
      Qt = RC2I_T
      Qt_inv = RC2I
! ----------------------------------------------------------------------
      Rt = R_era_n
      Rt_inv = R_era
! ----------------------------------------------------------------------
      Wt = RPOM_T
      Wt_inv = RPOM
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! GCRS to ITRS transformation matrix
! ----------------------------------------------------------------------
!SUBROUTINE iau_RXR ( A, B, ATB )
      CALL iau_RXR ( R_era, RC2I, GCRS2TIRS )
      CALL iau_RXR ( RPOM, GCRS2TIRS, CRS2TRS )
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! ITRS to GCRS transformation matrix (Inverse transformation)
      CALL iau_TR ( CRS2TRS, TRS2CRS )
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Alternative approach
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! ITRS to GCRS transformation matrix
! ----------------------------------------------------------------------
! [GCRS] = Q(t) * R(t) * W(t) * [ITRS] = EOM * {ITRS}
! ----------------------------------------------------------------------
! TRS2CRS = Qt * Rt * Wt
      CALL iau_RXR ( Qt, Rt, QR )
      CALL iau_RXR ( QR, Wt, TRS2CRS )
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! GCRS to ITRS transformation matrix
! ----------------------------------------------------------------------
! [ITRS] = W(t)^T * R(t)^T * Q(t)^T * [GCRS] = W(t)^T * R3(ERA) * Q(t)^T * [GCRS]
!*        [TRS]  =  RPOM * R_3(ERA) * RC2I * [CRS]
! ----------------------------------------------------------------------
! Inverse transformation matrix as transpose matrix (orthogonality)
      !CALL iau_TR ( TRS2CRS, CRS2TRS )

! or (analytical form)

! CRS2TRS = Wt_inv * Rt_inv * Qt_inv
      ! CRS2TRS = RPOM * R_era * RC2I
      CALL iau_RXR ( Wt_inv, Rt_inv, Wi_Ri )
      CALL iau_RXR ( Wi_Ri, Qt_inv, CRS2TRS )
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Derivatives of CRS-TRS transformation matrix (direct/inverse)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Earth angular velocity
! ----------------------------------------------------------------------
! IERS 2010;
!      dtheta = 0.7292115D0 * 10.0D-04
! ----------------------------------------------------------------------
! Omega as derivative of Earth Rotation Angle (ERA), dERA/dt in rad/s
      dtheta = 2.0D0 * PI_global * 1.00273781191135448D0 * (1.0D0 / 86400D0)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! d_TRS2CRS
! ----------------------------------------------------------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%% Computation of derivative of TRS2CRS matrix
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! d_TRS2CRS = d(TRS2CRS)/dt = Qt * (dtheta * P * Rt) * Wt
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! ----------------------------------------------------------------------
!P = [ 0  -1   0
!      1   0   0
!      0   0   0 ] ;
! ----------------------------------------------------------------------
      P_dR (1,1) =  0.0D0
      P_dR (1,2) = -1.0D0
      P_dR (1,3) =  0.0D0
      P_dR (2,1) =  1.0D0
      P_dR (2,2) =  0.0D0
      P_dR (2,3) =  0.0D0
      P_dR (3,1) =  0.0D0
      P_dR (3,2) =  0.0D0
      P_dR (3,3) =  0.0D0
! ----------------------------------------------------------------------
! d_TRS2CRS = dtheta * Qt * P * Rt * Wt
      CALL iau_RXR ( Qt, P_dR, QP )
      CALL iau_RXR ( QP, Rt, QPR )
      CALL iau_RXR ( QPR, Wt, QPRW )
      d_TRS2CRS = dtheta * QPRW
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! d_CRS2TRS
! ----------------------------------------------------------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%% Computation of derivative of CRS2TRS matrix
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! d_CRS2TRS = Wt_inv * (omega * P^T * Rt_inv) * Qt_inv
! d_CRS2TRS = omega * W(-t) * P^T * R(-t) * Q(-t) ;
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
      CALL iau_TR ( P_dR, P_dR_T )
      CALL iau_RXR ( Rt_inv, Qt_inv, Ri_Qi )
      CALL iau_RXR ( P_dR_T, Ri_Qi, PT_Ri_Qi )
      CALL iau_RXR ( Wt_inv, PT_Ri_Qi, Wi_PT_RiQi )
      d_CRS2TRS = dtheta * Wi_PT_RiQi
! ----------------------------------------------------------------------

END


      subroutine g1 (a,b,cos,sin,sig)
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
c
c     compute orthogonal rotation matrix..
c     compute.. matrix	 (c, s) so that (c, s)(a) = (sqrt(a**2+b**2))
c			 (-s,c) 	(-s,c)(b)   (	0	   )
c     compute sig = sqrt(a**2+b**2)
c	 sig is computed last to allow for the possibility that
c	 sig may be in the same location as a or b .
c
      zero=0.
      one=1.
      if (abs(a).le.abs(b)) go to 10
      xr=b/a
      yr=sqrt(one+xr**2)
      cos=sign(one/yr,a)
      sin=cos*xr
      sig=abs(a)*yr
      return
   10 if (b) 20,30,20
   20 xr=a/b
      yr=sqrt(one+xr**2)
      sin=sign(one/yr,b)
      cos=sin*xr
      sig=abs(b)*yr
      return
   30 sig=zero
      cos=zero
      sin=one
      return
      end


************************************************************************
*
*     Subroutine MLEVAR                            Called by: MLELOAD2
*
*
*     Estimate the variance of the mean MLE load using the method given
*     in Likes (1980) and Gilroy et al. (1990).
*
*     This version of TECALC1RC uses the function PHI given by Likes
*     (1980) rather the function GM originally given by Finney (1941)
*     as coded by Cohn et al. (1989). PHI takes longer to compute
*     but can handle larger arguments so there it is less likely that
*     the computation of the variance will fail. Likes (1980) gives
*     the relation:
*
*                                     (DF+1)*A
*                     PHI[A*W,DF]=GM[----------*W]
*                                      2*DF**2
*
*     To use GM rather than PHI see C. Crawford's original LOADEST2.
*
*     PHI is denoted MVUEPHI below, to distinguish it from the
*     function PHI used to calculate the probability density
*     function of the standard normal distribution.
*
*     Local variables
*     ---------------
*     DF2      degrees of freedom of the regression, divided by 2
*     LTE      log of transport (untransformed value from rating curve)
*     TE       uncorrected estimated population loads (transport est)
*     V        XO * XTXINV * XT for each population value
*     VIJ      XO * XTXINV * XJT for the Ith and Jth population value
*
************************************************************************
      SUBROUTINE MLEVAR(NPAR,XLEST,NUMOBSE,RVARMLE,XTXINV,VARMLE,DF2,
     &                  LTE,TE,V,NOBSE)
*
*     dimensional parameters
*
      INCLUDE 'fmodules.inc'
*
*     subroutine arguments
*
      INTEGER*4 NPAR,NUMOBSE,NOBSE
      DOUBLE PRECISION RVARMLE,VARMLE,DF2
      DOUBLE PRECISION LTE(*),TE(*),V(*)
      DOUBLE PRECISION XLEST(NOBSE,*),XTXINV(MAXPARMS,*)
*
*     local vars
*
      INTEGER*4 I,K
      DOUBLE PRECISION VIJ,TERM
*
*     function declarations
*
      DOUBLE PRECISION MVUEPHI
*
*     estimate the variance of the mean load.  Variance is equal to the
*     covariance of LDMLE(I) and LDMLE(K) summed over all I and K
*     (I=1,NUMOBSE; K=1,NUMOBSE).  Covariance is given in Gilroy et al.
*     (1990) and is computed as the expected value of
*     (LDMLE(I)*LDMLE(K)) minus the expected value of LDMLE(I) times the
*     expected value of LDMLE(K)
*
      VARMLE = 0.D0
      DO 40 I=1,NUMOBSE
         DO 30 K=1,I
            CALL MATMLT(VIJ,XLEST,XTXINV,NPAR,I,K,NOBSE)
            TERM = (((TE(I)*TE(K)*DEXP((V(I)+V(K)+2.D0*VIJ)
     &           *RVARMLE/2.D0))
     &           * (DEXP((2.D0-V(I)-V(K))*RVARMLE/2.D0))
     &           * (MVUEPHI(((1.D0-V(I))*(1.D0-V(K))*RVARMLE**2)
     &           /4.D0,DF2)))
     &           - (DEXP(LTE(I)+(RVARMLE/2.D0))
     &           * DEXP(LTE(K)+(RVARMLE/2.D0))))
            IF (K.EQ.I) THEN
               VARMLE = VARMLE + TERM
            ELSE
               VARMLE = VARMLE + 2.D0 * TERM
            ENDIF
 30      CONTINUE
 40   CONTINUE
*
*     calculate the variance of mean load
*
      VARMLE = VARMLE/DBLE(NUMOBSE**2)

      RETURN
      END


      SUBROUTINE FFTCORF(LD,LAGH1,N,N2P,ISW,X1,Y1,XA,X,Y,
     1CNA1,CN1,CN2,AMEAN)
C
      INCLUDE 'timsac_f.h'
C
C     PROGRAM 5.1.3   AUTO AND/OR CROSS CORRELATIONS VIA FFT.
C-----------------------------------------------------------------------
C     ** THIS PROGRAM IS AN ADAPTED VERSION OF THE ALGOL PROCEDURE
C         //CROSS CORRELATE// PREPARED BY DR GORDON SANDE AT PRINCETON
C         UNIVERSITY IN 1966-7.
C     ** DESIGNED BY H. AKAIKE, THE INSTITUTE OF STATISTICAL MATHEMATICS
C     ** PROGRAMMED BY E. ARAHATA, THE INSTITUTE OF STATISTICAL MATHEMAT
C         TOKYO
C     ** DATE OF THE LATEST REVISION: FEB. 16, 1978
C     ** THIS PROGRAM WAS ORIGINALLY PUBLISHED IN
C         "DAINAMIKKU SISTEMU NO TOKEI-TEKI KAISEKI TO SEIGYO (STATISTICA
C         ANALYSIS AND CONTROL OF DYNAMIC SYSTEMS)" BY H. AKAIKE AND
C         T. NAKAGAWA, SAIENSU-SHA, TOKYO, 1972 (IN JAPANESE)
C-----------------------------------------------------------------------
C     THIS PROGRAM COMPUTES AUTO AND/OR CROSS
C     COVARIANCES AND CORRELATIONS VIA FFT.
C     IT REQUIRES FOLLOWING INPUTS:
C     ISW: ISW=1...AUTO CORRELATION OF X (ONE-CHANNEL)
C           ISW=2...AUTO CORRELATIONS OF X AND Y (TWO-CHANNEL)
C           ISW=4...AUTO,CROSS CORRELATIONS OF X AND Y (TWO-CHANNEL)
C     LD: LENGTH OF DATA
C     LAGH: MAXIMUM LAG
C     DFORM: INPUT FORMAT SPECIFICATION STATEMENT IN ONE CARD,
C     FOR EXAMPLE
C     (8F10.4)
C     (X(I); I=1,LD): DATA OF CHANNEL X
C     (Y(I); I=1,LD): DATA OF CHANNEL Y (FOR ISW=2 OR 4 ONLY)
C
cc      !DEC$ ATTRIBUTES DLLEXPORT :: FFTCORF
c      USE DFLIB
C
cxx      IMPLICIT REAL*8(A-H,O-Y)
cxx      IMPLICIT COMPLEX*16(Z)
c      REAL*4 DFORM
c      DIMENSION X(2048),Y(2048),Z(2048),ZS(1025)
c      DIMENSION CN1(501),CN2(501)
c      DIMENSION DFORM(20)
c      REAL*4 XS,YS
c      DIMENSION XS(2048),YS(2048)
cxx      DIMENSION X1(LD),Y1(LD),XA(N,2),X(N),Y(N)
cxx      DIMENSION Z(N),ZS(N/2+1)
cxx      DIMENSION CNA1(LAGH1,2),CN1(LAGH1),CN2(LAGH1),AMEAN(2)
      INTEGER :: LD, LAGH1, N, N2P, ISW
      REAL(8) :: X1(LD), Y1(LD), XA(N,2), X(N), Y(N), CNA1(LAGH1,2),
     1           CN1(LAGH1), CN2(LAGH1), AMEAN(2)
      REAL(8) :: CST0, CST1, CST2, AN, ALD, ALD1, RF, SF,
     1           RG, SG, XI, XNI, YI, YNI, X0, XMEAN, YMEAN,
     2           CX0, Y0
      COMPLEX(kind(0d0)) :: Z(N), ZS(N/2+1), ZI, ZNI
C     INPUT / OUTPUT DATA FILE OPEN
c	CHARACTER(100) DFNAM
c	DFNAM='fftcor.out'
c	CALL SETWND
c	CALL FLOPN3(DFNAM,NFL)
c	IF (NFL.EQ.0) GO TO 999
C     INITIAL CONDITION INPUT AND PUNCH OUT
c      READ(5,1) ISW,LD,LAGH
c      WRITE(6,50)
c      WRITE(6,51)
c      WRITE(6,52) ISW,LD,LAGH
c      WRITE(7,1) LD,LAGH
c      LAGH1=LAGH+1
      LAGH=LAGH1-1
      ND=LD+LAGH1
C     N2P, N: DEFINITION
c      I0=1
c   10 IR1=2**I0
c      IF(IR1-ND) 11,12,12
c   11 I0=I0+1
c      GO TO 10
c   12 N2P=I0
c      N=2**N2P
      NP1=N+1
      NP2=N+2
      M=N/2
      M1=M+1
      CST0=0.0D-00
      CST1=1.0D-00
      CST2=0.25D-00
      AN=N
      ALD=LD
      ALD1=CST1/(AN*ALD)
C     INPUT FORMAT SPECIFICATION
c      READ(5,4) (DFORM(I),I=1,20)
c    4 FORMAT(20A4)
C     ORIGINAL DATA INPUT AND OUTPUT
      DO 20 I=1,N
      X(I)=CST0
      Y(I)=CST0
   20 CONTINUE
c      READ(5,DFORM) (XS(I),I=1,LD)
      DO 1200 I=1,LD
c      X(I)=DBLE(XS(I))
      X(I)=X1(I)
 1200 CONTINUE
      IF(ISW.EQ.1) GO TO 200
c      READ(5,DFORM) (YS(I),I=1,LD)
      DO 1201 I=1,LD
c      Y(I)=DBLE(YS(I))
      Y(I)=Y1(I)
 1201 CONTINUE
c  200 WRITE(6,53)
  200 CONTINUE
c      IF(ISW.NE.1) GO TO 201
c      WRITE(6,54)
c      CALL PRCOL1(X,1,LD,0)
c      GO TO 202
c  201 WRITE(6,55)
c      CALL PRCOL2(X,Y,1,LD,0)
C     MEAN DELETION
cxx  202 CALL DMEADL(X,LD,XMEAN)
      CALL DMEADL(X,LD,XMEAN)
      IF(ISW.EQ.1) GO TO 203
      CALL DMEADL(Y,LD,YMEAN)
C     DOUBLE PRECISION COMPLEX REPRESENTATION
  203 DO 31 I=1,N
cxx   31 Z(I)=DCMPLX(X(I),Y(I))
      Z(I)=DCMPLX(X(I),Y(I))
   31 CONTINUE
C     FOURIER TRANSFORM OF Z
      ISG=-1
      CALL MIXRAD(Z,N,N2P,ISG)
      IF(ISW.NE.1) GO TO 204
C     RAW SPECTRUM COMPUTATION
      DO 32 I=2,M
      X(I)=DREAL(Z(I))**2+DIMAG(Z(I))**2
      NI=NP2-I
cxx   32 X(NI)=X(I)
      X(NI)=X(I)
   32 CONTINUE
      X(1)=DREAL(Z(1))**2
      X(M1)=DREAL(Z(M1))**2
      GO TO 205
C     DECOMPOSITION AND RAW SPECTRUM COMPUTATION
  204 DO 125 I=2,M
      NI=NP2-I
      ZI=Z(I)
      ZNI=Z(NI)
      RF=DREAL(ZI)
      SF=DIMAG(ZI)
      RG=DREAL(ZNI)
      SG=DIMAG(ZNI)
      XI=RF+RG
      XNI=SF-SG
      Z(I)=DCMPLX(XI,XNI)
      X(I)=CST2*(XI**2+XNI**2)
      X(NI)=X(I)
      YI=SF+SG
      YNI=RF-RG
      Z(NI)=DCMPLX(YI,YNI)
      Y(I)=CST2*(YI**2+YNI**2)
      Y(NI)=Y(I)
  125 CONTINUE
      X(1)=DREAL(Z(1))**2
      Y(1)=DIMAG(Z(1))**2
      X(M1)=DREAL(Z(M1))**2
      Y(M1)=DIMAG(Z(M1))**2
      IF(ISW.NE.4) GO TO 205
C     RAW CROSS SPECTRUM COMPUTATION
      DO 126 I=2,M
      NI=NP2-I
cxx  126 ZS(I)=CST2*Z(I)*Z(NI)
      ZS(I)=CST2*Z(I)*Z(NI)
  126 CONTINUE
      ZS(1)=DREAL(Z(1))*DIMAG(Z(1))
      ZS(M1)=DREAL(Z(M1))*DIMAG(Z(M1))
C     AUTO COVARIANCE COMPUTATION
  205 DO 33 I=1,N
cxx   33 Z(I)=DCMPLX(X(I),Y(I))
      Z(I)=DCMPLX(X(I),Y(I))
   33 CONTINUE
C     FOURIER TRANSFORM
cxx  215 CALL MIXRAD(Z,N,N2P,ISG)
      CALL MIXRAD(Z,N,N2P,ISG)
      II=1
      DO 34 I=1,LAGH1
      X(I)=DREAL(Z(I))*ALD1
cxx   34 XA(I,II)=X(I)
      XA(I,II)=X(I)
   34 CONTINUE
      X0=X(1)
c      AMEAN=XMEAN
      AMEAN(II)=XMEAN
C     NORMALIZATION
   36 CX0=X(1)
c      CALL CORNOM(X,CN1,LAGH1,CX0,CX0)
      CALL CORNOM(X,CNA1(1,II),LAGH1,CX0,CX0)
C     AUTO COVARIANCE PRINT OUT
c      WRITE(6,162) II,II,AMEAN
c      WRITE(6,163)
c      CALL PRCOL2(X,CN1,1,LAGH1,1)
C     AUTO COVARIANCE PUNCH OUT
c      WRITE(7,1) II,II
c      WRITE(7,2) (X(I),I=1,LAGH1)
      IF(ISW.EQ.1) GO TO 300
      IF(II.EQ.2) GO TO 216
      II=2
      DO 35 I=1,LAGH1
      X(I)=DIMAG(Z(I))*ALD1
cxx   35 XA(I,II)=X(I)
      XA(I,II)=X(I)
   35 CONTINUE
      Y0=X(1)
c      AMEAN=YMEAN
      AMEAN(II)=YMEAN
      GO TO 36
  216 IF(ISW.NE.4) GO TO 300
C     CROSS COVARIANCE COMPUTATION
      DO 127 I=2,M
      NI=NP2-I
      Z(I)=ZS(I)
cxx  127 Z(NI)=DCONJG(ZS(I))
      Z(NI)=DCONJG(ZS(I))
  127 CONTINUE
      Z(1)=ZS(1)
      Z(M1)=ZS(M1)
C     FOURIER TRANSFORM
      CALL MIXRAD(Z,N,N2P,ISG)
      DO 41 I=1,LAGH
      I1=I+1
      J1=NP1-I
      X(I1)=DREAL(Z(I1))*ALD1
cxx   41 Y(I1)=DREAL(Z(J1))*ALD1
      Y(I1)=DREAL(Z(J1))*ALD1
   41 CONTINUE
      X(1)=DREAL(Z(1))*ALD1
      Y(1)=X(1)
C     NORMALIZATION
      CALL CORNOM(X,CN1,LAGH1,X0,Y0)
      CALL CORNOM(Y,CN2,LAGH1,X0,Y0)
C     CROSS COVARIANCE PRINT OUT
c      JJ=1
c      WRITE(6,165) II,JJ
c      WRITE(6,166)
c      CALL PRCOL4(X,CN1,Y,CN2,1,LAGH1,1)
C     CROSS COVARIANCE PUNCH OUT
c      WRITE(7,1) II,JJ
c      WRITE(7,2) (X(I),I=1,LAGH1)
c      WRITE(7,1) JJ,II
c      WRITE(7,2) (Y(I),I=1,LAGH1)
  300 CONTINUE
c	CALL FLCLS3(NFL)
c  999 CONTINUE
      RETURN
c    1 FORMAT(10I5)
c    2 FORMAT(4D20.10)
c   50 FORMAT(1H ,71HPROGRAM 5.1.3   AUTO AND/OR CROSS COVARIANCES AND CO
c     ARRELATIONS VIA FFT.)
c   51 FORMAT(1H ,17HINITIAL CONDITION)
c   52 FORMAT(1H ,4HISW=,I5,5X,3HLD=,I5,5X,5HLAGH=,I5)
c   53 FORMAT(1H ,13HORIGIANL DATA)
c   54 FORMAT(1H ,4X,1HI,12X,4HX(I))
c   55 FORMAT(1H ,4X,1HI,12X,4HX(I),10X,4HY(I))
c  162 FORMAT(//1H ,14HAUTOCOVARIANCE,5X,6HCIJ(L),5X,2HI=,I5,5X,2HJ=,I5,5
c     AX,5HMEAN=,D15.5)
c  163 FORMAT(1H ,4X,1HL,5X,6HCIJ(L),8X,10HNORMALIZED)
c  165 FORMAT(//1H ,16HCROSS COVARIANCE,5X,6HCIJ(L),5X,2HI=,I5,5X,2HJ=,I5
c     A)
c  166 FORMAT(1H ,4X,1HL,5X,6HCIJ(L),8X,10HNORMALIZED,4X,6HCJI(L),8X,10HN
c     AORMALIZED)
      END SUBROUTINE


module FFTW2d
	use, intrinsic :: iso_c_binding
	implicit none
   	include 'fftw3.f03'

	real (kind = 8) :: PI = 4.0d0 * atan(1.0d0)
contains
	function dfft( n1, n2, rinput )
		integer (kind = 8) :: p_r2c
		integer :: n1, n2 ! samples
		real ( kind = 8 ) :: rinput(n1, n2)
		complex ( kind = 8 ) :: dfft(n1/2 + 1, n2), coutput(n1/2 + 1, n2)

		call dfftw_plan_dft_r2c_2d(p_r2c, n1, n2, rinput, coutput, FFTW_ESTIMATE )
		call dfftw_execute_dft_r2c( p_r2c, rinput / real(n1*n2), coutput)
		call dfftw_destroy_plan( p_r2c )

		dfft = coutput
	end function
	function idfft( n1, n2, cinput )
		integer (kind = 8) :: p_c2r
		integer :: n1, n2 ! samples
		real ( kind = 8 ) :: idfft(n1, n2), routput(n1, n2)
		complex ( kind = 8 ) :: cinput(n1/2 + 1, n2), temp(n1/2 + 1, n2)

		call dfftw_plan_dft_c2r_2d(p_c2r, n1, n2, temp, routput, FFTW_ESTIMATE )
		temp = cinput
		call dfftw_execute_dft_c2r( p_c2r, temp, routput)
		call dfftw_destroy_plan( p_c2r )

		idfft = routput
	end function
end module


program test_free_energy2
use types, only: dp
use ofdft_fe, only: free_energy2
use ofdft, only: read_pseudo
use constants, only: Ha2eV, pi
use utils, only: loadtxt, stop_error, assert
use splines, only: spline3pars, iixmin, poly3, spline3ders
use interp3d, only: trilinear
use feutils, only: quad_gauss
use converged_energies, only: one_gaussian
implicit none
real(dp) :: Eh, Een, Ts, Exc, Etot
integer :: p, DOF, Nq
real(dp) :: Z, Ediff
real(dp), allocatable :: R(:), V(:), c(:, :)
real(dp), allocatable :: tmp(:), Vd(:), Vdd(:), density_en(:)
real(dp) :: Rcut, L, T_eV, T_au

call read_pseudo("H.pseudo.gaussian2", R, V, Z, Ediff)
allocate(tmp(size(R)), Vd(size(R)), Vdd(size(R)), density_en(size(R)))
call spline3ders(R, V, R, tmp, Vd, Vdd)
density_en = -(Vdd+2*Vd/R)/(4*pi)
allocate(c(0:4, size(R, 1)-1))
call spline3pars(R, density_en, [2, 2], [0._dp, 0._dp], c)
Rcut = R(size(R))
p = 5
L = 2
T_eV = 0.0862_dp
T_au = T_ev / Ha2eV
Nq = 20
call free_energy2(1._dp, L, 4, 4, 4, p, T_au, nen_splines, ne, &
        Nq, quad_gauss, &
        Eh, Een, Ts, Exc, DOF)
Etot = Eh + Een + Ts + Exc
print *, "Summary of energies [a.u.]:"
print "('    Ts   = ', f14.8)", Ts
print "('    Een  = ', f14.8)", Een
print "('    Eee  = ', f14.8)", Eh
print "('    Exc  = ', f14.8)", Exc
print *, "   ---------------------"
print "('    Etot = ', f14.8, ' a.u.')", Etot
call assert(abs(Ts - one_gaussian(1)) < 1e-8_dp)
call assert(abs(Een - (-3.77207363_dp)) < 3e-3_dp)
call assert(abs(Eh - one_gaussian(3)) < 3e-4_dp)
call assert(abs(Exc - one_gaussian(4)) < 1e-8_dp)

contains

real(dp) function nen_splines(x_, y_, z_) result(n)
real(dp), intent(in) :: x_, y_, z_
real(dp) :: r_
integer :: ip
! One atom in the center:
r_ = sqrt((x_+L/64-L/2)**2+(y_-L/2)**2+(z_-L/2)**2)
if (r_ >= Rcut) then
    n = 0
    return
end if
if (r_ <= 1e-4_dp) r_ = 1e-4_dp
ip = 0
ip = iixmin(r_, R, ip)
n = poly3(r_, c(:, ip))
! FIXME: We need to be using "rho", and flip the sign here:
n = -n
end function

real(dp) function ne(x, y, z) result(n)
real(dp), intent(in) :: x, y, z
real(dp), parameter :: alpha = 5, Z_ = 1
real(dp) :: r
r = sqrt((x-L/2)**2+(y-L/2)**2+(z-L/2)**2)
n = Z_*alpha**3/pi**(3._dp/2)*exp(-alpha**2*R**2)
!n = 1
end function

end program


module timedisc_const_mod

use constants_mod

real(dp), parameter :: A0 = 1.00000000000000_dp
real(dp), parameter :: A1 = 1.00000000000000_dp
real(dp), parameter :: A2 = 0.00000000000000_dp
real(dp), parameter :: A3 = 0.39175222700392_dp

real(dp), parameter :: B0 = 0.39175222700392_dp
real(dp), parameter :: B1 = 0.44437049406734_dp
real(dp), parameter :: B2 = 0.55562950593266_dp
real(dp), parameter :: B3 = 0.36841059262959_dp

real(dp), parameter :: C0 = 0.58607968896780_dp
real(dp), parameter :: C1 = 0.62010185138540_dp
real(dp), parameter :: C2 = 0.37989814861460_dp
real(dp), parameter :: C3 = 0.25189177424738_dp

real(dp), parameter :: D0 = 0.47454236302687_dp
real(dp), parameter :: D1 = 0.17807995410773_dp
real(dp), parameter :: D2 = 0.82192004589227_dp
real(dp), parameter :: D3 = 0.54497475021237_dp

real(dp), parameter :: E0 = 0.93501063100924_dp
real(dp), parameter :: E1 = 0.00683325884039_dp
real(dp), parameter :: E2 = 0.34833675773694_dp
real(dp), parameter :: E3 = 0.22600748319395_dp

real(dp), parameter :: E4 = 0.51723167208978_dp
real(dp), parameter :: E5 = 0.12759831133288_dp
real(dp), parameter :: E6 = 0.08460416338212_dp

integer, parameter :: nstages = 5

real(dp), parameter :: dt_coeffs(nstages) = (/A0, B0, C0, D0, E0/)

end module


!
!  Copyright 2016 ARTED developers
!
!  Licensed under the Apache License, Version 2.0 (the "License");
!  you may not use this file except in compliance with the License.
!  You may obtain a copy of the License at
!
!      http://www.apache.org/licenses/LICENSE-2.0
!
!  Unless required by applicable law or agreed to in writing, software
!  distributed under the License is distributed on an "AS IS" BASIS,
!  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!  See the License for the specific language governing permissions and
!  limitations under the License.
!
Subroutine Fermi_Dirac_distribution
  use Global_Variables
  implicit none
  real(8) :: chemical_potential
  real(8) :: chem_max,chem_min,elec_num
  real(8) :: beta_FD
  real(8),allocatable :: occ_l(:,:),esp_l(:,:),esp_temp(:,:)
  real(8) s,st
  integer :: ik,ib
  real(8) :: timer1,timer2

  timer1=MPI_WTIME()
  beta_FD=1d0/(KbTev/(2d0*Ry))
  allocate(occ_l(NB,NK),esp_l(NB,NK),esp_temp(NB,NK))
  occ_l=0d0 ; esp_l=0d0
  esp_l(:,NK_s:NK_e)=esp(:,NK_s:NK_e)
  call MPI_ALLREDUCE(esp_l,esp_temp,NB*NK,MPI_REAL8,MPI_SUM,NEW_COMM_WORLD,ierr)
  chem_max=maxval(esp_temp)
  chem_min=minval(esp_temp)
  if(myrank == 0)then
    write(*,*)'max esp =',chem_max
    write(*,*)'min esp =',chem_min
  end if
  chemical_potential=0.5d0*(chem_max+chem_min)
  do

    do ik=NK_s,NK_e
      do ib=1,NB
        occ_l(ib,ik)=2.d0/(NKx*NKy*NKz)*wk(ik) &
          &/(exp(beta_FD*(esp(ib,ik)-chemical_potential))+1d0)
      end do
    end do

    st=sum(occ_l(:,NK_s:NK_e))
    call MPI_ALLREDUCE(st,s,1,MPI_REAL8,MPI_SUM,NEW_COMM_WORLD,ierr)
    elec_num=s

    if(abs(elec_num-dble(Nelec)) <= 1d-6)exit
    if(elec_num-dble(Nelec) > 0d0)then
      chem_max=chemical_potential
      chemical_potential=0.5d0*(chem_max+chem_min)
    else
      chem_min=chemical_potential
      chemical_potential=0.5d0*(chem_max+chem_min)
    end if
    if(chem_max-chem_min < 1d-10)exit

  end do

  call MPI_ALLREDUCE(occ_l,occ,NB*NK,MPI_REAL8,MPI_SUM,NEW_COMM_WORLD,ierr)
  st=sum(occ_l(Nelec/2+1:NB,NK_s:NK_e))
  call MPI_ALLREDUCE(st,s,1,MPI_REAL8,MPI_SUM,NEW_COMM_WORLD,ierr)

  timer2=MPI_WTIME()
  if(myrank == 0)then
    write(*,*)'Fermi-Dirac dist. time=',timer2-timer1,'sec'
    write(*,*)'chemical potential =',chemical_potential
    write(*,*)'elec_num =',elec_num
    write(*,*)'excited electron =',s
!    open(126,file='occ.dat')
!    do ik=1,NK
!      do ib=1,NB
!        write(126,*)ik,ib,occ(ib,ik)
!      end do
!    end do
!    close(126)
  end if

  return
end Subroutine Fermi_Dirac_distribution


PROGRAM question5
    IMPLICIT NONE
    real :: x = 2
    print *, (1./3)*log(1 + sqrt(x)) + (1./15.)*(2. + sqrt(x))
    STOP
END PROGRAM question5


PROGRAM flatlens
  use random
  USE healpix_types
  USE fitstools, only: fits2cl
  use alm_tools, only: create_alm
  use rngmod, only: rand_init, planck_rng
  use AMLutils, only: spline_double
  implicit none
  type(planck_rng) :: rng_handle

  character(len=128)  :: clfile
  integer(I4b):: lmax,ncl
  integer(I8b)::i
  real(dp), dimension(:,:), allocatable :: cl
  real(dp), dimension(:), allocatable:: CTT2,ell
  complex, dimension(:,:,:), allocatable :: almloaded
  character(len=80), dimension(1:70) :: header,units
  logical :: RandInited = .false.
  real(dp) ::cl3,tempCl

  !! grid parameters

  complex, dimension(:,:,:),allocatable::PHYXY
  integer(I8b),parameter::xmax=2**3,ymax=2**3
  real(dp),parameter::delx=0.5d0,dely=0.5d0
  real(dp)::tamp,x,y,lenght
  integer(i8b)::xcounter,ycounter,xcenter,ycenter
  allocate(PHYXY(0:(xmax-1),0:(ymax-1),1:1))
  write(*,*) size(PHYXY)

!!!!

  !character(len=80):: units
  ncl=1
  lmax=1000
  allocate(cl(0:lmax,1:ncl))
  allocate(almloaded(1:1,0:lmax,0:128))
  clfile='manzotti_scalCls.fits'
  call fits2cl(clfile,cl,lmax,ncl,header,units)
  !! slpine Cls to fill non integer k (same as l ) on the 2d grid
  allocate(CTT2(0:lmax))
  allocate(ell(0:lmax))

  DO i=0,lmax
     ell(i)=i
  END DO

  call spline_double(ell,cl(0:lmax,1),lmax+1,cTT2(0:lmax))

  stop

do l = 1, 1000, 1
  call splint(ell,cl(0:lmax,1),cTT2(0:lmax),cTT2(0:lmax),tempCl)
!write(unit=iounit, fmt="(format string)", iostat=ios, advance='NO') cl(l,1),tempCl
!if ( ios /= 0 ) stop "Write error in file unit iounit"

end do

!!! now create lx ly coefficient in 2d Flat sky approximation
  !! Prepere for gaussian generation

  call InitRandom
  RandInited = .true.

  !Write(*,*) gaussian1()
!! then you can use Gaussian(1) to extract

!! grid

x=0d0

!!look notes---> thanks to simmetry we can loop on only the half of the grid.

xcenter=xmax/2+1
ycenter=ymax/2+1
!write(*,*) ymax/2+1,xmax/2+1

  DO xcounter=0,xmax-1

     y=0d0

     DO ycounter=0,ymax/2+1

        lenght=sqrt(((xcounter-xcenter)*delx)**2+((ycounter-ycenter)*dely)**2)
       ! write(*,*) xcounter,ycounter
       ! write(*,*)dble((xcounter-xcenter)*delx),dble((xcounter-xcenter))*dely,lenght
       ! write(*,*)

        call splint(ell,cl(0:lmax,1),cTT2(0:lmax),lmax+1,lenght,cl3)

        tamp = sqrt(cl3/2)

        ! note in the center line you are doing this 2 times, improve this for performance

        PHYXY(xcounter,ycounter,1)= cmplx(Gaussian1(),Gaussian1())*tamp
        PHYXY(-xcounter,-ycounter,1)= cmplx(Gaussian1(),-Gaussian1())*tamp

        write(*,*) PHYXY(xcounter,ycounter,1), PHYXY(-xcounter,-ycounter,1),xcounter,ycounter

     END DO

      !! At this point you shoulf FFT

  END DO

CONTAINS

   SUBROUTINE splint(xa, ya, y2a, n, x, y)
!   USE nrtype
!
! Given the arrays xa(1:n) and ya(1:n) of length n, which tabulate a function
! (with the xa(i) in order), and given the array y2a(1:n), which is the output
! from the subroutine spline, and given a value of x, this routine returns a
! cubic spline interpolated value y.
! (adopted from Numerical Recipes in FORTRAN 77)
!
   INTEGER, PARAMETER :: DP = KIND(1.0D0)
   INTEGER:: n
   REAL(DP):: x, y, xa(n), y2a(n), ya(n)
   INTEGER:: k, khi, klo
   REAL(DP):: a, b, h

     klo=1
     khi=n
1   if (khi-klo.gt.1) then
        k=(khi+klo)/2
        if (xa(k).gt.x) then
           khi=k
        else
           klo=k
        endif
        goto 1
     endif

     h=xa(khi)-xa(klo)
     if (h.eq.0.) pause 'bad xa input in splint'

     a=(xa(khi)-x)/h
     b=(x-xa(klo))/h
     y=a*ya(klo)+b*ya(khi)+((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**2)/6.

     return

   END SUBROUTINE splint

END PROGRAM flatlens


module physics
    ! always keep module named 'physics'
    !   even if the file name changes.
    !   - this lets you create different physics for different runs,
    !       and have things like simply by compiling the right physics file
    !       !!! NOTE !!!
    !           - this means you MUST make sure you have a recent,
    !             compiled version of the right physics.

    implicit none
    private calc_energy, calc_angular_momentum_scalar
    public calc_force, accuracy_check
    integer, parameter           :: precision=16 ! double precision

    type, public :: accuracy_state
            real(kind=precision) :: energy, angular_momentum
        contains
            procedure, pass :: initialize => accuracy_state_initialize
    end type accuracy_state

    real(kind=precision), parameter     :: energy_tol           = 1d-11
    real(kind=precision), parameter     :: angular_momentum_tol = 1d-6

    logical, parameter                  :: allow_z_motion = .False. ! for bulirsch_stoer

    contains

subroutine calc_force(n_bodies, x, v, mass, force)
    ! Calculate gravitational forces given current positions

    ! inputs:
    !   n_bodies    - integer - number of interacting bodies
    !   x           - (n_bodies x 3) float array - positions

    ! outputs:
    !   f           - (n_bodies x 3) float array - forces

    ! side effects:
    !   none (this is enforced)

    ! assumes:

    ! features for later:

    implicit none
    integer,                                      intent(in)  :: n_bodies
    real(kind=precision), dimension(n_bodies, 3), intent(in)  :: x
    real(kind=precision), dimension(n_bodies, 3), intent(in)  :: v
    real(kind=precision), dimension(n_bodies   ), intent(in)  :: mass
    real(kind=precision), dimension(n_bodies, 3), intent(out) :: force
    real(kind=precision), dimension(3)                        :: df
    integer                                            :: i,j ! loop variables

    force = 0.

    do concurrent (i=1:n_bodies, j=1:n_bodies, i.gt.j )
        df = mass(i)*mass(j) &
            * ( x(j,:) - x(i,:) ) &   ! displacement vector from j to i
            / sqrt(sum( (x(j,:) - x(i,:))**2 ))**3 ! distance^3
        force(i,:) = force(i,:) + df
        force(j,:) = force(j,:) - df ! "-" sign for flip of displacement
    end do

end subroutine calc_force
    pure function calc_energy(n_bodies, x, v, mass) result(energy)
        implicit none
        integer,                               intent(in)  :: n_bodies
        real(kind=precision), dimension(n_bodies, 3), intent(in)  :: x, v
        real(kind=precision), dimension(n_bodies   ), intent(in)  :: mass
        real(kind=precision)                                      :: energy
        integer                                            :: i,j ! loop variables

        energy = 0.

        do concurrent (i=1:n_bodies, j=1:3)
            energy = energy + 1./2 * mass(i) * v(i,j)**2
        end do

        do concurrent (i=1:n_bodies, j=1:n_bodies, i.gt.j )
            energy  = energy -  mass(i)*mass(j) &
                / sqrt(sum((/ x(j,:) - x(i,:) /)**2))   ! distance
        end do

    end function calc_energy

    pure function calc_angular_momentum_scalar(n_bodies, x, v, mass) result(angular_momentum)
        ! only calculates angular momentum in z-hat direction
        implicit none
        integer,                               intent(in)  :: n_bodies
        real(kind=precision), dimension(n_bodies, 3), intent(in)  :: x, v
        real(kind=precision), dimension(n_bodies   ), intent(in)  :: mass
        real(kind=precision)                                      :: angular_momentum
        integer                                            :: i ! loop variables

        angular_momentum = 0.

        do concurrent (i=1:n_bodies)
            ! ! ! L = m * (r x v) = m * (x*v_y - y*v_x)
            angular_momentum = angular_momentum &
                + mass(i) * ( (x(i,1) * v(i,2)) - (x(i,2) * v(i,1)) )
        end do

    end function calc_angular_momentum_scalar

    function accuracy_check(state_initial, state_current) result (check)
        implicit none
        class(accuracy_state), intent(in) :: state_initial, state_current
        logical :: check
        real(kind=precision) :: energy_err, angular_momentum_err

        energy_err = abs( (state_current%energy - state_initial%energy) &
            / (state_initial%energy) )

        angular_momentum_err = abs( state_current%angular_momentum &
            - state_initial%angular_momentum )

        check = .False.
        if (energy_err.lt.energy_tol) then
            if (angular_momentum_err.lt.angular_momentum_tol) then
                check = .True.
            end if
        end if

    end function

    subroutine accuracy_state_initialize(state, n_bodies, x, v, mass)
        implicit none
        class(accuracy_state),                 intent(out) :: state
        integer,                               intent(in)  :: n_bodies
        real(kind=precision), dimension(n_bodies, 3), intent(in)  :: x, v
        real(kind=precision), dimension(n_bodies   ), intent(in)  :: mass
        real(kind=precision) :: energy, angular_momentum

        energy = calc_energy(n_bodies, x, v, mass)
        angular_momentum = calc_angular_momentum_scalar(n_bodies, x, v, mass)

        state%energy = energy
        state%angular_momentum = angular_momentum

    end subroutine

    end module


!This subroutine calculates the Bayesian joint probability from the input data
subroutine ruler
use fdeclarations

implicit none
allocate(p1matrix(nn,w+1))
allocate(p2matrix(nn,w))
p1matrix(:,:)=0
p2matrix(:,:)=0

do i=1,nn !For the nn combinations of the amatrix
do j=1,ii !And for the n samples
if ((amatrix(i,1) .eq. cmatrix(j,1)) .and. (amatrix(i,2) .eq. cmatrix(j,2)) &
.and. (amatrix(i,3) .eq. cmatrix(j,3)) .and. (amatrix(i,4) .eq. cmatrix(j,4))) then !If any row of the class matrix equals a row in the amatrix
if (cmatrix(j,5) .eq. 5) then !Then check the suitability class and
p1matrix(i,1)=p1matrix(i,1)+1 !Make a new matrix with the suitabilities at each column
else if (cmatrix(j,5) .eq. 4) then
p1matrix(i,2)=p1matrix(i,2)+1 !And assign 1 to the relevant suitability column
else if (cmatrix(j,5) .eq. 3) then
p1matrix(i,3)=p1matrix(i,3)+1
else if (cmatrix(j,5) .eq. 2) then
p1matrix(i,4)=p1matrix(i,4)+1
else if (cmatrix(j,5) .eq. 1) then
p1matrix(i,5)=p1matrix(i,5)+1
end if
end if
end do
end do

do i=1,nn
p1matrix(i,w+1)=sum(p1matrix(i,1:w)) !Then attach an extra column where all 1 will be sumed
end do

do i=1,nn
do j=1,w
if (p1matrix(i,j)>0 .and. p1matrix(i,w+1)>0) then
p2matrix(i,j)=p1matrix(i,j)/p1matrix(i,w+1) !And now create another matrix where all the probabilities will be stored
else !If a combination gets 1 and the suitability s also 1 then the probability is the division between P for a class by P all classes
p2matrix(i,j)=0 !If not then P = 0
end if
end do
end do

end subroutine ruler


!===============================================================================
!> Define code units, in terms of (here) CGS units
!===============================================================================
MODULE scaling_mod
  USE units_mod
  USE io_mod
  implicit none
  private
  type, public:: scaling_t
    real(kind=8):: l = 1.0
    real(kind=8):: t = 1.0
    real(kind=8):: m = 1.0
    real(kind=8):: d = 1.0
    real(kind=8):: e = 1.0
    real(kind=8):: p = 1.0
    real(kind=8):: f = 1.0
    real(kind=8):: u = 1.0
    real(kind=8):: grav = 1.0
    real(kind=8):: temp = 1.0
    real(kind=8):: mu = 2.4                             ! mean molecular weight
  contains
    procedure:: init
  end type
  type(scaling_t), public:: scaling
CONTAINS
!===============================================================================
!> Initialize code units:
!===============================================================================
SUBROUTINE init (self)
  USE math_mod
  class(scaling_t):: self
  real(kind=8):: l0=3.12e16
  logical, save:: first_time=.true.
  namelist / scaling_params / l0
  !----------------------------------------------------------------------------
  if (.not.first_time) return
  !$omp critical (input_cr)
  if (first_time) then
    rewind (io%input)
    read (io%input, scaling_params)
    if (io%master) write (*, scaling_params)
  end if
  !$omp end critical (input_cr)
  first_time = .false.

  call cgs%init
  self%l = l0                                           ! length; cm
  self%m = cgs%m_sun                                    ! mass; g
  self%d = self%m/self%l**3                             ! mass density; g cm**-3
  self%grav = 0.25 / math%pi                            ! gravitational constant
  self%t = sqrt(self%grav / cgs%grav / self%d)          ! time; s
  self%u = self%l/self%t                                ! speed
  self%p = self%d*self%u**2                             ! pressure = energy density
  self%e = self%m*self%u**2                             ! energy
  self%f = self%p*self%u                                ! energy flux = P u
  self%temp = self%mu*(cgs%m_u/self%m)/(cgs%k_b/self%e) ! temperature for give mu
  if (io%master) then
    print 1,' CODE UNITS:   (to cgs):'
    print 1,'     length: ',self%l
    print 1,'   velocity: ',self%u
    print 1,'       mass: ',self%m
    print 1,'       time: ',self%t
    print 1,'    density: ',self%d
    print 1,'   pressure: ',self%p
    print 1,'     energy: ',self%e
    print 1,'energy flux: ',self%f
    print 1,'    gravity: ',self%grav
    print 1,'temperature: ',self%temp
  1 format(1x,a,1p,e11.3)
  end if
END SUBROUTINE init
END MODULE scaling_mod


!---------------------------------------------------!
! Copyright (c) 2016 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
!-------10--------20--------30--------40--------50--------60--------70--------80--------90
subroutine ppsi(ik)
  use global_variables
  implicit none
  integer :: ix,ik

  zhtpsi(1)=-zI*( &
    &+G_coef(1)*(ztpsi(2)-ztpsi(Nx)) &
    &+G_coef(2)*(ztpsi(3)-ztpsi(Nx-1)))
  zhtpsi(2)=-zI*( &
    &+G_coef(1)*(ztpsi(3)-ztpsi(1)) &
    &+G_coef(2)*(ztpsi(4)-ztpsi(Nx)))

  do ix=3,Nx-2
    zhtpsi(ix)=-zI*( &
      &+G_coef(1)*(ztpsi(ix+1)-ztpsi(ix-1)) &
      &+G_coef(2)*(ztpsi(ix+2)-ztpsi(ix-2)))
  end do

  zhtpsi(Nx-1)=-zI*( &
    &+G_coef(1)*(ztpsi(Nx)-ztpsi(Nx-2)) &
    &+G_coef(2)*(ztpsi(1)-ztpsi(Nx-3)))
  zhtpsi(Nx)=-zI*( &
    &+G_coef(1)*(ztpsi(1)-ztpsi(Nx-1)) &
    &+G_coef(2)*(ztpsi(2)-ztpsi(Nx-2)))

  return
end subroutine ppsi
!-------10--------20--------30--------40--------50--------60--------70--------80--------90