!--------------------------------------------------------------------------------------------------!
! Module: random
!
! Variables and routines to generate random numbers from different distributions. Currently, the
! available random distributions are:
!     - Uniform
!     - Normal (Gaussian)
!
!--------------------------------------------------------------------------------------------------!
module random

integer, public :: iseed

public :: timeseed
public :: ran0

public :: c4_normal_01
public :: c8_normal_01
public :: i4_normal_ab
public :: i8_normal_ab
public :: r4_normal_01
public :: r4_normal_ab
public :: r4_uniform_01
public :: r4vec_uniform_01
public :: r4vec_normal_ab
public :: r8_normal_01
public :: r8_normal_ab
public :: r8_uniform_01
public :: r8mat_normal_01
public :: r8mat_normal_ab
public :: r8mat_print
public :: r8mat_print_some
public :: r8vec_normal_01
public :: r8vec_normal_ab
public :: r8vec_print
public :: r8vec_uniform_01

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

function timeseed()
!----
! Generate a six-digit random number seed from the system hour, minute, and second
!----

implicit none

! I/O variables
integer :: timeseed

! Local variables
integer :: time(3)
character(len=8) :: string

! Fortran intrinsic function itime returns hour, minute, second to integer array
call itime(time)

! Convert to a single integer
write(string,'(I0.2I0.2I0.2)') time(1), time(2), time(3)
read(string,*) timeseed

return
end function

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

function ran0(idum)
!----
! Random number generator from Numerical Recipes in Fortran 90, Press et al.
!----

implicit none

! Arguments
real :: ran0
integer, parameter :: K4B = selected_int_kind(9)
integer(K4B), intent(inout) :: idum

! Local variables
integer(K4B), parameter :: IA=16807
integer(K4B), parameter :: IM=2147483647
integer(K4B), parameter :: IQ=127773
integer(K4B), parameter :: IR=2836
real, save :: am
integer(K4B), save :: ix = -1
integer(K4B), save :: iy = -1
integer(K4B), save :: k

! Initialize
if (idum.le.0.or.iy.lt.0) then
    am = nearest(1.0,-1.0)/real(IM)
    iy = ior(ieor(888889999,abs(idum)),1)
    ix = ieor(777755555,abs(idum))

    ! Set idum positive
    idum = abs(idum)+1
endif

! Marsaglia shift sequence with period 2^32−1
ix = ieor(ix,ishft(ix,13))
ix = ieor(ix,ishft(ix,-17))
ix = ieor(ix,ishft(ix,5))

! Park-Miller sequence by Schrage’s method, period 2^31−2.
k = iy/IQ
iy = IA*(iy-k*IQ)-IR*k
if (iy.lt.0) then
    iy = iy+IM
endif

! Combine the two generators with masking to ensure nonzero value
ran0 = am*ior(iand(IM,ieor(ix,iy)),1)

end function

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

function c4_normal_01 ( seed )

!*****************************************************************************80
!
!! C4_NORMAL_01 returns a unit pseudonormal C4.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    31 May 2007
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, integer ( kind = 4 ) SEED, a seed for the random
!    number generator.
!
!    Output, complex ( kind = 4 ) C4_NORMAL_01, a unit pseudonormal value.
!
  implicit none

  complex ( kind = 4 ) c4_normal_01
  real ( kind = 4 ), parameter :: r4_pi = 3.141592653589793E+00
  ! real ( kind = 4 ) r4_uniform_01 ! ALREADY PART OF MODULE
  integer ( kind = 4 ) seed
  real ( kind = 4 ) v1
  real ( kind = 4 ) v2
  real ( kind = 4 ) x_c
  real ( kind = 4 ) x_r

  v1 = r4_uniform_01 ( seed )
  v2 = r4_uniform_01 ( seed )

  x_r = sqrt ( - 2.0E+00 * log ( v1 ) ) * cos ( 2.0E+00 * r4_pi * v2 )
  x_c = sqrt ( - 2.0E+00 * log ( v1 ) ) * sin ( 2.0E+00 * r4_pi * v2 )

  c4_normal_01 = cmplx ( x_r, x_c )

  return
end

function c8_normal_01 ( seed )

!*****************************************************************************80
!
!! C8_NORMAL_01 returns a unit pseudonormal C8.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    31 May 2007
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) SEED, a seed for the random number
!    generator.
!
!    Output, complex ( kind = 8 ) C8_NORMAL_01, a sample of the PDF.
!
!    Output, integer ( kind = 4 ) SEED, a seed for the random number
!    generator.
!
  implicit none

  complex ( kind = 8 ) c8_normal_01
  real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793D+00
  ! real ( kind = 8 ) r8_uniform_01 ! ALREADY PART OF MODULE
  integer ( kind = 4 ) seed
  real ( kind = 8 ) v1
  real ( kind = 8 ) v2
  real ( kind = 8 ) x_c
  real ( kind = 8 ) x_r

  v1 = r8_uniform_01 ( seed )
  v2 = r8_uniform_01 ( seed )

  x_r = sqrt ( - 2.0D+00 * log ( v1 ) ) * cos ( 2.0D+00 * r8_pi * v2 )
  x_c = sqrt ( - 2.0D+00 * log ( v1 ) ) * sin ( 2.0D+00 * r8_pi * v2 )

  c8_normal_01 = cmplx ( x_r, x_c, kind = 8 )

  return
end

function i4_normal_ab ( a, b, seed )

!*****************************************************************************80
!
!! I4_NORMAL_AB returns a scaled pseudonormal I4.
!
!  Discussion:
!
!    The normal probability distribution function (PDF) is sampled,
!    with mean A and standard deviation B.
!
!    The result is then rounded to the nearest integer.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    06 August 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real ( kind = 4 ) A, the mean of the PDF.
!
!    Input, real ( kind = 4 ) B, the standard deviation of the PDF.
!
!    Input/output, integer ( kind = 4 ) SEED, a seed for the
!    random number generator.
!
!    Output, integer ( kind = 4 ) I4_NORMAL_AB, a sample of the normal PDF.
!
  implicit none

  real ( kind = 4 ) a
  real ( kind = 4 ) b
  integer ( kind = 4 ) i4_normal_ab
  real ( kind = 4 ) r1
  real ( kind = 4 ) r2
  real ( kind = 4 ), parameter :: r4_pi = 3.141592653589793E+00
  ! real ( kind = 4 ) r4_uniform_01 ! ALREADY PART OF MODULE
  integer ( kind = 4 ) seed
  real ( kind = 4 ) x

  r1 = r4_uniform_01 ( seed )
  r2 = r4_uniform_01 ( seed )
  x = sqrt ( - 2.0E+00 * log ( r1 ) ) * cos ( 2.0E+00 * r4_pi * r2 )

  i4_normal_ab = nint ( a + b * x )

  return
end

function i8_normal_ab ( a, b, seed )

!*****************************************************************************80
!
!! I8_NORMAL_AB returns a scaled pseudonormal I8.
!
!  Discussion:
!
!    The normal probability distribution function (PDF) is sampled,
!    with mean A and standard deviation B.
!
!    The result is then rounded to the nearest integer.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    06 August 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real ( kind = 8 ) A, the mean of the PDF.
!
!    Input, real ( kind = 8 ) B, the standard deviation of the PDF.
!
!    Input/output, integer ( kind = 4 ) SEED, a seed for the
!    random number generator.
!
!    Output, integer ( kind = 8 ) I8_NORMAL_AB, a sample of the normal PDF.
!
  implicit none

  real ( kind = 8 ) a
  real ( kind = 8 ) b
  integer ( kind = 8 ) i8_normal_ab
  real ( kind = 8 ) r1
  real ( kind = 8 ) r2
  real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793D+00
  ! real ( kind = 8 ) r8_uniform_01 ! ALREADY PART OF MODULE
  integer ( kind = 4 ) seed
  real ( kind = 8 ) x

  r1 = r8_uniform_01 ( seed )
  r2 = r8_uniform_01 ( seed )
  x = sqrt ( - 2.0D+00 * log ( r1 ) ) * cos ( 2.0D+00 * r8_pi * r2 )

  i8_normal_ab = nint ( a + b * x )

  return
end

function r4_normal_01 ( seed )

!*****************************************************************************80
!
!! R4_NORMAL_01 returns a unit pseudonormal R4.
!
!  Discussion:
!
!    The standard normal probability distribution function (PDF) has
!    mean 0 and standard deviation 1.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    06 August 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, integer ( kind = 4 ) SEED, a seed for the random
!    number generator.
!
!    Output, real ( kind = 4 ) R4_NORMAL_01, a sample of the standard
!    normal PDF.
!
  implicit none

  real ( kind = 4 ) r1
  real ( kind = 4 ) r2
  real ( kind = 4 ) r4_normal_01
  real ( kind = 4 ), parameter :: r4_pi = 3.141592653589793E+00
  ! real ( kind = 4 ) r4_uniform_01 ! ALREADY PART OF MODULE
  integer ( kind = 4 ) seed
  real ( kind = 4 ) x

  r1 = r4_uniform_01 ( seed )
  r2 = r4_uniform_01 ( seed )
  x = sqrt ( - 2.0E+00 * log ( r1 ) ) * cos ( 2.0E+00 * r4_pi * r2 )

  r4_normal_01 = x

  return
end

function r4_normal_ab ( a, b, seed )

!*****************************************************************************80
!
!! R4_NORMAL_AB returns a scaled pseudonormal R4.
!
!  Discussion:
!
!    The normal probability distribution function (PDF) is sampled,
!    with mean A and standard deviation B.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    06 August 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real ( kind = 4 ) A, the mean of the PDF.
!
!    Input, real ( kind = 4 ) B, the standard deviation of the PDF.
!
!    Input/output, integer ( kind = 4 ) SEED, a seed for the random
!    number generator.
!
!    Output, real ( kind = 4 ) R4_NORMAL_AB, a sample of the normal PDF.
!
  implicit none

  real ( kind = 4 ) a
  real ( kind = 4 ) b
  real ( kind = 4 ) r1
  real ( kind = 4 ) r2
  real ( kind = 4 ) r4_normal_ab
  real ( kind = 4 ), parameter :: r4_pi = 3.141592653589793E+00
  ! real ( kind = 4 ) r4_uniform_01 ! ALREADY PART OF MODULE
  integer ( kind = 4 ) seed
  real ( kind = 4 ) x

  r1 = r4_uniform_01 ( seed )
  r2 = r4_uniform_01 ( seed )
  x = sqrt ( - 2.0E+00 * log ( r1 ) ) * cos ( 2.0E+00 * r4_pi * r2 )

  r4_normal_ab = a + b * x

  return
end

function r4_uniform_01 ( seed )

