! **************************************************************************
! ... eof.f90
! ... Quim Ballabrera, March 2013
! ...
! ... System Dynamics
! ...
! **************************************************************************

program eof

use sysdyn

implicit none

logical Zexist
integer i,j,k,Nv,Nt,step,rank,iu

real(dp) xsum,xsum2
real(dp), dimension(:), allocatable        :: Zm,Zs
real(dp), dimension(:,:), allocatable      :: Z,cov
real(dp), dimension(:), allocatable        :: Lambda,ev,pc
real(dp), dimension(:,:), allocatable      :: U
real(dp), dimension(:), allocatable        :: T

character(len=180) nfile,tfile,cfile,efile,pfile,mfile,sfile,xfile
character(len=180) rfile,line

namelist/nameof/tfile,     &
                cfile,     &
                efile,     &
                pfile,     &
                mfile,     &
                sfile,     &
                xfile

call header()

tfile = 'lorenz_simulation.dat'
mfile = 'lorenz.mean'
sfile = 'lorenz.stdv'
cfile = 'lorenz.cov'
rfile = 'lorenz.cor'
efile = 'lorenz.eof'
xfile = 'lorenz.spm'
pfile = 'lorenz.pc'

nfile = ''
CALL getarg(1,nfile)
inquire(file=nfile,exist=Zexist)

if (len_trim(nfile).gt.0) then
  if (Zexist) then
    write(*,*) 'Reading ', trim(nfile)
    iu = unitfree()
    open(iu,FILE=nfile,STATUS='old')
    rewind(iu)
    read(iu,nameof)
    close(iu)
  else
    call stop_error (1,'Namelist file not found')
  endif
endif

! ... Open input trajectory
! ...
iu = unitfree()
write(*,*) 'Opening file ', trim(tfile)
open(iu,file=tfile,status='old')
rewind(iu)
Nt = numlines(iu)

rewind(iu)
read(iu,'(A)') line
Nv = numwords(line) - 1

allocate (Z(Nv,Nt))
allocate (T(Nt))
allocate (Zs(Nv))
allocate (cov(Nv,Nv))

! ... Load the data:
! ...
rewind(iu)
do step=1,Nt
  READ(iu,*) T(step),Z(:,step)
enddo
close(iu)

! ... Long term mean:
! ...
allocate (Zm(Nv))
Zm(:) = 0.0D0
do step=1,Nt
  Zm(:) = Zm(:) + Z(:,step)
enddo
Zm(:) = Zm(:) / Nt

write(*,*) 'Saving long term mean ', trim(mfile)
open(iu,file=mfile,status='unknown')
rewind(iu)
write(iu,*) 0.0, SNGL(Zm)
close(iu)

! ... Anomalies:
! ...
do i=1,Nv
  Z(i,:) = Z(i,:) - Zm(i)
enddo

! ... Calculate the covariance matrix
! ...
do j=1,Nv
do i=j,Nv
  xsum = 0.0D0
  do k=1,Nt
    xsum = xsum + Z(i,k)*Z(j,k)
  enddo
  cov(i,j) = xsum / (Nt-1.0D0)
  cov(j,i) = cov(i,j)
enddo
enddo

write(*,*) 'Covariance : '
do i=1,Nv
  write(*,'(100F9.3)') cov(i,:)
enddo

write(*,*) 'Saving covariance matrix ', trim(cfile)
iu = unitfree()
open(iu,file=cfile,status='unknown')
rewind(iu)
write(iu,*) Nv, Nv
do j=1,Nv
  write(iu,*) cov(:,j)
enddo
close(iu)

! ... Standard deviation
! ...
do i=1,Nv
  Zs(i) = SQRT(DOT_PRODUCT(Z(i,:),Z(i,:))/(Nt-1.0D0))
enddo

write(*,*) 'Saving standard deviation ', trim(sfile)
open(iu,file=sfile,status='unknown')
rewind(iu)
write(iu,*) 0.0D0, SNGL(Zs)
close(iu)

! ... Scale the anomalies:
! ...
do i=1,Nv
  Z(i,:) = Z(i,:)/Zs(i)
enddo

! ... Calculate the correlation matrix
! ...
do j=1,Nv
do i=j,Nv
  xsum = 0.0D0
  do k=1,Nt
    xsum = xsum + Z(i,k)*Z(j,k)
  enddo
  cov(i,j) = xsum / (Nt-1.0D0)
  cov(j,i) = cov(i,j)
enddo
enddo

write(*,*)
write(*,*) 'Mean : '
write(*,*) SNGL(Zm)
write(*,*) 'Standard deviation : '
write(*,*) SNGL(Zs)
write(*,*) 'Correlation : '
do i=1,Nv
  write(*,'(100F9.3)') cov(i,:)
enddo

! ... Save the covariance matrix
! ...
write(*,*) 'Saving correlation matrix ', trim(rfile)
iu = unitfree()
open(iu,file=rfile,status='unknown')
rewind(iu)
write(iu,*) Nv, Nv
do j=1,Nv
  write(iu,*) cov(:,j)
enddo
close(iu)

! ... Just to be safe: print the trace of the covariance matrix:
! ...
xsum = 0.0D0
do i=1,Nv
do k=1,Nt
  xsum = xsum + Z(i,k)*Z(i,k)
enddo
enddo
write(*,*) 'Trace coavariance matrix (Z Z^T): ', xsum/(Nt-1.0D0)

! ... EOFs:
! ...
rank = MIN(nv,nt-1)
write(*,*) 'Rank: ', rank

allocate (U(Nv,rank))
allocate (Lambda(rank))

call get_the_eofs (Z,Nv,Nt,rank,U,Lambda)

! ... The covariance matrix seen by the EOFs: Cov = U Lambda U^T
! ...
xsum = 0.0D0
do i=1,Nv
do k=1,rank
  xsum = xsum + Lambda(k)*U(i,k)*U(i,k)
enddo
enddo
write(*,*) 'Trace coavariance matrix (U Lambda U^T): ', xsum

! ... Explained variance:
! ...
allocate (ev(rank))
xsum  = SUM(Lambda(:))
xsum2 = 0.0D0
do k=1,rank
  xsum2 = xsum2 + 100.0D0*Lambda(k)/xsum
  ev(k) = xsum2
enddo

write(*,*) 'Saving scpectrum file ', trim(xfile)
iu = unitfree()
open (iu,file=xfile,status='unknown')
rewind(iu)
do k=1,rank
  write(iu,'(i5,F18.5,2F9.3)') k, Lambda(k), 100.0*Lambda(k)/xsum, ev(k)
enddo
close(iu)

write(*,*) 'Saving the EOFs matrix ', trim(efile)
iu = unitfree()
open(iu,file=efile,status='unknown')
rewind(iu)
write(iu,*) Nv, rank
do k=1,rank
  write(iu,*) U(:,k)
enddo
close(iu)

! ... Principal components:
! ...
allocate (pc(rank))
write(*,*) 'Saving the PC matrix ', trim(pfile)
iu = unitfree()
open(iu,file=pfile,status='unknown')
rewind(iu)

do step=1,Nt
  do k=1,rank
    xsum = 0.0D0
    do i=1,Nv
      xsum = xsum + U(i,k)*Z(i,step)
    enddo
    pc(k) = xsum
  enddo
  write(iu,'(4F10.4)') T(step), pc(:)
enddo
close(iu)

call stop_error (0,'EOF Ok')
end program eof
! ...
! =====================================================================
! ...
SUBROUTINE get_the_eofs (Z,Nv,Nt,rank,U,Lambda)

use sysdyn

implicit none

integer Nv,Nt,rank
real(dp), dimension(Nv,Nt), intent(in)       :: Z
real(dp), dimension(Nv,rank), intent(out)    :: U
real(dp), dimension(rank), intent(out)       :: Lambda

integer Nm,k
real(dp), dimension(:), allocatable          :: DD
real(dp), dimension(:,:), allocatable        :: UU,VV

if (Nv.GE.Nt) then
  write(*,*) 'Singular Value Decomposition of Z ...'

  Nm = Nt
  allocate (UU(Nv,Nt))
  allocate (VV(Nt,Nt))
  allocate (DD(Nt))

  UU(:,:) = Z(:,:)
  call svdcmp (UU,Nv,Nt,Nv,Nt,DD,VV)

else
  write(*,*) 'Singular Value Decomposition of Z^T ...'

  Nm = Nv
  allocate (UU(Nv,Nv))
  allocate (VV(Nt,Nv))
  allocate (DD(Nv))

  VV = TRANSPOSE(Z)
  call svdcmp (VV,Nt,Nv,Nt,Nv,DD,UU)

endif

DD(:) = DD(:)**2
call eigsort (DD,Nm,UU,Nv)

IF (rank.GT.Nm) call stop_error(1,'ERROR: rank to large !!!!!')

! ... Output arrays:
! ...
do k=1,rank
  Lambda(k) = DD(k)/(Nt-1.0D0)
  U(:,k)    = UU(:,k)
enddo

deallocate (UU)
deallocate (VV)
deallocate (DD)

return
end
! ...
! ====================================================================
! ...


module procedures
implicit none
contains

subroutine writes2d (A)
   real(kind=8), allocatable, dimension(:,:), intent(in) :: A
   integer :: n, m, i, j

   n = size(A, 1)
   m = size(A, 2)

   do i = 1,n
      write(*,'(20F8.3)') (A(i,j), j = 1, m)
   end do
   write(*,*)
end subroutine writes2d

subroutine writes1d (A)
   real(kind=8), allocatable, dimension(:), intent(in) :: A
   integer :: n, i

   n = size(A)

   write(*,'(20F8.3)') (A(i), i = 1, n)
   write(*,*)
end subroutine writes1d

subroutine Gauss_Elimination (A, n, M)
   real(kind=8), allocatable, dimension(:,:), intent(inout) :: A
   integer, intent(in) :: n !dimension
   real(kind=8), allocatable, dimension(:,:), intent(out) :: M
   real(kind=8) :: temp1, temp2
   integer :: i, j, k

   ! Initialize M:
   allocate (M(n,n))
   do i = 1, n
      do j = 1, n
         M(i,j) = 0.0
         if (i == j) then
            M(i,j) = 1
         end if
      end do
   end do

   ! Perform the Gauss Elimination:
   do k = 1, n-1 ! pivot row

      ! If the pivot element is very small:
      if (dabs(A(k,k)) .le. 0.01) then
         write(*,*)
         write(*,*)"--------------------------------------"
         write(*,*) "pivot element too small..."
         do i = k, n !look at the remaining rows
            if (dabs(A(k,i)) .gt. 0.01) then !if one of these rows has
                                             ! has A(k,i) > 0.01
               write(*,*) "swtching rows", i, "and", k
               write(*,*) "--------------------------------------"
               write(*,*)
               do j = 1, n !switch the i-th and the k-th row
                  temp1 = A(k,j)
                  temp2 = A(i,j)
                  A(k,j) = temp2
                  A(i,j) = temp1
               end do
            end if
         end do
      end if

      do i = 1, n-k ! now modify the n-k rows for this pivot
         M(i+k,k) = A(i+k,k)/A(k,k) ! find the multiplier for row i+k

         write(*,*) "--------------------------------------"
         write(*,'(A6,I3,A6,I3,A7,I1,A1,I1,A3,F7.3)') " Step:", k, "  Row:", i+k, "     m(", i+k,",", k, "): ", m(i+k,k)
         write(*,*) "--------------------------------------"

         do j = k, n ! for every column, j,  in row i+k
            A(i+k,j) = A(i+k,j) - M(i+k,k)*A(k,j) ! change the value of the matrix
                                                ! element A(i+k,j)
         end do
         call writes2d(A)
      end do
   end do

   write(*,*) '--------------------------------'
   write(*,*) '[L]: '
   write(*,*) '--------------------------------'
   call writes2d(M)
   write(*,*)
   write(*,*) '--------------------------------'
   write(*,*) '[U]: '
   write(*,*) '--------------------------------'
   call writes2d(a)

end subroutine Gauss_Elimination

subroutine Forward_Substitution(L,b,n,Y)
   real(kind=8), allocatable, dimension(:,:), intent(inout) :: L
   real(kind=8), allocatable, dimension(:), intent(in) :: b
   integer, intent(in) :: n !dimension
   real(kind=8), allocatable, dimension(:), intent(out) :: Y
   integer :: i, j

   allocate( Y(n) )
   do i = 1, n
      Y(i) = b(i)
      do j = 1, i-1
         Y(i) = Y(i) - L(i,j)*Y(j)
      end do
      Y(i) = Y(i)/L(i,i)
   end do
end subroutine Forward_Substitution

subroutine Back_Substitution(U,b,n,X)
   real(kind=8), allocatable, dimension(:,:), intent(inout) :: U
   real(kind=8), allocatable, dimension(:), intent(in) :: b
   integer, intent(in) :: n !dimension
   real(kind=8), allocatable, dimension(:), intent(out) :: X
   integer :: i, j

   allocate( X(n) )
   do i = n, 1, -1
      X(i) = b(i)
      do j = i+1, n
         X(i) = X(i) - U(i,j)*X(j)
      end do
      X(i) = X(i)/U(i,i)
   end do

end subroutine Back_Substitution

end module procedures


module mGf90
implicit none

private
public srand_mtGaus
contains

real function srand_mtGaus(N, mean, cvm) result(y)
implicit none

!The dimension of the multivariate vector
integer, intent(in)   :: N

real,    intent(in)   :: mean(N)  !Mean values of the multivariate distribution

real,    intent(in)   :: cvm(N,N) !Covariance matrix of the multivariate distribution
dimension             :: y(N)
integer    :: nullty  ! i/o for cholesky subroutine
integer    :: error
integer    :: i, j
real       :: cvm_(N*(N+1)/2)
real       :: chol(N*(N+1)/2)

!Convert cvm to a vector with length N*(N+1)/2
do i = 1, N
  do j = 1,i
    cvm_(i*(i-1)/2+j) = cvm(i,j)
  enddo
enddo

call cholesky(cvm_,N,N*(N+1)/2,chol,nullty,error)

y = multiGauss(chol,mean,N)
end function srand_mtGaus

real function gasdev() result(gval)
!This function generates an array of independent Gaussian variates
implicit none
real :: FAC, R, V1, V2, X
real, save :: GSET
integer, save :: ISET = 0

IF (ISET.EQ.0) THEN
   R = 99
   do while( R .ge. 1.0d0 )
      call random_number(V1)
      V1= 2d0*V1 - 1d0

      call random_number(V2)
      V2= 2d0*V2 - 1d0

      R = V1**2 + V2**2
   end do
   FAC  = SQRT( -2.0d0*LOG(R)/R )
   GSET = V1*FAC
   gval = V2*FAC
   ISET = 1
ELSE
   gval=GSET
   ISET=0
ENDIF

RETURN
END function gasdev

subroutine cholesky ( a, n, nn, u, nullty, ifault )
!*****************************************************************************80
!
!! CHOLESKY computes the Cholesky factorization of a PDS matrix.
!
!  Discussion:
!
!    For a positive definite symmetric matrix A, the Cholesky factor U
!    is an upper triangular matrix such that A = U' * U.
!
!    This routine was originally named "CHOL", but that conflicted with
!    a built in MATLAB routine name.
!
!  Modified:
!
!    01 February 2008
!
!  Author:
!
!    Michael Healy
!    Modifications by AJ Miller.
!    FORTRAN90 version by John Burkardt
!
!  Reference:
!
!    Michael Healy,
!    Algorithm AS 6:
!    Triangular decomposition of a symmetric matrix,
!    Applied Statistics,
!    Volume 17, Number 2, 1968, pages 195-197.
!
!  Parameters:
!
!    Input, real ( kind = 8 ) A((N*(N+1))/2), a positive definite matrix
!    stored by rows in lower triangular form as a one dimensional array,
!    in the sequence
!    A(1,1),
!    A(2,1), A(2,2),
!    A(3,1), A(3,2), A(3,3), and so on.
!
!    Input, integer ( kind = 4 ) N, the order of A.
!
!    Input, integer NN, the dimension of the array used to store A,
!    which should be at least (N*(N+1))/2.
!
!    Output, real ( kind = 8 ) U((N*(N+1))/2), an upper triangular matrix,
!    stored by columns, which is the Cholesky factor of A.  The program is
!    written in such a way that A and U can share storage.
!    It is also the same as lower triangular matrix stored by rows (by B. Chen on 12 Aug 2019)
!
!    Output, integer ( kind = 4 ) NULLTY, the rank deficiency of A.  If NULLTY is zero,
!    the matrix is judged to have full rank.
!
!    Output, integer ( kind = 4 ) IFAULT, an error indicator.
!    0, no error was detected;
!    1, if N < 1;
!    2, if A is not positive semi-definite.
!    3, NN < (N*(N+1))/2.
!
!  Local Parameters:
!
!    Local, real ( kind = 8 ) ETA, should be set equal to the smallest positive
!    value such that 1.0 + ETA is calculated as being greater than 1.0 in the
!    accuracy being used.
!
  implicit none

  integer ( kind = 4 ), intent(in) :: n
  integer ( kind = 4 ), intent(in) :: nn

  real    ( kind = 8 ), intent(in) :: a(nn)
  real    ( kind = 8 ), parameter :: eta = 1.0D-19
  integer ( kind = 4 ) i
  integer ( kind = 4 ) icol
  integer ( kind = 4 ), intent(out) :: ifault
  integer ( kind = 4 ) ii
  integer ( kind = 4 ) irow
  integer ( kind = 4 ) j
  integer ( kind = 4 ) k
  integer ( kind = 4 ) kk
  integer ( kind = 4 ) l
  integer ( kind = 4 ) m
  integer ( kind = 4 ), intent(out) :: nullty
  real    ( kind = 8 ), intent(out) :: u(nn)
  real    ( kind = 8 ) w
  real    ( kind = 8 ) x

  ifault = 0
  nullty = 0

  if ( n <= 0 ) then
    ifault = 1
    return
  end if

  if ( nn < ( n * ( n + 1 ) ) / 2 ) then
    ifault = 3
    return
  end if

  j = 1
  k = 0
  ii = 0
!
!  Factorize column by column, ICOL = column number.
!
  do icol = 1, n

    ii = ii + icol
    x = eta * eta * a(ii)
    l = 0
    kk = 0
!
!  IROW = row number within column ICOL.
!
    do irow = 1, icol

      kk = kk + irow
      k = k + 1
      w = a(k)
      m = j

      do i = 1, irow - 1
        l = l + 1
        w = w - u(l) * u(m)
        m = m + 1
      end do

      l = l + 1

      if ( irow == icol ) then
        exit
      end if

      if ( u(l) /= 0.0D+00 ) then

        u(k) = w / u(l)

      else

        u(k) = 0.0D+00

        if ( abs ( x * a(k) ) < w * w ) then
          ifault = 2
          return
        end if

      end if

    end do
!
!  End of row, estimate relative accuracy of diagonal element.
!
    if ( abs ( w ) <= abs ( eta * a(k) ) ) then

      u(k) = 0.0D+00
      nullty = nullty + 1

    else

      if ( w < 0.0D+00 ) then
        ifault = 2
        return
      end if

      u(k) = sqrt ( w )

    end if

    j = j + icol

  end do

  return
end subroutine cholesky

!-----------------------------------------------------------------------------
subroutine subchl ( a, b, n, u, nullty, ifault, ndim, det )

!*****************************************************************************80
!
!! SUBCHL computes the Cholesky factorization of a (subset of a) PDS matrix.
!
!  Modified:
!
!    11 February 2008
!
!  Author:
!
!    FORTRAN77 version by Michael Healy, PR Freeman
!    FORTRAN90 version by  John Burkardt
!
!  Reference:
!
!    PR Freeman,
!    Remark AS R44:
!    A Remark on AS 6 and AS7: Triangular decomposition of a symmetric matrix
!    and Inversion of a positive semi-definite symmetric matrix,
!    Applied Statistics,
!    Volume 31, Number 3, 1982, pages 336-339.
!
!    Michael Healy,
!    Algorithm AS 6:
!    Triangular decomposition of a symmetric matrix,
!    Applied Statistics,
!    Volume 17, Number 2, 1968, pages 195-197.
!
!  Parameters:
!
!    Input, real ( kind = 8 ) A((M*(M+1))/2), a positive definite matrix
!    stored by rows in lower triangular form as a one dimensional array,
!    in the sequence
!    A(1,1),
!    A(2,1), A(2,2),
!    A(3,1), A(3,2), A(3,3), and so on.
!    In the simplest case, M, the order of A, is equal to N.
!
!    Input, integer ( kind = 4 ) B(N), indicates the order in which the
!    rows and columns of A are to be used.  In the simplest case,
!    B = (1,2,3...,N).
!
!    Input, integer ( kind = 4 ) N, the order of the matrix, that is,
!    the matrix formed by using B to select N rows and columns of A.
!
!    Output, real ( kind = 8 ) U((N*(N+1))/2), an upper triangular matrix,
!    stored by columns, which is the Cholesky factor of A.  The program is
!    written in such a way that A and U can share storage.
!
!    Output, integer ( kind = 4 ) NULLTY, the rank deficiency of A.
!    If NULLTY is zero, the matrix is judged to have full rank.
!
!    Output, integer ( kind = 4 ) IFAULT, an error indicator.
!    0, no error was detected;
!    1, if N < 1;
!    2, if A is not positive semi-definite.
!
!    Input, integer ( kind = 4 ) NDIM, the dimension of A and U, which might
!    be presumed to be (N*(N+1))/2.
!
!    Output, real ( kind = 8 ) DET, the determinant of the matrix.
!
  implicit none

  integer ( kind = 4 ) n
  integer ( kind = 4 ) ndim

  real    ( kind = 8 ) a(ndim)
  integer ( kind = 4 ) b(n)
  real    ( kind = 8 ) det
  real    ( kind = 8 ), parameter :: eta = 1.0D-09
  integer ( kind = 4 ) i
  integer ( kind = 4 ) icol
  integer ( kind = 4 ) ifault
  integer ( kind = 4 ) ii
  integer ( kind = 4 ) ij
  integer ( kind = 4 ) irow
  integer ( kind = 4 ) j
  integer ( kind = 4 ) jj
  integer ( kind = 4 ) k
  integer ( kind = 4 ) kk
  integer ( kind = 4 ) l
  integer ( kind = 4 ) m
  integer ( kind = 4 ) nullty
  real    ( kind = 8 ) u(ndim)
  real    ( kind = 8 ) w
  real    ( kind = 8 ) x

  ifault = 0
  nullty = 0
  det = 1.0D+00

  if ( n <= 0 ) then
    ifault = 1
    return
  end if

  ifault = 2
  j = 1
  k = 0

  do icol = 1, n

    ij = ( b(icol) * ( b(icol) - 1 ) ) / 2
    ii = ij + b(icol)
    x = eta * eta * a(ii)
    l = 0

    do irow = 1, icol

      kk = ( b(irow) * ( b(irow) + 1 ) ) / 2
      k = k + 1
      jj = ij + b(irow)
      w = a(jj)
      m = j

      do i = 1, irow - 1
        l = l + 1
        w = w - u(l) * u(m)
        m = m + 1
      end do

      l = l + 1

      if ( irow == icol ) then
        exit
      end if

      if ( u(l) /= 0.0D+00 ) then

        u(k) = w / u(l)

      else

        if ( abs ( x * a(kk) ) < w * w ) then
          ifault = 2
          return
        end if

        u(k) = 0.0D+00

      end if

    end do

    if ( abs ( eta * a(kk) ) <= abs ( w ) ) then

      if ( w < 0.0D+00 ) then
        ifault = 2
        return
      end if

      u(k) = sqrt ( w )

    else

      u(k) = 0.0D+00
      nullty = nullty + 1

    end if

    j = j + icol
    det = det * u(k) * u(k)

  end do

  return
end subroutine subchl

real function multigauss(R,mu,n) result(G)
!!$ Generates a one dimensional array of length n containing multivariate Gaussian pseudo-random numbers
!!$ where R is the lower-triangular Cholesky factor of the covariance matrix of the desired distribution
!!$ and mu is a one dimensional array of length n, containing the mean value for each random variable.
!!$ R must be a one dimensional array, containing the lower-triangular matrix stored by row, starting from the
!!$ uppermost, leftmost entry (first row, first column).
   implicit none
   integer, intent(in) :: n
   real, intent(in) :: R(n*(n+1)/2)
   real, intent(in) :: mu(n)
   real :: Nu(n)
   dimension :: G(n)
   integer :: i, j

   if( n*(n+1)/2 .ne. size(R) ) then
      write(6,*) ' n*(n+1)/2 != size(R) in multiGauss '
      write(6,*) ' Cholesky factor matrix has size ', size(R)
      write(6,*) ' but you are requesting a vector of size ',n
      stop
   else

!!$ generate an array of independent Gaussian variates
      do j = 1, n
         Nu(j) = gasdev()
      end do

!!$ start with the desired mean, and add the product of
!!$ [the lower-triangular Cholesky factor of the covariance matrix] x [ the vector of iid Gaussian variates]
      do i = 1, n
         G(i) = mu(i)
         do j =  1,i
            G(i) = G(i) + R( i*(i-1)/2 + j ) * Nu(j)
         end do
      end do

   end if
   return
 end function multigauss
end module mGf90


module KinematicClass
    use, intrinsic :: iso_fortran_env
    use MathClass

    implicit none

contains

! #############################################
function RotationMatrix3D(rotx,roty,rotz,n,angle) result(Rmat)
    real(real64)::Rmat(3,3)
    real(real64),optional,intent(in)::rotx,roty,rotz,n(3),angle
    integer(int32) :: i
    Rmat(:,:)=0.0d0
    do i=1,3
        Rmat(i,i)=1.0d0
    enddo

    if(present(rotx) )then
        Rmat(2,2) = cos(rotx)
        Rmat(2,3) = -sin(rotx)
        Rmat(3,2) = sin(rotx)
        Rmat(3,3) = cos(rotx)
    endif

    if(present(rotx) )then
        Rmat(1,1) = cos(rotx)
        Rmat(1,3) = sin(rotx)
        Rmat(3,1) = -sin(rotx)
        Rmat(3,3) = cos(rotx)
    endif

    if(present(rotx) )then
        Rmat(2,2) = cos(rotx)
        Rmat(2,3) = -sin(rotx)
        Rmat(3,2) = sin(rotx)
        Rmat(3,3) = cos(rotx)
    endif

    if(present(n) .and. present(angle) )then
        ! Rodrigues' rotation formula
        Rmat(1,1)=cos(angle)+n(1)*n(1)*(1.0d0 - cos(angle) )
        Rmat(1,2)=n(1)*n(2)*(1.0d0 - cos(angle) )-n(3)*sin(angle)
        Rmat(1,3)=n(1)*n(3)*(1.0d0 + cos(angle) )-n(2)*sin(angle)
        Rmat(2,1)=n(2)*n(1)*(1.0d0 + cos(angle) )-n(3)*sin(angle)
        Rmat(2,2)=cos(angle)+n(2)*n(2)*(1.0d0 - cos(angle) )
        Rmat(2,3)=n(2)*n(3)*(1.0d0 - cos(angle) )-n(1)*sin(angle)
        Rmat(3,1)=n(3)*n(1)*(1.0d0 - cos(angle) )-n(2)*sin(angle)
        Rmat(3,2)=n(3)*n(2)*(1.0d0 + cos(angle) )-n(1)*sin(angle)
        Rmat(3,3)=cos(angle)+n(3)*n(3)*(1.0d0 - cos(angle) )
    endif

end function
! #############################################

! #############################################
function Rotation3D(vector,rotx,roty,rotz,n,angle) result(vec)
    real(real64)::vec(3)
    real(real64),intent(in)::vector(3)
    real(real64),optional,intent(in)::rotx,roty,rotz,n(3),angle

    vec(:) = matmul( RotationMatrix3D(rotx,roty,rotz,n,angle) ,vector)

end function
! #############################################

end module


implicit none
double complex :: x, xold, f, fprime, top, bot

x = (1,0d0, 3.0d0)
xold = 2.0d0 * x

do while (abs(x - xold) > 1.0d-11)
  cold = x
  top = f(x)
  bot = fprime(x)
  x = (x - top) / bot
  print*, 'x = ', x
  print*, top
  print*,
end do
print*, 'End of program.'

stop
end

double complex function f(x)
  implicit none
  double complex :: x

  f = sin(x) - 2.0d0

  return
end

double complex function fprime(x)
  implicit none
  double complex :: x

  fprime = cos(x)

  return
end

4670 Numerical Analysis/Class Examples/newton2.f90


Program itsatrap
  implicit none
  REAL::x, f, a, b, Int, h
  INTEGER::i, N
  N=100000
  a=0
  b=1
  Int=0
  h=(b-a)/N
  do i=1, N
     x=a+i*h
     Int=Int+f(x)
  end do
  Int=(b-a)*(f(a)+2*Int+f(b))/(2*N)
  write(*, *) Int
end Program itsatrap

function f(x)
  implicit none
  REAL::x, f
  f=exp(-x**2)
end function f


     FUNCTION f_qv_from_rh (RH, T_K, RH0, T_K0, P_PA0) RESULT (QV_KG)
!!!--------------------------------------------------------------------------
!!!
!!!                       FUNCTION F_QV_FROM_RH
!!!                     **************************
!!!
!!!  PURPOSE:
!!!  -------
!!!     TANGENT LINEAR CODE FOR
!!!     COMPUTING MIXING RATIO FROM RELATIVE HUMIDITY, TEMPERATURE AND PRESSURE
!!!
!!!     THE ERROR DERIVATION SHOULD USED THE TANGENT LINEAR CODE, NOT THE
!!!     ORIGINAL NON-LINEAR CODE.
!!!
!!   METHOD:
!!   ------
!!      LINEAR OR LOGARITHMIC VERTICAL INTERPOLATION
!!      OUT OF BOUND LOCATIONS ARE EXTRAPOLATED
!!
!!   INPUT:
!!   -----
!!      RH:    RELAITVE HUMIDITY in %
!!      P_PA:  PRESSURE          in Pa
!!      T_K:   TEMPERATURE       in K
!!
!!   OUTPUT:
!!   ------
!!      QV_KG: MIXING RATIO IN kg/kg
!!
!!   COMMON:           NO
!!   -------
!!   EXTERNAL:         NO
!!   --------
!!
!!   REFERENCES:
!!   -----------
!!    R. R. ROGERS AND M. K. YAU, 1989: A SHORT COURSE IN CLOUD PHYSICS,
!!                                      3ND EDITION, PERGAMON PRESS, PAGE 14-19.
!!
!!   VERIFICATION SET:
!!   -----------------
!!    T_K  = 268.15 K,
!!    TD_K = 262.55 K
!!    RH   = 65 %,
!!    P_PA = 80000  Pa,
!!    QV   = 2.11E-03 kg/kg,
!!
!!  MODIFICATIONS:
!!   ------------
!!       Developed by Yong-Run Guo (11/07/00)
!!----------------------------------------------------------------------------CC

      IMPLICIT NONE

      REAL T_K , RH , QV_KG
      REAL P_PA0, T_K0, RH0
      ! REAL P_MB, W_KG
      REAL ES , QS
      REAL P_MB0, ES0, QS0, QV_KG0