!*****************************************************************************80
!
!! R4_UNIFORM_01 returns a unit pseudorandom R4.
!
!  Discussion:
!
!    An R4 is a real ( kind = 4 ) value.
!
!    This routine implements the recursion
!
!      seed = 16807 * seed mod ( 2^31 - 1 )
!      r4_uniform_01 = seed / ( 2^31 - 1 )
!
!    The integer arithmetic never requires more than 32 bits,
!    including a sign bit.
!
!    If the initial seed is 12345, then the first three computations are
!
!      Input     Output      R4_UNIFORM_01
!      SEED      SEED
!
!         12345   207482415  0.096616
!     207482415  1790989824  0.833995
!    1790989824  2035175616  0.947702
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    31 May 2007
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Paul Bratley, Bennett Fox, Linus Schrage,
!    A Guide to Simulation,
!    Second Edition,
!    Springer, 1987,
!    ISBN: 0387964673,
!    LC: QA76.9.C65.B73.
!
!    Bennett Fox,
!    Algorithm 647:
!    Implementation and Relative Efficiency of Quasirandom
!    Sequence Generators,
!    ACM Transactions on Mathematical Software,
!    Volume 12, Number 4, December 1986, pages 362-376.
!
!    Pierre L'Ecuyer,
!    Random Number Generation,
!    in Handbook of Simulation,
!    edited by Jerry Banks,
!    Wiley, 1998,
!    ISBN: 0471134031,
!    LC: T57.62.H37.
!
!    Peter Lewis, Allen Goodman, James Miller,
!    A Pseudo-Random Number Generator for the System/360,
!    IBM Systems Journal,
!    Volume 8, Number 2, 1969, pages 136-143.
!
!  Parameters:
!
!    Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
!    should NOT be 0.  On output, SEED has been updated.
!
!    Output, real ( kind = 4 ) R4_UNIFORM_01, a new pseudorandom variate,
!    strictly between 0 and 1.
!
  implicit none

  integer ( kind = 4 ), parameter :: i4_huge = 2147483647
  integer ( kind = 4 ) k
  integer ( kind = 4 ) seed
  real ( kind = 4 ) r4_uniform_01

  if ( seed == 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'R4_UNIFORM_01 - Fatal error!'
    write ( *, '(a)' ) '  Input value of SEED = 0.'
    call error_exit(1)
  end if

  k = seed / 127773

  seed = 16807 * ( seed - k * 127773 ) - k * 2836

  if ( seed < 0 ) then
    seed = seed + i4_huge
  end if

  r4_uniform_01 = real ( seed, kind = 4 ) * 4.656612875E-10

  return
end

subroutine r4vec_uniform_01 ( n, seed, r )

!*****************************************************************************80
!
!! R4VEC_UNIFORM_01 returns a unit pseudorandom R4VEC.
!
!  Discussion:
!
!    An R4VEC is an array of real ( kind = 4 ) values.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    31 May 2007
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Paul Bratley, Bennett Fox, Linus Schrage,
!    A Guide to Simulation,
!    Second Edition,
!    Springer, 1987,
!    ISBN: 0387964673,
!    LC: QA76.9.C65.B73.
!
!    Bennett Fox,
!    Algorithm 647:
!    Implementation and Relative Efficiency of Quasirandom
!    Sequence Generators,
!    ACM Transactions on Mathematical Software,
!    Volume 12, Number 4, December 1986, pages 362-376.
!
!    Pierre L'Ecuyer,
!    Random Number Generation,
!    in Handbook of Simulation,
!    edited by Jerry Banks,
!    Wiley, 1998,
!    ISBN: 0471134031,
!    LC: T57.62.H37.
!
!    Peter Lewis, Allen Goodman, James Miller,
!    A Pseudo-Random Number Generator for the System/360,
!    IBM Systems Journal,
!    Volume 8, Number 2, 1969, pages 136-143.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of entries in the vector.
!
!    Input/output, integer ( kind = 4 ) SEED, the "seed" value,
!    which should NOT be 0.
!    On output, SEED has been updated.
!
!    Output, real ( kind = 4 ) R(N), the vector of pseudorandom values.
!
  implicit none

  integer ( kind = 4 ) n

  integer ( kind = 4 ) i
  integer ( kind = 4 ), parameter :: i4_huge = 2147483647
  integer ( kind = 4 ) k
  integer ( kind = 4 ) seed
  real ( kind = 4 ) r(n)

  if ( seed == 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'R4VEC_UNIFORM_01 - Fatal error!'
    write ( *, '(a)' ) '  Input value of SEED = 0.'
    call error_exit(1)
  end if

  do i = 1, n

    k = seed / 127773

    seed = 16807 * ( seed - k * 127773 ) - k * 2836

    if ( seed < 0 ) then
      seed = seed + i4_huge
    end if

    r(i) = real ( seed, kind = 4 ) * 4.656612875E-10

  end do

  return
end

subroutine r4vec_normal_ab ( n, a, b, seed, x )

!*****************************************************************************80
!
!! R4VEC_NORMAL_AB returns a scaled pseudonormal R4VEC.
!
!  Discussion:
!
!    The standard normal probability distribution function (PDF) has
!    mean 0 and standard deviation 1.
!
!    An R4VEC is a vector of R4's.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    06 August 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of values desired.
!
!    Input, real ( kind = 4 ) A, B, the mean and standard deviation.
!
!    Input/output, integer ( kind = 4 ) SEED, a seed for the random
!    number generator.
!
!    Output, real ( kind = 4 ) X(N), a sample of the standard normal PDF.
!
!  Local parameters:
!
!    Local, real ( kind = 4 ) R(N+1), is used to store some uniform
!    random values.  Its dimension is N+1, but really it is only needed
!    to be the smallest even number greater than or equal to N.
!
!    Local, integer ( kind = 4 ) X_LO_INDEX, X_HI_INDEX, records the range
!    of entries of X that we need to compute.
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 4 ) a
  real ( kind = 4 ) b
  integer ( kind = 4 ) m
  real ( kind = 4 ) r(n+1)
  real ( kind = 4 ), parameter :: r4_pi = 3.141592653589793E+00
  ! real ( kind = 4 ) r4_uniform_01 ! ALREADY PART OF MODULE
  integer ( kind = 4 ) seed
  real ( kind = 4 ) x(n)
  integer ( kind = 4 ) x_hi_index
  integer ( kind = 4 ) x_lo_index
!
!  Record the range of X we need to fill in.
!
  x_lo_index = 1
  x_hi_index = n
!
!  If we need just one new value, do that here to avoid null arrays.
!
  if ( x_hi_index - x_lo_index + 1 == 1 ) then

    r(1) = r4_uniform_01 ( seed )

    if ( abs(r(1))  <= 1.0E-10 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'R4VEC_NORMAL_AB - Fatal error!'
      write ( *, '(a)' ) '  R4_UNIFORM_01 returned a value of 0.'
      call error_exit(1)
    end if

    r(2) = r4_uniform_01 ( seed )

    x(x_hi_index) = &
      sqrt ( - 2.0E+00 * log ( r(1) ) ) * cos ( 2.0E+00 * r4_pi * r(2) )
!
!  If we require an even number of values, that's easy.
!
  else if ( mod ( x_hi_index - x_lo_index, 2 ) == 1 ) then

    m = ( x_hi_index - x_lo_index + 1 ) / 2

    call r4vec_uniform_01 ( 2*m, seed, r )

    x(x_lo_index:x_hi_index-1:2) = &
      sqrt ( - 2.0E+00 * log ( r(1:2*m-1:2) ) ) &
      * cos ( 2.0E+00 * r4_pi * r(2:2*m:2) )

    x(x_lo_index+1:x_hi_index:2) = &
      sqrt ( - 2.0E+00 * log ( r(1:2*m-1:2) ) ) &
      * sin ( 2.0E+00 * r4_pi * r(2:2*m:2) )
!
!  If we require an odd number of values, we generate an even number,
!  and handle the last pair specially, storing one in X(N), and
!  saving the other for later.
!
  else

    x_hi_index = x_hi_index - 1

    m = ( x_hi_index - x_lo_index + 1 ) / 2 + 1

    call r4vec_uniform_01 ( 2*m, seed, r )

    x(x_lo_index:x_hi_index-1:2) = &
      sqrt ( - 2.0E+00 * log ( r(1:2*m-3:2) ) ) &
      * cos ( 2.0E+00 * r4_pi * r(2:2*m-2:2) )

    x(x_lo_index+1:x_hi_index:2) = &
      sqrt ( - 2.0E+00 * log ( r(1:2*m-3:2) ) ) &
      * sin ( 2.0E+00 * r4_pi * r(2:2*m-2:2) )

    x(n) = sqrt ( - 2.0E+00 * log ( r(2*m-1) ) ) &
      * cos ( 2.0E+00 * r4_pi * r(2*m) )

  end if

  x(1:n) = a + b * x(1:n)

  return
end

function r8_normal_01 ( seed )

!*****************************************************************************80
!
!! R8_NORMAL_01 returns a unit pseudonormal R8.
!
!  Discussion:
!
!    The standard normal probability distribution function (PDF) has
!    mean 0 and standard deviation 1.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    06 August 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, integer ( kind = 4 ) SEED, a seed for the random
!    number generator.
!
!    Output, real ( kind = 8 ) R8_NORMAL_01, a normally distributed
!    random value.
!
  implicit none

  real ( kind = 8 ) r1
  real ( kind = 8 ) r2
  real ( kind = 8 ) r8_normal_01
  real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793D+00
  ! real ( kind = 8 ) r8_uniform_01 ! ALREADY PART OF MODULE
  integer ( kind = 4 ) seed
  real ( kind = 8 ) x

  r1 = r8_uniform_01 ( seed )
  r2 = r8_uniform_01 ( seed )
  x = sqrt ( - 2.0D+00 * log ( r1 ) ) * cos ( 2.0D+00 * r8_pi * r2 )

  r8_normal_01 = x

  return
end

function r8_normal_ab ( a, b, seed )

!*****************************************************************************80
!
!! R8_NORMAL_AB returns a scaled pseudonormal R8.
!
!  Discussion:
!
!    The normal probability distribution function (PDF) is sampled,
!    with mean A and standard deviation B.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    06 August 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real ( kind = 8 ) A, the mean of the PDF.
!
!    Input, real ( kind = 8 ) B, the standard deviation of the PDF.
!
!    Input/output, integer ( kind = 4 ) SEED, a seed for the random
!    number generator.
!
!    Output, real ( kind = 8 ) R8_NORMAL_AB, a sample of the normal PDF.
!
  implicit none

  real ( kind = 8 ) a
  real ( kind = 8 ) b
  real ( kind = 8 ) r1
  real ( kind = 8 ) r2
  real ( kind = 8 ) r8_normal_ab
  real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793D+00
  ! real ( kind = 8 ) r8_uniform_01 ! ALREADY PART OF MODULE
  integer ( kind = 4 ) seed
  real ( kind = 8 ) x

  r1 = r8_uniform_01 ( seed )
  r2 = r8_uniform_01 ( seed )
  x = sqrt ( - 2.0D+00 * log ( r1 ) ) * cos ( 2.0D+00 * r8_pi * r2 )

  r8_normal_ab = a + b * x

  return
end

function r8_uniform_01 ( seed )

!*****************************************************************************80
!
!! R8_UNIFORM_01 returns a unit pseudorandom R8.
!
!  Discussion:
!
!    This routine implements the recursion
!
!      seed = 16807 * seed mod ( 2^31 - 1 )
!      r8_uniform_01 = seed / ( 2^31 - 1 )
!
!    The integer arithmetic never requires more than 32 bits,
!    including a sign bit.
!
!    If the initial seed is 12345, then the first three computations are
!
!      Input     Output      R8_UNIFORM_01
!      SEED      SEED
!
!         12345   207482415  0.096616
!     207482415  1790989824  0.833995
!    1790989824  2035175616  0.947702
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    31 May 2007
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Paul Bratley, Bennett Fox, Linus Schrage,
!    A Guide to Simulation,
!    Second Edition,
!    Springer, 1987,
!    ISBN: 0387964673,
!    LC: QA76.9.C65.B73.
!
!    Bennett Fox,
!    Algorithm 647:
!    Implementation and Relative Efficiency of Quasirandom
!    Sequence Generators,
!    ACM Transactions on Mathematical Software,
!    Volume 12, Number 4, December 1986, pages 362-376.
!
!    Pierre L'Ecuyer,
!    Random Number Generation,
!    in Handbook of Simulation,
!    edited by Jerry Banks,
!    Wiley, 1998,
!    ISBN: 0471134031,
!    LC: T57.62.H37.
!
!    Peter Lewis, Allen Goodman, James Miller,
!    A Pseudo-Random Number Generator for the System/360,
!    IBM Systems Journal,
!    Volume 8, 1969, pages 136-143.
!
!  Parameters:
!
!    Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
!    should NOT be 0.
!    On output, SEED has been updated.
!
!    Output, real ( kind = 8 ) R8_UNIFORM_01, a new pseudorandom variate,
!    strictly between 0 and 1.
!
  implicit none

  integer ( kind = 8 ) k
  real ( kind = 8 ) r8_uniform_01
  integer ( kind = 4 ) seed

  k = seed / 127773

  seed = 16807 * ( seed - int(k) * 127773 ) - int(k) * 2836

  if ( seed < 0 ) then
    seed = seed + 2147483647
  end if
!
!  Although SEED can be represented exactly as a 32 bit integer,
!  it generally cannot be represented exactly as a 32 bit real number!
!
  r8_uniform_01 = real ( seed, kind = 8 ) * 4.656612875D-10

  return
end

subroutine r8mat_normal_01 ( m, n, seed, r )

!*****************************************************************************80
!
!! R8MAT_NORMAL_01 returns a unit pseudonormal R8MAT.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    12 November 2010
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Paul Bratley, Bennett Fox, Linus Schrage,
!    A Guide to Simulation,
!    Second Edition,
!    Springer, 1987,
!    ISBN: 0387964673,
!    LC: QA76.9.C65.B73.
!
!    Bennett Fox,
!    Algorithm 647:
!    Implementation and Relative Efficiency of Quasirandom
!    Sequence Generators,
!    ACM Transactions on Mathematical Software,
!    Volume 12, Number 4, December 1986, pages 362-376.
!
!    Pierre L'Ecuyer,
!    Random Number Generation,
!    in Handbook of Simulation,
!    edited by Jerry Banks,
!    Wiley, 1998,
!    ISBN: 0471134031,
!    LC: T57.62.H37.
!
!    Peter Lewis, Allen Goodman, James Miller,
!    A Pseudo-Random Number Generator for the System/360,
!    IBM Systems Journal,
!    Volume 8, 1969, pages 136-143.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) M, N, the number of rows and columns
!    in the array.
!
!    Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
!    should NOT be 0.  On output, SEED has been updated.
!
!    Output, real ( kind = 8 ) R(M,N), the array of pseudonormal values.
!
  implicit none

  integer ( kind = 4 ) m
  integer ( kind = 4 ) n

  integer ( kind = 4 ) seed
  real ( kind = 8 ) r(m,n)

  call r8vec_normal_01 ( m * n, seed, r )

  return
end

subroutine r8mat_normal_ab ( m, n, a, b, seed, r )

!*****************************************************************************80
!
!! R8MAT_NORMAL_AB returns a scaled pseudonormal R8MAT.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    06 August 2013
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Paul Bratley, Bennett Fox, Linus Schrage,
!    A Guide to Simulation,
!    Second Edition,
!    Springer, 1987,
!    ISBN: 0387964673,
!    LC: QA76.9.C65.B73.
!
!    Bennett Fox,
!    Algorithm 647:
!    Implementation and Relative Efficiency of Quasirandom
!    Sequence Generators,
!    ACM Transactions on Mathematical Software,
!    Volume 12, Number 4, December 1986, pages 362-376.
!
!    Pierre L'Ecuyer,
!    Random Number Generation,
!    in Handbook of Simulation,
!    edited by Jerry Banks,
!    Wiley, 1998,
!    ISBN: 0471134031,
!    LC: T57.62.H37.
!
!    Peter Lewis, Allen Goodman, James Miller,
!    A Pseudo-Random Number Generator for the System/360,
!    IBM Systems Journal,
!    Volume 8, 1969, pages 136-143.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) M, N, the number of rows and columns
!    in the array.
!
!    Input, real ( kind = 8 ) A, B, the mean and standard deviation.
!
!    Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
!    should NOT be 0.  On output, SEED has been updated.
!
!    Output, real ( kind = 8 ) R(M,N), the array of pseudonormal values.
!
  implicit none

  integer ( kind = 4 ) m
  integer ( kind = 4 ) n

  real ( kind = 8 ) a
  real ( kind = 8 ) b
  integer ( kind = 4 ) seed
  real ( kind = 8 ) r(m,n)

  call r8vec_normal_ab ( m * n, a, b, seed, r )

  return
end

subroutine r8vec_normal_01 ( n, seed, x )

!*****************************************************************************80
!
!! R8VEC_NORMAL_01 returns a unit pseudonormal R8VEC.
!
!  Discussion:
!
!    An R8VEC is an array of double precision real values.
!
!    The standard normal probability distribution function (PDF) has
!    mean 0 and standard deviation 1.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 May 2014
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of values desired.
!
!    Input/output, integer ( kind = 4 ) SEED, a seed for the random
!    number generator.
!
!    Output, real ( kind = 8 ) X(N), a sample of the standard normal PDF.
!
!  Local parameters:
!
!    Local, real ( kind = 8 ) R(N+1), is used to store some uniform
!    random values.  Its dimension is N+1, but really it is only needed
!    to be the smallest even number greater than or equal to N.
!
!    Local, integer ( kind = 4 ) X_LO_INDEX, X_HI_INDEX, records the range
!    of entries of X that we need to compute
!
  implicit none

  integer ( kind = 4 ) n

  integer ( kind = 4 ) m
  real ( kind = 8 ) r(n+1)
  real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793D+00
  ! real ( kind = 8 ) r8_uniform_01 ! ALREADY PART OF MODULE
  integer ( kind = 4 ) seed
  real ( kind = 8 ) x(n)
  integer ( kind = 4 ) x_hi_index
  integer ( kind = 4 ) x_lo_index
!
!  Record the range of X we need to fill in.
!
  x_lo_index = 1
  x_hi_index = n
!
!  If we need just one new value, do that here to avoid null arrays.
!
  if ( x_hi_index - x_lo_index + 1 == 1 ) then

    r(1) = r8_uniform_01 ( seed )

    if ( abs(r(1))  <= 1.0D-10 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'R8VEC_NORMAL_01 - Fatal error!'
      write ( *, '(a)' ) '  R8_UNIFORM_01 returned a value of 0.'
      call error_exit(1)
    end if

    r(2) = r8_uniform_01 ( seed )

    x(x_hi_index) = &
      sqrt ( - 2.0D+00 * log ( r(1) ) ) * cos ( 2.0D+00 * r8_pi * r(2) )
!
!  If we require an even number of values, that's easy.
!
  else if ( mod ( x_hi_index - x_lo_index, 2 ) == 1 ) then

    m = ( x_hi_index - x_lo_index + 1 ) / 2

    call r8vec_uniform_01 ( 2*m, seed, r )

    x(x_lo_index:x_hi_index-1:2) = &
      sqrt ( - 2.0D+00 * log ( r(1:2*m-1:2) ) ) &
      * cos ( 2.0D+00 * r8_pi * r(2:2*m:2) )

    x(x_lo_index+1:x_hi_index:2) = &
      sqrt ( - 2.0D+00 * log ( r(1:2*m-1:2) ) ) &
      * sin ( 2.0D+00 * r8_pi * r(2:2*m:2) )
!
!  If we require an odd number of values, we generate an even number,
!  and handle the last pair specially, storing one in X(N), and
!  saving the other for later.
!
  else

    x_hi_index = x_hi_index - 1

    m = ( x_hi_index - x_lo_index + 1 ) / 2 + 1

    call r8vec_uniform_01 ( 2*m, seed, r )

    x(x_lo_index:x_hi_index-1:2) = &
      sqrt ( - 2.0D+00 * log ( r(1:2*m-3:2) ) ) &
      * cos ( 2.0D+00 * r8_pi * r(2:2*m-2:2) )

    x(x_lo_index+1:x_hi_index:2) = &
      sqrt ( - 2.0D+00 * log ( r(1:2*m-3:2) ) ) &
      * sin ( 2.0D+00 * r8_pi * r(2:2*m-2:2) )

    x(n) = sqrt ( - 2.0D+00 * log ( r(2*m-1) ) ) &
      * cos ( 2.0D+00 * r8_pi * r(2*m) )

  end if

  return
end

subroutine r8vec_normal_ab ( n, a, b, seed, x )

!*****************************************************************************80
!
!! R8VEC_NORMAL_AB returns a scaled pseudonormal R8VEC.
!
!  Discussion:
!
!    The standard normal probability distribution function (PDF) has
!    mean 0 and standard deviation 1.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    06 August 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of values desired.
!
!    Input, real ( kind = 8 ) A, B, the mean and standard deviation.
!
!    Input/output, integer ( kind = 4 ) SEED, a seed for the random
!    number generator.
!
!    Output, real ( kind = 8 ) X(N), a sample of the standard normal PDF.
!
!  Local parameters:
!
!    Local, real ( kind = 8 ) R(N+1), is used to store some uniform
!    random values.  Its dimension is N+1, but really it is only needed
!    to be the smallest even number greater than or equal to N.
!
!    Local, integer ( kind = 4 ) X_LO_INDEX, X_HI_INDEX, records the range
!    of entries of X that we need to compute.
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ) a
  real ( kind = 8 ) b
  integer ( kind = 4 ) m
  real ( kind = 8 ) r(n+1)
  real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793D+00
  ! real ( kind = 8 ) r8_uniform_01 ! ALREADY PART OF MODULE
  integer ( kind = 4 ) seed
  real ( kind = 8 ) x(n)
  integer ( kind = 4 ) x_hi_index
  integer ( kind = 4 ) x_lo_index
!
!  Record the range of X we need to fill in.
!
  x_lo_index = 1
  x_hi_index = n