!------------------------------------------------------------------------------C

!...P in mb

      P_MB0 = P_PA0 / 100.

!...VAPOR PRESSURE in mb

      ES  = 6.112 * 17.67 * 243.5 * T_K /                       &
                    ((T_K0-273.15+243.5)*(T_K0-273.15+243.5)) * &
                    EXP (17.67*(T_K0-273.15)/(T_K0-273.15+243.5))
      ES0 = 6.112 * EXP (17.67*(T_K0-273.15)/(T_K0-273.15+243.5))

!...SATURATION MIXING RATIO in kg/kg

      QS  = 0.622 * (P_MB0 * ES ) /  &
                   ((P_MB0 - ES0) * (P_MB0 - ES0))
      QS0 = 0.622 * ES0 /(P_MB0-ES0)

!...MIXING RATIO in kg/kg

      QV_KG  = 0.01 * (RH0 * QS + RH * QS0)
      QV_KG0 = 0.01 * RH0 * QS0

!...Mixing ratio must be positive

      IF (QV_KG0 < 0.) QV_KG = 0.

      RETURN

      END FUNCTION f_qv_from_rh


	REAL*4 FUNCTION
     .	TPOWER(ITYPE,ALPHA,MYDIFF,SIGMA,N,M)
	USE MSIMSL
C
C-Description-----------------------------------------------------------
	IMPLICIT NONE
C
C  Function:
C	Determine Power
C  Arguments:
C   input from user
C	ALPHA	Type I error probability (two sided)
C	N	Number of experimental patients for independent
C		t-tests or the number of pairs of patients
C		for paired t-tests
C	M	the number of control patients per experimental patient.
C		M is only defined for independent t-tests.
C	MYDIFF    A difference in population means
C	SIGMA	An estimate of the within group standard deviation for
C		independent tests.  It is an estimate of the standard
C		deviation of paired response MYDIFFerences for paired data.
C   output:
C	POWER	The probability of correctly rejecting the null hypotheses
C		of equal population means given N pairs of patients (or
C		N experimental patients with M controls per experimental
C		patient), and a type I error probability ALPHA when the
C		true MYDIFFerence in population means is MYDIFF.
C
C  Notes:
C
C	This program gives results that are consistant with the
C	TSAMPLESIZE routine.  An elementary reference is Steel and
C	Torrie:  Principles and Procedures of Statistics:  A Biometrical
C	Approach, 2nd ed. New York:  McGraw-Hill 1980.
C
C	Let TCRVALUE(P,NU) returns the critical value that is exceeded
C	by a t statistic with NU degrees of freedom with probability P.
C
C	Let TCUM(T,NU) return the probability that a t statistic
C	with NU degrees of freedom will be <= T.
C
C	Then the derivation of the study power given below follows
C	from elementary computations.  The validity of these results
C	can be confirmed by the analogous use of routine TSAMPLESIZE.
C
C	The resulting power calculations produced by this program
C	are in close agreement with those obtained from Table 10 of
C	Pearson and Hartley, Biometrika Tables for Statisticians, Vol I,
C	3rd Ed., Cambridge:  Cambridge U. Press, 1970.
C
C   .	This routine was written by Dale Plummer
C   .	Designed by William Dupont
C
C-Declarations----------------------------------------------------------
C
C  Arguments
C
	INTEGER ITYPE
	REAL ALPHA,MYDIFF,SIGMA,N,M
C
C  Functions
C
	REAL TCUM,TCRVALUE
C
C  Locals
C
      REAL DELTA
      REAL DRN,TCRV,NU
C
C-Code------------------------------------------------------------------
C
C    A single value of MYDIFF is specified.
C
	IF (ITYPE.EQ.1) THEN
C
C    Paired
C    Perform the computations.
C
		NU=N-1.
		IF (NU.LT.1.) THEN
			TPOWER=-999
			RETURN
		END IF
		DELTA=MYDIFF/SIGMA
		DRN=DELTA*SQRT(N)
C		TCRV=TCRVALUE(ALPHA/2.,NU)
		TCRV=TIN((1.-ALPHA/2.),NU)
		TPOWER=TCUM(DRN-TCRV,NU)+TCUM(-DRN-TCRV,NU)
	ELSE
C
C    Independent
C    Perform the computations.
C
		NU=N*(M+1.)-2.
		IF (NU.LT.1.) THEN
			TPOWER=-999
			RETURN
		END IF
		DELTA=MYDIFF/(SIGMA*SQRT(1.+1./M))
		DRN=DELTA*SQRT(N)
C		TCRV=TCRVALUE(ALPHA/2.,NU)
		TCRV=TIN((1.-ALPHA/2.),NU)
		TPOWER=TCUM(DRN-TCRV,NU)+TCUM(-DRN-TCRV,NU)
	END IF
	RETURN
	END


PROGRAM monte_pi_serial

  IMPLICIT NONE

  INTEGER(kind=4) :: i, count
  REAL(kind=8) :: x, y, pi
  REAL(kind=8) :: t_start, t_end
  INTEGER(kind=8), PARAMETER :: num_points = 300000000

  count=0

  CALL cpu_time(t_start)
  CALL random_seed()
  DO i=0,num_points
     CALL random_number(x)
     CALL random_number(y)
     IF (x*x + y*y <= 1)  count = count + 1
  END DO

  pi = 4.0*count/num_points

  CALL cpu_time(t_end)

  WRITE(*,*) "Value of pi = ",pi
  WRITE(*,*) "Expended wall clock time = ",t_end-t_start

END PROGRAM monte_pi_serial


Subroutine triangulate(A, n)
	Implicit None

	Integer, Intent(In) :: n
	Double Precision, Dimension(n, n), Intent(InOut) :: A

	Double Precision, Dimension(n, n):: tmp
	Integer :: i, j, k

	tmp = A
	Do k = 1, n-1
		Do i = n, k+1, -1
			Do j = k, n
				tmp(i, j) = A(i, j) - A(i, k) * A(k, j) / A(k, k)
			End Do
		End Do
		A = tmp
	End Do

End Subroutine triangulate


      SUBROUTINE sla_DCS2C (A, B, V)
*+
*     - - - - - -
*      D C S 2 C
*     - - - - - -
*
*  Spherical coordinates to direction cosines (double precision)
*
*  Given:
*     A,B       dp      spherical coordinates in radians
*                        (RA,Dec), (Long,Lat) etc
*
*  Returned:
*     V         dp(3)   x,y,z unit vector
*
*  The spherical coordinates are longitude (+ve anticlockwise
*  looking from the +ve latitude pole) and latitude.  The
*  Cartesian coordinates are right handed, with the x axis
*  at zero longitude and latitude, and the z axis at the
*  +ve latitude pole.
*
*  P.T.Wallace   Starlink   October 1984
*
*  Copyright (C) 1995 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 59 Temple Place, Suite 330,
*    Boston, MA  02111-1307  USA
*
*-

      IMPLICIT NONE

      DOUBLE PRECISION A,B,V(3)

      DOUBLE PRECISION COSB

      COSB=COS(B)

      V(1)=COS(A)*COSB
      V(2)=SIN(A)*COSB
      V(3)=SIN(B)

      END


!******************************************************************************
!*
!*                      VARIOUS APPLICATIONS OF FFT
!*
!******************************************************************************

  !==========================================================================
  ! 1) AUTHOR: F. Galliano
  !
  ! 2) HISTORY:
  !    - Created 07/2013
  !
  ! 3) DESCRIPTION: implements FFTs, and various relaed functions.
  !==========================================================================

MODULE FFT_specials

  USE utilities, ONLY:
  USE constants, ONLY:
  USE arrays, ONLY:
  IMPLICIT NONE
  PRIVATE

  PUBLIC :: realft, correl

CONTAINS

  !==========================================================================
  ! CALL FOURROW(data,isign)
  !
  !   Replaces each row (constant first index) of data(1:M,1:N) by its discrete
  ! Fourier transform (transform on second index), if isign is input as 1; or
  ! replaces each row of data by N times its inverse discrete Fourier
  ! transform, if isign is input as −1. N must be an integer power of 2.
  ! Parallelism is M-fold on the first index of data.
  !==========================================================================

  SUBROUTINE fourrow (data,isign)

    USE utilities, ONLY: DP, CDP, swap, strike
    USE constants, ONLY: pi
    IMPLICIT NONE
    COMPLEX(CDP), DIMENSION(:,:), INTENT(INOUT) :: data
    INTEGER, INTENT(IN) :: isign
    INTEGER :: N, i, istep, j, m, Mmax, N2
    REAL(DP) :: theta
    COMPLEX(CDP), DIMENSION(SIZE(data,1)) :: temp
    COMPLEX(CDP) :: w,wp
    COMPLEX(CDP) :: ws

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

    N = SIZE(data,2)
    IF (IAND(N,N-1) /= 0) CALL STRIKE("FOOURROW","n must be a power of 2")
    N2 = N / 2
    j = N2
    DO i=1,N-2
      IF (j > i) CALL SWAP(data(:,j+1),data(:,i+1))
      m = N2
      DO
        IF (m < 2 .OR. j < m) EXIT
        j = j - m
        m = m / 2
      END DO
      j = j + m
    END DO
    Mmax = 1
    DO
      IF (N <= Mmax) EXIT
      istep = 2 * Mmax
      theta = pi / (isign*Mmax)
      wp = CMPLX(-2._DP*SIN(0.5_DP*theta)**2,SIN(theta),KIND=CDP)
      w = CMPLX(1._DP,0._DP,KIND=CDP)
      DO m=1,Mmax
        ws = w
        DO i=m,n,istep
          j = i + Mmax
          temp = ws * data(:,j)
          data(:,j) = data(:,i) - temp
          data(:,i) = data(:,i) + temp
        END DO
        w = w * wp + w
      END DO
      Mmax = istep
    END DO

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

  END SUBROUTINE fourrow

  !==========================================================================
  ! CALL FOUR1(data,isign)
  !
  !   Replaces a complex array data by its discrete Fourier transform, if
  ! isign is input as 1; or replaces data by its inverse discrete Fourier
  ! transform times the size of data, if isign is input as −1. The size of
  ! data must be an integer power of 2. Parallelism is achieved by internally
  ! reshaping the input array to two dimensions. (Use this version if fourrow
  ! is faster than fourcol on your machine.)
  !==========================================================================

  SUBROUTINE four1 (data,isign)

    USE utilities, ONLY: DP, CDP, strike, arth
    USE constants, ONLY: twopi
    IMPLICIT NONE
    COMPLEX(CDP), DIMENSION(:), INTENT(INOUT) :: data
    INTEGER, INTENT(IN) :: isign
    COMPLEX(CDP), DIMENSION(:,:), ALLOCATABLE :: dat, temp
    COMPLEX(CDP), DIMENSION(:), ALLOCATABLE :: w, wp
    REAL(DP), DIMENSION(:), ALLOCATABLE :: theta
    INTEGER :: N, m1, m2, j

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

    N = SIZE(data)
    IF (IAND(N,N-1) /=0) CALL STRIKE("FOUR1","N must be a power of 2")
    m1 = 2**CEILING( 0.5_DP * LOG(REAL(N,DP)) / 0.693147_DP )
    m2 = n / m1
    ALLOCATE (dat(m1,m2),theta(m1),w(m1),wp(m1),temp(m2,m1))
    dat = RESHAPE(data,SHAPE(dat))
    CALL FOURROW(dat,isign)
    theta = ARTH(0,isign,m1) * TWOPI / N
    wp = CMPLX(-2._DP*SIN(0.5_DP*theta)**2,SIN(theta),KIND=CDP)
    w = CMPLX(1._DP,0._DP,KIND=CDP)
    DO j=2,m2
      w = w * wp + w
      dat(:,j) = dat(:,j) * w
    END DO
    temp = TRANSPOSE(dat)
    CALL FOURROW(temp,isign)
    data = RESHAPE(temp,SHAPE(data))
    DEALLOCATE (dat,w,wp,theta,temp)

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

  END SUBROUTINE four1

  !==========================================================================
  ! CALL REALFT(data,isign,zdata)
  !
  !   When isign = 1, calculates the Fourier transform of a set of N
  ! real-valued data points, input in the array data. If the optional argument
  ! zdata is not present, the data are replaced by the positive frequency half
  ! of its complex Fourier transform. The real-valued first and last components
  ! of the complex transform are returned as elements data(1) and data(2),
  ! respectively. If the complex array zdata of length N/2 is present, data is
  ! unchanged and the transform is returned in zdata. N must be a power of 2.
  ! If isign = 1, this routine calculates the inverse transform of a complex
  ! data array if it is the transform of real data. (Result in this case must
  ! be multiplied by 2/N.) The data can be supplied either in data, with zdata
  ! absent, or in zdata.
  !==========================================================================

  SUBROUTINE REALFT(data,isign,zdata)

    USE utilities, ONLY: DP, CDP, strike, zroots_unity
    IMPLICIT NONE
    REAL(DP), DIMENSION(:), INTENT(INOUT) :: data
    INTEGER, INTENT(IN) :: isign
    COMPLEX(CDP), DIMENSION(:), OPTIONAL, TARGET :: zdata
    INTEGER :: N, Ndum, Nh, Nq
    COMPLEX(CDP), DIMENSION(SIZE(data)/4) :: w
    COMPLEX(CDP), DIMENSION(SIZE(data)/4-1) :: h1, h2
    COMPLEX(CDP), DIMENSION(:), POINTER :: cdata
    COMPLEX(CDP) :: z
    REAL(DP) :: c1 = 0.5_DP, c2

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

    N = SIZE(data)
    IF (IAND(N,N-1) /= 0) CALL STRIKE("REALFT","N must be a power of 2")
    Nh = N / 2
    Nq = N / 4
    IF (PRESENT(zdata)) THEN
      Ndum = N / 2
      IF (SIZE(zdata) /= N/2) CALL STRIKE("REALFT","Wonrg size of input")
      cdata => zdata
      IF (isign == 1) cdata = CMPLX(data(1:N-1:2),data(2:N:2),KIND=CDP)
    ELSE
      ALLOCATE (cdata(N/2))
      cdata = CMPLX(data(1:N-1:2),data(2:N:2),KIND=CDP)
    END IF

    IF (isign == 1) THEN
      c2 = - 0.5_DP
      CALL four1(cdata,+1)
    ELSE
      c2 = 0.5_DP
    END IF
    w = ZROOTS_UNITY(SIGN(N,isign),N/4)
    w = CMPLX(-AIMAG(w),REAL(w),KIND=CDP)
    h1 = c1 * (cdata(2:Nq)+CONJG(cdata(Nh:Nq+2:-1)))
    h2 = c2 * (cdata(2:Nq)-CONJG(cdata(Nh:Nq+2:-1)))
    cdata(2:Nq) = h1 + w(2:Nq) * h2
    cdata(Nh:Nq+2:-1) = CONJG(h1-w(2:Nq)*h2)
    z = cdata(1)
    IF (isign == 1) THEN
      cdata(1) = CMPLX(REAL(z)+AIMAG(z),REAL(z)-AIMAG(z),KIND=CDP)
    ELSE
      cdata(1) = CMPLX(c1*(REAL(z)+AIMAG(z)),c1*(REAL(z)-AIMAG(z)),KIND=CDP)
      CALL FOUR1(cdata,-1)
    END IF
    IF (PRESENT(zdata)) THEN
      IF (isign /= 1) THEN
        data(1:N-1:2) = REAL(cdata)
         data(2:N:2) = AIMAG(cdata)
      END IF
    ELSE
      data(1:N-1:2) = REAL(cdata)
      data(2:N:2) = AIMAG(cdata)
      DEALLOCATE(cdata)
    END IF

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

  END SUBROUTINE realft

  !==========================================================================
  ! f[N] = CORREL(data1[N],data2[N])
  !
  !   Computes the correlation of two arrays for a lag: f(N) to f(N/2+1) are
  ! negative lags, f(1) is lag 0, and f(1) to f(N/2) are positive lags.
  !==========================================================================

  FUNCTION correl (data1,data2)

    USE utilities, ONLY: DP, CDP, strike
    IMPLICIT NONE
    REAL(DP), DIMENSION(:), INTENT(INOUT) :: data1, data2
    REAL(DP), DIMENSION(SIZE(data1)) :: correl

    COMPLEX(CDP), DIMENSION(SIZE(data1)/2) :: cdat1, cdat2
    INTEGER :: No2, N

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

    ! Preliminaries
    N = SIZE(data1)
    IF (SIZE(data2) /= N) CALL STRIKE("CORREL","Wrong size of input")
    IF (IAND(N,N-1) /= 0) CALL STRIKE("CORREL","N must be a power of 2")
    No2 = N / 2

    ! Transform both data vectors
    CALL REALFT(data1,1,cdat1)
    CALL REALFT(data2,1,cdat2)

    ! Multiply to find FFT of their correlation
    cdat1(1) = CMPLX( REAL(cdat1(1)) * REAL(cdat2(1)) / No2, &
                      AIMAG(cdat1(1)) * AIMAG(cdat2(1)) / No2, KIND=CDP )
    cdat1(2:) = cdat1(2:) * CONJG(cdat2(2:)) / No2

    ! Inverse transform gives correlation
    CALL REALFT(correl,-1,cdat1)

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

  END FUNCTION correl