!
!  If we need just one new value, do that here to avoid null arrays.
!
  if ( x_hi_index - x_lo_index + 1 == 1 ) then

    r(1) = r8_uniform_01 ( seed )

    if ( abs(r(1)) <= 1.0D-10 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'R8VEC_NORMAL_AB - Fatal error!'
      write ( *, '(a)' ) '  R8_UNIFORM_01 returned a value of 0.'
      call error_exit(1)
    end if

    r(2) = r8_uniform_01 ( seed )

    x(x_hi_index) = &
      sqrt ( - 2.0D+00 * log ( r(1) ) ) * cos ( 2.0D+00 * r8_pi * r(2) )
!
!  If we require an even number of values, that's easy.
!
  else if ( mod ( x_hi_index - x_lo_index, 2 ) == 1 ) then

    m = ( x_hi_index - x_lo_index + 1 ) / 2

    call r8vec_uniform_01 ( 2*m, seed, r )

    x(x_lo_index:x_hi_index-1:2) = &
      sqrt ( - 2.0D+00 * log ( r(1:2*m-1:2) ) ) &
      * cos ( 2.0D+00 * r8_pi * r(2:2*m:2) )

    x(x_lo_index+1:x_hi_index:2) = &
      sqrt ( - 2.0D+00 * log ( r(1:2*m-1:2) ) ) &
      * sin ( 2.0D+00 * r8_pi * r(2:2*m:2) )
!
!  If we require an odd number of values, we generate an even number,
!  and handle the last pair specially, storing one in X(N), and
!  saving the other for later.
!
  else

    x_hi_index = x_hi_index - 1

    m = ( x_hi_index - x_lo_index + 1 ) / 2 + 1

    call r8vec_uniform_01 ( 2*m, seed, r )

    x(x_lo_index:x_hi_index-1:2) = &
      sqrt ( - 2.0D+00 * log ( r(1:2*m-3:2) ) ) &
      * cos ( 2.0D+00 * r8_pi * r(2:2*m-2:2) )

    x(x_lo_index+1:x_hi_index:2) = &
      sqrt ( - 2.0D+00 * log ( r(1:2*m-3:2) ) ) &
      * sin ( 2.0D+00 * r8_pi * r(2:2*m-2:2) )

    x(n) = sqrt ( - 2.0D+00 * log ( r(2*m-1) ) ) &
      * cos ( 2.0D+00 * r8_pi * r(2*m) )

  end if

  x(1:n) = a + b * x(1:n)

  return
end

subroutine r8vec_uniform_01 ( n, seed, r )

!*****************************************************************************80
!
!! R8VEC_UNIFORM_01 returns a unit pseudorandom R8VEC.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    31 May 2007
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Paul Bratley, Bennett Fox, Linus Schrage,
!    A Guide to Simulation,
!    Second Edition,
!    Springer, 1987,
!    ISBN: 0387964673,
!    LC: QA76.9.C65.B73.
!
!    Bennett Fox,
!    Algorithm 647:
!    Implementation and Relative Efficiency of Quasirandom
!    Sequence Generators,
!    ACM Transactions on Mathematical Software,
!    Volume 12, Number 4, December 1986, pages 362-376.
!
!    Pierre L'Ecuyer,
!    Random Number Generation,
!    in Handbook of Simulation,
!    edited by Jerry Banks,
!    Wiley, 1998,
!    ISBN: 0471134031,
!    LC: T57.62.H37.
!
!    Peter Lewis, Allen Goodman, James Miller,
!    A Pseudo-Random Number Generator for the System/360,
!    IBM Systems Journal,
!    Volume 8, 1969, pages 136-143.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of entries in the vector.
!
!    Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
!    should NOT be 0.  On output, SEED has been updated.
!
!    Output, real ( kind = 8 ) R(N), the vector of pseudorandom values.
!
  implicit none

  integer ( kind = 4 ) n

  integer ( kind = 4 ) i
  integer ( kind = 4 ) k
  integer ( kind = 4 ) seed
  real ( kind = 8 ) r(n)

  do i = 1, n

    k = seed / 127773

    seed = 16807 * ( seed - k * 127773 ) - k * 2836

    if ( seed < 0 ) then
      seed = seed + 2147483647
    end if

    r(i) = real ( seed, kind = 8 ) * 4.656612875D-10

  end do

  return
end

end module


!**********************************************************************
!    LICENSED MATERIALS - PROPERTY OF IBM                             *
!    "RESTRICTED MATERIALS OF IBM"                                    *
!                                                                     *
!    5765-422                                                         *
!    (C) COPYRIGHT IBM CORP. 1995. ALL RIGHTS RESERVED.               *
!                                                                     *
!    U.S. GOVERNMENT USERS RESTRICTED RIGHTS - USE, DUPLICATION       *
!    OR DISCLOSURE RESTRICTED BY GSA ADP SCHEDULE CONTRACT WITH       *
!    IBM CORP.                                                        *
!**********************************************************************
      module parameters
!
!   Purpose: Define system wide parameters and pessl structure.
!
        implicit none
        public
        integer, parameter :: long=8, short=4
        real(long), parameter :: pi = 3.141592653589793d0
        real(long), parameter :: twopi = 2.d0*pi

        type g_index
         integer :: num_row_blks, num_col_blks
         integer, pointer :: srb(:), scb(:), erb(:), ecb(:)
        end type g_index
!
!  The g_index type was created for convenience
!     components:
!        num_row_blks: number of block repetitions over matrix rows.
!        num_col_blks: number of block repetitions over matrix columns.
!        srb: global row index at start of a block
!             corresponding local index is ( block # -1) * mb
!             where mb is the number of rows in the block.
!
!        scb: global column index at start of a block
!             corresponding local index is ( block # -1) * nb
!             where nb is the number of columns in the block.
!
!        erb: last global row index in the block.
!        ecb: last global column index in the block.
        public g_index

      end module parameters


module flow_rate_t_interface
  !! Describe the gas flow rates resulting from the chamber-pressure/exit-pressure differential
  use constants, only : dp
  implicit none

  private

  type, public :: flow_rate_t
    !! Encapsulate the gas mass and internal energy flow rates
    private
    real(dp) mdotos_ !! mass flow rate
    real(dp) edotos_ !! internal energy flow rate
  contains
    procedure :: mdotos
    procedure :: edotos
  end type

  interface flow_rate_t !! Generic interface to user-defined structure constructors
    module procedure new_flow_rate_t
  end interface

  interface

    pure module function new_flow_rate_t(t, g, rgas, p, cp, area) result(new_flow_rate)
       !! Result is a new flow_rate_t object defined by the actual arguments
       implicit none
       real(dp), intent(in) :: t       !! temperature
       real(dp), intent(in) :: g       !! ratio of specific heats
       real(dp), intent(in) :: rgas    !! ideal gas constant
       real(dp), intent(in) :: p       !! pressure
       real(dp), intent(in) :: cp      !! constant-pressure specific heat
       real(dp), intent(in) :: area    !! flow area
       type(flow_rate_t) new_flow_rate
    end function

    pure module function mdotos(this)
      !! Result is this flow_rate_t object's mass flow rate
      implicit none
      class(flow_rate_t), intent(in) :: this
      real(dp) mdotos
    end function

    pure module function edotos(this)
      !! Result is this flow_rate_t object's internal energy flow rate
      implicit none
      class(flow_rate_t), intent(in) :: this
      real(dp) edotos
    end function

  end interface

end module flow_rate_t_interface


christen this file checkd.f

c  Copyright (C) 2010 Roger Fletcher

c  Current version 20 January 2011

c  THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THE ECLIPSE PUBLIC
c  LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION OF THE PROGRAM
c  CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT

      subroutine checkd(n,m,x,al,ws,lws,maxa,maxla,maxu,maxiu,
     *  mxws,mxlws,tol,iprint,nout,ifail)
      implicit double precision (a-h,o-z)

c  first derivative checking subroutine for use with filterSD code

c  Parameters
c  **********
c  n    set number of variables
c  m    set number of constraints
c  x    set any vector of variables in x(i), i=1,n
c  al   set a vector of differencing increments in al(i), i=1,n
c        (al(i) is the difference interval for x(i) and must be nonzero,
c        say 0.01 times the typical magnitude of x(i))
c  ws   double precision workspace (the amount required for filterSD.f should
c       be plenty)
c  lws  integer workspace (use the amount required for filterSD.f)
c  maxa set as maxa parameter for filterSD
c  maxla set as maxla parameter for filterSD
c  maxu  set as maxu parameter for filterSD
c  maxiu  set as maxiu parameter for filterSD
c  mxws  set the length of ws as provided in the driver
c  mxlws  set the length of lws as provided in the driver
c  tol  tolerace (>0) for reporting inconsistencies in derivatives (eg 1.D-12)
C  iprint  verbosity of printing (0=none, 1=one line per iteration,
C            2=additional text information given)
C  nout    output channel for write(nout,*)ing
c  ifail   returns failure indication as follows
c              -1 = ws not large enough
c              -2 = lws not large enough
c              -3 = derivative inconsistency in constraint/variable

c  Usage
c  *****
c  The user must write subroutines 'functions' and 'gradients' as for filterSD
c  Write a driver program for your problem,  but replace the call of filterSD
c  by a call of checkd (having set differencing increments in al).
c    The program will report any inconsistencies in the derivatives.
c  If the difference quotient estimate lies between the derivatives
c  at x and x+h (h is the perturbation stored in in al) then the
c  derivative is assumed to be correct. Small errors in this
c  comparison may be ignored. If no errors are reported then the
c  call of filter.. may be restored.

      dimension x(*),al(*),ws(*),lws(*)
      if (iprint.gt.0) write(nout,*) 'entering checkd'
      m1=m+1
c  set real storage map for ws
c  first maxu locations are user storage for functions and gradients
c  vectors required by checkd: two slots of length maxa for a(*)
      last1=maxu+1
      next1=last1+maxa
c  slot of length m+1 for f,c at x
      ncx0=next1+maxa
      ncx1=ncx0+1
c  slot of length m+1 for f,c at x + h.e_i
      ncxd0=ncx0+m1
      ncxd1=ncxd0+1
c  total length of ws used is
      kk=ncxd0+m
      if(kk.gt.mxws)then
        if (iprint.gt.0)then
          write(nout,1) 'ws not large enough: kk, mxws =',kk,mxws
        endif
        ifail = -1
        return
      endif

c  set integer storage map for lws
c  first maxiu locations are user storage for functions and gradients
c  storage of length maxla for la(0:*)
      nla1=maxiu+1
c  total storage needed is
      ll=nla1+maxla-1
      if(ll.gt.mxlws)then
        if (iprint.gt.0)then
          write(nout,1) 'lws not large enough: ll, mxlws =',ll,mxlws
        endif
        ifail = -2
        return
      endif

      call functions(n,m,x,ws(ncx0),ws(ncx1),ws,lws)
      call gradients(n,m,x,ws(last1),ws,lws)
c     if (iprint.gt.0)
c       write(nout,4) 'ws_0',(ws(j),j=last1,last1+7)
c     endif
      do i=1,n
        xi=x(i)
        x(i)=x(i)+al(i)
        call functions(n,m,x,ws(ncxd0),ws(ncxd1),ws,lws,iflag)
        call gradients(n,m,x,ws(next1),ws,lws,iflag)
        do 10 j=0,m
          dfi=(ws(ncxd0+j)-ws(ncx0+j))/al(i)
          a_ij=aij(i,j,ws(last1),lws(nla1))
          ah_ij=aij(i,j,ws(next1),lws(nla1))
          if((dfi.ge.a_ij-tol.and.dfi.le.ah_ij+tol).or.
     *      (dfi.ge.ah_ij-tol.and.dfi.le.a_ij+tol))goto10
          if (iprint.gt.0)then
            write(nout,1)
     *        'derivative inconsistency in constraint/variable',j,i
            write(nout,*) 'deriv at x, diff quotient, deriv at x+h =',
     *          a_ij,dfi,ah_ij
            write(nout,*) 'c at x+h, c at x',ws(ncxd0+j),ws(ncx0+j)
c           write(nout,1) 'la(0) =',la(0)
c           write(nout,1) 'c/s j pointer =',la(la(0)+j)
c           write(nout,3) 'c/s j indices',
c     *        (la(k),k=la(la(0)+j),la(la(0)+j+1)-1)
c           write(nout,4) 'c/s j entries',
c     *        (a(k),k=la(la(0)+j),la(la(0)+j+1)-1)
          endif
          ifail = -3
          return
   10   continue
        x(i)=xi
      enddo
      if (iprint.gt.0) write(nout,*) 'derivative check successful'
      if (iprint.gt.0) write(nout,*) 'exiting checkd'
    1 format(A,15I5)
    2 format(A,6E15.7)
    3 format(A/(20I4))
    4 format(A/(6E15.7))
      return
      end


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!! Norm ovelap with the bare vacuum !!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

      Subroutine zbareover(ZV,ZU,ZZc,Det,N)
      Use VAPHFB_Par
      implicit real*8 (a-h,o-y)
      implicit complex*16 (z)

      Dimension ZV(N,N),ZU(N,N)
      Dimension ZUINV(N,N),ZZ(N,N),ZZc(N,N)
      Dimension ZZTZ(N,N)
      Dimension IPIV(N)
      Dimension ZWORK(N)
      Dimension ZWR(N)
      Dimension ZVL(N,N)
      Dimension ZVR(N,N)
      Dimension ZWORK1(2*N)
      Dimension WORK1(2*N)

!      ulimit=1.e+15
      do ii=1,N
       do jj=1,N
        ZUINV(jj,ii)=ZU(jj,ii)
       end do
      end do

      !LU factorization: The factorization has the form A = P * L * U
      call ZGETRF(N,N,ZUINV,N,IPIV,INFO1)

      if(info1.ne.0) then
	write(6,*) ' In bareover got INFO1 = ',info1,' from ZGETRF'
	stop
      end if

!    This method inverts U and then computes inv(A) by solving the system
!    inv(A)*L = inv(U) for inv(A).
!    .............................
      ! U Inverse: U^-1
      call ZGETRI(N,ZUINV,N,IPIV,ZWORK,N,INFO2)
      if(info2.ne.0) then
	write(6,*) ' In bareover got INFO2 = ',info2,' from ZGETRI'
	stop
      end if

      ! Z^* = VU^-1
      call ZGEMM ('n','n',N,N,N,zone,ZV,N,ZUINV,N,zzero,ZZ,N)

      do ii=1,N
      do jj=1,N
         ZZc(jj,ii)=dconjg(ZZ(jj,ii))
!         write(700,'(2i3,2f12.5)') ii,jj,ZZc(jj,ii)
      end do
      end do

      !Z^t*Z
      call ZGEMM ('t','n',N,N,N,zone,ZZc,N,ZZc,N,zzero,ZZTZ,N)

      !Eigensystem: ZGEEV computes for an N-by-N complex nonsymmetric matrix A,
      !the eigenvalues and, optionally, the left and/or right eigenvectors.
      call ZGEEV('n','n',N,ZZTZ,N,ZWR,ZVL,N,ZVR,N,ZWORK1,2*N,WORK1,INFO3 )
          if(info3.ne.0) then
           write(6,*) ' In bareover got INFO3 = ',info3,' from ZGEEV'
             stop
      end if

      ztest = zzero
      zdet=zone
      do ii=1,N
       zdet=zdet*(zone+ZWR(ii))
       ztest = ztest + log(1.d0+ZWR(ii))
      end do
      Det  = dreal(EXP(-ztest/4.d0))
      return
      end

      subroutine ROTATION_MAT(alp,bet,gam,ZROT,NLEV)
!    .................................................................
!     R(alp,bet,gam) = e^(-i alp J_z) * e^(-i bet J_y) * e^(-i gam J_z)
!    .................................................................
      USE VAPHFB_PAR
      implicit real*8 (a-h,o-y)
      implicit complex*16 (z)

      DIMENSION ZROT(NLEV,NLEV)
      DIMENSION ZAUX(NLEV,NLEV)
      do ii=1,NLEV
	do jj=1,NLEV
	 ZROT(jj,ii)=zzero
	end do
      end do

      !matrix elements
      do ia=1,NLEV

         ina=tnljm%n(ia) ! nlindex(ia)
         ila =tnljm%l(ia) ! lang(ia)
         ija =tnljm%twoj(ia) ! jang(ia)
         ima =tnljm%twom(ia) ! mjang(ia)
         ita =tnljm%t(ia)    ! mtisos(ia)

	rma=ima/2.d0

	zialpha_ma=cdexp(-Zimag*alp*rma)

       do ib=1,NLEV

         inb =tnljm%n(ib) ! nlindex(ia)
         ilb =tnljm%l(ib) ! lang(ia)
         ijb =tnljm%twoj(ib) ! jang(ia)
         imb =tnljm%twom(ib) ! mjang(ia)
         itb =tnljm%t(ib)    ! mtisos(ia)

        if((inb.eq.ina).AND.(ilb.eq.ila).AND.  &
     &  (itb.eq.ita).AND.(ijb.eq.ija)) then

        rmb=imb/2.d0

        zigamma_mb=cdexp(-Zimag*gam*rmb)
        ZROT(ia,ib)=zialpha_ma*zigamma_mb*dwignerI_gen('h',ija,ima,imb,bet)
        end if

       end do
      end do

!      call ZGEMM ('c','n',NLEV,NLEV,NLEV,zone, &
!     & ZROT,NLEV,ZROT,NLEV,Zzero,ZAUX,NLEV)
!      call print_zmatrix(NLEV,ZROT)

      end subroutine

      SUBROUTINE Pfaf_Over(ZM0,ZUbar,ZVbar,ZdetPfaf,N)
      USE VAPHFB_Par
      implicit real*8(a-h,o-y)
      implicit complex*16 (z)

      Dimension ZPfaf(2*N,2*N) !rotation matrix
      Dimension ZUbar(N,N),ZVbar(N,N)
      Dimension ZUbar_inv(N,N),ZVbar_c(N,N)
      Dimension ZM0(N,N)

      Dimension IPIV(N)
      Dimension ZWORK(N)

      Dimension ZM1(N,N)

      Dimension ZAUX1(N,N)
      Dimension ZAUX2(N,N)

      DIMENSION Ipiv2(2*N,2)

      do ii=1,N
       do jj=1,N
        ZUbar_inv(jj,ii)=dconjg(ZUbar(jj,ii))
        ZVbar_c(jj,ii)=dconjg(ZVbar(jj,ii))
       end do
      end do

      !LU factorization
      call ZGETRF(N,N,ZUbar_inv,N,IPIV,INFO1)

      if(info1.ne.0) then
        write(6,*) ' In Pfaf_Over got INFO1 = ',info1,' from ZGETRF'
        stop
      end if

      !Inverse
      call ZGETRI(N,ZUbar_inv,N,IPIV,ZWORK,N,INFO2)
      if(info2.ne.0) then
       write(6,*) ' In Pfaf_Over got INFO2 = ',info2,' from ZGETRI'
       stop
      end if

      !Z
      call ZGEMM ('n','n',N,N,N,zone,ZVbar_c,N,ZUbar_inv,N,zzero,ZM1,N)

      !Big M
      do ii=1,N
       do jj=1,N
         ZPfaf(jj,ii)=ZM1(jj,ii)
         ZPfaf(jj+N,ii+N)=-ZM0(jj,ii)
         ZPfaf(jj,ii+N)=zzero
         ZPfaf(jj+N,ii)=zzero
         if (ii.eq.jj) then
           ZPfaf(ii,ii+N)=-zone
           ZPfaf(ii+N,ii)=zone
          end if
       end do
      end do
!     .............. scaled by a factor
      do ii=1,N*2
      do jj=1,N*2
           ZPfaf(ii,jj)=ZPfaf(ii,jj)*Input%Cscale
      end do
      end do
      call ZPfaffianF(ZPfaf,2*N,2*N,Ipiv2,ZdetPfaf)

      end subroutine

!+--------------------------------------------------------------------+
!|   C o m p l e x    V e r s i o n                                   |
!|                                                                    |
!+--------------------------------------------------------------------+
       Subroutine ZPfaffianF(SK,LDS,N,Ipiv,Pf)
       Implicit none
       Double Complex SK(LDS,N)
       Double Complex Pf,SS,SW,one,zero
       Double Precision epsln,phas,big
       Integer Ipiv(N,2),N,LDS,NB,IB,i,j,k,ip,NR,NC,I1,I2

       one = dcmplx(1.0d+00,0.0d+00)
       zero= dcmplx(0.0d+00,0.0d+00)

       epsln = 1.0d-13   ! smallest number such that 1+epsln=1

       if(mod(N,2).eq.1) then ! N odd

       Pf = zero

       else

       NB= N / 2   ! Number of 2x2 blocks

       if (NB.eq.1) then

! The pfaffian of a 2x2 matrix is Pf=Sk(1,2)

       Pf = SK(1,2)

       else   ! NB.gt.1

       Pf = one

       do IB=1,NB-1

          NR = IB*2 - 1 ! row numb of the 1,2 element of the 2x2 block
          NC = NR + 1

          big = 0.0d+00

          I1 = NR
          I2 = NC

          do i=NR,N-1 ! all rows
             do j=i+1,N

                if(abs(SK( i , j )).gt. big) then
                   big = abs(SK( i , j ))
                   I1 = i
                   I2 = j
                end if

             end do
          end do

          Ipiv( IB , 1) = I1 ! to initialize
          Ipiv( IB , 2) = I2 ! to initialize

          phas = 1.0d+00
          if(I1.eq.NR) phas = -phas
          if(I2.eq.NC) phas = -phas

! Pivoting of element NR,NC with ip1,ip2

!
!   Pivoting for a skew-symmetric matrix (Upper)
!
          if(I1.ne.NR) Call Zexch(SK,LDS,N,NR,I1)
          if(I2.ne.NC) Call Zexch(SK,LDS,N,NC,I2)

       ss = Sk( NR , NC )

!       write(6,*) ' IB I2, I2 ', IB,I1,I2,big,ss

       if(abs(ss).gt.epsln) then
!
!      Updating the Schur complement  matrix
!

       do i = 2*IB+1 , N-1

          do j = i+1 , N

             Sk(i,j) = Sk(i,j) +   (Sk(NC,i)*Sk(NR,j)-Sk(NR,i)*Sk(NC,j))/SS
          end do
       end do
!
! Storing X and Y vectors in the lower part of the matrix
!
       do i = 2*IB+1 , N

          Sk( i , NR ) =  -Sk( NC , i )/SS
          Sk( i , NC ) =   Sk( NR , i )/SS

       end do

       if (IB.ge.2) then  ! swap

!
!   Swapping
!
       do j= 1 , 2*IB

          SW           = Sk( NR , j )
          Sk( NR , j ) = Sk( I1 , j )
          Sk( I1 , j ) = SW

          SW           = Sk( NC , j )
          Sk( NC , j ) = Sk( I2 , j )
          Sk( I2 , j ) = SW

       end do

       end if

       else

       Pf = zero

       return

       end if ! dabs(ss).gt.epsln

       Pf = Pf * SS * phas

       end do ! IB

       Pf = Pf * Sk(N-1,N)

       end if !    NB.eq.1

       end if !    mod(N,2).eq.1

       return
       end
!
!  Exchange of rows i1 i2 and columns i1 i2
!  SK is assumed upper triangular
!  i1 < i2
!
       Subroutine ZExch(SK,LDS,N,I1,I2)
       Implicit none
       Double Complex SK(LDS,N)
       Double Complex SS
       Integer LDS,N,I1,I2,I

       SK(i1,i2) = -SK(i1,i2)

       if(I1.ne.1) then

          do i=1,I1-1
             SS           = SK( i , I1 )
             SK( i , I1 ) = SK( i , I2 )
             SK( i , I2 ) = SS
          end do
       end if

       if(I2.ne.N) then

          do i=I2+1,N
             SS           = SK( I1 , i )
             SK( I1 , i ) = SK( I2 , i )
             SK( I2 , i ) = SS
          end do
       end if

       if(I2.ge.I1+2) then

          do i=I1+1,I2-1
             SS           =  SK( I1 , i )
             SK( I1 , i ) = -SK( i , I2 )
             SK( i , I2 ) = -SS
          end do
       end if

       return
       end

      subroutine UVphiomega(philZ,philN,ZROT,ZU,ZV,ZUbar,ZVbar,ZAM_PHI_OMEGA,N)
!    ............................................................
!    calculate  U(Omega), V(Omega,phi_n,phi_p)
!    ............................................................

      implicit real*8 (a-h,o-y)
      implicit complex*16 (z)
      Parameter (zone=(1.d0,0.d0))
      Parameter (zimag=(0.d0,1.d0))
      Parameter (zzero=(0.d0,0.d0))

      Dimension ZV(N,N),ZU(N,N)
      Dimension ZUbar(N,N),ZVbar(N,N)
      Dimension ZROT(N,N)
      Dimension ZAM_PHI_OMEGA(N,N),ZAM_PHI_OMEGAc(N,N)

!     ............................
      zphasUZ=cdexp(zimag*philZ)       ! exp(i*phi_p)
      zphasUN=cdexp(zimag*philN)       ! exp(i*phi_n)
      zphasVZ=cdexp(-zimag*philZ)
      zphasVN=cdexp(-zimag*philN)

      do ii=1,N
       do jj=1,N
          ZAM_PHI_OMEGA(jj,ii)=zzero
          ZAM_PHI_OMEGAc(jj,ii)=zzero
        end do
      end do

!   .........................
!   U_p(Omega) = R(Omega)   U_p: 1,.., N/2
!   U_n(Omega) = R(Omega)   U_n: N/2+1, ..., N
!   V_p(Omega) = R^*(Omega) V_p: 1,..., N/2
!   V_n(Omega) = R^*(Omega) V_n: N/2+1, ..., N
!   ........................

      do ii=1,N/2
       do jj=1,N/2
        ZAM_PHI_OMEGA(ii,jj)         =zphasUZ*ZROT(ii,jj)
        ZAM_PHI_OMEGA(ii+N/2,jj+N/2) =zphasUN*ZROT(ii+N/2,jj+N/2)
        ZAM_PHI_OMEGAc(ii,jj)        =dconjg(ZAM_PHI_OMEGA(ii,jj))
        ZAM_PHI_OMEGAc(ii+N/2,jj+N/2)=dconjg(ZAM_PHI_OMEGA(ii+N/2,jj+N/2))
       end do
      end do

      !Ubar
      call ZGEMM ('n','n',N,N,N,zone,ZAM_PHI_OMEGA,N,ZU,N,zzero,ZUbar,N)
!    ............................................
!     If you find ZUbar  different, which is probabbly due to different ZROT
!     from the different definition of the ordering for the s.p. energy levels
!    ............................................
!      write(*,*) N
!      call ZGEMM ('n','n',N,N,N,zone,ZROT,N,ZU,N,zzero,ZUbar,N)
!      call print_zmatrix3(N,ZROT,ZU,ZUbar)  ! ZROT, ZU are the same

      !Vbar
      call ZGEMM ('n','n',N,N,N,zone,ZAM_PHI_OMEGAc,N,ZV,N,zzero,ZVbar,N)

      end subroutine

       SUBROUTINE ROKAPPAphiomega(ZAM_phi_omega,ZU0,ZV0,ZU1,ZV1,ZRO,ZKAPA10,ZKAPA01,N)

      implicit real*8 (a-h,o-y)
      implicit complex*16 (z)
      Parameter (zone=(1.d0,0.d0))
      Parameter (zonem=(-1.d0,0.d0))
      Parameter (zimag=(0.d0,1.d0))
      Parameter (zzero=(0.d0,0.d0))

      DIMENSION ZAM_phi_omega(N,N)
      DIMENSION ZAM_phi_omegac(N,N)
      DIMENSION ZU0(N,N),ZV0(N,N)
      DIMENSION ZU1(N,N),ZV1(N,N)
      DIMENSION ZRO(N,N)
      DIMENSION ZKAPA10(N,N),ZKAPA01(N,N)

      DIMENSION ZT22INV(N,N)
      Dimension IPIV(N)
      Dimension ZWORK(N)

      DIMENSION ZAUX1(N,N)
      DIMENSION ZAUX2(N,N)
      DIMENSION ZAUX3(N,N)
      DIMENSION ZAUX4(N,N)

      do ii=1,N
       do jj=1,N
	ZAM_phi_omegac(jj,ii)=dconjg(ZAM_phi_omega(jj,ii))
        end do
      end do

!!!!!!!!!!!!! T22/T22inv !!!!!!!!!!!!!!!!!

      call ZGEMM ('t','n',N,N,N,zone,        &
     &	ZV0,N,ZAM_phi_omega,N,zzero,ZAUX1,N)

      call ZGEMM ('n','n',N,N,N,zone,        &
     &	ZAUX1,N,ZV1,N,zzero,ZAUX2,N)

       call ZGEMM ('t','n',N,N,N,zone,       &
     &	ZU0,N,ZAM_phi_omegac,N,zzero,ZAUX3,N)

      call ZGEMM ('n','n',N,N,N,zone,        &
     &	ZAUX3,N,ZU1,N,zzero,ZAUX4,N)

      do ii=1,N
       do jj=1,N
          ZT22INV(jj,ii)=ZAUX2(jj,ii)+ZAUX4(jj,ii)
        end do
      end do

      !LU factorization
      call ZGETRF(N,N,ZT22INV,N,IPIV,INFO1)
      !Inverse
      call ZGETRI(N,ZT22INV,N,IPIV,ZWORK,N,INFO2)

!!!!!!!!!!! RHO, KAPPA !!!!!!!!!!!
      call ZGEMM ('n','n',N,N,N,zone,  &
     &	ZAM_phi_omega,N,ZV1,N,zzero,ZAUX1,N)

      call ZGEMM ('n','n',N,N,N,zonem,  &
     &	ZAM_phi_omegac,N,ZU1,N,zzero,ZAUX2,N)

      call ZGEMM ('n','t',N,N,N,zone,   &
     &	ZT22INV,N,ZV0,N,zzero,ZAUX3,N)

      call ZGEMM ('n','t',N,N,N,zone,   &
     &	ZT22INV,N,ZU0,N,zzero,ZAUX4,N)

      !rho
      call ZGEMM ('n','n',N,N,N,zone,  &
     &	ZAUX1,N,ZAUX3,N,zzero,ZRO,N)

      !kappa10
      call ZGEMM ('n','n',N,N,N,zone,   &
     &	ZAUX1,N,ZAUX4,N,zzero,ZKAPA10,N)

      !kappa10
      call ZGEMM ('n','n',N,N,N,zone,  &
     &	ZAUX2,N,ZAUX3,N,zzero,ZKAPA01,N)

       return
       END SUBROUTINE

      subroutine UVbar(philZ,philN,ZU,ZV,ZUbar,ZVbar,N)
      implicit real*8 (a-h,o-y)
      implicit complex*16 (z)
      Parameter (zone=(1.d0,0.d0))
      Parameter (zimag=(0.d0,1.d0))
      Parameter (zzero=(0.d0,0.d0))

      Dimension ZV(N,N),ZU(N,N)
      Dimension ZUbar(N,N),ZVbar(N,N)

      zphasUZ=cdexp(zimag*philZ)
      zphasUN=cdexp(zimag*philN)
      zphasVZ=cdexp(-zimag*philZ)
      zphasVN=cdexp(-zimag*philN)

      do ii=1,N/2
       do jj=1,N
        ZUbar(ii    ,jj)=zphasUZ*ZU(ii    ,jj)
        ZUbar(ii+N/2,jj)=zphasUN*ZU(ii+N/2,jj)
        ZVbar(ii    ,jj)=zphasVZ*ZV(ii    ,jj)
        ZVbar(ii+N/2,jj)=zphasVN*ZV(ii+N/2,jj)
       end do
      end do

      end subroutine

      subroutine UVphi(ZU,ZV,ZUbar,ZVbar,ZAphi,ZRO,ZKAPA10,ZKAPA01,ZUphic,ZVphic,N)

      implicit real*8 (a-h,o-y)
      implicit complex*16 (z)
      Parameter (zone=(1.d0,0.d0))
      Parameter (zonem=(-1.d0,0.d0))
      Parameter (zimag=(0.d0,1.d0))
      Parameter (zzero=(0.d0,0.d0))

      Dimension ZV(N,N),ZU(N,N)
      Dimension ZVc(N,N),ZUc(N,N)
      Dimension ZUbar(N,N),ZVbar(N,N)
      Dimension ZUphi(N,N),ZVphi(N,N)
      Dimension ZUphic(N,N),ZVphic(N,N)
      Dimension ZUtilde(N,N),ZVtilde(N,N)
      Dimension ZUtilde_inv(N,N),ZVtilde_c(N,N)
      Dimension ZAphi(N,N)
      Dimension ZRO(N,N),ZKAPA10(N,N),ZKAPA01(N,N)
      Dimension IPIV(N)
      Dimension ZWORK(N)
      Dimension ZAUX1(N,N)
      Dimension ZAUX2(N,N)

      call ZGEMM ('c','n',N,N,N,zone,ZU,N,ZUbar,N,Zzero,ZUtilde,N)
      call ZGEMM ('c','n',N,N,N,zone,ZV,N,ZVbar,N,zone,ZUtilde,N)

      call ZGEMM ('t','n',N,N,N,zone,ZV,N,ZUbar,N,Zzero,ZVtilde,N)
      call ZGEMM ('t','n',N,N,N,zone,ZU,N,ZVbar,N,zone,ZVtilde,N)

      do ii=1,N
       do jj=1,N
        ZUtilde_inv(jj,ii)=dconjg(ZUtilde(jj,ii))
        ZVtilde_c(jj,ii)=dconjg(ZVtilde(jj,ii))
        ZVc(jj,ii)=dconjg(ZV(jj,ii))
        ZUc(jj,ii)=dconjg(ZU(jj,ii))
       end do
      end do

      Call ZGETRF(N,N,ZUtilde_inv,N,IPIV,INFO)

      if(info.ne.0) then
        write(6,*) ' In AINV got INFO = ',info,' from ZGETRF 3'
        stop
      end if

      Call Zgetri (N,ZUtilde_inv,N,IPIV,ZWORK,N,INFO)
      if(info.ne.0) then
        write(6,*) ' In AINV got INFO = ',info,' from DGETRI 4'
        stop
      end if

      call ZGEMM ('n','n',N,N,N,Zone,          &
     &	ZVtilde_c,N,ZUtilde_inv,N,zzero,ZAphi,N)

      call ZGEMM ('n','n',N,N,N,zone,	      &
     & ZU,N,ZAphi,N,Zzero,ZAUX1,N)
      call ZGEMM ('n','n',N,N,N,zone,	      &
     & ZV,N,ZAphi,N,Zzero,ZAUX2,N)

      do ii=1,N
       do jj=1,N
        ZVphi(jj,ii)=ZVc(jj,ii)+ZAUX1(jj,ii)
        ZUphi(jj,ii)=ZUc(jj,ii)+ZAUX2(jj,ii)
        ZVphic(jj,ii)=dconjg(ZVphi(jj,ii))
        ZUphic(jj,ii)=dconjg(ZUphi(jj,ii))
       end do
      end do

      call ZGEMM ('n','t',N,N,N,zone, ZVphi,N,ZV,N,Zzero,ZRO,N)

      call ZGEMM ('n','t',N,N,N,zone, ZVphi,N,ZU,N,Zzero,ZKAPA10,N)

      call ZGEMM ('n','t',N,N,N,zonem, ZUphi,N,ZV,N,Zzero,ZKAPA01,N)

      end subroutine

!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!     Computes the norm overlap following Neergard's prescription           c
!                                                                           c
!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      SUBROUTINE Neer_Over(Zneer,ZUbar,ZVbar,ZdetNe,N)

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

      Parameter (Zone=(1.d0,0.d0))
      Parameter (Zzero=(0.d0,0.d0))
      Parameter (Zimag=(0.d0,1.d0))

      Dimension Zneer(N,N) !rotation matrix
      Dimension ZUbar(N,N),ZVbar(N,N)
      Dimension ZUbar_inv(N,N),ZVbar_c(N,N)
      Dimension ZZ(N,N)

      Dimension IPIV(N)
      Dimension ZWORK(N)

      Dimension ZZZS(N,N)

      Dimension ZAUX1(N,N)
      Dimension ZAUX2(N,N)

      do ii=1,N
       do jj=1,N
        ZUbar_inv(jj,ii)=dconjg(ZUbar(jj,ii))
	ZVbar_c(jj,ii)=dconjg(ZVbar(jj,ii))
       end do
      end do
      !LU factorization
      call ZGETRF(N,N,ZUbar_inv,N,IPIV,INFO1)

      if(info1.ne.0) then
	write(6,*) ' In Neerover got INFO1 = ',info1,' from ZGETRF'
	stop
      end if

      !Inverse
      call ZGETRI(N,ZUbar_inv,N,IPIV,ZWORK,N,INFO2)
      if(info2.ne.0) then
	write(6,*) ' In Neerover got INFO2 = ',info2,' from ZGETRI'
	stop
      end if

      !Z
      call ZGEMM ('n','n',N,N,N,zone,ZVbar_c,N,ZUbar_inv,N,zzero,ZZ,N)

      !ZtZ
      call ZGEMM ('t','n',N,N,N,zone,Zneer,N,ZZ,N,zzero,ZZZS,N)

      call ccstot(ZZZS,ZdetNe,N)

      return

      END SUBROUTINE

      SUBROUTINE ccstot(ZCCS,ZdetNe,N)

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

      Parameter (Zone=(1.d0,0.d0))
      Parameter (Zzero=(0.d0,0.d0))
      Parameter (Zimag=(0.d0,1.d0))

      Dimension ZCCS(N,N)
      Dimension Zeigen(N),Zeigenaux1(N)
      Dimension Zeigenaux(N)
      Dimension ZWORK(2*N)
      Dimension AModeigen(N)
      Dimension Ieigen(N)

      Dimension RWORK(2*N)

      Dimension ZVL(N,N),ZVR(N,N)

!      !Diagonalization
      Call ZGEEV('n','n',N,ZCCS,N,Zeigen,ZVL,N,ZVR,N,   &
     & ZWORK,2*N,RWORK,INFOCC)
      if(infoCC.ne.0) then
       write(6,*) ' In ccstot got INFOCC = ',infoCC,' from ZGETRF CC'
       stop
      end if

      do ii=1,N
       Amodeigen(ii)=dsqrt(dreal(Zeigen(ii))**2+dimag(Zeigen(ii))**2)
       Ieigen(ii)=ii
      end do

      call SORTVC (N,Ieigen,Amodeigen,1)

      do ii=1,N
       jj=Ieigen(ii)
       Zeigenaux1(ii)=Zeigen(jj)
      end do

      do ii=1,N,2

       Zeigenaux(ii)=Zeigenaux1(ii)
       Zeigenaux(ii+1)=Zeigenaux1(ii+1)

       aa=Dimag(Zeigenaux1(ii));bb=Dimag(Zeigenaux1(ii+1))
       if(aa.lt.bb) then
        Zeigenaux(ii+1)=Zeigenaux1(ii)
        Zeigenaux(ii)=Zeigenaux1(ii+1)
       end if
      end do

      ZdetNe=Zone
      ij=0
      do ii=1,N,2
       jj=ii+ij
       ZdetNe=ZdetNe*(Zone+Zeigenaux(jj))
       ij=1-ij
      end do

1000  format(I4,2E20.10)
      return

      END SUBROUTINE

! ******************************************************************
!
!  Sortvc sorts D and (if required) E and the columns of Q.
!
!     Prameters:
!
!       ND      (I) :  Number of elements in D (or columns in Q)
!       ID      (IO):  original index corresponding to the elements sorted
!       D       (I) :  Vector to sort
!               (O) :  Sorted vector
!       M       (I) :  1: Descending order in D
!                     -1: Ascending order in D
!                      otherwise: no sorting
! **********************************************************************
!
      SUBROUTINE SORTVC (ND,ID,D,M)
        IMPLICIT REAL*8 (A-H,O-Z)
        LOGICAL    LMIN,LMAX
        DIMENSION  D(ND)
	DIMENSION  ID(ND)
!
        IF (ND .LT. 2) RETURN
        LMAX = (M .EQ.  1)
        LMIN = (M .EQ. -1)
        IF (.NOT. (LMAX .OR. LMIN)) RETURN
        DO 40 KK = 2,ND
          K = KK - 1
          J = K
          H = D(K)
	  L = ID(K)
!
!  FIND EXTREMUM
!
          DO 10 I = KK,ND
            S = D(I)
	    MM = ID(I)
            IF (LMIN .AND. (S .GE. H)) GOTO 10
            IF (LMAX .AND. (S .LE. H)) GOTO 10
            J = I
            H = S
	    L = MM
   10     CONTINUE
          IF (J .EQ. K) GOTO 40
!
!  SORT D
!
          D(J) = D(K)
	  ID(J) = ID(K)
          D(K) = H
	  ID(K) = L

   40   CONTINUE
        RETURN
      END

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!! ISOSPIN ROTATION MATRIX  !!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	subroutine isospin_rot(alp,bet,gam,ZROT_ISO,NDIM)

	implicit real*8 (a-h,o-y)
	implicit complex*16 (z)
	PARAMETER (zone=(1.d0,0.d0))
	PARAMETER (zzero=(0.d0,0.d0))
	PARAMETER (zimag=(0.d0,1.d0))

	DIMENSION ZROT_ISO(NDIM,NDIM)

	do ii=1,NDIM
	 do jj=1,NDIM
	  ZROT_ISO(jj,ii)=zero
	 end do
	end do

	zprot_a=cdexp(zimag*alp/2.d0)
	zprot_c=cdexp(zimag*gam/2.d0)

	zneut_a=cdexp(-zimag*alp/2.d0)
	zneut_c=cdexp(-zimag*gam/2.d0)

	sb=dsin(bet/2.)
	cb=dcos(bet/2.)

!POINTERS
        ip=0
	ipb=ip+NDIM/4
	in=ipb+NDIM/4
	inb=in+NDIM/4

	do ii=1,NDIM/4
	  !Tz
	  ZROT_ISO(ii+ip,ii+ip )  = zprot_a*zprot_c*cb
	  ZROT_ISO(ii+ipb,ii+ipb )= zprot_a*zprot_c*cb
	  ZROT_ISO(ii+in,ii+in )  = zneut_a*zneut_c*cb
	  ZROT_ISO(ii+inb,ii+inb )= zneut_a*zneut_c*cb

	  !Tx
	  ZROT_ISO(ii+ip,ii+in)  = zprot_a*zneut_c*sb
	  ZROT_ISO(ii+ipb,ii+inb)= zprot_a*zneut_c*sb
	  ZROT_ISO(ii+in,ii+ip)  =-zneut_a*zprot_c*sb
	  ZROT_ISO(ii+inb,ii+ipb)=-zneut_a*zprot_c*sb
	end do

        end subroutine

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!! SPIN ROTATION MATRIX     !!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	subroutine spin_rot(alp,bet,gam,ZROT_SPIN,NDIM)

	implicit real*8 (a-h,o-y)
	implicit complex*16 (z)
	PARAMETER (zone=(1.d0,0.d0))
	PARAMETER (zzero=(0.d0,0.d0))
	PARAMETER (zimag=(0.d0,1.d0))

	DIMENSION ZROT_SPIN(NDIM,NDIM)

	do ii=1,NDIM
	 do jj=1,NDIM
	  ZROT_SPIN(jj,ii)=zero
	 end do
	end do

	zalpp=cdexp(zimag*alp/2.d0)
	zgamp=cdexp(zimag*gam/2.d0)
	zalpm=cdexp(-zimag*alp/2.d0)
	zgamm=cdexp(-zimag*gam/2.d0)

	sb=dsin(bet/2.)
	cb=dcos(bet/2.)

!POINTERS
        ip=0
	ipb=ip+NDIM/4
	in=ipb+NDIM/4
	inb=in+NDIM/4

	do ii=1,NDIM/4
	  !protons
	  ZROT_SPIN(ii+ip,ii+ip )  = zalpm*cb*zgamm
	  ZROT_SPIN(ii+ipb,ii+ipb )= zalpp*cb*zgamp
	  ZROT_SPIN(ii+in,ii+in )  = zalpm*cb*zgamm
	  ZROT_SPIN(ii+inb,ii+inb )= zalpp*cb*zgamp

	  !neutrons
	  ZROT_SPIN(ii+ip,ii+ipb)=-zalpm*sb*zgamp
	  ZROT_SPIN(ii+ipb,ii+ip)=zalpp*sb*zgamm
	  ZROT_SPIN(ii+in,ii+inb)=-zalpm*sb*zgamp
	  ZROT_SPIN(ii+inb,ii+in)=zalpp*sb*zgamm
	end do

        end subroutine
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!     Evaluates:                                             c
!                                                            c
!     a) T22                                                 c
!                                                            c
!     For triaxial PNAMP                                     c
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

       SUBROUTINE T22_Over(phil,ZU1,ZV1,ZROT,ZT22_INV,zdeterm,N)

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

      Parameter (Zone=(1.d0,0.d0))
      Parameter (Zonem=(-1.d0,0.d0))
      Parameter (Zzero=(0.d0,0.d0))
      Parameter (Zimag=(0.d0,1.d0))

      Dimension ZU1(N,N)
      Dimension ZV1(N,N)
      Dimension ZU1c(N,N)
      Dimension ZV1c(N,N)
      Dimension ZROT(N,N)
      Dimension ZROTconj(N,N)
      Dimension ZT22_INV(N,N)

      Dimension IPIV(N)
      Dimension ZWORK(N)

      Dimension ZAUX1(N,N)
      Dimension ZAUX2(N,N)

      Zfas1=cdexp(Zimag*phil)
      Zfas2=cdexp(-Zimag*phil)
      pi=4.d0*datan(1.d0)

      do ii=1,N
       do jj=1,N
        ZROTconj(jj,ii)=dconjg(ZROT(jj,ii))
        ZU1c(jj,ii)=dconjg(ZU1(jj,ii))
        ZV1c(jj,ii)=dconjg(ZV1(jj,ii))
       end do
      end do

      call ZGEMM ('t','n',N,N,N,Zfas1,ZV1,N,ZROT,N,Zzero,ZAUX1,N)
      call ZGEMM ('n','n',N,N,N,Zone,ZAUX1,N,ZV1c,N,Zzero,ZT22_INV,N)

      call ZGEMM ('t','n',N,N,N,Zfas2,ZU1,N,ZROTconj,N,Zzero,ZAUX2,N)
      call ZGEMM ('n','n',N,N,N,Zone,ZAUX2,N,ZU1c,N,Zone,ZT22_INV,N)

      Call ZGETRF(N,N,ZT22_INV,N,IPIV,INFO)

      if(info.ne.0) then
        write(6,*) ' In AINV got INFO = ',info,' from ZGETRF 3'
        stop
      end if

      zdeterm=zone
      inter=0
      do ii=1,N
       zdeterm=zdeterm*ZT22_INV(ii,ii)
         if(ipiv(ii).ne.ii) inter = inter + 1
      end do

      isign=1-2*Mod(inter,2)
      If(isign.eq.1) then
       zdeterm = zdeterm
      else
        zdeterm = -zdeterm
      end if

      zdeterm=zdeterm**(.5d0)

      Call Zgetri (N,ZT22_INV,N,IPIV,ZWORK,N,INFO)
      if(info.ne.0) then
        write(6,*) ' In AINV got INFO = ',info,' from DGETRI 4'
        stop
      end if

      return
      END SUBROUTINE

!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!     Computes the norm overlap following Neergard's prescription           c
!                                                                           c
!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      SUBROUTINE Neer_Over_ISOS(phil,ZTHOUL,ZROT,ZdetNe,N)

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

      Parameter (Zone=(1.d0,0.d0))
      Parameter (Zzero=(0.d0,0.d0))
      Parameter (Zimag=(0.d0,1.d0))

      Dimension ZROT(N,N) !rotation matrix
      Dimension ZTHOUL(N,N)

      Dimension ZZZS(N,N)

      Dimension ZAUX1(N,N)
      Dimension ZAUX2(N,N)

      Zfas=cdexp(2.d0*Zimag*phiL)

!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!                  Calculation of auxiliary matrices                                        c
!                     									    c
!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      call ZGEMM ('n','t',N,N,N,Zfas, ZTHOUL,N,ZROT,N,Zzero,ZAUX1,N)

      call ZGEMM ('t','n',N,N,N,Zone,ZTHOUL,N,ZROT,N,Zzero,ZAUX2,N)

      call ZGEMM ('n','n',N,N,N,Zone, ZAUX1,N,ZAUX2,N,Zzero,ZZZS,N)

      call ccstot(ZZZS,ZdetNe,N)

      return

      END SUBROUTINE


      subroutine couplz(xw)
      implicit none
      include 'constants.f'
      include 'zcouple.f'
      include 'ewcharge.f'
c---calculate the couplings as given in Kunszt and Gunion
c---Modified to notation of DKS (ie divided by 2*sw*cw)
c---xw=sin^2 theta_w
      integer j
      double precision xw
      sin2w=two*sqrt(xw*(1d0-xw))
      do j=1,nf
      l(j)=(tau(j)-two*Q(j)*xw)/sin2w
      r(j)=      (-two*Q(j)*xw)/sin2w
      enddo

      le=(-1d0-two*(-1d0)*xw)/sin2w
      re=(-two*(-1d0)*xw)/sin2w

      ln=(+1d0-two*(+0d0)*xw)/sin2w
      rn=0d0

      return
      end


      subroutine waltalbe(a,ap,b,c,
     s           brdfalb)
      parameter (nta=24,nfa=48)
      real teta1,teta2,phi1,phi2,ta(nta),fa(nfa),wta(nta),wfa(nfa)
      real a,ap,b,c
      real pi
      real brdfalb,summ,si2,si1,ts,tv,phi,pond,brdfint,mu1,mu2
      integer k,j,l
      pi=atan(1.)*4.
      teta1=0.
      teta2=pi/2.
      call gauss(teta1,teta2,ta,wta,nta)
      phi1=0.
      phi2=2.*pi
      call gauss(phi1,phi2,fa,wfa,nfa)
      brdfalb=0.
      summ=0.
      do 1 k=1,nfa
      do 2 j=1,nta
      do 3 l=1,nta
      si2=sin(ta(j))
      si1=sin(ta(l))
      mu2=cos(ta(j))
      mu1=cos(ta(l))
      ts=ta(j)
      tv=ta(l)
      phi=fa(k)
      pond=mu1*mu2*si1*si2*wfa(k)*wta(j)*wta(l)
      brdfint=a*ts*ts*tv*tv+ap*(ts*ts+tv*tv)+b*ts*tv*cos(phi)+c
      brdfalb=brdfalb+brdfint*pond
      summ=summ+pond
  3   continue
  2   continue
  1   continue
      brdfalb=brdfalb/summ
      return
      end


subroutine chebyshev_coefficients ( a, b, n, f, c )

!*****************************************************************************80
!
!! CHEBYSHEV_COEFFICIENTS determines Chebyshev interpolation coefficients.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    14 September 2011
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Roger Broucke,
!    Algorithm 446:
!    Ten Subroutines for the Manipulation of Chebyshev Series,
!    Communications of the ACM,
!    Volume 16, Number 4, April 1973, pages 254-256.
!
!    William Press, Brian Flannery, Saul Teukolsky, William Vetterling,
!    Numerical Recipes in FORTRAN: The Art of Scientific Computing,
!    Second Edition,
!    Cambridge University Press, 1992,
!    ISBN: 0-521-43064-X,
!    LC: QA297.N866.
!
!  Parameters:
!
!    Input, real ( kind = 8 ) A, B, the domain of definition.
!
!    Input, integer ( kind = 4 ) N, the order of the interpolant.
!
!    Input, real ( kind = 8 ), external :: F ( X ), an external function.
!
!    Output, real ( kind = 8 ) C(N), the Chebyshev coefficients.
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ) a
  real ( kind = 8 ) angle
  real ( kind = 8 ) b
  real ( kind = 8 ) c(n)
  real ( kind = 8 ), external :: f
  real ( kind = 8 ) fx(n)
  integer ( kind = 4 ) i
  integer ( kind = 4 ) j
  real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00
  real ( kind = 8 ) x

  do i = 1, n
    angle = real ( 2 * i - 1, kind = 8 ) * pi / real ( 2 * n, kind = 8 )
    x = cos ( angle )
    x = 0.5D+00 * ( a + b ) + x * 0.5D+00 * ( b - a )
    fx(i) = f ( x );
  end do

  do i = 1, n
    c(i) = 0.0D+00
    do j = 1, n
      angle = real ( ( i - 1 ) * ( 2 * j - 1 ), kind = 8 ) * pi &
        / real ( 2 * n, kind = 8 )
      c(i) = c(i) + fx(j) * cos ( angle )
    end do
  end do

  c(1:n) = 2.0D+00 * c(1:n) / real ( n, kind = 8 )

  return
end
subroutine chebyshev_interpolant ( a, b, n, c, m, x, cf )

!*****************************************************************************80
!
!! CHEBYSHEV_INTERPOLANT evaluates a Chebyshev interpolant.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    14 September 2011
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Roger Broucke,
!    Algorithm 446:
!    Ten Subroutines for the Manipulation of Chebyshev Series,
!    Communications of the ACM,
!    Volume 16, Number 4, April 1973, pages 254-256.
!
!    William Press, Brian Flannery, Saul Teukolsky, William Vetterling,
!    Numerical Recipes in FORTRAN: The Art of Scientific Computing,
!    Second Edition,
!    Cambridge University Press, 1992,
!    ISBN: 0-521-43064-X,
!    LC: QA297.N866.
!
!  Parameters:
!
!    Input, real ( kind = 8 ) A, B, the domain of definition.
!
!    Input, integer ( kind = 4 ) N, the order of the polynomial.
!
!    Input, real ( kind = 8 ) C(N), the Chebyshev coefficients.
!
!    Input, integer ( kind = 4 ) M, the number of points.
!
!    Input, real ( kind = 8 ) X(M), the point at which the polynomial is
!    to be evaluated.
!
!    Output, real ( kind = 8 ) CF(M), the value of the Chebyshev
!    polynomial at X.
!
  implicit none

  integer ( kind = 4 ) m
  integer ( kind = 4 ) n

  real ( kind = 8 ) a
  real ( kind = 8 ) b
  real ( kind = 8 ) c(n)
  real ( kind = 8 ) cf(m)
  real ( kind = 8 ) di
  real ( kind = 8 ) dip1
  real ( kind = 8 ) dip2
  integer ( kind = 4 ) i
  integer ( kind = 4 ) j
  real ( kind = 8 ) x(m)
  real ( kind = 8 ) y

  do j = 1, m

    dip1 = 0.0D+00
    di = 0.0D+00
    y = ( 2.0D+00 * x(j) - a  - b ) / ( b - a )

    do i = n, 2, -1
      dip2 = dip1
      dip1 = di
      di = 2.0D+00 * y * dip1 - dip2 + c(i)
    end do

    cf(j) = y * di - dip1 + 0.5D+00 * c(1)

  end do

  return
end
subroutine chebyshev_zeros ( n, x )

!*****************************************************************************80
!
!! CHEBYSHEV_ZEROS returns zeroes of the Chebyshev polynomial T(N,X).
!
!  Discussion:
!
!    We produce the Chebyshev zeros in ascending order.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    14 September 2011
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the order of the polynomial.
!
!    Output, real ( kind = 8 ) X(N), the zeroes of T(N)(X).
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ) angle
  integer ( kind = 4 ) i
  real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00
  real ( kind = 8 ) x(n)

  do i = 1, n
    angle = real ( 2 * ( n - i ) + 1, kind = 8 ) * pi / real ( 2 * n, kind = 8 )
    x(i) = cos ( angle )
  end do

  return