END MODULE FFT_specials


SUBROUTINE ludcmp_sp(a,indx,d)
  use mo_kind,   ONLY : i4, sp
  use mo_nrutil, ONLY : assert_eq,imaxloc,nrerror,outerprod,swap
  IMPLICIT NONE
  REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a
  INTEGER(I4), DIMENSION(:), INTENT(OUT) :: indx
  REAL(SP), INTENT(OUT) :: d
  REAL(SP), DIMENSION(size(a,1)) :: vv
  REAL(SP), PARAMETER :: TINY=1.0e-20_sp
  INTEGER(I4) :: j,n,imax
  n=assert_eq(size(a,1),size(a,2),size(indx),'ludcmp')
  d=1.0_sp
  vv=maxval(abs(a),dim=2)
  if (any(vv == 0.0)) call nrerror('singular matrix in ludcmp')
  vv=1.0_sp/vv
  do j=1,n
     imax=(j-1)+imaxloc(vv(j:n)*abs(a(j:n,j)))
     if (j /= imax) then
        call swap(a(imax,:),a(j,:))
        d=-d
        vv(imax)=vv(j)
     end if
     indx(j)=imax
     if (a(j,j) == 0.0) a(j,j)=TINY
     a(j+1:n,j)=a(j+1:n,j)/a(j,j)
     a(j+1:n,j+1:n)=a(j+1:n,j+1:n)-outerprod(a(j+1:n,j),a(j,j+1:n))
  end do
END SUBROUTINE ludcmp_sp

SUBROUTINE ludcmp_dp(a,indx,d)
  use mo_kind,   ONLY : i4, dp
  use mo_nrutil, ONLY : assert_eq,imaxloc,nrerror,outerprod,swap
  IMPLICIT NONE
  REAL(DP), DIMENSION(:,:), INTENT(INOUT) :: a
  INTEGER(I4), DIMENSION(:), INTENT(OUT) :: indx
  REAL(DP), INTENT(OUT) :: d
  REAL(DP), DIMENSION(size(a,1)) :: vv
  REAL(DP), PARAMETER :: TINY=1.0e-20_dp
  INTEGER(I4) :: j,n,imax
  n=assert_eq(size(a,1),size(a,2),size(indx),'ludcmp')
  d=1.0_dp
  vv=maxval(abs(a),dim=2)
  if (any(vv == 0.0)) call nrerror('singular matrix in ludcmp')
  vv=1.0_dp/vv
  do j=1,n
     imax=(j-1)+imaxloc(vv(j:n)*abs(a(j:n,j)))
     if (j /= imax) then
        call swap(a(imax,:),a(j,:))
        d=-d
        vv(imax)=vv(j)
     end if
     indx(j)=imax
     if (a(j,j) == 0.0) a(j,j)=TINY
     a(j+1:n,j)=a(j+1:n,j)/a(j,j)
     a(j+1:n,j+1:n)=a(j+1:n,j+1:n)-outerprod(a(j+1:n,j),a(j,j+1:n))
  end do
END SUBROUTINE ludcmp_dp


SUBROUTINE SubmergedBar_2D(FineGrid,x0,GhostGridX)
!
! Define bottom and bottom gradients for submerged bar test (2D)
!
! By Allan P. Engsig-Karup.
USE Precision
USE Constants
USE DataTypes
IMPLICIT NONE
TYPE (Level_def) :: FineGrid
REAL(KIND=long)  :: x,x0
INTEGER :: Nx, i, j, GhostGridX

Nx = FineGrid%Nx+2*GhostGridX
j=1

DO i = 1 , Nx
  	x = FineGrid%x(i,j)-x0
    IF (x<=6.0_long) THEN
        FineGrid%h(i,j)   = 0.4_long
        FineGrid%hx(i,j)  = zero
        FineGrid%hxx(i,j) = zero
    ELSE IF (x<=12.0_long) THEN
        FineGrid%h(i,j)   = 0.4_long - 1.0_long/20.0_long*(x-6.0_long)
        FineGrid%hx(i,j)  = -1.0_long/20.0_long
        FineGrid%hxx(i,j) = zero
    ELSE IF (x<=14.0_long) THEN
        FineGrid%h(i,j)   = 0.1_long
        FineGrid%hx(i,j)  = zero
        FineGrid%hxx(i,j) = zero
    ELSE IF (x<=17.0_long) THEN
        FineGrid%h(i,j)   = 0.1_long + 1.0_long/10.0_long*(x-14.0_long)
        FineGrid%hx(i,j)  = 1.0_long/10.0_long
        FineGrid%hxx(i,j) = zero
    ELSE
        FineGrid%h(i,j)   = 0.4_long
        FineGrid%hx(i,j)  = zero
        FineGrid%hxx(i,j) = zero
    ENDIF
END DO

END SUBROUTINE SubmergedBar_2D


MODULE module_rectangle

    IMPLICIT NONE

CONTAINS

    REAL FUNCTION rectagle_area( side_a_length , side_b_length )
        IMPLICIT NONE
        REAL, INTENT(IN) :: side_a_length
        REAL, INTENT(IN) :: side_b_length

        rectagle_area=side_a_length*side_b_length
    END FUNCTION

    REAL FUNCTION rectagle_perimeter( side_a_length , side_b_length )
        IMPLICIT NONE
        REAL, INTENT(IN) :: side_a_length
        REAL, INTENT(IN) :: side_b_length

        rectagle_perimeter=2*side_a_length+2*side_b_length
    END FUNCTION

END MODULE module_rectangle


\ Using Algorithm in http://en.wikipedia.org/wiki/Sieve_of_Eratosthenes
\ by yap yapcheahshen@gmail.com 2008.1.23

: n 1024 ;                                     \ find all prime below N
: sqrt 0 swap 0 do 1 + dup 2 * 1 + +loop ;  \ square root
create buffer n allot                           \ buffer to hold numbers
buffer n 255 fill                    \ initial value, all numbers are prime

\ sieve ( r -- )  remove all proper multiply of r ,
\ which are r*2, r*3, r*4 ... r*m < n
: sieve n over dup + do 0 i buffer + c! dup +loop drop ;

\ sieve all number less than square root of N
: eratosthenes n sqrt 2 do buffer i + c@ if i sieve then loop ;

: prime eratosthenes n 2 do buffer i + c@ if i . then loop ;
.( Prime numbers below ) n . cr prime


    MODULE random_binomial_mod
! .. Implicit None Statement ..
      IMPLICIT NONE
! ..
    CONTAINS

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

      FUNCTION random_binomial(n,pr)
!**********************************************************************
!     INTEGER FUNCTION IGNBIN( N, pr )
!                    GENerate BINomial random deviate
!                              Function
!     Generates a single random deviate from a binomial
!     distribution whose number of trials is N and whose
!     probability of an event in each trial is P.
!                              Arguments
!     N  --> The number of trials in the binomial distribution
!            from which a random deviate is to be generated.
!                              INTEGER N
!     JJV                      (N >= 0)
!     pr --> The probability of an event in each trial of the
!            binomial distribution from which a random deviate
!            is to be generated.
!                              REAL pr
!     JJV                      (0.0 <= pr <= 1.0)
!     IGNBIN <-- A random deviate yielding the number of events
!                from N independent trials, each of which has
!                a probability of event P.
!                              INTEGER IGNBIN
!                              Note
!     Uses RANF so the value of the seeds, ISEED1 and ISEED2 must be set
!     by a call similar to the following
!          DUM = RANSET( ISEED1, ISEED2 )
!                              Method
!     This is algorithm BTPE from:
!         Kachitvichyanukul, V. and Schmeiser, B. W.
!         Binomial Random Variate Generation.
!         Communications of the ACM, 31, 2
!         (February, 1988) 216.
!**********************************************************************
!     SUBROUTINE BTPEC(N,pr,ISEED,JX)
!     BINOMIAL RANDOM VARIATE GENERATOR
!     MEAN .LT. 30 -- INVERSE CDF
!       MEAN .GE. 30 -- ALGORITHM BTPE:  ACCEPTANCE-REJECTION VIA
!       FOUR REGION COMPOSITION.  THE FOUR REGIONS ARE A TRIANGLE
!       (SYMMETRIC IN THE CENTER), A PAIR OF PARALLELOGRAMS (ABOVE
!       THE TRIANGLE), AND EXPONENTIAL LEFT AND RIGHT TAILS.
!     BTPE REFERS TO BINOMIAL-TRIANGLE-PARALLELOGRAM-EXPONENTIAL.
!     BTPEC REFERS TO BTPE AND "COMBINED."  THUS BTPE IS THE
!       RESEARCH AND BTPEC IS THE IMPLEMENTATION OF A COMPLETE
!       USABLE ALGORITHM.
!     REFERENCE:  VORATAS KACHITVICHYANUKUL AND BRUCE SCHMEISER,
!       "BINOMIAL RANDOM VARIATE GENERATION,"
!       COMMUNICATIONS OF THE ACM, FORTHCOMING
!     WRITTEN:  SEPTEMBER 1980.
!       LAST REVISED:  MAY 1985, JULY 1987
!     REQUIRED SUBPROGRAM:  RAND() -- A UNIFORM (0,1) RANDOM NUMBER
!                           GENERATOR
!     ARGUMENTS
!       N : NUMBER OF BERNOULLI TRIALS            (INPUT)
!       pr : PROBABILITY OF SUCCESS IN EACH TRIAL (INPUT)
!       ISEED:  RANDOM NUMBER SEED                (INPUT AND OUTPUT)
!       JX:  RANDOMLY GENERATED OBSERVATION       (OUTPUT)
!     VARIABLES
!       PSAVE: VALUE OF pr FROM THE LAST CALL TO BTPEC
!       NSAVE: VALUE OF N FROM THE LAST CALL TO BTPEC
!       XNP:  VALUE OF THE MEAN FROM THE LAST CALL TO BTPEC
!       P: PROBABILITY USED IN THE GENERATION PHASE OF BTPEC
!       FFM: TEMPORARY VARIABLE EQUAL TO XNP + P
!       M:  INTEGER VALUE OF THE CURRENT MODE
!       FM:  FLOATING POINT VALUE OF THE CURRENT MODE
!       XNPQ: TEMPORARY VARIABLE USED IN SETUP AND SQUEEZING STEPS
!       P1:  AREA OF THE TRIANGLE
!       C:  HEIGHT OF THE PARALLELOGRAMS
!       XM:  CENTER OF THE TRIANGLE
!       XL:  LEFT END OF THE TRIANGLE
!       XR:  RIGHT END OF THE TRIANGLE
!       AL:  TEMPORARY VARIABLE
!       XLL:  RATE FOR THE LEFT EXPONENTIAL TAIL
!       XLR:  RATE FOR THE RIGHT EXPONENTIAL TAIL
!       P2:  AREA OF THE PARALLELOGRAMS
!       P3:  AREA OF THE LEFT EXPONENTIAL TAIL
!       P4:  AREA OF THE RIGHT EXPONENTIAL TAIL
!       U:  A U(0,P4) RANDOM VARIATE USED FIRST TO SELECT ONE OF THE
!           FOUR REGIONS AND THEN CONDITIONALLY TO GENERATE A VALUE
!           FROM THE REGION
!       V:  A U(0,1) RANDOM NUMBER USED TO GENERATE THE RANDOM VALUE
!           (REGION 1) OR TRANSFORMED INTO THE VARIATE TO ACCEPT OR
!           REJECT THE CANDIDATE VALUE
!       IX:  INTEGER CANDIDATE VALUE
!       X:  PRELIMINARY CONTINUOUS CANDIDATE VALUE IN REGION 2 LOGIC
!           AND A FLOATING POINT IX IN THE ACCEPT/REJECT LOGIC
!       K:  ABSOLUTE VALUE OF (IX-M)
!       F:  THE HEIGHT OF THE SCALED DENSITY FUNCTION USED IN THE
!           ACCEPT/REJECT DECISION WHEN BOTH M AND IX ARE SMALL
!           ALSO USED IN THE INVERSE TRANSFORMATION
!       R: THE RATIO P/Q
!       G: CONSTANT USED IN CALCULATION OF PROBABILITY
!       MP:  MODE PLUS ONE, THE LOWER INDEX FOR EXPLICIT CALCULATION
!            OF F WHEN IX IS GREATER THAN M
!       IX1:  CANDIDATE VALUE PLUS ONE, THE LOWER INDEX FOR EXPLICIT
!             CALCULATION OF F WHEN IX IS LESS THAN M
!       I:  INDEX FOR EXPLICIT CALCULATION OF F FOR BTPE
!       AMAXP: MAXIMUM ERROR OF THE LOGARITHM OF NORMAL BOUND
!       YNORM: LOGARITHM OF NORMAL BOUND
!       ALV:  NATURAL LOGARITHM OF THE ACCEPT/REJECT VARIATE V
!       X1,F1,Z,W,Z2,X2,F2, AND W2 ARE TEMPORARY VARIABLES TO BE
!       USED IN THE FINAL ACCEPT/REJECT TEST
!       QN: PROBABILITY OF NO SUCCESS IN N TRIALS
!     REMARK
!       IX AND JX COULD LOGICALLY BE THE SAME VARIABLE, WHICH WOULD
!       SAVE A MEMORY POSITION AND A LINE OF CODE.  HOWEVER, SOME
!       COMPILERS (E.G.,CDC MNF) OPTIMIZE BETTER WHEN THE ARGUMENTS
!       ARE NOT INVOLVED.
!     ISEED NEEDS TO BE DOUBLE PRECISION IF THE IMSL ROUTINE
!     GGUBFS IS USED TO GENERATE UNIFORM RANDOM NUMBER, OTHERWISE
!     TYPE OF ISEED SHOULD BE DICTATED BY THE UNIFORM GENERATOR
!**********************************************************************
!*****DETERMINE APPROPRIATE ALGORITHM AND WHETHER SETUP IS NECESSARY
!     JJV ..
!     JJV .. Save statement ..
!     JJV I am including the variables in data statements
!     JJV made these ridiculous starting values - the hope is that
!     JJV no one will call this the first time with them as args
! .. Use Statements ..
        USE random_standard_uniform_mod
! ..
! .. Implicit None Statement ..
        IMPLICIT NONE
! ..
! .. Function Return Value ..
        INTEGER :: random_binomial
! ..
! .. Scalar Arguments ..
        REAL, INTENT (IN) :: pr
        INTEGER, INTENT (IN) :: n
! ..
! .. Local Scalars ..
        REAL :: al, alv, amaxp, f, f1, f2, ffm, u, v, w, w2, x, x1, x2, &
          ynorm, z, z2
        REAL, SAVE :: c, fm, g, p, p1, p2, p3, p4, psave, q, qn, r, xl, &
          xll, xlr, xm, xnp, xnpq, xr
        INTEGER :: i, ix, ix1, k, mp
        INTEGER, SAVE :: m, nsave
! ..
! .. Intrinsic Functions ..
        INTRINSIC ABS, ALOG, AMIN1, IABS, INT, SQRT
! ..
! .. Data Statements ..
        DATA psave, nsave/ -1.0E37, -214748365/
! ..
! .. Executable Statements ..

        IF (pr==psave) THEN
          IF (n/=nsave) GO TO 10
          IF (xnp-30.<0.) GO TO 50
          GO TO 20
        END IF

!*****SETUP, PERFORM ONLY WHEN PARAMETERS CHANGE

!     JJV added the argument checker - involved only renaming 10
!     JJV and 20 to the checkers and adding checkers
!     JJV Only remaining problem - if called initially with the
!     JJV initial values of psave and nsave, it will hang
        IF (pr<0.0) STOP 'pr < 0.0 in IGNBIN - ABORT!'
        IF (pr>1.0) STOP 'pr > 1.0 in IGNBIN - ABORT!'
        psave = pr
        p = AMIN1(psave,1.-psave)
        q = 1. - p
10      CONTINUE
        IF (n<0) STOP 'N < 0 in IGNBIN - ABORT!'
        xnp = n*p
        nsave = n
        IF (xnp<30.) GO TO 40
        ffm = xnp + p
        m = ffm
        fm = m
        xnpq = xnp*q
        p1 = INT(2.195*SQRT(xnpq)-4.6*q) + 0.5
        xm = fm + 0.5
        xl = xm - p1
        xr = xm + p1
        c = 0.134 + 20.5/(15.3+fm)
        al = (ffm-xl)/(ffm-xl*p)
        xll = al*(1.+0.5*al)
        al = (xr-ffm)/(xr*q)
        xlr = al*(1.+0.5*al)
        p2 = p1*(1.+c+c)
        p3 = p2 + c/xll
        p4 = p3 + c/xlr
!      WRITE(6,100) N,P,P1,P2,P3,P4,XL,XR,XM,FM
!  100 FORMAT(I15,4F18.7/5F18.7)

!*****GENERATE VARIATE

20      CONTINUE
        u = random_standard_uniform()*p4
        v = random_standard_uniform()

!     TRIANGULAR REGION

        IF (u<=p1) THEN
          ix = xm - p1*v + u
          GO TO 70
        END IF

!     PARALLELOGRAM REGION

        IF (u<=p2) THEN
          x = xl + (u-p1)/c
          v = v*c + 1. - ABS(xm-x)/p1
          IF (v>1. .OR. v<=0.) GO TO 20
          ix = x
        ELSE

!     LEFT TAIL

          IF (u<=p3) THEN
            ix = xl + ALOG(v)/xll
            IF (ix<0) GO TO 20
            v = v*(u-p2)*xll
          ELSE

!     RIGHT TAIL

            ix = xr - ALOG(v)/xlr
            IF (ix>n) GO TO 20
            v = v*(u-p3)*xlr

!*****DETERMINE APPROPRIATE WAY TO PERFORM ACCEPT/REJECT TEST

          END IF
        END IF
        k = IABS(ix-m)
        IF (k<=20 .OR. k>=xnpq/2-1) THEN

!     EXPLICIT EVALUATION

          f = 1.0
          r = p/q
          g = (n+1)*r
          IF (m-ix<=0) THEN
            IF (m-ix==0) GO TO 30
            mp = m + 1
            DO i = mp, ix
              f = f*(g/i-r)
            END DO
            GO TO 30
          END IF

          ix1 = ix + 1
          DO i = ix1, m
            f = f/(g/i-r)
          END DO
30        CONTINUE
          IF (v-f>0.) GO TO 20
          GO TO 70
        END IF

!     SQUEEZING USING UPPER AND LOWER BOUNDS ON ALOG(F(X))

        amaxp = (k/xnpq)*((k*(k/3.+0.625)+0.1666666666666)/xnpq+0.5)
        ynorm = -k*k/(2.*xnpq)
        alv = ALOG(v)
        IF (alv<ynorm-amaxp) GO TO 70
        IF (alv>ynorm+amaxp) GO TO 20

!     STIRLING'S FORMULA TO MACHINE ACCURACY FOR
!     THE FINAL ACCEPTANCE/REJECTION TEST

        x1 = ix + 1
        f1 = fm + 1.
        z = n + 1 - fm
        w = n - ix + 1.
        z2 = z*z
        x2 = x1*x1
        f2 = f1*f1
        w2 = w*w
        IF (alv-(xm*ALOG(f1/x1)+(n-m+0.5)*ALOG(z/w)+(ix-m)*ALOG(w*p/(x1*q &
          ))+(13860.-(462.-(132.-(99.-140./f2)/f2)/f2)/f2)/f1/166320.+( &
          13860.-(462.-(132.-(99.-140./z2)/z2)/z2)/z2)/z/166320.+(13860.- &
          (462.-(132.-(99.-140./x2)/x2)/x2)/x2)/x1/166320.+(13860.-(462.- &
          (132.-(99.-140./w2)/w2)/w2)/w2)/w/166320.)>0.) GO TO 20
        GO TO 70

!     INVERSE CDF LOGIC FOR MEAN LESS THAN 30

40      CONTINUE
        qn = q**n
        r = p/q
        g = r*(n+1)
50      CONTINUE
        ix = 0
        f = qn
        u = random_standard_uniform()
60      CONTINUE
        IF (u<f) GO TO 70
        IF (ix>110) GO TO 50
        u = u - f
        ix = ix + 1
        f = f*(g/ix-r)
        GO TO 60

70      CONTINUE
        IF (psave>0.5) ix = n - ix
        random_binomial = ix
        RETURN

      END FUNCTION random_binomial

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

    END MODULE random_binomial_mod


module algebra

public :: normalize
public :: dot_product
public :: cross_product
public :: rotate_vector_angle_axis
public :: rotate_matrix_angle_axis
public :: jacobi
public :: eig_sort
public :: mean
public :: stdev
public :: coefvar

!--------------------------------------------------------------------------------------------------!
contains
!--------------------------------------------------------------------------------------------------!

subroutine normalize(vector)
implicit none
double precision :: vector(3)
double precision :: magnitude
magnitude = sqrt(vector(1)*vector(1)+vector(2)*vector(2)+vector(3)*vector(3))
vector = vector/magnitude
return
end

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

subroutine dot_product(vec1,vec2,dot)
implicit none
double precision :: vec1(3), vec2(3)
double precision :: dot
dot = vec1(1)*vec2(1) + vec1(2)*vec2(2) + vec1(3)*vec2(3)
return
end subroutine

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

subroutine cross_product(vec1,vec2,cross)
implicit none
double precision :: vec1(3), vec2(3)
double precision :: cross(3)
cross(1) = vec1(2)*vec2(3) - vec1(3)*vec2(2)
cross(2) = vec1(3)*vec2(1) - vec1(1)*vec2(3)
cross(3) = vec1(1)*vec2(2) - vec1(2)*vec2(1)
return
end subroutine

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

subroutine rotate_vector_angle_axis(vec_in,angle,axis,vec_out,ierr)
!----
! Rotate a vector counter-clockwise through a coordinate system by an angle (in degrees) about an
! axis of the coordinate system.
!----

use io, only: stderr
use trig, only: d2r

implicit none

! Arguments
double precision :: vec_in(3), angle
double precision :: vec_out(3)
character(len=*) :: axis
integer          :: ierr

! Local variables
double precision :: vec_tmp(3), rot_matrix(3,3), cosa, sina

! Initialize error
ierr = 0

! Cosine and sine of angle
cosa = cos(angle*d2r)
sina = sin(angle*d2r)

vec_tmp = vec_in

! Build the rotation matrix
rot_matrix = 0.0d0
if (axis.eq.'x') then
    rot_matrix(1,1) = 1.0d0
    rot_matrix(2,2) =  cosa
    rot_matrix(3,3) =  cosa
    rot_matrix(2,3) = -sina
    rot_matrix(3,2) =  sina
elseif (axis.eq.'y') then
    rot_matrix(2,2) = 1.0d0
    rot_matrix(3,3) =  cosa
    rot_matrix(1,1) =  cosa
    rot_matrix(3,1) = -sina
    rot_matrix(1,3) =  sina
elseif (axis.eq.'z') then
    rot_matrix(3,3) = 1.0d0
    rot_matrix(1,1) =  cosa
    rot_matrix(2,2) =  cosa
    rot_matrix(1,2) = -sina
    rot_matrix(2,1) =  sina
else
    write(stderr,*) 'rotate_vector_angle_axis: no axis named "',trim(axis),'"'
    ierr = 1
    return
endif

! Multiply matrix and input vector to get rotated vector
vec_out(1) = rot_matrix(1,1)*vec_tmp(1) + rot_matrix(1,2)*vec_tmp(2) + rot_matrix(1,3)*vec_tmp(3)
vec_out(2) = rot_matrix(2,1)*vec_tmp(1) + rot_matrix(2,2)*vec_tmp(2) + rot_matrix(2,3)*vec_tmp(3)
vec_out(3) = rot_matrix(3,1)*vec_tmp(1) + rot_matrix(3,2)*vec_tmp(2) + rot_matrix(3,3)*vec_tmp(3)

return
end subroutine

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

subroutine rotate_matrix_angle_axis(matrix_in,angle,axis,matrix_out,ierr)
!----
! Rotate a matrix counter-clockwise through a coordinate system by an angle (in degrees) about an
! axis of the coordinate system.
!----

use io, only: stderr
use trig, only: d2r

implicit none

! Arguments
double precision :: matrix_in(3,3), angle
double precision :: matrix_out(3,3)
character(len=*) :: axis
integer          :: ierr

! Local variables
double precision :: rot_matrix(3,3), rot_matrix_trans(3,3), matrix_tmp(3,3), cosa, sina
integer :: i, j

! Initialize error
ierr = 0

! Cosine and sine of angle
cosa = cos(angle*d2r)
sina = sin(angle*d2r)

! Build the rotation matrix
rot_matrix = 0.0d0
if (axis.eq.'x') then
    rot_matrix(1,1) = 1.0d0
    rot_matrix(2,2) =  cosa
    rot_matrix(3,3) =  cosa
    rot_matrix(2,3) = -sina
    rot_matrix(3,2) =  sina
elseif (axis.eq.'y') then
    rot_matrix(2,2) = 1.0d0
    rot_matrix(3,3) =  cosa
    rot_matrix(1,1) =  cosa
    rot_matrix(3,1) = -sina
    rot_matrix(1,3) =  sina
elseif (axis.eq.'z') then
    rot_matrix(3,3) = 1.0d0
    rot_matrix(1,1) =  cosa
    rot_matrix(2,2) =  cosa
    rot_matrix(1,2) = -sina
    rot_matrix(2,1) =  sina
else
    write(stderr,*) 'rotate_matrix_angle_axis: no axis named "',trim(axis),'"'
    ierr = 1
    return
endif

! And its transpose (inverse)
rot_matrix_trans = rot_matrix
rot_matrix_trans(1,2) = rot_matrix(2,1)
rot_matrix_trans(1,3) = rot_matrix(3,1)
rot_matrix_trans(2,1) = rot_matrix(1,2)
rot_matrix_trans(2,3) = rot_matrix(3,2)
rot_matrix_trans(3,1) = rot_matrix(1,3)
rot_matrix_trans(3,2) = rot_matrix(2,3)

! Multiply input matrix by rotation matrix and transpose to get rotated matrix: R*M*RT
do i = 1,3
    do j = 1,3
        matrix_tmp(i,j) = rot_matrix(i,1)*matrix_in(1,j) + &
                          rot_matrix(i,2)*matrix_in(2,j) + &
                          rot_matrix(i,3)*matrix_in(3,j)
    enddo
enddo
do i = 1,3
    do j = 1,3
        matrix_out(i,j) = matrix_tmp(i,1)*rot_matrix_trans(1,j) + &
                          matrix_tmp(i,2)*rot_matrix_trans(2,j) + &
                          matrix_tmp(i,3)*rot_matrix_trans(3,j)
    enddo
enddo

return
end subroutine

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

subroutine jacobi(a,n,np,d,v,nrot,ierr)
!----
! Computes all eigenvalues and eigenvectors of a real symmetric matrix a, which is of size n by n,
! stored in a physical np by np array. On output, elements of a above the diagonal are destroyed. d
! returns the eigenvalues of a in its first n elements. v is a matrix with the same logical and
! physical dimensions as a, whose columns contain, on output, the normalized eigenvectors of a.
! nrot returns the number of Jacobi rotations that were required.
!
! Numerical Recipes (Press et al.)
!----

use io, only: stderr

implicit none

! Arguments
integer :: n, np
integer :: nrot, ierr
double precision :: a(np,np), d(np), v(np,np)