end


module interpolate_prog

character(len=512) :: anchor_point_file
character(len=512) :: interpolation_point_file
character(len=512) :: output_file
double precision :: slope1
double precision :: slope2

end module

!==================================================================================================!

program main

use interpolate_prog, only: anchor_point_file, &
                            interpolation_point_file, &
                            output_file, &
                            slope1, &
                            slope2
use interpolation, only: spline, spline_interpolation

use io, only: fileExists, line_count

implicit none

! Local variables
double precision, allocatable :: x(:), y(:), dy(:), d2y(:)
double precision :: xi, yi, dyi, d2yi
integer :: i, nanchor, ninterpolation, lu_out

! Parse command line arguments
call gcmdln()

! Check for inputs
if (.not.fileExists(anchor_point_file)) then
    call usage('interpolate: no anchor point file found named "'//trim(anchor_point_file)//'"')
endif
if (.not.fileExists(interpolation_point_file)) then
    call usage('interpolate: no interpolation point file found named "'// &
                   trim(interpolation_point_file)//'"')
endif

! Count number of inputs and allocate memory
nanchor = line_count(anchor_point_file)
ninterpolation = line_count(interpolation_point_file)

allocate(x(nanchor))
allocate(y(nanchor))
allocate(dy(nanchor))
allocate(d2y(nanchor))

! Read the anchor points
open(unit=11,file=anchor_point_file,status='old')
do i = 1,nanchor
    read(11,*) x(i),y(i)
enddo
close(11)

! Calculate the interpolation
call spline(x,y,nanchor,slope1,slope2,d2y)

! Select the points to calculate the interpolation
open(unit=12,file=interpolation_point_file,status='old')
if (output_file.ne.'') then
    lu_out = 13
    open(lu_out,file=output_file,status='unknown')
else
    lu_out = 6
endif
do i = 1,ninterpolation
    read(12,*) xi
    call spline_interpolation(x,y,d2y,nanchor,xi,yi,dyi,d2yi)
    write(lu_out,*) xi,yi,dyi,d2yi
enddo
close(12)

if (lu_out.ne.6) then
    close(lu_out)
endif

end

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

subroutine gcmdln()

use interpolate_prog, only: anchor_point_file, &
                            interpolation_point_file, &
                            output_file, &
                            slope1, &
                            slope2

implicit none

! Local variables
integer :: i, narg
character(len=512) :: tag

! Initialize control parameters
anchor_point_file = ''
interpolation_point_file = ''
output_file = ''
slope1 = 1.01d30
slope2 = 1.01d30

! Number of arguments
narg = command_argument_count()
if (narg.eq.0) then
  call usage('')
endif

! Read arguments
i = 1
do while (i.le.narg)

    call get_command_argument(i,tag)

    if (tag.eq.'-a') then
        i = i + 1
        call get_command_argument(i,anchor_point_file)
    elseif (tag.eq.'-i') then
        i = i + 1
        call get_command_argument(i,interpolation_point_file)
    elseif (tag.eq.'-o') then
        i = i + 1
        call get_command_argument(i,output_file)
    elseif (tag.eq.'-slope1') then
        i = i + 1
        call get_command_argument(i,tag)
        read(tag,*) slope1
    elseif (tag.eq.'-slope2') then
        i = i + 1
        call get_command_argument(i,tag)
        read(tag,*) slope2
    else
        call usage('interpolate: no option '//trim(tag))
    endif

    i = i + 1

enddo

return
end subroutine

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

subroutine usage(str)

use io, only: stderr
implicit none

character(len=*) :: str

if (str.ne.'') then
    write(stderr,*) trim(str)
    write(stderr,*)
endif

write(stderr,*) 'Usage: interpolate -a ANCHOR_POINTS -i INTERPOLATION_POINTS [-o OUTPUT_FILE]'
write(stderr,*) '       [-slope[1|2] SLOPE]'
write(stderr,*)
write(stderr,*) '-a ANCHOR_POINTS         Points in function (x,y)'
write(stderr,*) '-i INTERPOLATION_POINTS  X-coordinates to interpolate (xi)'
write(stderr,*) '-o OUTPUT_FILE           Output file: (xi,yi) (default: stdout)'
write(stderr,*) '-slope[1|2] SLOPE        Slope at first or last point'
write(stderr,*)

call error_exit(1)
end subroutine


! Ref: https://stackoverflow.com/questions/2390395/fortran-handling-integer-values-of-size-700000000000

program intt
  print *, selected_int_kind(1)
  print *, selected_int_kind(4)
  print *, selected_int_kind(8)
  print *, selected_int_kind(16)
  print *, selected_int_kind(32)
  print *, selected_int_kind(64)
  print *, huge(0_1)
  print *, huge(0_2)
  print *, huge(0_4)
  print *, huge(0_8)
  print *, huge(0_16)
end program intt


module tracking
    integer, parameter:: i8 = selected_int_kind(14)
end module
program xyz
    use tracking
    implicit none
    integer(i8) malloc_count_peak,malloc_count_current
    integer(i8) stack_count_usage,stack_count_clear
    integer(i8)base
    integer n
    real x
    real, allocatable :: block(:)
    base=stack_count_clear()
    write(*,'(20x,"            ",2a16)')"peak","current"
    write(*,'(20x,"      before",2i16)')malloc_count_peak(),malloc_count_current()
    allocate(block(10000000))
    block=1
    write(*,'(20x,"   allocated",2i16)')malloc_count_peak(),malloc_count_current()
    deallocate(block)
    write(*,'(20x," deallocated",2i16)')malloc_count_peak(),malloc_count_current()
    allocate(block(1000))
    write(*,'(20x," reallocated",2i16)')malloc_count_peak(),malloc_count_current()
    n=1
    x=0
    base=stack_count_clear()
    write(*,'("stack before",i8)')stack_count_usage(base)
    call sumit(n,x,base)
! note: the stack_count_usage call gives max stack size, not current
    write(*,'(" stack after",i8)')stack_count_usage(base)
    write(*,'(20x,"  after call",2i16)')malloc_count_peak(),malloc_count_current()
    write(*,*)x

end program
recursive subroutine sumit(n,x,base)
    use tracking
    integer(i8) malloc_count_peak,malloc_count_current
    integer(i8) stack_count_usage,stack_count_clear
    integer n
    real x
    integer(i8) base
    real  :: sblock(10000)
    sblock=1
    x=sum(sblock)+x
    write(*,'("stack inside",i8,1x,i2)')stack_count_usage(base),n
    n=n+1
    if(n < 10 )then
      call sumit(n,x,base)
      base=stack_count_clear()
      write(*,'("   unwinding",i8,1x,i2)')stack_count_usage(base),n
    endif
end


*> \brief \b IDAMAX
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       INTEGER FUNCTION IDAMAX(N,DX,INCX)
*
*       .. Scalar Arguments ..
*       INTEGER INCX,N
*       ..
*       .. Array Arguments ..
*       DOUBLE PRECISION DX(*)
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*>    IDAMAX finds the index of the first element having maximum absolute value.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2015
*
*> \ingroup aux_blas
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>     jack dongarra, linpack, 3/11/78.
*>     modified 3/93 to return if incx .le. 0.
*>     modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
*  =====================================================================
      INTEGER FUNCTION IDAMAX(N,DX,INCX)
*
*  -- Reference BLAS level1 routine (version 3.6.0) --
*  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2015
*
*     .. Scalar Arguments ..
      INTEGER INCX,N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION DX(*)
*     ..
*
*  =====================================================================
*
*     .. Local Scalars ..
      DOUBLE PRECISION DMAX
      INTEGER I,IX
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC DABS
*     ..
      IDAMAX = 0
      IF (N.LT.1 .OR. INCX.LE.0) RETURN
      IDAMAX = 1
      IF (N.EQ.1) RETURN
      IF (INCX.EQ.1) THEN
*
*        code for increment equal to 1
*
         DMAX = DABS(DX(1))
         DO I = 2,N
            IF (DABS(DX(I)).GT.DMAX) THEN
               IDAMAX = I
               DMAX = DABS(DX(I))
            END IF
         END DO
      ELSE
*
*        code for increment not equal to 1
*
         IX = 1
         DMAX = DABS(DX(1))
         IX = IX + INCX
         DO I = 2,N
            IF (DABS(DX(IX)).GT.DMAX) THEN
               IDAMAX = I
               DMAX = DABS(DX(IX))
            END IF
            IX = IX + INCX
         END DO
      END IF
      RETURN
      END


! { dg-do run }
! { dg-options "-fdump-tree-original" }
!
! PR fortran/38184
! invariant RESHAPE not expanded if SOURCE is empty.
!
! Original program by James Van Buskirk

integer, parameter :: N = 3
integer, parameter :: A(N,N) = reshape([integer::],[N,N],reshape([1],[N+1],[2]))
integer, parameter :: K = N*A(2,2)+A(2,3)
integer :: B(N,N) = reshape([1,2,2,2,1,2,2,2,1],[3,3])
integer :: i
i = 5
if (any(A /= B)) call abort
if (K /= i) call abort
end

! { dg-final { scan-tree-dump-times "\\\{1, 2, 2, 2, 1, 2, 2, 2, 1\\\}" 2 "original" } }
! { dg-final { cleanup-tree-dump "original" } }


! -----------------------------------------------------------------
! Programmer(s): Cody J. Balos @ LLNL
! -----------------------------------------------------------------
! SUNDIALS Copyright Start
! Copyright (c) 2002-2021, Lawrence Livermore National Security
! and Southern Methodist University.
! All rights reserved.
!
! See the top-level LICENSE and NOTICE files for details.
!
! SPDX-License-Identifier: BSD-3-Clause
! SUNDIALS Copyright End
! -----------------------------------------------------------------
! This file tests the Fortran 2003 interface to the SUNDIALS
! dense SUNLinearSolver implementation.
! -----------------------------------------------------------------

module test_fsunlinsol_dense
  use, intrinsic :: iso_c_binding
  implicit none

  integer(C_LONG), private, parameter :: N = 100

contains

  integer(C_INT) function unit_tests() result(fails)
    use, intrinsic :: iso_c_binding
    use fsundials_nvector_mod
    use fsundials_matrix_mod
    use fsundials_linearsolver_mod
    use fnvector_serial_mod
    use fsunmatrix_dense_mod
    use fsunlinsol_dense_mod
    use test_sunlinsol

    implicit none

    type(SUNLinearSolver), pointer :: LS                ! test linear solver
    type(SUNMatrix),       pointer :: A, I              ! test matrices
    type(N_Vector),        pointer :: x, b              ! test vectors
    real(C_DOUBLE),        pointer :: colj(:), colIj(:) ! matrix column data
    real(C_DOUBLE),        pointer :: xdata(:)          ! x vector data
    real(C_DOUBLE)                 :: tmpr              ! temporary real value
    integer(C_LONG)                :: j, k
    integer(C_INT)                 :: tmp

    fails = 0

    A => FSUNDenseMatrix(N, N)
    I => FSUNDenseMatrix(N, N)
    x => FN_VNew_Serial(N)
    b => FN_VNew_Serial(N)

    ! fill A matrix with uniform random data in [0, 1/N)
    do j=1, N
      colj => FSUNDenseMatrix_Column(A, j-1)
      do k=1, N
        call random_number(tmpr)
        colj(k) = tmpr / N
      end do
    end do

    ! create anti-identity matrix
    j = N
    do k=1, N
      colj => FSUNDenseMatrix_Column(I, j-1)
      colj(k) = ONE
      j = j-1
    end do

    ! add anti-identity to ensure the solver needs to do row-swapping
    do k=1, N
      do j=1, N
        colj => FSUNDenseMatrix_Column(A, j-1)
        colIj => FSUNDenseMatrix_Column(I, j-1)
        colj(k) = colj(k) + colIj(k)
      end do
    end do

    ! fill x vector with uniform random data in [0, 1)
    xdata => FN_VGetArrayPointer(x)
    do j=1, N
      call random_number(tmpr)
      xdata(j) = tmpr
    end do

    ! create RHS vector for linear solve
    fails = FSUNMatMatvec(A, x, b)
    if (fails /= 0) then
      call FSUNMatDestroy(A)
      call FSUNMatDestroy(I)
      call FN_VDestroy(x)
      call FN_VDestroy(b)
      return
    end if

    ! create dense linear solver
    LS => FSUNLinSol_Dense(x, A)

    ! run tests
    fails = fails + Test_FSUNLinSolInitialize(LS, 0)
    fails = fails + Test_FSUNLinSolSetup(LS, A, 0)
    fails = fails + Test_FSUNLinSolSolve(LS, A, x, b, 100*UNIT_ROUNDOFF, 0)

    fails = fails + Test_FSUNLinSolGetType(LS, SUNLINEARSOLVER_DIRECT, 0)
    fails = fails + Test_FSUNLinSolLastFlag(LS, 0)
    fails = fails + Test_FSUNLinSolSpace(LS, 0)

    ! cleanup
    tmp = FSUNLinSolFree(LS)
    call FSUNMatDestroy(A)
    call FSUNMatDestroy(I)
    call FN_VDestroy(x)
    call FN_VDestroy(b)

  end function unit_tests

end module

integer(C_INT) function check_vector(X, Y, tol) result(failure)
  use, intrinsic :: iso_c_binding
  use fsundials_nvector_mod
  use test_utilities

  implicit none
  type(N_Vector)  :: x, y
  real(C_DOUBLE)  :: tol, maxerr
  integer(C_LONG) :: i, xlen, ylen
  real(C_DOUBLE), pointer :: xdata(:), ydata(:)

  failure = 0

  xdata => FN_VGetArrayPointer(x)
  ydata => FN_VGetArrayPointer(y)

  xlen = FN_VGetLength(x)
  ylen = FN_VGetLength(y)

  if (xlen /= ylen) then
    print *, 'FAIL: check_vector: different data array lengths'
    failure = 1
    return
  end if

  do i = 1, xlen
    failure = failure + FNEQTOL(xdata(i), ydata(i), tol)
  end do

  if (failure > 0) then
    maxerr = ZERO
    do i = 1, xlen
      maxerr = max(abs(xdata(i)-ydata(i))/abs(ydata(i)), maxerr)
    end do
    write(*,'(A,E14.7,A,E14.7,A)') &
      "FAIL: check_vector failure: maxerr = ", maxerr, "  (tol = ", tol, ")"
  end if

end function check_vector

program main
  !======== Inclusions ==========
  use, intrinsic :: iso_c_binding
  use test_fsunlinsol_dense

  !======== Declarations ========
  implicit none
  integer(C_INT) :: fails = 0

  !============== Introduction =============
  print *, 'Dense SUNLinearSolver Fortran 2003 interface test'

  fails = unit_tests()
  if (fails /= 0) then
    print *, 'FAILURE: n unit tests failed'
    stop 1
  else
    print *,'SUCCESS: all unit tests passed'
  end if
end program main


!-----------------------------------------------------------------------
      subroutine setup_mass(ctx,q,u1,u2,u3,u4,u5,u6,u7,u8,u9,u10,u11,u12,u13,&
&           u14,u15,u16,v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15,&
&           v16,ierr)
      real*8 ctx
      real*8 u1(1)
      real*8 u2(1)
      real*8 v1(1)
      integer q,ierr

      do i=1,q
        v1(i)=u2(i)*(u1(i+q*0)*u1(i+q*3)-u1(i+q*1)*u1(i+q*2))
      enddo

      ierr=0
      end
!-----------------------------------------------------------------------
      subroutine setup_diff(ctx,q,u1,u2,u3,u4,u5,u6,u7,u8,u9,u10,u11,u12,u13,&
&           u14,u15,u16,v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15,&
&           v16,ierr)
      real*8 ctx
      real*8 u1(1)
      real*8 u2(1)
      real*8 v1(1)
      real*8 w
      integer q,ierr

      do i=1,q
        w=u2(i)/(u1(i+q*0)*u1(i+q*3)-u1(i+q*1)*u1(i+q*2))
        v1(i+q*0)=w*(u1(i+q*2)*u1(i+q*2)+u1(i+q*3)*u1(i+q*3))
        v1(i+q*1)=w*(u1(i+q*0)*u1(i+q*0)+u1(i+q*1)*u1(i+q*1))
        v1(i+q*2)=-w*(u1(i+q*0)*u1(i+q*2)+u1(i+q*2)*u1(i+q*3))
      enddo

      ierr=0
      end
!-----------------------------------------------------------------------
      subroutine apply(ctx,q,u1,u2,u3,u4,u5,u6,u7,u8,u9,u10,u11,u12,u13,u14,&
&           u15,u16,v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15,v16,ierr)
      real*8 ctx
      real*8 u1(1)
      real*8 u2(1)
      real*8 u3(1)
      real*8 u4(1)
      real*8 v1(1)
      real*8 v2(1)
      real*8 du0,du1
      integer q,ierr

      do i=1,q
!       mass
        v1(i) = u2(i)*u4(i)
!       diff
        du0=u1(i+q*0)
        du1=u1(i+q*1)
        v2(i+q*0)=u3(i+q*0)*du0+u3(i+q*2)*du1
        v2(i+q*1)=u3(i+q*2)*du0+u3(i+q*1)*du1
      enddo

      ierr=0
      end
!-----------------------------------------------------------------------
      program test

      include 'ceedf.h'

      integer ceed,err,i,j,k
      integer erestrictx,erestrictu,erestrictxi,erestrictui,erestrictqi
      integer bx,bu
      integer qf_setup_mass,qf_setup_diff,qf_apply
      integer op_setup_mass,op_setup_diff,op_apply
      integer qdata_mass,qdata_diff,x,a,u,v
      integer nelem,p,q,d
      integer row,col,offset
      parameter(nelem=6)
      parameter(p=3)
      parameter(q=4)
      parameter(d=2)
      integer ndofs,nqpts,nx,ny
      parameter(nx=3)
      parameter(ny=2)
      parameter(ndofs=(nx*2+1)*(ny*2+1))
      parameter(nqpts=nelem*q*q)
      integer indx(nelem*p*p)
      real*8 arrx(d*ndofs),aa(nqpts),uu(ndofs),vv(ndofs),atrue(ndofs)
      integer*8 xoffset,aoffset,uoffset,voffset

      character arg*32

      external setup_mass,setup_diff,apply,apply_lin

      call getarg(1,arg)

      call ceedinit(trim(arg)//char(0),ceed,err)

! DoF Coordinates
      do i=0,nx*2
        do j=0,ny*2
          arrx(i+j*(nx*2+1)+0*ndofs+1)=1.d0*i/(2*nx)
          arrx(i+j*(nx*2+1)+1*ndofs+1)=1.d0*j/(2*ny)
        enddo
      enddo
      call ceedvectorcreate(ceed,d*ndofs,x,err)
      xoffset=0
      call ceedvectorsetarray(x,ceed_mem_host,ceed_use_pointer,arrx,xoffset,err)

! Qdata Vector
      call ceedvectorcreate(ceed,nqpts,qdata_mass,err)
      call ceedvectorcreate(ceed,nqpts*d*(d+1)/2,qdata_diff,err)

! Element Setup
      do i=0,nelem-1
        col=mod(i,nx)
        row=i/nx
        offset=col*(p-1)+row*(nx*2+1)*(p-1)
        do j=0,p-1
          do k=0,p-1
            indx(p*(p*i+k)+j+1)=offset+k*(nx*2+1)+j
          enddo
        enddo
      enddo

! Restrictions
      call ceedelemrestrictioncreate(ceed,nelem,p*p,ndofs,d,&
     & ceed_mem_host,ceed_use_pointer,indx,erestrictx,err)
      call ceedelemrestrictioncreateidentity(ceed,nelem,p*p,&
     & nelem*p*p,d,erestrictxi,err)

      call ceedelemrestrictioncreate(ceed,nelem,p*p,ndofs,1,&
     & ceed_mem_host,ceed_use_pointer,indx,erestrictu,err)
      call ceedelemrestrictioncreateidentity(ceed,nelem,q*q,nqpts,&
     & 1,erestrictui,err)

      call ceedelemrestrictioncreateidentity(ceed,nelem,q*q,nqpts,&
     & d*(d+1)/2,erestrictqi,err)

! Bases
      call ceedbasiscreatetensorh1lagrange(ceed,d,d,p,q,ceed_gauss,bx,err)
      call ceedbasiscreatetensorh1lagrange(ceed,d,1,p,q,ceed_gauss,bu,err)

! QFunction - setup mass
      call ceedqfunctioncreateinterior(ceed,1,setup_mass,&
     &SOURCE_DIR&
     &//'t532-operator.h:setup_mass'//char(0),qf_setup_mass,err)
      call ceedqfunctionaddinput(qf_setup_mass,'dx',d*d,ceed_eval_grad,err)
      call ceedqfunctionaddinput(qf_setup_mass,'_weight',1,ceed_eval_weight,err)
      call ceedqfunctionaddoutput(qf_setup_mass,'qdata',1,ceed_eval_none,err)

! Operator - setup mass
      call ceedoperatorcreate(ceed,qf_setup_mass,ceed_qfunction_none,&
     & ceed_qfunction_none,op_setup_mass,err)
      call ceedoperatorsetfield(op_setup_mass,'dx',erestrictx,&
     & ceed_notranspose,bx,ceed_vector_active,err)
      call ceedoperatorsetfield(op_setup_mass,'_weight',erestrictxi,&
     & ceed_notranspose,bx,ceed_vector_none,err)
      call ceedoperatorsetfield(op_setup_mass,'qdata',erestrictui,&
     & ceed_notranspose,ceed_basis_collocated,ceed_vector_active,err)

! QFunction - setup diff
      call ceedqfunctioncreateinterior(ceed,1,setup_diff,&
     &SOURCE_DIR&
     &//'t532-operator.h:setup_diff'//char(0),qf_setup_diff,err)
      call ceedqfunctionaddinput(qf_setup_diff,'dx',d*d,ceed_eval_grad,err)
      call ceedqfunctionaddinput(qf_setup_diff,'_weight',1,ceed_eval_weight,err)
      call ceedqfunctionaddoutput(qf_setup_diff,'qdata',&
     & d*(d+1)/2,ceed_eval_none,err)

! Operator - setup diff
      call ceedoperatorcreate(ceed,qf_setup_diff,ceed_qfunction_none,&
     & ceed_qfunction_none,op_setup_diff,err)
      call ceedoperatorsetfield(op_setup_diff,'dx',erestrictx,&
     & ceed_notranspose,bx,ceed_vector_active,err)
      call ceedoperatorsetfield(op_setup_diff,'_weight',erestrictxi,&
     & ceed_notranspose,bx,ceed_vector_none,err)
      call ceedoperatorsetfield(op_setup_diff,'qdata',erestrictqi,&
     & ceed_notranspose,ceed_basis_collocated,ceed_vector_active,err)

! Apply Setup Operators
      call ceedoperatorapply(op_setup_mass,x,qdata_mass,&
     & ceed_request_immediate,err)
      call ceedoperatorapply(op_setup_diff,x,qdata_diff,&
     & ceed_request_immediate,err)

! QFunction - apply
      call ceedqfunctioncreateinterior(ceed,1,apply,&
     &SOURCE_DIR&
     &//'t532-operator.h:apply'//char(0),qf_apply,err)
      call ceedqfunctionaddinput(qf_apply,'du',d,ceed_eval_grad,err)
      call ceedqfunctionaddinput(qf_apply,'qdata_mass',1,ceed_eval_none,err)
      call ceedqfunctionaddinput(qf_apply,'qdata_diff',&
     & d*(d+1)/2,ceed_eval_none,err)
      call ceedqfunctionaddinput(qf_apply,'u',1,ceed_eval_interp,err)
      call ceedqfunctionaddoutput(qf_apply,'v',1,ceed_eval_interp,err)
      call ceedqfunctionaddoutput(qf_apply,'dv',d,ceed_eval_grad,err)

! Operator - apply
      call ceedoperatorcreate(ceed,qf_apply,ceed_qfunction_none,&
     & ceed_qfunction_none,op_apply,err)
      call ceedoperatorsetfield(op_apply,'du',erestrictu,&
     & ceed_notranspose,bu,ceed_vector_active,err)
      call ceedoperatorsetfield(op_apply,'qdata_mass',erestrictui,&
     & ceed_notranspose,ceed_basis_collocated,qdata_mass,err)
      call ceedoperatorsetfield(op_apply,'qdata_diff',erestrictqi,&
     & ceed_notranspose,ceed_basis_collocated,qdata_diff,err)
      call ceedoperatorsetfield(op_apply,'u',erestrictu,&
     & ceed_notranspose,bu,ceed_vector_active,err)
      call ceedoperatorsetfield(op_apply,'v',erestrictu,&
     & ceed_notranspose,bu,ceed_vector_active,err)
      call ceedoperatorsetfield(op_apply,'dv',erestrictu,&
     & ceed_notranspose,bu,ceed_vector_active,err)

! Assemble Diagonal
      call ceedoperatorassemblelineardiagonal(op_apply,a,&
     & ceed_request_immediate,err)

! Manually assemble diagonal
      call ceedvectorcreate(ceed,ndofs,u,err)
      call ceedvectorsetvalue(u,0.d0,err)
      call ceedvectorcreate(ceed,ndofs,v,err)
      do i=1,ndofs
        call ceedvectorgetarray(u,ceed_mem_host,uu,uoffset,err)
        uu(i+uoffset)=1.d0
        if (i>1) then
          uu(i-1+uoffset)=0.d0
        endif
        call ceedvectorrestorearray(u,uu,uoffset,err)

        call ceedoperatorapply(op_apply,u,v,ceed_request_immediate,err)

        call ceedvectorgetarrayread(v,ceed_mem_host,vv,voffset,err)
        atrue(i)=vv(voffset+i)
        call ceedvectorrestorearrayread(v,vv,voffset,err)
      enddo

! Check Output
      call ceedvectorgetarrayread(a,ceed_mem_host,aa,aoffset,err)
      do i=1,ndofs
        if (abs(aa(aoffset+i)-atrue(i))>1.0d-14) then
! LCOV_EXCL_START
          write(*,*) '[',i,'] Error in assembly: ',aa(aoffset+i),' != ',&
     &      atrue(i)
! LCOV_EXCL_STOP
        endif
      enddo
      call ceedvectorrestorearrayread(a,aa,aoffset,err)

! Cleanup
      call ceedqfunctiondestroy(qf_setup_mass,err)
      call ceedqfunctiondestroy(qf_setup_diff,err)
      call ceedqfunctiondestroy(qf_apply,err)
      call ceedoperatordestroy(op_setup_mass,err)
      call ceedoperatordestroy(op_setup_diff,err)
      call ceedoperatordestroy(op_apply,err)
      call ceedelemrestrictiondestroy(erestrictu,err)
      call ceedelemrestrictiondestroy(erestrictx,err)
      call ceedelemrestrictiondestroy(erestrictxi,err)
      call ceedelemrestrictiondestroy(erestrictui,err)
      call ceedelemrestrictiondestroy(erestrictqi,err)
      call ceedbasisdestroy(bu,err)
      call ceedbasisdestroy(bx,err)
      call ceedvectordestroy(x,err)
      call ceedvectordestroy(a,err)
      call ceedvectordestroy(u,err)
      call ceedvectordestroy(v,err)
      call ceedvectordestroy(qdata_mass,err)
      call ceedvectordestroy(qdata_diff,err)
      call ceeddestroy(ceed,err)
      end
!-----------------------------------------------------------------------