! Local variables
integer, parameter :: NMAX = 500
integer :: i, ip, iq, j
double precision :: c, g, h, s, sm, t, tau, theta, tresh, b(NMAX), z(NMAX)
double precision, parameter :: eps = 1.0d-12

ierr = 0

! Initialize v to the identity matrix
v = 0.0d0
do ip = 1,n
    v(ip,ip) = 1.0d0
enddo

! Initialize b and d to the diagonal of a
! Vector z will accumulate terms of the form tapq as in equation (11.1.14)
do ip = 1,n
    b(ip) = a(ip,ip)
    d(ip) = b(ip)
    z(ip) = 0.0d0
enddo

nrot = 0
do i = 1,50

    ! Sum off-diagonal elements
    sm = 0.0d0
    do ip = 1,n-1
        do iq = ip+1,n
            sm = sm + abs(a(ip,iq))
        enddo
    enddo

    ! The normal return, which relies on quadratic convergence
    if (abs(sm).lt.eps) then
        return
    endif

    if (i.lt.4) then
        tresh = 0.2d0*sm/n**2
    else
        tresh = 0.0d0
    endif

    do ip = 1,n-1
        do iq = ip+1,n

            g = 100.0d0*abs(a(ip,iq))

            ! After four sweeps, skip the rotation if the off-diagonal element is small
            if ((i.gt.4) .and. abs(g).lt.eps) then
                a(ip,iq) = 0.0d0
            elseif (abs(a(ip,iq)).gt.tresh) then
                h = d(iq)-d(ip)
                if (abs(g).lt.eps) then
                    t = a(ip,iq)/h  ! t = 1/(2theta)
                else
                    theta = 0.5d0*h/a(ip,iq) !Equation (11.1.10)
                    t = 1.0d0/(abs(theta)+sqrt(1.0d0+theta**2))
                    if (theta.lt.0.0d0) then
                        t = -t
                    endif
                endif
                c = 1.0d0/sqrt(1.0d0+t**2)
                s = t*c
                tau = s/(1.0d0+c)
                h = t*a(ip,iq)
                z(ip) = z(ip)-h
                z(iq) = z(iq)+h
                d(ip) = d(ip)-h
                d(iq) = d(iq)+h
                a(ip,iq) = 0.0d0
                do j = 1,ip-1 ! Case of rotations 1 < j < p
                    g = a(j,ip)
                    h = a(j,iq)
                    a(j,ip) = g-s*(h+g*tau)
                    a(j,iq) = h+s*(g-h*tau)
                enddo
                do j = ip+1,iq-1 !Case of rotations p < j < q
                    g = a(ip,j)
                    h = a(j,iq)
                    a(ip,j) = g-s*(h+g*tau)
                    a(j,iq) = h+s*(g-h*tau)
                enddo
                do j = iq+1,n !Case of rotations q < j ≤ n
                    g = a(ip,j)
                    h = a(iq,j)
                    a(ip,j) = g-s*(h+g*tau)
                    a(iq,j) = h+s*(g-h*tau)
                enddo
                do j = 1,n
                    g = v(j,ip)
                    h = v(j,iq)
                    v(j,ip) = g-s*(h+g*tau)
                    v(j,iq) = h+s*(g-h*tau)
                enddo
                nrot = nrot + 1
            endif
        enddo
    enddo

    ! Update d with the sum of tapq, and reinitialize z
    do ip = 1,n
        b(ip) = b(ip)+z(ip)
        d(ip) = b(ip)
        z(ip) = 0.0d0
    enddo
enddo

write(stderr,*) 'Warning: jacobi: too many iterations'
ierr = 1

return
end subroutine

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

subroutine eig_sort(d,v,n,np)
!----
! Given the eigenvalues d and eigenvectors v as output from jacobi, this routine sorts the
! eigenvalues into ascending order, and rearranges the columns of v correspondingly. The method
! is straight insertion.
!
! Numerical Recipes (Press et al.)
!----

implicit none

! Arguments
integer          :: n, np
double precision :: d(np), v(np,np)

! local variables
integer :: i, j, k
double precision :: p

do i = 1,n-1
    k = i
    p = d(i)
    do j = i+1,n
        if (d(j).le.p) then
            k = j
            p = d(j)
        endif
    enddo
    if (k.ne.i) then
        d(k) = d(i)
        d(i) = p
        do j = 1,n
            p = v(j,i)
            v(j,i) = v(j,k)
            v(j,k) = p
        enddo
    endif
enddo

return
end subroutine

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

function mean(values,nvalues,ierr)
!----
! Calculate mean of a set of values
!----

implicit none

! Arguments
integer          :: nvalues
integer          :: ierr
double precision :: values(nvalues)
double precision :: mean

! Local variables
integer :: i

! Initialize variables
ierr = 0
mean = 0.0d0

! Calculate sum of values
do i = 1,nvalues
    mean = mean + values(i)
enddo

! Divide by number of values
mean = mean/dble(nvalues)

return
end function

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

function stdev(values,nvalues,ierr)
!----
! Calculate standard deviation of a set of values
!----

implicit none

! Arguments
integer :: nvalues
integer :: ierr
double precision :: values(nvalues)
double precision :: stdev

! Local variables
integer :: i
double precision :: m

! Initialize variables
ierr = 0
stdev = 0.0d0

! Calculate mean
m = mean(values,nvalues,ierr)

! Calculate sum of differences squared
do i = 1,nvalues
    stdev = stdev + (values(i)-m)**2
enddo

! Divide by number of values, take square root
stdev = sqrt(stdev/dble(nvalues-1))

return
end function

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

function coefvar(values,nvalues,ierr)
!----
! Calculate coefficient of variation (standard deviation divided by mean) of a set of values
!----

implicit none

! Arguments
integer          :: nvalues
integer          :: ierr
double precision :: values(nvalues)
double precision :: coefvar

! Local variables
double precision :: s, m
double precision, parameter :: eps = 1.0d-30

! Initialize variables
ierr = 0
coefvar = 0.0d0

! Calculate mean
m = mean(values,nvalues,ierr)
if (abs(m).lt.eps) then
    return
    ierr = 1
endif

! Calculate standard deviation
s = stdev(values,nvalues,ierr)

! Divide standard devation by mean
coefvar = s/m

return
end function

end module


program tquadgs

!   David H. Bailey     28 April 2018

!  COPYRIGHT AND DISCLAIMER:
!    All software in this package (c) 2018 David H. Bailey.
!    By downloading or using this software you agree to the copyright, disclaimer
!    and license agreement in the accompanying file DISCLAIMER.txt.

!   NOTE: This program runs very long (800 seconds with MPFUN-MPFR or 2800
!   seconds with MPFUN-Fort, on the author's computer), compared with tquad.f90
!   and the other sample application programs. For this reason it is NOT
!   included in the script mpfun-tests.scr.

!   This program demonstrates the quadrature routine 'quadgs', which employs
!   Gaussian quadrature. The function quadgs is suitable to integrate a
!   function that is continuous, infinitely differentiable and integrable on an
!   open interval containing the given finite interval. It can also be used for
!   integrals on the entire real line, by making a variable transformation,
!   which can be achieved by merely computing a modified set of weights and
!   abscissas -- see subroutine initqgs and the examples below.

!   The quadrature computation proceeds level-by-level, with the computational
!   cost (and, often, the accuracy) approximately doubling with each iteration,
!   until a target accuracy (500-digit precision in this case), based on an
!   accuracy estimate computed by the program, is achieved. In most cases
!   quadgs is significantly faster than quadts (tanh-sinh quadrature) for
!   regular functions on finite intervals. However, quadgs is not effective
!   in cases where the function or one of its higher-order derivatives has a
!   singularity at one or both endpoints. Also, the computational cost of
!   generating weight-abscissa data in quadgs is MUCH greater than for quadts,
!   quades or quadss; on the other hand, these data can be computed once and
!   stored in a file -- see below. For additional details on Gaussian
!   quadrature versus tanh-sinh schemes, see:

!   David H. Bailey, Xiaoye S. Li and Karthik Jeyabalan, "A comparison of
!   three high-precision quadrature schemes," Experimental Mathematics,
!   vol. 14 (2005), no. 3, pg. 317-329, preprint available at
!   http://www.davidhbailey.com/dhbpapers/quadrature-em.pdf.

!   The function to be integrated must be defined in an external function
!   subprogram (see samples below), and the name of the function must be
!   included in a "type (mp_real)" and an "external" statement. Prior to
!   calling the quadrature routine, the initialization routine initgs must
!   be called to initialize the weight-abscissa arrays wkgs, xkgs, wkgu and
!   xkgu, or else these arrays must be read from a file -- see idata  below.

!   All of these routines are 100% THREAD SAFE -- all requisite parameters
!   and arrays are passed through subroutine arguments.

!   Specific instructions:

!   First call initqgs with the arrays wkgs, xkgs, xkgu and xkgu as the last
!   four arguments. The initialization routine initqgs may run for a long
!   time, depending on precision: for nq1 = 11 and ndp1 = 500, initqgs runs
!   12 minutes on the author's computer. In the code below, one has the option
!   of calling initqgs and then writing wkgs, xkgs, wkgu and xkgu to a file,
!   or else reading the previously computed arrays from a file -- see the
!   parameter idata.

!   For finite interval problems, call quadgs with the arrays wkgs and xkgs
!   as the last two arguments. Set x1 and x2, the limits of integration,
!   in executable statements, using high precision (nwds2 words) if possible.
!   Note in the examples below, x1 and x2 and set using high-precision values
!   of zero, one and pi (the variables zero, one and mppic). Using high
!   precision values for x1 and x2 facilitates more accurate argument scaling
!   in quadgs and, if necessary, in the function routines. See examples below.

!   For problems over the entire real line, call quadgs with wkgu and xkgu as
!   the last two arguments, and set x1 = -one and x2 = one. See examples below.

!   The problems performed below are a subset of the problems performed in
!   tquad.f90; the problem numbers here correspond to those in tquad.f90.

!   The following inputs are set in the parameter statement below:
!   idata  0: compute abscissas and weights from scratch and write to file
!             before performing quadrature problems.
!          1: read abscissas and weights from a file.
!          By default, idata = 0; the file name is "gauss-mm-nnnn.dat", where
!          "mm" is the value of nq1 and "nnnn" is the value of ndp1.
!   ndp1   Primary ("low") precision in digits; this is the working precision
!          and also the target accuracy of quadrature results.
!   ndp2   Secondary ("high") precision in digits. By default, ndp2 = 2*ndp1.
!   neps1  Log10 of the primary tolerance. By default, neps1 = - ndp1.
!   neps2  Log10 of the secondary tolerance. By default, neps2 = -ndp2.
!   nq1    Max number of phases in quadrature routine; adding 1 increases
!          (possibly doubles) the number of accurate digits in the result,
!          but also roughly doubles the run time. nq1 must be at least 3.
!   nq2    Space parameter for wk and xk arrays in the calling program.  By
!          default it is set to 6 * 2^nq1 + 100.
!   nwds1  Low precision in words. By default nwds1 = int (ndp1 / mpdpw + 2).
!   nwds2  High precision in words. By default nwds2 = int (ndp2 / mpdpw + 2).

use mpmodule
implicit none
integer i, i1, i2, idata, ndp1, ndp2, neps1, neps2, nq1, nq2, nwds1, nwds2, n1
parameter (idata = 0, ndp1 = 500, ndp2 = 1000, neps1 = -ndp1, neps2 = -ndp2, &
  nq1 = 11, nq2 = 6 * 2 ** nq1 + 100, nwds1 = int (ndp1 / mpdpw + 2), &
  nwds2 = int (ndp2 / mpdpw + 2))
character*32 chr32
real (8) dplog10q, d1, d2, second, tm0, tm1, tm2
type (mp_real) err, quadgs, fun01, fun02, fun03, fun04, &
  fun15, fun16, fun17, fun18, one, t1, t2, t3, t4, wkgs(-1:nq2), xkgs(-1:nq2), &
  wkgu(-1:nq2), xkgu(-1:nq2), zero
type (mp_real) mppic, mpl02, x1, x2
external fun01, fun02, fun03, fun04, fun15, fun16, fun17, fun18, &
  quadgs, second

!   Check to see if default precision is high enough.

if (ndp2 > mpipl) then
  write (6, '("Increase default precision in module MPFUNF.")')
  stop
endif

!   Compute pi and log(2) to high precision (nwds2 words).

one = mpreal (1.d0, nwds2)
zero = mpreal (0.d0, nwds2)
mppic = mppi (nwds2)
mpl02 = mplog2 (nwds2)

write (6, 1) nq1, ndp1, ndp2, neps1, neps2
1 format ('Quadgs test:  Quadlevel =',i6/'Digits1 =',i6,'  Digits2 =',i6, &
  '  Epsilon1 =',i6,'  Epsilon2 =',i6)

!   Initialize weights and abscissas: wkgs, xkgs, wkgu, xkgu.

write (chr32, '("gauss-"i2.2,"-",i4.4,".dat")') nq1, ndp1
open (11, file = chr32)
rewind 11
tm0 = second ()
if (idata == 0) then

!   Generate xkgs, xkgs, wkgu and xkgu from scratch and write to file.

  call initqgs (nq1, nq2, nwds1, wkgs, xkgs, wkgu, xkgu)
  n1 = dble (xkgs(-1))

  do i = -1, n1
    write (11, '(2i6)') i, n1
    call mpwrite (11, ndp1 + 30, ndp1 + 10, wkgs(i), xkgs(i))
    call mpwrite (11, ndp1 + 30, ndp1 + 10, wkgu(i), xkgu(i))
  enddo
else

!   Read xkgs, xkgs, wkgu and xkgu from file.

  open (11, file = chr32)
  rewind 11
  read (11, '(2i6)') i1, i2
  call mpread (11, wkgs(-1), xkgs(-1), nwds1)
  call mpread (11, wkgu(-1), xkgu(-1), nwds1)
  n1 = dble (xkgs(-1))
  if (i1 /= -1 .or. i2 /= n1) stop

  do i = 0, n1
    read (11, '(2i6)') i1, i2
    if (i1 /= i .or. i2 /= n1) stop
    call mpread (11, wkgs(i), xkgs(i), nwds1)
    call mpread (11, wkgu(i), xkgu(i), nwds1)
  enddo
endif
close (11)
tm1 = second ()
tm2 = tm1 - tm0
write (6, 2) tm1 - tm0
2 format ('Quadrature initialization completed: cpu time =',f12.4)

!   Begin quadrature tests.

write (6, 11)
11 format (/'Continuous functions on finite intervals:'//&
  'Problem 1: Int_0^1 t*log(1+t) dt = 1/4'/)
x1 = zero
x2 = one
tm0 = second ()
t1 = quadgs (fun01, x1, x2, nq1, nq2, nwds1, nwds2, neps1, wkgs, xkgs)
tm1 = second ()
tm2 = tm2 + (tm1 - tm0)
write (6, 3) tm1 - tm0
3 format ('Quadrature completed: CPU time =',f12.6/'Result =')
call mpwrite (6, ndp1 + 20, ndp1, t1)
t2 = mpreal (0.25d0, nwds1)
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1
4 format ('Actual error =',f10.6,'x10^',i6)

write (6, 12)
12 format (/'Problem 2: Int_0^1 t^2*arctan(t) dt = (pi - 2 + 2*log(2))/12'/)
x1 = zero
x2 = one
tm0 = second ()
t1 = quadgs (fun02, x1, x2, nq1, nq2, nwds1, nwds2, neps1, wkgs, xkgs)
tm1 = second ()
tm2 = tm2 + (tm1 - tm0)
write (6, 3) tm1 - tm0
call mpwrite (6, ndp1 + 20, ndp1, t1)
t2 = (mppic - 2.d0 + 2.d0 * mpl02) / 12.d0
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 13)
13 format (/'Problem 3: Int_0^(pi/2) e^t*cos(t) dt = 1/2*(e^(pi/2) - 1)'/)
x1 = zero
x2 = 0.5d0 * mppic
tm0 = second ()
t1 = quadgs (fun03, x1, x2, nq1, nq2, nwds1, nwds2, neps1, wkgs, xkgs)
tm1 = second ()
tm2 = tm2 + (tm1 - tm0)
write (6, 3) tm1 - tm0
call mpwrite (6, ndp1 + 20, ndp1, t1)
t2 = 0.5d0 * (exp (0.5d0 * mppic) - 1.d0)
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 14)
14 format (/ &
  'Problem 4: Int_0^1 arctan(sqrt(2+t^2))/((1+t^2)sqrt(2+t^2)) dt = 5*Pi^2/96'/)
x1 = zero
x2 = one
tm0 = second ()
t1 = quadgs (fun04, x1, x2, nq1, nq2, nwds1, nwds2, neps1, wkgs, xkgs)
tm1 = second ()
tm2 = tm2 + (tm1 - tm0)
write (6, 3) tm1 - tm0
call mpwrite (6, ndp1 + 20, ndp1, t1)
t2 = 5.d0 * mppic**2 / 96.d0
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 25)
25 format (/ &
   'Functions on the entire real line:'// &
   'Problem 15: Int_-inf^inf 1/(1+t^2) dt = Pi'/)
x1 = -one
x2 = one
tm0 = second ()
t1 = quadgs (fun15, x1, x2, nq1, nq2, nwds1, nwds2, neps1, wkgu, xkgu)
tm1 = second ()
tm2 = tm2 + (tm1 - tm0)
write (6, 3) tm1 - tm0
call mpwrite (6, ndp1 + 20, ndp1, t1)
t2 = mppic
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 26)
26 format (/'Problem 16: Int_-inf^inf 1/(1+t^4) dt = Pi/Sqrt(2)'/)
x1 = -one
x2 = one
tm0 = second ()
t1 = quadgs (fun16, x1, x2, nq1, nq2, nwds1, nwds2, neps1, wkgu, xkgu)
tm1 = second ()
tm2 = tm2 + (tm1 - tm0)
write (6, 3) tm1 - tm0
call mpwrite (6, ndp1 + 20, ndp1, t1)
t2 = mppic / sqrt (mpreal (2.d0, nwds1))
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 27)
27 format (/'Problem 17: Int_-inf^inf e^(-t^2/2) dt = sqrt (2*Pi)'/)
x1 = -one
x2 = one
tm0 = second ()
t1 = quadgs (fun17, x1, x2, nq1, nq2, nwds1, nwds2, neps1, wkgu, xkgu)
tm1 = second ()
tm2 = tm2 + (tm1 - tm0)
write (6, 3) tm1 - tm0
call mpwrite (6, ndp1 + 20, ndp1, t1)
t2 = sqrt (2.d0 * mppic)
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 28)
28 format (/'Problem 18: Int_-inf^inf e^(-t^2/2) cos(t) dt = sqrt (2*Pi/e)'/)
x1 = -one
x2 = one
tm0 = second ()
t1 = quadgs (fun18, x1, x2, nq1, nq2, nwds1, nwds2, neps1, wkgu, xkgu)
tm1 = second ()
tm2 = tm2 + (tm1 - tm0)
write (6, 3) tm1 - tm0
call mpwrite (6, ndp1 + 20, ndp1, t1)
t2 = sqrt (2.d0 * mppic / exp (mpreal (1.d0, nwds1)))
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 99) tm2
99 format ('Total CPU time =',f12.6)

stop
end

function fun01 (t, nwds1, nwds2)

!   fun01(t) = t * log(1+t)

use mpmodule
implicit none
integer nwds1, nwds2
type (mp_real) fun01, t1, t2
type (mp_real) t

t1 = mpreal (t, nwds1)
fun01 = t1 * log (1.d0 + t1)
return
end

function fun02 (t, nwds1, nwds2)

!   fun02(t) = t^2 * arctan(t)

use mpmodule
implicit none
integer nwds1, nwds2
type (mp_real) fun02, t1
type (mp_real) t

t1 = mpreal (t, nwds1)
fun02 = t1 ** 2 * atan (t1)
return
end

function fun03 (t, nwds1, nwds2)

!   fun03(t) = e^t * cos(t)

use mpmodule
implicit none
integer nwds1, nwds2
type (mp_real) fun03, t1
type (mp_real) t

t1 = mpreal (t, nwds1)
fun03 = exp(t1) * cos(t1)
return
end

function fun04 (t, nwds1, nwds2)

!   fun04(t) = arctan(sqrt(2+t^2))/((1+t^2)sqrt(2+t^2))

use mpmodule
implicit none
integer nwds1, nwds2
type (mp_real) fun04, t1, t2
type (mp_real) t

t1 = mpreal (t, nwds1)
t2 = sqrt (2.d0 + t1**2)
fun04 = atan(t2) / ((1.d0 + t1**2) * t2)
return
end

function fun15 (t, nwds1, nwds2)
use mpmodule
implicit none
integer nwds1, nwds2
type (mp_real) t, fun15

fun15 = 1.d0 / (1.d0 + t**2)
return
end

function fun16 (t, nwds1, nwds2)
use mpmodule
implicit none
integer nwds1, nwds2
type (mp_real) t, fun16

fun16 = 1.d0 / (1.d0 + t**4)
return
end

function fun17 (t, nwds1, nwds2)
use mpmodule
implicit none
integer nwds1, nwds2
type (mp_real) t, fun17

fun17 = exp (-0.5d0 * t**2)
return
end

function fun18 (t, nwds1, nwds2)
use mpmodule
implicit none
integer nwds1, nwds2
type (mp_real) t, fun18

fun18 = exp (-0.5d0 * t**2) * cos (t)
return
end

subroutine initqgs (nq1, nq2, nwds1, wkgs, xkgs, wkgu, xkgu)

!   This subroutine initializes the quadrature arrays wkgs and xkgs for standard
!   Gaussian quadrature, and also wkgu and xkgu for quadrature over the real line.
!   It employs a Newton iteration scheme with a dynamic precision level that
!   approximately doubles with each iteration.  The argument nq2, which is the
!   space allocated for wkgs, xkgs, wkgu and xkgu in the calling program, should
!   be at least 6 * 2^nq1 + 100.

!   The wkgu and xkgu arrays are computed from wkgs and xkgs based on the
!   transformation t = tan (pi/2 * x), which transforms an integral on
!   (-infinity, infinity) to an integral on (-1, 1). In particular,
!     xkgu(i) = tan (pi/2 * xkgs(i))
!     wkgu(i) = pi/2 * wkgs(i) / cos (pi/2 * xkgs(i))^2

!   David H Bailey    28 Apr 2018

use mpmodule
implicit none
integer i, ierror, ik0, iprint, j, j1, k, n, ndebug, nq1, nq2, nwds1, nwp
real (8) dpi
parameter (ik0 = 100, iprint = 1, ndebug = 2, dpi = 3.141592653589793238d0)
type (mp_real) eps, pi2, r, t1, t2, t3, t4, t5, wkgs(-1:nq2), xkgs(-1:nq2), &
  wkgu(-1:nq2), xkgu(-1:nq2), zero

if (ndebug >= 1) then
  write (6, 1)
1 format ('initqgs: Gaussian quadrature initialization')
endif

pi2 = 0.5d0 * mppi (nwds1)
zero = mpreal (0.d0, nwds1)
wkgs(-1) = mpreal (dble (nq1), nwds1)
xkgs(-1) = zero
wkgs(0) = zero
xkgs(0) = zero
wkgs(1) = mpreal (dble (nq1), nwds1)
xkgs(1) = mpreal (dble (ik0), nwds1)
wkgu(-1) = mpreal (dble (nq1), nwds1)
xkgu(-1) = zero
wkgu(0) = zero
xkgu(0) = zero
wkgu(1) = mpreal (dble (nq1), nwds1)
xkgu(1) = mpreal (dble (ik0), nwds1)
i = ik0

do j = 2, ik0
  wkgs(j) = zero
  xkgs(j) = zero
  wkgu(j) = zero
  xkgu(j) = zero
enddo

do k = 1, nq1
  if (ndebug >= 2 .and. mod (k, iprint) == 0) write (6, *) k, i, nq2
  n = 3 * 2 ** (k + 1)

  do j = 1, n / 2

!   Set working precision = 4 words, and compute a DP estimate of the root.

    nwp = 4
    eps = mpreal (2.d0 ** (48 - nwp * mpnbt), nwds1)
    r = mpreald (cos ((dpi * (j - 0.25d0)) / (n + 0.5d0)), nwp)

!   Compute the j-th root of the n-degree Legendre polynomial using Newton's
!   iteration.

100 continue

!   Perform the next 11 lines with working precision nwp words.

    t1 = mpreal (1.d0, nwp)
    t2 = mpreal (0.d0, nwp)
    r = mpreal (r, nwp)

    do j1 = 1, n
      t3 = t2
      t2 = t1
      t1 = ((2 * j1 - 1) * r * t2 - (j1 - 1) * t3) / j1
    enddo

    t4 = n * (r * t1 - t2) / (r ** 2  - 1.d0)
    t5 = r
    r = r - t1 / t4

!   Once convergence is achieved at nwp = 4, then start doubling (almost) the
!   working precision level at each iteration until full precision is reached.

    if (nwp == 4) then
      if (abs (r - t5) > eps) goto 100
      nwp = min (2 * nwp - 1, nwds1)
      goto 100
    elseif (nwp < nwds1) then
      nwp = min (2 * nwp - 1, nwds1)
      goto 100
    endif

    i = i + 1
    if (i > nq2) goto 110
    xkgs(i) = r
    t4 = n * (r * t1 - t2) / (r ** 2  - 1.d0)
    wkgs(i) = 2.d0 / ((1.d0 - r ** 2) * t4 ** 2)
    xkgu(i) = tan (pi2 * r)
    wkgu(i) = pi2 * wkgs(i) / cos (pi2 * r)**2
  enddo

!   Save i (starting index for the next block) in the first 100 elements of
!   xkgs and xkgu.

  xkgs(k+1) = mpreal (dble (i), nwds1)
  xkgu(k+1) = mpreal (dble (i), nwds1)
enddo

!   Save the size of the arrays in index -1 of xkgs and xkgu.

xkgs(-1) = mpreal (dble (i), nwds1)
xkgu(-1) = mpreal (dble (i), nwds1)
if (ndebug >= 2) then
  write (6, 2) i
2 format ('initqgs: Table spaced used =',i8)
endif
goto 130

110 continue

write (6, 3) nq2
3 format ('initqgs: Table space parameter is too small; value =',i8)
stop

130 continue

return
end

function quadgs (fun, x1, x2, nq1, nq2, nwds1, nwds2, neps1, wkgs, xkgs)

!   This routine computes the integral of the function fun on the interval
!   (x1, x2) with a target tolerance of 10^neps1.  The quadrature level is
!   progressively increased (approximately doubling the work with each level)
!   until level nq1 has been performed or the target tolerance has been met.
!   nq2 is the size of the wkgs and xkgs arrays, which must first be initialized
!   by calling initqgs. The function fun is not evaluated at the endpoints
!   x1 and x2.  If quadgs outputs the message "Increase Quadlevel" or "Terms
!   too large", adjust nq1 and neps2 as necessary in the call to initqgs.

!   Both initqgs and quadgs are 100% THREAD SAFE -- all requisite parameters
!   and arrays are passed through subroutine arguments.

!   For some functions, it is important that the endpoints x1 and x2 be
!   computed to high precision (nwds2 words) in the calling program, that
!   these high-precision values be passed to quadgs (where scaled abscissas
!   are calculated to high precision), and that the function definition
!   itself uses these high-precision scaled abscissas in any initial
!   subtractions or other sensitive operations involving the input argument.
!   Otherwise the accuracy of the quadrature result might only be half as
!   high as it otherwise could be.  See the function definitions of fun06,
!   fun07, fun09 and fun10 for examples on how this is done.  Otherwise the
!   function evaluation can and should be performed with low precision
!   (nwds1 words) for faster run times.  The two precision levels (nwds1
!   and nwds2) are specified by the user in the calling program.

!   David H Bailey   28 Apr 2018

use mpmodule
implicit none
integer i, ierror, ik0, iq, izx, k, j, n, ndebug, nds, nq1, nq2, &
  neps1, nerr, nwds1, nwds2, nwp
logical log1, log2
double precision d1, d2, d3, dfrac, dplog10q
parameter (dfrac = 100.d0, ik0 = 100, izx = 5, ndebug = 2)
type (mp_real) ax, bx, c10, eps1, eps2, epsilon1, err, fun, &
  quadgs, tsum, s1, s2, s3, t1, t2, tw1, tw2, twmx, wkgs(-1:nq2), xkgs(-1:nq2), &
  x1, x2, xx1, xx2
external fun, dplog10q

!  These two lines are performed in high precision (nwds2 words).

ax = 0.5d0 * (x2 - x1)
bx = 0.5d0 * (x2 + x1)

!  The remaining initialization is performed in low precision (nwds1 words).

epsilon1 = dfrac * mpreal (10.d0, nwds1) ** neps1
s1 = mpreal (0.d0, nwds1)
s2 = mpreal (0.d0, nwds1)
c10 = mpreal (10.d0, nwds1)

if (wkgs(-1) < dble (nq1)) then
  write (6, 1) nq1
1 format ('quadgs: quadrature arrays have not been initialized; nq1 =',i6)
  goto 140
endif

!   Determine if the quadrature is over (-1,1) or (-inf,inf).

if (dble (wkgs(101)) <= 1.d0) then
  iq = 0
else
  iq = 1
endif

do k = 1, nq1
  n = 3 * 2 ** (k + 1)
  s3 = s2
  s2 = s1
  twmx = mpreal (0.d0, nwds1)
  tsum = mpreal (0.d0, nwds1)
  i = dble (xkgs(k))

  do j = 1, n / 2
    i = i + 1

!   These two lines are performed in high precision.

    xx1 = - ax * xkgs(i) + bx
    xx2 = ax * xkgs(i) + bx

    t1 = fun (xx1, nwds1, nwds2)
    tw1 = t1 * wkgs(i)

    if (j + k > 2) then
      t2 = fun (xx2, nwds1, nwds2)
      tw2 = t2 * wkgs(i)
    else
      t2 = mpreal (0.d0, nwds1)
      tw2 = mpreal (0.d0, nwds1)
    endif

    tsum = tsum + tw1 + tw2
    twmx = max (twmx, abs (tw1), abs (tw2))
  enddo

!   Compute s1 = current integral approximation and err = error estimate.
!   Tsum is the sum of all tw1 and tw2 from the loop above.
!   Twmx is the largest absolute value of tw1 and tw2 from the loop above.

  s1 =  mpreal (ax, nwds1) * tsum
  eps1 = twmx * epsilon1
  d1 = dplog10q (abs ((s1 - s2) / s1))
  d2 = dplog10q (abs ((s1 - s3) / s1))
  d3 = dplog10q (eps1) - 1.d0

  if (k <= 2) then
    err = mpreal (1.d0, nwds1)
  elseif (d1 .eq. -999999.d0) then
    err = mpreal (0.d0, nwds1)
  else
    err = c10 ** nint (min (0.d0, max (d1 ** 2 / d2, 2.d0 * d1, d3)))
  endif

!   Output current integral approximation and error estimate, to 60 digits.

  if (ndebug >= 2) then
    write (6, 2) k, nq1, nint (dplog10q (abs (err)))
2   format ('quadgs: Iteration',i3,' of',i3,'; est error = 10^',i7, &
      '; approx value =')
    call mpwrite (6, 80, 60, s1)
  endif

  if (k >= 3 .and. err < eps1) then
    write (6, 4) nint (dplog10q (abs (err)))
4   format ('quadgs: Estimated error = 10^',i7)
    goto 140
  endif
enddo

140 continue

quadgs = s1
return
end

function dplog10q (a)

!   For input MP value a, this routine returns a DP approximation to log10 (a).

use mpmodule
implicit none
integer ia
real (8) da, dplog10q, t1
type (mp_real) a

call mpmdi (a, da, ia)
if (da .eq. 0.d0) then
  dplog10q = -999999.d0
else
  dplog10q = log10 (abs (da)) + ia * log10 (2.d0)
endif

100 continue
return
end

subroutine decmdq (a, b, ib)

!   For input MP value a, this routine returns DP b and integer ib such that
!   a = b * 10^ib, with 1 <= abs (b) < 10 for nonzero a.

use mpmodule
implicit none
integer ia, ib
real (8) da, b, t1, xlt
parameter (xlt = 0.3010299956639812d0)
type (mp_real) a

call mpmdi (a, da, ia)
if (da .ne. 0.d0) then
  t1 = xlt * ia + log10 (abs (da))
  ib = t1
  if (t1 .lt. 0.d0) ib = ib - 1
  b = sign (10.d0 ** (t1 - ib), da)
else
  b = 0.d0
  ib = 0
endif

return
end


        subroutine hypot_normal(x, y, h)
        double precision :: x, y, h

        h = SQRT(x*x + y*y)
        end subroutine

        subroutine hypot_safer_fabs(x, y, h)
        double precision :: x, y, h

        if (x > y) then
            h = ABS(x) * SQRT(1.0 +(y/x)*(y/x))
        else if(x < y) then
            h = ABS(y) * SQRT(1.0 +(x/y)*(x/y))
        else
            h = SQRT(2.0) * ABS(x)
        end if
        end subroutine


C*******************************************************************
C RETURN THE HISTOGRAM OF ARRAY X, THAT IS, THE NUMBER OF ELEMENTS
C IN X FALLING INTO EACH BIN.
C THE BIN ARRAY CONSISTS IN N BINS STARTING AT BIN0 WITH WIDTH DELTA.
C HISTO H : | LOWER OUTLIERS | 1 | 2 | 3 | ... |  N  | UPPER OUTLIERS |
C INDEX i : |        1       | 2 | 3 | 4 | ... | N+1 |      N+2       |

      SUBROUTINE FIXED_BINSIZE(X, BIN0, DELTA, N, NX, H)

C PARAMETERS
C ----------
C X : ARRAY
C BIN0 : LEFT BIN EDGE
C DELTA : BIN WIDTH
C N : NUMBER OF BINS
C H : HISTOGRAM

      IMPLICIT NONE
      INTEGER :: N, NX, i, K
      DOUBLE PRECISION ::  X(NX), BIN0, DELTA
      INTEGER :: H(N+2), UP, LOW

CF2PY INTEGER INTENT(IN) :: N
CF2PY INTEGER INTENT(HIDE) :: NX = LEN(X)
CF2PY DOUBLE PRECISION DIMENSION(NX), INTENT(IN) :: X
CF2PY DOUBLE PRECISION INTENT(IN) :: BIN0, DELTA
CF2PY INTEGER DIMENSION(N+2), INTENT(OUT) :: H
CF2PY THREADSAFE

      DO i=1,N+2
        H(i) = 0
      ENDDO

C     OUTLIERS INDICES
      UP = N+2
      LOW = 1

      DO i=1,NX
        IF (X(i) >= BIN0) THEN
          K = INT((X(i)-BIN0)/DELTA)+1
          IF (K <= N) THEN
            H(K+1) = H(K+1) + 1
          ELSE
            H(UP) = H(UP) + 1
          ENDIF
        ELSE
          H(LOW) = H(LOW) + 1
        ENDIF
      ENDDO

      END SUBROUTINE

C*******************************************************************
C RETURN THE WEIGHTED HISTOGRAM OF ARRAY X, THAT IS, THE SUM OF THE
C WEIGHTS OF THE ELEMENTS OF X FALLING INTO EACH BIN.
C THE BIN ARRAY CONSISTS IN N BINS STARTING AT BIN0 WITH WIDTH DELTA.
C HISTO H : | LOWER OUTLIERS | 1 | 2 | 3 | ... |  N  | UPPER OUTLIERS |
C INDEX i : |        1       | 2 | 3 | 4 | ... | N+1 |      N+2       |

      SUBROUTINE WEIGHTED_FIXED_BINSIZE(X, W, BIN0, DELTA, N, NX, H)

C PARAMETERS
C ----------
C X : ARRAY
C W : WEIGHTS
C BIN0 : LEFT BIN EDGE
C DELTA : BIN WIDTH
C N : NUMBER OF BINS
C H : HISTOGRAM

      IMPLICIT NONE
      INTEGER :: N, NX, i, K
      DOUBLE PRECISION ::  X(NX), W(NX), BIN0, DELTA, H(N+2)
      INTEGER :: UP, LOW

CF2PY INTEGER INTENT(IN) :: N
CF2PY INTEGER INTENT(HIDE) :: NX = LEN(X)
CF2PY DOUBLE PRECISION DIMENSION(NX), INTENT(IN) :: X, W
CF2PY DOUBLE PRECISION INTENT(IN) :: BIN0, DELTA
CF2PY DOUBLE PRECISION DIMENSION(N+2), INTENT(OUT) :: H
CF2PY THREADSAFE

      DO i=1,N+2
        H(i) = 0.D0
      ENDDO

C     OUTLIERS INDICES
      UP = N+2
      LOW = 1

      DO i=1,NX
        IF (X(i) >= BIN0) THEN
          K = INT((X(i)-BIN0)/DELTA)+1
          IF (K <= N) THEN
            H(K+1) = H(K+1) + W(i)
          ELSE
            H(UP) = H(UP) + W(i)
          ENDIF
        ELSE
          H(LOW) = H(LOW) + W(i)
        ENDIF
      ENDDO

      END SUBROUTINE

C*****************************************************************************
C COMPUTE N DIMENSIONAL FLATTENED HISTOGRAM

      SUBROUTINE FIXED_BINSIZE_ND(X, BIN0, DELTA, N, COUNT, NX,D,NC)

C PARAMETERS
C ----------
C X : ARRAY (NXD)
C BIN0 : LEFT BIN EDGES (D)
C DELTA : BIN WIDTH (D)
C N : NUMBER OF BINS (D)
C COUNT : FLATTENED HISTOGRAM (NC)
C NC : PROD(N(:)+2)

      IMPLICIT NONE
      INTEGER :: NX, D, NC,N(D), i, j, k, T
      DOUBLE PRECISION :: X(NX,D), BIN0(D), DELTA(D)
      INTEGER :: INDEX(NX), ORDER(D), MULT, COUNT(NC)

CF2PY DOUBLE PRECISION DIMENSION(NX,D), INTENT(IN) :: X
CF2PY DOUBLE PRECISION DIMENSION(D) :: BIN0, DELTA
CF2PY INTEGER INTENT(IN) :: N
CF2PY INTEGER DIMENSION(NC), INTENT(OUT) :: COUNT
CF2PY INTEGER INTENT(HIDE) :: NX=SHAPE(X,1)
CF2PY INTEGER INTENT(HIDE) :: D=SHAPE(X,2)
CF2PY THREADSAFE

C     INITIALIZE INDEX
      DO i=1, NX
        INDEX(i) = 0
      ENDDO

C     INITIALIZE COUNT
      DO i=1,NC
        COUNT(i) = 0
      ENDDO

C     ORDER THE BIN SIZE ARRAY N(D)
      CALL QSORTI(ORDER, D, N)

C     INITIALIZE THE DIMENSIONAL MULTIPLIER
      MULT=1

C     FIND THE FLATTENED INDEX OF EACH SAMPLE
      DO j=1, D
        k = ORDER(j)
        MULT=MULT*N(k)

        DO i=1, NX
          IF (X(i,k) >= BIN0(k)) THEN
            T = INT((X(i, k)-BIN0(k))/DELTA(k))+1
            IF (T <= N(k)) THEN
              T = T+1
            ELSE
              T = N(k)+2
            ENDIF
          ELSE
            T = 1
          ENDIF

          INDEX(i) = INDEX(I) + T*MULT
        ENDDO
      ENDDO

C     COUNT THE NUMBER OF SAMPLES FALLING INTO EACH BIN
      DO i=1,NX
        COUNT(INDEX(i)) =  COUNT(INDEX(i)) + 1
      ENDDO

      END SUBROUTINE

C From HDK@psuvm.psu.edu Thu Dec  8 15:27:16 MST 1994
C
C The following was converted from Algol recursive to Fortran iterative
C by a colleague at Penn State (a long time ago - Fortran 66, please
C excuse the GoTo's). The following code also corrects a bug in the
C Quicksort algorithm published in the ACM (see Algorithm 402, CACM,
C Sept. 1970, pp 563-567; also you younger folks who weren't born at
C that time might find interesting the history of the Quicksort
C algorithm beginning with the original published in CACM, July 1961,
C pp 321-322, Algorithm 64). Note that the following algorithm sorts
C integer data; actual data is not moved but sort is affected by sorting
C a companion index array (see leading comments). The data type being
C sorted can be changed by changing one line; see comments after
C declarations and subsequent one regarding comparisons(Fortran
C 77 takes care of character comparisons of course, so that comment
C is merely historical from the days when we had to write character
C compare subprograms, usually in assembler language for a specific
C mainframe platform at that time). But the following algorithm is
C good, still one of the best available.

      SUBROUTINE QSORTI (ORD,N,A)
C
C==============SORTS THE ARRAY A(I),I=1,2,...,N BY PUTTING THE
C   ASCENDING ORDER VECTOR IN ORD.  THAT IS ASCENDING ORDERED A
C   IS A(ORD(I)),I=1,2,...,N; DESCENDING ORDER A IS A(ORD(N-I+1)),
C   I=1,2,...,N .  THIS SORT RUNS IN TIME PROPORTIONAL TO N LOG N .
C
C
C     ACM QUICKSORT - ALGORITHM #402 - IMPLEMENTED IN FORTRAN 66 BY
C                                 WILLIAM H. VERITY, WHV@PSUVM.PSU.EDU
C                                 CENTER FOR ACADEMIC COMPUTING
C                                 THE PENNSYLVANIA STATE UNIVERSITY
C                                 UNIVERSITY PARK, PA.  16802
C
      IMPLICIT INTEGER (A-Z)
C
      DIMENSION ORD(N),POPLST(2,20)
      INTEGER X,XX,Z,ZZ,Y,N
C
C     TO SORT DIFFERENT INPUT TYPES, CHANGE THE FOLLOWING
C     SPECIFICATION STATEMENTS; FOR EXAMPLE, FOR FORTRAN CHARACTER
C     USE THE FOLLOWING:  CHARACTER *(*) A(N)
C
      INTEGER A(N)
C
      NDEEP=0
      U1=N
      L1=1
      DO 1  I=1,N
    1 ORD(I)=I
    2 IF (U1.LE.L1) RETURN
C
    3 L=L1
      U=U1
C
C PART
C
    4 P=L
      Q=U
C     FOR CHARACTER SORTS, THE FOLLOWING 3 STATEMENTS WOULD BECOME
C     X = ORD(P)
C     Z = ORD(Q)
C     IF (A(X) .LE. A(Z)) GO TO 2
C
C     WHERE "CLE" IS A LOGICAL FUNCTION WHICH RETURNS "TRUE" IF THE
C     FIRST ARGUMENT IS LESS THAN OR EQUAL TO THE SECOND, BASED ON "LEN"
C     CHARACTERS.
C
      X=A(ORD(P))
      Z=A(ORD(Q))
      IF (X.LE.Z) GO TO 5
      Y=X
      X=Z
      Z=Y
      YP=ORD(P)
      ORD(P)=ORD(Q)
      ORD(Q)=YP
    5 IF (U-L.LE.1) GO TO 15
      XX=X
      IX=P
      ZZ=Z
      IZ=Q
C
C LEFT
C
    6 P=P+1
      IF (P.GE.Q) GO TO 7
      X=A(ORD(P))
      IF (X.GE.XX) GO TO 8
      GO TO 6
    7 P=Q-1
      GO TO 13
C
C RIGHT
C
    8 Q=Q-1
      IF (Q.LE.P) GO TO 9
      Z=A(ORD(Q))
      IF (Z.LE.ZZ) GO TO 10
      GO TO 8
    9 Q=P
      P=P-1
      Z=X
      X=A(ORD(P))
C
C DIST
C
   10 IF (X.LE.Z) GO TO 11
      Y=X
      X=Z
      Z=Y
      IP=ORD(P)
      ORD(P)=ORD(Q)
      ORD(Q)=IP
   11 IF (X.LE.XX) GO TO 12
      XX=X
      IX=P
   12 IF (Z.GE.ZZ) GO TO 6
      ZZ=Z
      IZ=Q
      GO TO 6
C
C OUT
C
   13 CONTINUE
      IF (.NOT.(P.NE.IX.AND.X.NE.XX)) GO TO 14
      IP=ORD(P)
      ORD(P)=ORD(IX)
      ORD(IX)=IP
   14 CONTINUE
      IF (.NOT.(Q.NE.IZ.AND.Z.NE.ZZ)) GO TO 15
      IQ=ORD(Q)
      ORD(Q)=ORD(IZ)
      ORD(IZ)=IQ
   15 CONTINUE
      IF (U-Q.LE.P-L) GO TO 16
      L1=L
      U1=P-1
      L=Q+1
      GO TO 17
   16 U1=U
      L1=Q+1
      U=P-1
   17 CONTINUE
      IF (U1.LE.L1) GO TO 18
C
C START RECURSIVE CALL
C
      NDEEP=NDEEP+1
      POPLST(1,NDEEP)=U
      POPLST(2,NDEEP)=L
      GO TO 3
   18 IF (U.GT.L) GO TO 4
C
C POP BACK UP IN THE RECURSION LIST
C
      IF (NDEEP.EQ.0) GO TO 2
      U=POPLST(1,NDEEP)
      L=POPLST(2,NDEEP)
      NDEEP=NDEEP-1
      GO TO 18
C
C END SORT
C END QSORT
C
      END