! ar1のソート順序でar2もソートする。
module double_merge_sort_mod
    ! call double_merge_sort(ar1, ar2) <- int32, int64
    use,intrinsic :: iso_fortran_env
    implicit none
    private
    public:: double_merge_sort

    interface double_merge_sort
        module procedure dms32, dms64
    end interface
contains
    recursive subroutine dms32(ar1, ar2)
        integer(int32),intent(inout):: ar1(:), ar2(:)
        integer(int32):: m

        if (size(ar1) <= 1) then
            return
        else
            m = size(ar1)/2
            call dms32(ar1(:m), ar2(:m))
            call dms32(ar1(m+1:), ar2(m+1:))
            call sub_ms32(ar1,ar2)
        end if
    end subroutine

    subroutine sub_ms32(ar1, ar2)
        integer(int32),intent(inout):: ar1(:), ar2(:)
        integer(int32):: tmp1(1:size(ar1)), tmp2(1:size(ar2))
        integer(int32):: m,l,r,i

        m=size(ar1)/2; l=1; r=m+1
        tmp1(:)=ar1(:); tmp2(:)=ar2(:)

        do i=1,size(ar1)
            if (m < l) then
                ar1(i:) = tmp1(r:)
                ar2(i:) = tmp2(r:)
                return
            else if (size(ar1) < r) then
                ar1(i:) = tmp1(l:m)
                ar2(i:) = tmp2(l:m)
                return
            else
                if (tmp1(l) <= tmp1(r)) then
                    ar1(i) = tmp1(l)
                    ar2(i) = tmp2(l)
                    l=l+1
                else
                    ar1(i) = tmp1(r)
                    ar2(i) = tmp2(r)
                    r=r+1
                end if
            end if
        end do
    end subroutine

    recursive subroutine dms64(ar1, ar2)
        integer(int64),intent(inout):: ar1(:), ar2(:)
        integer(int32):: m

        if (size(ar1) <= 1) then
            return
        else
            m = size(ar1)/2
            call dms64(ar1(:m), ar2(:m))
            call dms64(ar1(m+1:), ar2(m+1:))
            call sub_ms64(ar1,ar2)
        end if
    end subroutine

    subroutine sub_ms64(ar1, ar2)
        integer(int64),intent(inout):: ar1(:), ar2(:)
        integer(int64):: tmp1(1:size(ar1)), tmp2(1:size(ar2))
        integer(int32):: m,l,r,i

        m=size(ar1)/2; l=1; r=m+1
        tmp1(:)=ar1(:); tmp2(:)=ar2(:)

        do i=1,size(ar1)
            if (m < l) then
                ar1(i:) = tmp1(r:)
                ar2(i:) = tmp2(r:)
                return
            else if (size(ar1) < r) then
                ar1(i:) = tmp1(l:m)
                ar2(i:) = tmp2(l:m)
                return
            else
                if (tmp1(l) <= tmp1(r)) then
                    ar1(i) = tmp1(l)
                    ar2(i) = tmp2(l)
                    l=l+1
                else
                    ar1(i) = tmp1(r)
                    ar2(i) = tmp2(r)
                    r=r+1
                end if
            end if
        end do
    end subroutine
end module


Program testBisectionSearch

Use Kinds, Only: dp
Use Utilities, Only: Bisection_Search
Use Sorting, Only: Quick_Sort

Implicit None

Integer :: s
Integer, Allocatable :: seed(:)
Integer, Parameter :: n = 33
Integer, Parameter :: m = 1000000
Real(dp) :: r_list(1:n)
Real(dp) :: r_test(1:m*n)
Integer :: i,j
Integer :: found(1:n)
Integer :: missed(1:n)
Real(dp) :: r

Call RANDOM_SEED(SIZE=s)
Allocate(seed(1:s))
seed = 7777777
Call RANDOM_SEED(PUT=seed)
Call RANDOM_NUMBER(r_list)
r_list(1) = 0._dp
r_list(n) = 1._dp
Call Quick_Sort(r_list)
Call RANDOM_NUMBER(r_test)

found = 0
missed = 0
!search for distributed values in the list
Do i = 1,n*m
    r = r_test(i)
    j = Bisection_Search(r,r_list,n)
    !check the returned location
    If (r.GT.r_list(j-1) .AND. r.LE.r_list(j)) Then
        found(j) = found(j) + 1
    Else
        missed(j) = missed(j) + 1
    End If
End Do
!search for boundary values in the list
Do i = 1,n
    r = r_list(i)
    j = Bisection_Search(r,r_list,n)
    !check the returned location
    If (r.GE.r_list(j-1) .AND. r.LE.r_list(j)) Then
        found(i) = found(i) + 1
    Else
        missed(i) = missed(i) + 1
    End If
End Do
!print summary of found/missed to screen
Write(*,*)
Write(*,'(A,I0,A,I0,A,F0.2,A)') 'Found ',Sum(found),' of ',n+n*m,' (',100._dp*Real(Sum(found),dp)/Real(n+n*m,dp),'%)'
Write(*,'(A)') '----------------------------------------'
Write(*,'(3A10)') '   Bin  ','  Found ',' Missed '
Write(*,'(3A10)') '--------','--------','--------'
!recognized that index 1 in the found/missed is only the bottom bound of the first bin, add it to index 2
found(2) = found(1) + found(2)
missed(2) = missed(1) + missed(2)
Do i = 2,n
    Write(*,'(3I10)') i-1,found(i),missed(i)
End Do
Write(*,'(A)') '----------------------------------------'
!check out of bounds behavior and print to screen
Write(*,'(A)') 'Checking out-of-bounds behavior...'
j = Bisection_Search(0._dp-SPACING(0._dp),r_list,n)
Write(*,'(A,I0)',ADVANCE="NO") '    Below min: j = ',j
If (j .EQ. 1) Then
    Write(*,'(A)') ' (FOUND)'
Else
    Write(*,'(A)') ' (MISSED)'
End If
j = Bisection_Search(1._dp+SPACING(1._dp),r_list,n)
Write(*,'(A,I0)',ADVANCE="NO") '    Above max: j = ',j
If (j .EQ. n+1) Then
    Write(*,'(A)') ' (FOUND)'
Else
    Write(*,'(A)') ' (MISSED)'
End If
Write(*,*)

End Program testBisectionSearch


! { dg-do run }
! { dg-options "-fno-range-check" }
!
! PR fortran/34342
!
! Test for Fortran 2003 BOZ.
!
program f2003
implicit none

real,parameter             :: r2c = real(int(z'3333'))
real,parameter             :: rc  = real(z'50CB9F09')
double precision,parameter :: dc  = dble(Z'3FD34413509F79FF')
complex,parameter          :: z1c = cmplx(b'11000001010001101101110110000011', 3.049426e-10)
complex,parameter          :: z2c = cmplx(4.160326e16, o'6503667306')

real             :: r2 = real(int(z'3333'))
real             :: r  = real(z'50CB9F09')
double precision :: d  = dble(Z'3FD34413509F79FF')
complex          :: z1 = cmplx(b'11000001010001101101110110000011', 3.049426e-10)
complex          :: z2 = cmplx(4.160326e16, o'6503667306')

if (r2c /= 13107.0) call abort()
if (rc  /= 2.732958e10) call abort()
if (dc /= 0.30102999566398120d0) call abort()
if (real(z1c) /= -1.242908e1 .or. aimag(z1c) /= 3.049426e-10) call abort()
if (real(z2c) /= 4.160326e16 .or. aimag(z2c) /= 5.343285e-7) call abort()

if (r2 /= 13107.0) call abort()
if (r  /= 2.732958e10) call abort()
if (d /= 0.30102999566398120d0) call abort()
if (real(z1) /= -1.242908e1 .or. aimag(z1) /= 3.049426e-10) call abort()
if (real(z2) /= 4.160326e16 .or. aimag(z2) /= 5.343285e-7) call abort()

r2 = dble(int(z'3333'))
r = real(z'50CB9F09')
d = dble(Z'3FD34413509F79FF')
z1 = cmplx(b'11000001010001101101110110000011', 3.049426e-10)
z2 = cmplx(4.160326e16, o'6503667306')

if (r2 /= 13107d0) call abort()
if (r  /= 2.732958e10) call abort()
if (d /= 0.30102999566398120d0) call abort()
if (real(z1) /= -1.242908e1 .or. aimag(z1) /= 3.049426e-10) call abort()
if (real(z2) /= 4.160326e16 .or. aimag(z2) /= 5.343285e-7) call abort()

call test4()
call test8()

contains

subroutine test4
real,parameter             :: r2c = real(int(z'3333', kind=4), kind=4)
real,parameter             :: rc  = real(z'50CB9F09', kind=4)
complex,parameter          :: z1c = cmplx(b'11000001010001101101110110000011', 3.049426e-10, kind=4)
complex,parameter          :: z2c = cmplx(4.160326e16, o'6503667306', kind=4)

real             :: r2 = real(int(z'3333', kind=4), kind=4)
real             :: r  = real(z'50CB9F09', kind=4)
complex          :: z1 = cmplx(b'11000001010001101101110110000011', 3.049426e-10, kind=4)
complex          :: z2 = cmplx(4.160326e16, o'6503667306', kind=4)

if (r2c /= 13107.0) call abort()
if (rc  /= 2.732958e10) call abort()
if (real(z1) /= -1.242908e1 .or. aimag(z1) /= 3.049426e-10) call abort()
if (real(z2) /= 4.160326e16 .or. aimag(z2) /= 5.343285e-7) call abort()

if (r2 /= 13107.0) call abort()
if (r  /= 2.732958e10) call abort()
if (real(z1) /= -1.242908e1 .or. aimag(z1) /= 3.049426e-10) call abort()
if (real(z2) /= 4.160326e16 .or. aimag(z2) /= 5.343285e-7) call abort()

r2 = real(int(z'3333'), kind=4)
r = real(z'50CB9F09', kind=4)
z1 = cmplx(b'11000001010001101101110110000011', 3.049426e-10, kind=4)
z2 = cmplx(4.160326e16, o'6503667306', kind=4)

if (r2 /= 13107.0) call abort()
if (r  /= 2.732958e10) call abort()
if (real(z1) /= -1.242908e1 .or. aimag(z1) /= 3.049426e-10) call abort()
if (real(z2) /= 4.160326e16 .or. aimag(z2) /= 5.343285e-7) call abort()
end subroutine test4

subroutine test8
real(8),parameter     :: r2c = real(int(z'FFFFFF3333', kind=8), kind=8)
real(8),parameter     :: rc  = real(z'AAAAAFFFFFFF3333', kind=8)
complex(8),parameter  :: z1c = cmplx(b'11111011111111111111111111111111111111111111111111111111110101',-4.0, kind=8)
complex(8),parameter  :: z2c = cmplx(5.0, o'442222222222233301245', kind=8)

real(8)             :: r2 = real(int(z'FFFFFF3333',kind=8),kind=8)
real(8)             :: r  = real(z'AAAAAFFFFFFF3333', kind=8)
complex(8)          :: z1 = cmplx(b'11111011111111111111111111111111111111111111111111111111110101',-4.0, kind=8)
complex(8)          :: z2 = cmplx(5.0, o'442222222222233301245', kind=8)

if (r2c /= 1099511575347.0d0) call abort()
if (rc  /= -3.72356884822177915d-103) call abort()
if (real(z1c) /= 3.05175781249999627d-5 .or. aimag(z1c) /= -4.0) call abort()
if (real(z2c) /= 5.0 .or. aimag(z2c) /= 3.98227593015308981d41) call abort()

if (r2 /= 1099511575347.0d0) call abort()
if (r  /= -3.72356884822177915d-103) call abort()
if (real(z1) /= 3.05175781249999627d-5 .or. aimag(z1) /= -4.0) call abort()
if (real(z2) /= 5.0 .or. aimag(z2) /= 3.98227593015308981d41) call abort()

r2 = real(int(z'FFFFFF3333',kind=8),kind=8)
r  = real(z'AAAAAFFFFFFF3333', kind=8)
z1 = cmplx(b'11111011111111111111111111111111111111111111111111111111110101',-4.0, kind=8)
z2 = cmplx(5.0, o'442222222222233301245', kind=8)

if (r2 /= 1099511575347.0d0) call abort()
if (r  /= -3.72356884822177915d-103) call abort()
if (real(z1) /= 3.05175781249999627d-5 .or. aimag(z1) /= -4.0) call abort()
if (real(z2) /= 5.0 .or. aimag(z2) /= 3.98227593015308981d41) call abort()

end subroutine test8

end program f2003


! { dg-do run }
! { dg-options "-fno-range-check -O0" }
!
! This testcase arose from PR 31262
  integer :: a
  integer(kind=8) :: b
  a = -3
  b = -huge(b) / 7
  a = a ** 73
  b = 7894_8 * b - 78941_8
  if ((-3)**73 /= a) call abort
  if (7894_8 * (-huge(b) / 7) - 78941_8 /= b) call abort

  a = 1234789786453123
  if (a - 1234789786453123 /= a - (-426244989)) call abort
  end


! { dg-do run }
! Tests the fix for PR42104 in which the call to the procedure pointer
! component caused an ICE because the "always_implicit flag was not used
! to force the passing of a descriptor for the array argument.
!
! Contributed by Martien Hulsen <m.a.hulsen@tue.nl>
!
module poisson_functions_m

  implicit none

contains

  function func ( nr, x )
    integer, intent(in) :: nr
    real, intent(in), dimension(:) :: x
    real :: func

    real :: pi

    pi = 4 * atan(1.)

    select case(nr)
      case(1)
        func = 0
      case(2)
        func = 1
      case(3)
        func = 1 + cos(pi*x(1))*cos(pi*x(2))
      case default
        write(*,'(/a,i0/)') 'Error func: wrong function number: ', nr
        stop
    end select

  end function func

end module poisson_functions_m

module element_defs_m

  implicit none

  abstract interface
    function dummyfunc ( nr, x )
      integer, intent(in) :: nr
      real, intent(in), dimension(:) :: x
      real :: dummyfunc
    end function dummyfunc
  end interface

  type function_p
    procedure(dummyfunc), nopass, pointer :: p => null()
  end type function_p

end module element_defs_m

program t

use poisson_functions_m
use element_defs_m

procedure(dummyfunc), pointer :: p => null()
type(function_p) :: funcp

p => func
funcp%p => func

print *, func(nr=3,x=(/0.1,0.1/))
print *, p(nr=3,x=(/0.1,0.1/))
print *, funcp%p(nr=3,x=(/0.1,0.1/))

end program t


!
!     ------------------------------------------------------------------
!     P O L I N T
!     ------------------------------------------------------------------
!
      subroutine polint(xa, ya, n, x, y, dy)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  double
!...Translated by Pacific-Sierra Research 77to90  4.3E  10:46:35  11/20/01
!...Switches:
      implicit none
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      integer , intent(in) :: n
      real(double) , intent(in) :: x
      real(double) , intent(out) :: y
      real(double) , intent(out) :: dy
      real(double) , intent(in) :: xa(n)
      real(double) , intent(in) :: ya(n)
!-----------------------------------------------
!   L o c a l   P a r a m e t e r s
!-----------------------------------------------
      integer, parameter :: nmax = 10
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      integer :: i, m, ns
      real(double) :: den, dif, dift, ho, hp, w
      real(double), dimension(nmax) :: c, d
!-----------------------------------------------
      ns = 1
      dif = abs(x - xa(1))
      do i = 1, n
         dift = abs(x - xa(i))
         if (dift < dif) then
            ns = i
            dif = dift
         endif
         c(i) = ya(i)
         d(i) = ya(i)
      end do
      y = ya(ns)
      ns = ns - 1
      do m = 1, n - 1
         do i = 1, n - m
            ho = xa(i) - x
            hp = xa(i+m) - x
            w = c(i+1) - d(i)
            den = ho - hp
            if (den == 0.D0) then
               write (*, '(2A)') 'PAUSE ', 'failure in polint'
               read *
            endif
            den = w/den
            d(i) = hp*den
            c(i) = ho*den
         end do
         if (2*ns < n - m) then
            dy = c(ns+1)
         else
            dy = d(ns)
            ns = ns - 1
         endif
         y = y + dy
      end do
      return
      end subroutine polint


	SUBROUTINE GCESPL ( xval, np, coeffs, xout, npout, yout, iret )
C************************************************************************
C* GCESPL								*
C*									*
C* This subroutine evaluates points on a cubic curve.			*
C*									*
C* GCESPL  ( XVAL, NP, COEFFS, XOUT, NPOUT, YOUT, IRET )		*
C*									*
C* Input parameters:							*
C*	XVAL (NP)	REAL		X input coordinates		*
C*	NP		INTEGER		Number of input points 		*
C*	COEFFS (4,NP)	REAL		Coefficients of line segments	*
C*	XOUT (NPOUT)	REAL		X coordinates to evaluate	*
C*	NPOUT		INTEGER		Number of points to evaluate	*
C*									*
C* Output parameters:							*
C*	YOUT (NPOUT)	REAL		Evaluated Y coordinates		*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	12/85						*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		xval (*), coeffs (4,*), xout (*), yout (*)
C*
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = 0
C
C*	Loop through all the points.
C
	DO  i = 1, npout
	    xx = xout (i)
C
C*		Do not evaluate if input is "missing".
C
	    IF ( ERMISS (xx)) THEN
		yout (i) = RMISSD
C
C*		Do not evaluate if input is out of range.
C
	      ELSE IF ( (xx .lt. xval (1) ) .or. (xx .gt. xval (np)))
     +          THEN
		yout (i) = RMISSD
C
C*		The data to be evaluated is at the first point.
C
	      ELSE IF ( xx .eq. xval (1) ) THEN
		yout (i) = coeffs (4,1)
C
C*		Find the interval containing the point and evaluate it.
C
	      ELSE
		j = 2
		DO WHILE ( ( xx .gt. xval (j)) .and. ( j .le. np ) )
		    j = j + 1
		END DO
		j = j - 1
		yout (i) = coeffs (1,j) * xx + coeffs (2,j)
		dx = xx - xval (j)
		yout (i) = coeffs (1,j) * dx**3 + coeffs (2,j) * dx**2 +
     +	       		   coeffs (3,j) * dx + coeffs (4,j)
	    END IF
	END DO
C*
	RETURN
	END


!##############################################################################
!# Tutorial 004g: Datastructures - graph
!##############################################################################

module tutorial004g

  ! Include basic Feat-2 modules
  use fsystem
  use genoutput
  use graph
  use linearsystemscalar
  use matrixio

  implicit none
  private

  public :: start_tutorial004g

contains

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

  subroutine start_tutorial004g

    ! Declare some variables
    type(t_graph) :: rgraph
    type(t_matrixScalar) :: rmatrix
    character(LEN=SYS_STRLEN) :: spostdir
    integer :: i

    ! Print a message
    call output_lbrk()
    call output_separator (OU_SEP_STAR)
    call output_line ("This is FEAT-2. Tutorial 004g")
    call output_separator (OU_SEP_MINUS)

    ! =================================
    ! Create undirected graph with space
    ! for 10 vertices and 100 edges
    ! before new memory is allocated
    ! =================================

    call grph_createGraph(rgraph, GRPH_UNDIRECTED, 10, 100, .false.)

    ! =================================
    ! Insert 5 new vertices into the graph
    ! =================================

    do i=1,5
      call grph_insertVertex(rgraph, i)
    end do

    ! =================================
    ! Insert some edges into the graph
    ! =================================

    call grph_insertEdge(rgraph, 1,2)
    call grph_insertEdge(rgraph, 1,3)
    call grph_insertEdge(rgraph, 2,4)
    call grph_insertEdge(rgraph, 2,3)
    call grph_insertEdge(rgraph, 2,5)
    call grph_insertEdge(rgraph, 3,1)
    call grph_insertEdge(rgraph, 3,5)
    call grph_insertEdge(rgraph, 4,2)
    call grph_insertEdge(rgraph, 4,3)
    call grph_insertEdge(rgraph, 5,1)
    call grph_insertEdge(rgraph, 5,2)

    ! =================================
    ! Print graph
    ! =================================

    call grph_printGraph(rgraph)

    ! =================================
    ! Check if vertex 3 exists
    ! =================================

    if (grph_hasVertex(rgraph, 3)) then
      call output_line ("Graph has vertex 3.")
    else
      call output_line ("Graph does not have vertex 3.")
    end if

    ! =================================
    ! Check if edge (3,1) exists
    ! =================================

    if (grph_hasEdge(rgraph, 3,1)) then
      call output_line ("Graph has edge (3,1).")
    else
      call output_line ("Graph does not have edge (3,1).")
    end if

    ! =================================
    ! Create CSR9 matrix from graph
    ! =================================

    rmatrix%cmatrixFormat = LSYSSC_MATRIX9
    call lsyssc_createMatrixFromGraph(rgraph, rmatrix)

    ! =================================
    ! Write matrix to textfile
    ! =================================

    if (sys_getenv_string("POSTDIR",spostdir)) then
      call matio_spyMatrix(&
          trim(spostdir)//"/tutorial004g_matrix.m","matrix",rmatrix,.false.)
    else
      call matio_spyMatrix(&
          "./post/tutorial004g_matrix.m","matrix",rmatrix,.false.)
    end if

    ! =================================
    ! Release graph
    ! =================================

    call grph_releaseGraph(rgraph)

    ! =================================
    ! Create graph from matrix
    ! =================================

    call lsyssc_createGraphFromMatrix(rmatrix, rgraph)

    ! =================================
    ! Print graph
    ! =================================

    call grph_printGraph(rgraph)

    ! =================================
    ! Release graph and matrix
    ! =================================

    call grph_releaseGraph(rgraph)
    call lsyssc_releaseMatrix(rmatrix)

  end subroutine

end module


c=======================================================================
c
c     subroutine COVMVM
c
c     Empirical Covariance matrix and mean vector:
c
c                       n
c                 1    ---
c     cov(i,j) = ---   \   [X(k,i) - rho(i)] * [X(k,j) - rho(j)]
c               (n-1)  /
c                      ---
c                      k=1
c
c                  n
c              1  ---
c     rho(j) = -  \   X(i,j) for j = 1,...,p
c              n  /
c                 ---
c                 i=1
c
c-----------------------------------------------------------------------
      SUBROUTINE covmvm ( n, p, X, dwork, rho, cov, info)
c-----------------------------------------------------------------------
c
c     INPUT
c            n      : number of value(s) (n > 1)                 integer
c            p      : number of asset(s) (p >= 1)                integer
c            X      : value(s) (n*p)                              double
c
c     WORKSPACE
c            dwork  : vector( p*n )                               double
c
c     OUTPUT
c            rho    : mean vector (p)                             double
c            cov    : empirical covariance matrix (p*p)           double
c            info   : diagnostic argument                        integer
c
c     CALL
c            MCM    : mean of each column of a vectorized full matrix
c            EMPCOV : empirical covariance matrix
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, p, info
      DOUBLE PRECISION X(n, *), rho(*), cov(p, *)
c
c     workspaces
      DOUBLE PRECISION dwork(*)
c
c     local variables
      integer pdwork
c
c     external subroutines
      EXTERNAL MCM, empcov
c
c-----------------------------------------------------------------------
c
c     initialisations
      info = 0
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pdwork = 1
c     pdwork : pointer for relatives rents, so ( n*p ) more
c
c     Total size of dwork array = ( p*n )
c
c----------------------------------------------------------------------
c
c     means return(s)
      CALL MCM (n, p, X, rho )
c
c     empirical covariance matrix
      CALL empcov ( n, p, X, rho, dwork(pdwork), cov, info )
c
      RETURN
      END


module energies
    use types
    use box_pot_parameters

    implicit none

    private
    public force

contains

    subroutine force(r, f, ener, virial)
        real(dp), intent(in) :: r(:, :)
        real(dp), intent(inout) :: f(:, :)
        real(dp), intent(out) :: ener, virial

        ! Local variables
        integer, parameter :: n = 3 ! Spatial dimension
        integer :: i, j
        real(dp) :: rij, uij
        real(dp) :: frij(n), rposij(n)

        ! Variable intialization
        ener = 0.0_dp
        f = 0.0_dp
        virial = 0.0_dp
        frij(:) = 0.0_dp

        do i = 1, np - 1
            do j = i + 1, np
                uij = 0._dp

                rposij(:) = r(:, i) - r(:, j)
                rposij(:) = rposij(:) - boxl*nint(rposij(:)/boxl)
                rij = norm2(rposij)

                if (rij < rc) then
                    call hardsphere(rij, uij, rposij, frij)

                    ener = ener + uij
                    f(:, i) = f(:, i) + frij
                    f(:, j) = f(:, j) - frij
                    virial = virial + sum(frij * rposij)
                end if
            end do
        end do
    end subroutine force

    subroutine hardsphere(rij, uij, rposij, frij)
        ! Variables de entrada
        real(dp), intent(in) :: rij, rposij(:)
        real(dp), intent(inout) :: frij(:), uij
        ! Variables locales
        real(dp) ::  fij

        if (rij < bpot) then
            uij = (a2/dT)*((1.0_dp/rij)**dlr - (1.0_dp/rij)**dla)
            uij = uij + 1.0_dp/dT
            fij = dlr*(1.0_dp/rij)**(dlr + 1.0_dp) - dla*(1.0_dp/rij)**(dla + 1.0_dp)
            fij = a2*fij/dT
        else
            uij = 0.0_dp
            fij = 0.0_dp
        end if

        frij(:) = fij*rposij(:)/rij
    end subroutine hardsphere
end module energies


submodule (demo_svd) lapack

contains

module procedure svd
real(sp) :: truthS(N), errmag(N)

truthS = [3.97303, 1.46913, 1.02795]

call sgesvd('A','N',M,N, A, M,S,U,M,VT, N, SWORK, LWORK, info)

errmag = abs(s-truthS)
if (any(errmag > 1e-3)) then
  print *,'estimated singular values: ',S
  print *,'true singular values: ',truthS
  write(stderr,*) 'large error on singular values', errmag
  error stop
endif

end procedure svd

end submodule lapack


module map_surface
use math
use evaluate
implicit none

private
public :: surface_distance_map

contains

subroutine surface_distance_map(n, p, uk, m, q, vk, cpw, nu, nv, ugrid, vgrid, &
                                udist, vdist, uparam, vparam, xy)
    !> Build a distance map of the surface.

    !f2py intent(in) n, p, uk, q, m, vk, cpw, nu, nv, ugrid, vgrid
    !f2py intent(out) udist, vdist, uparam, vparam, xy
    !f2py depend(n, p) uk
    !f2py depend(m, q) vk
    !f2py depend(n, m) cpw
    !f2py depend(nu) ugrid
    !f2py depend(nv) vgrid
    !f2py depend(nu, nv) udist, vdist, xy

    ! Input
    integer, intent(in) :: n, p, m, q, nu, nv
    double precision, intent(in) :: uk(0:n + p + 1), vk(0:m + q + 1)
    double precision, intent(in) :: cpw(0:n, 0:m, 0:3)
    double precision, intent(in) :: ugrid(nu), vgrid(nv)

    ! Ouptut
    double precision, intent(out) :: udist(nu, nv), vdist(nu, nv)
    double precision, intent(out) :: uparam(nu * nv), vparam(nu * nv)
    double precision, intent(out) :: xy(nu * nv, 2)

    ! Working
    integer :: i, j, k
    double precision :: d, dv, du, du_0, du_1, dv_0, dv_1
    double precision :: p0(3), p1(3), dp(3)

    udist(:, :) = 0.0d0
    vdist(:, :) = 0.0d0
    uparam(:) = 0.0d0
    vparam(:) = 0.0d0
    xy(:, :) = 0.0d0

    ! Map u-direction.
    do j = 1, nv
        dv = vgrid(j)
        d = 0.0d0
        do i = 2, nu
            du_0 = ugrid(i - 1)
            du_1 = ugrid(i)
            call surface_point(n, p, uk, m, q, vk, cpw, du_0, dv, p0)
            call surface_point(n, p, uk, m, q, vk, cpw, du_1, dv, p1)
            dp = p1 - p0
            d = d + norm(dp)
            udist(i, j) = d
        end do
    end do

    ! Map v-direction.
    do i = 1, nu
        du = ugrid(i)
        d = 0.0d0
        do j = 2, nv
            dv_0 = vgrid(j - 1)
            dv_1 = vgrid(j)
            call surface_point(n, p, uk, m, q, vk, cpw, du, dv_0, p0)
            call surface_point(n, p, uk, m, q, vk, cpw, du, dv_1, p1)
            dp = p1 - p0
            d = d + norm(dp)
            vdist(i, j) = d
        end do
    end do

    ! Build data for inversion.
    k = 1
    do j = 1, nv
        do i = 1, nu
            xy(k, :) = (/ udist(i, j), vdist(i, j) /)
            uparam(k) = ugrid(i)
            vparam(k) = vgrid(j)
            k = k + 1
        end do
    end do

end subroutine surface_distance_map

end module map_surface


! { dg-do compile }
! { dg-options "-O3 -ffast-math" }

! This tests only for compile-time failure, which formerly occurred
! when statements were emitted out of order, failing verify_ssa.

MODULE xc_cs1
  INTEGER, PARAMETER :: dp=KIND(0.0D0)
  REAL(KIND=dp), PARAMETER :: a = 0.04918_dp, &
                              c = 0.2533_dp, &
                              d = 0.349_dp
CONTAINS
  SUBROUTINE cs1_u_2 ( rho, grho, r13, e_rho_rho, e_rho_ndrho, e_ndrho_ndrho,&
       npoints, error)
    REAL(KIND=dp), DIMENSION(*), &
      INTENT(INOUT)                          :: e_rho_rho, e_rho_ndrho, &
                                                e_ndrho_ndrho
    DO ip = 1, npoints
      IF ( rho(ip) > eps_rho ) THEN
         oc = 1.0_dp/(r*r*r3*r3 + c*g*g)
         d2rF4 = c4p*f13*f23*g**4*r3/r * (193*d*r**5*r3*r3+90*d*d*r**5*r3 &
                 -88*g*g*c*r**3*r3-100*d*d*c*g*g*r*r*r3*r3 &
                 +104*r**6)*od**3*oc**4
         e_rho_rho(ip) = e_rho_rho(ip) + d2F1 + d2rF2 + d2F3 + d2rF4
      END IF
    END DO
  END SUBROUTINE cs1_u_2
END MODULE xc_cs1


      DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B)

C***********************************************************************
C Sampling from f(x)=1./SQRT(X**2+B**2) between x1 and x2.             *
C Processed by S. Roesler, 6.5.95                                      *
C***********************************************************************

      IMPLICIT NONE
      DOUBLE PRECISION a , a1 , a2 , an , B , bb , DT_RNDM , TWO , X1 ,
     &                 X2
      SAVE
      PARAMETER (TWO=2.0D0)

      a1 = LOG(X1+SQRT(X1**2+B**2))
      a2 = LOG(X2+SQRT(X2**2+B**2))
      an = a2 - a1
      a = an*DT_RNDM(a1) + a1
      bb = EXP(a)
      DT_SAMPXB = (bb**2-B**2)/(TWO*bb)

      END FUNCTION


program standard_deviation

	use grib_api

	implicit none

	character(len=100)                  ::  file_name,out_file
	integer                             ::  ifile,ofile
	integer                             ::  igrib,ogrib
	integer                             ::  numberOfValues, nMessages
	integer                             ::  iret,i
	real(8), dimension(:), allocatable  ::  values,sums,square_sums

	! --- get input arguments
	call getarg(1,file_name)
	call getarg(2,out_file)

	call grib_open_file(ifile,file_name,'r')
	call grib_open_file(ofile,out_file,'w')

	! --- count number of messages in grib
	call grib_count_in_file(ifile,nMessages)

	call grib_new_from_file(ifile,igrib,iret)

	! --- create ouput grib from this one
	call grib_clone(igrib,ogrib)

	! --- get the number of values, we suppose all messages have
	! -     the same size for the sake of this example
	call grib_get(igrib,'numberOfValues',numberOfValues)

	! --- one should check if allocation was successfull
	allocate(values(numberOfValues))
	allocate(sums(numberOfValues))
	allocate(square_sums(numberOfValues))

	! --- compute the standard deviation
	sums = 0
	square_sums = 0
	do while (iret/=GRIB_END_OF_FILE)
		call grib_get(igrib,'values',values)
		sums = sums + values
		square_sums = square_sums + values * values
		call grib_new_from_file(ifile,igrib,iret)
	end do
	sums = sums/nMessages
	square_sums = square_sums/nMessages - sums*sums

	do i=1,numberOfValues
		if (square_sums(i) > 0.0) then
			square_sums(i) = sqrt(square_sums(i))
		else
			square_sums(i) = 0.0
		end if
	end do

	! --- write to the out file
	call grib_set(ogrib,'values',square_sums)
	call grib_write(ogrib,ofile)

	! --- release mem
	deallocate(values)
	deallocate(sums)
	call grib_release(igrib)
	call grib_close_file(ifile)
	call grib_close_file(ofile)

end program standard_deviation


module median_stats_mod
    use :: quicksort_mod
    implicit none

    private

    type, public :: descriptive_stats_t
        private
        integer :: nr_values = 0
        real :: sum = 0.0, sum2 = 0.0
        real, dimension(:), allocatable :: values
    end type descriptive_stats_t

    public :: init_stats, add_value, get_nr_values, get_mean, get_stddev, &
        get_median, finalize_stats

contains

    subroutine init_stats(stats, nr_values)
        use, intrinsic :: iso_fortran_env, only : error_unit
        type(descriptive_stats_t), intent(inout) :: stats
        integer, value :: nr_values
        integer :: status

        allocate(stats%values(nr_values), stat=status)
        if (status /= 0) then
            write (unit=error_unit, fmt='(A, I0, A)') &
                'error: can not allocated memory for ', nr_values, ' values'
            stop 3
        end if
    end subroutine init_stats

    subroutine add_value(stats, new_value)
        use, intrinsic :: iso_fortran_env, only : error_unit
        implicit none
        type(descriptive_stats_t), intent(inout) :: stats
        real, value :: new_value

        stats%nr_values = stats%nr_values + 1
        if (stats%nr_values > size(stats%values)) then
            write (unit=error_unit, fmt='(A, I0, A)') &
                'error: capacity exceeded, maximum ', size(stats%values), &
                ' can be processed'
            stop 4
        end if
        stats%sum = stats%sum + new_value
        stats%sum2 = stats%sum2 + new_value**2
        stats%values(stats%nr_values) = new_value
    end subroutine add_value

    function get_nr_values(stats) result(nr_values)
        implicit none
        type(descriptive_stats_t), intent(in) :: stats
        integer :: nr_values

        nr_values = stats%nr_values
    end function get_nr_values

    function get_mean(stats) result(mean_value)
        use, intrinsic :: iso_fortran_env, only : error_unit
        implicit none
        type(descriptive_stats_t), intent(inout) :: stats
        real :: mean_value

        if (stats%nr_values == 0) then
            write (unit=error_unit, fmt='(A)') &
                'error: too few data value to compute mean'
            stop 1
        end if
        associate (n => stats%nr_values, sum => stats%sum)
            mean_value = sum/n
        end associate
    end function get_mean

    function get_stddev(stats) result(stddev_value)
        use, intrinsic :: iso_fortran_env, only : error_unit
        implicit none
        type(descriptive_stats_t), intent(inout) :: stats
        real :: stddev_value

        if (stats%nr_values < 2) then
            write (unit=error_unit, fmt='(A)') &
                'error: too few data values to compute stddev'
            stop 2
        end if
        associate (n => stats%nr_values, sum => stats%sum, sum2 => stats%sum2)
            stddev_value = sqrt((sum2 - sum**2/n)/(n - 1.0))
        end associate
    end function get_stddev

    function get_median(stats) result(median_value)
        use, intrinsic :: iso_fortran_env, only : error_unit
        implicit none
        type(descriptive_stats_t), intent(inout) :: stats
        real :: median_value

        if (stats%nr_values == 0) then
            write (unit=error_unit, fmt='(A)') &
                'error: too few data value to compute median'
            stop 1
        end if
        associate(n => stats%nr_values, values => stats%values)
            call qsort(values)
            if (mod(n, 2) == 0) then
                median_value = (values(n/2) + values(n/2 + 1))/2.0
            else
                median_value = values(n/2 + 1)
            end if
        end associate
    end function get_median

    subroutine finalize_stats(stats)
        use, intrinsic :: iso_fortran_env, only : error_unit
        type(descriptive_stats_t), intent(inout) :: stats

        deallocate(stats%values)
    end subroutine finalize_stats

end module median_stats_mod


      SUBROUTINE rkck(y,dydx,n,x,h,yout,yerr,derivs)
      USE TIPrecision
      IMPLICIT                        NONE

   ! Local variables.
INTEGER (4)                  :: n,i
INTEGER (4), PARAMETER       :: NMAX=50

REAL(DbKi)                   :: h,x,dydx(n),y(n),yerr(n),yout(n)
REAL(DbKi)                   :: ak2(NMAX),ak3(NMAX),ak4(NMAX),ak5(NMAX),ak6(NMAX)
REAL(DbKi)                   :: ytemp(NMAX)
REAL(DbKi),PARAMETER         :: A2=.2
REAL(DbKi),PARAMETER         :: A3=.3
REAL(DbKi),PARAMETER         :: A4=.6
REAL(DbKi),PARAMETER         :: A5=1.
REAL(DbKi),PARAMETER         :: A6=.875
REAL(DbKi),PARAMETER         :: B21=.2
REAL(DbKi),PARAMETER         :: B31=3./40.
REAL(DbKi),PARAMETER         :: B32=9./40.
REAL(DbKi),PARAMETER         :: B41=.3
REAL(DbKi),PARAMETER         :: B42=-.9
REAL(DbKi),PARAMETER         :: B43=1.2
REAL(DbKi),PARAMETER         :: B51=-11./54.
REAL(DbKi),PARAMETER         :: B52=2.5
REAL(DbKi),PARAMETER         :: B53=-70./27.
REAL(DbKi),PARAMETER         :: B54=35./27.
REAL(DbKi),PARAMETER         :: B61=1631./55296.
REAL(DbKi),PARAMETER         :: B62=175./512.
REAL(DbKi),PARAMETER         :: B63=575./13824.
REAL(DbKi),PARAMETER         :: B64=44275./110592.
REAL(DbKi),PARAMETER         :: B65=253./4096.
REAL(DbKi),PARAMETER         :: C1=37./378.
REAL(DbKi),PARAMETER         :: C3=250./621.
REAL(DbKi),PARAMETER         :: C4=125./594.
REAL(DbKi),PARAMETER         :: C6=512./1771.
REAL(DbKi),PARAMETER         :: DC1=C1-2825./27648.
REAL(DbKi),PARAMETER         :: DC3=C3-18575./48384.
REAL(DbKi),PARAMETER         :: DC4=C4-13525./55296.
REAL(DbKi),PARAMETER         :: DC5=-277./14336.
REAL(DbKi),PARAMETER         :: DC6=C6-.25

EXTERNAL          :: derivs

!U    USES derivs

      do i=1,n
        ytemp(i)=y(i)+B21*h*dydx(i)
      enddo
      call derivs(x+A2*h,ytemp,ak2)
      do i=1,n
        ytemp(i)=y(i)+h*(B31*dydx(i)+B32*ak2(i))
      enddo
      call derivs(x+A3*h,ytemp,ak3)
      do i=1,n
        ytemp(i)=y(i)+h*(B41*dydx(i)+B42*ak2(i)+B43*ak3(i))
      enddo
      call derivs(x+A4*h,ytemp,ak4)
      do i=1,n
        ytemp(i)=y(i)+h*(B51*dydx(i)+B52*ak2(i)+B53*ak3(i)+B54*ak4(i))
      enddo
      call derivs(x+A5*h,ytemp,ak5)
      do i=1,n
        ytemp(i)=y(i)+h*(B61*dydx(i)+B62*ak2(i)+B63*ak3(i)+B64*ak4(i)+B65*ak5(i))
      enddo
      call derivs(x+A6*h,ytemp,ak6)
      do i=1,n
        yout(i)=y(i)+h*(C1*dydx(i)+C3*ak3(i)+C4*ak4(i)+C6*ak6(i))
      enddo
      do  i=1,n
        yerr(i)=h*(DC1*dydx(i)+DC3*ak3(i)+DC4*ak4(i)+DC5*ak5(i)+DC6*ak6(i))
      enddo
      return
      END


MODULE pchipmod

  ! subroutines and functions related to the calculation of the
  ! Piecewise Cubic Hermite Interpolating Polynomial (PCHIP)

  IMPLICIT NONE
  SAVE

  REAL (KIND=8), PRIVATE                 :: h
  REAL (KIND=8), PRIVATE                 :: fprime_r, fprime_i

CONTAINS

  SUBROUTINE PCHIP( x, y, N, PolyCoef, csWork )

    ! This implements the monotone piecewise cubic Hermite interpolating
    ! polynomial (PCHIP) algorithm. This is a new variant of monotone PCHIP
    ! (paper submitted to JASA). Also see;
    !
    ! F. N. Fritsch and J. Butland, "A Method for Constructing Local Monotone
    ! Piecewise Cubic Interpolants", SIAM Journal on Scientific and Statistical
    ! Computing, 5(2):300-304, (1984) https://doi.org/10.1137/0905021
    !
    ! F. N. Fritsch and R. E. Carlson. "Monotone Piecewise Cubic Interpolation",
    ! SIAM Journal on Numerical Analysis, 17(2):238-246, (1980) https://doi.org/10.1137/0717021
    !
    ! N is the number of nodes
    ! x is a vector of the abscissa values
    ! y is a vector of the associated ordinate values
    ! PolyCoef are the coefficients of the standard polynomial
    ! csWork is a temporary work space for the cubic spline

    INTEGER,          INTENT( IN  )   :: N
    REAL    (KIND=8), INTENT( IN  )   :: x( * )
    COMPLEX (KIND=8), INTENT( IN  )   :: y( * )
    COMPLEX (KIND=8), INTENT( INOUT ) :: PolyCoef( 4, * ), csWork( 4, * )

    INTEGER           :: ix, iBCBeg, iBCEnd
    REAL     (KIND=8) :: h1, h2
    COMPLEX  (KIND=8) :: del1, del2, f1, f2, f1prime, f2prime, fprimeT

    !  Precompute estimates of the derivatives at the nodes
    !  The vector PolyCoef(1,*) holds the ordinate values at the nodes
    !  The vector PolyCoef(2,*) holds the ordinate derivatives at the nodes

    IF ( N .EQ. 2 ) THEN

    ! handle special case of two data points seperately (linear interpolation)

    PolyCoef( 1, 1 ) = y( 1 )
    PolyCoef( 2, 1 ) = ( y( 2 ) - y( 1 ) ) / ( x( 2 ) - x( 1 ) )
    PolyCoef( 3, 1 ) = 0.0D0
    PolyCoef( 4, 1 ) = 0.0D0

    ELSE

    ! general case of more than two data points

    PolyCoef( 1, 1 : N ) = y( 1 : N )

    ! left endpoint (non-centered 3-point difference formula)

    CALL h_del( x, y, 2, h1, h2, del1, del2 )
    fprimeT = ( ( 2.0D0 * h1 + h2 ) * del1 - h1 * del2 ) / ( h1 + h2 )
    PolyCoef( 2, 1 ) = fprime_left_end_Cmplx( del1, del2, fprimeT )

    ! right endpoint (non-centered 3-point difference formula)

    CALL h_del( x, y, N - 1, h1, h2, del1, del2 )
    fprimeT = ( -h2 * del1 + ( h1 + 2.0D0 * h2 ) * del2 ) / ( h1 + h2 )
    PolyCoef( 2, N ) = fprime_right_end_Cmplx( del1, del2, fprimeT )

    ! compute coefficients of the cubic spline interpolating polynomial

    iBCBeg = 1   ! specified derivatives at the end points
    iBCEnd = 1
    csWork( 1, 1 : N ) = PolyCoef( 1, 1 : N )
    csWork( 2,     1 ) = PolyCoef( 2, 1 )
    csWork( 2,     N ) = PolyCoef( 2, N )
    CALL CSpline( x, csWork( 1, 1 ), N, iBCBeg, iBCEnd, N )

    ! interior nodes (use derivatives from the cubic spline as initial estimate)

    DO ix = 2, N - 1
       CALL h_del( x, y, ix, h1, h2, del1, del2 )
       ! check if the derivative from the cubic spline satisfies monotonicity
       PolyCoef( 2, ix ) = fprime_interior_Cmplx( del1, del2, csWork( 2, ix ) )
    END DO

    !                                                               2      3
    ! compute coefficients of std cubic polynomial: c0 + c1*x + c2*x + c3*x
    !

    DO ix = 1, N - 1
       h  = x( ix + 1 ) - x( ix )

       f1 = PolyCoef( 1, ix )
       f2 = PolyCoef( 1, ix + 1 )

       f1prime = PolyCoef( 2, ix )
       f2prime = PolyCoef( 2, ix + 1 )

       PolyCoef( 3, ix ) = ( 3.0D0 * ( f2 - f1 )  - h * ( 2.0D0 * f1prime + f2prime ) ) / h**2
       PolyCoef( 4, ix ) = ( h * ( f1prime + f2prime ) - 2.0D0 * ( f2 - f1 ) ) / h**3
    END DO

    END IF

    RETURN
  END SUBROUTINE PCHIP

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

  SUBROUTINE h_del( x, y, ix, h1, h2, del1, del2 )

    INTEGER,          INTENT( IN  ) :: ix   ! index of the center point
    REAL    (KIND=8), INTENT( IN  ) :: x( * )
    COMPLEX (KIND=8), INTENT( IN  ) :: y( * )
    REAL    (KIND=8), INTENT( OUT ) :: h1, h2
    COMPLEX (KIND=8), INTENT( OUT ) :: del1, del2

    h1   =   x( ix     ) - x( ix - 1 )
    h2   =   x( ix + 1 ) - x( ix     )

    del1 = ( y( ix     ) - y( ix - 1 ) ) / h1
    del2 = ( y( ix + 1 ) - y( ix     ) ) / h2

    RETURN
  END SUBROUTINE h_del

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

  FUNCTION fprime_interior_Cmplx( del1, del2, fprime )

    COMPLEX (KIND=8), INTENT( IN ) :: del1, del2, fprime
    COMPLEX (KIND=8)               :: fprime_interior_Cmplx

    fprime_r = fprime_interior( REAL(  del1 ), REAL(  del2 ), REAL(  fprime ) )
    fprime_i = fprime_interior( AIMAG( del1 ), AIMAG( del2 ), AIMAG( fprime ) )

    fprime_interior_Cmplx = CMPLX( fprime_r, fprime_i, KIND=8 )

  END FUNCTION fprime_interior_Cmplx

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

  FUNCTION fprime_left_end_Cmplx( del1, del2, fprime )

    COMPLEX (KIND=8), INTENT( IN ) :: del1, del2, fprime
    COMPLEX (KIND=8)               :: fprime_left_end_Cmplx

    fprime_r = fprime_left_end( REAL(  del1 ), REAL(  del2 ), REAL(  fprime ) )
    fprime_i = fprime_left_end( AIMAG( del1 ), AIMAG( del2 ), AIMAG( fprime ) )

    fprime_left_end_Cmplx = CMPLX( fprime_r, fprime_i, KIND=8 )

  END FUNCTION fprime_left_end_Cmplx

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

  FUNCTION fprime_right_end_Cmplx( del1, del2, fprime )

    COMPLEX (KIND=8), INTENT( IN ) :: del1, del2, fprime
    COMPLEX (KIND=8)               :: fprime_right_end_Cmplx

    fprime_r = fprime_right_end( REAL(  del1 ), REAL(  del2 ), REAL(  fprime ) )
    fprime_i = fprime_right_end( AIMAG( del1 ), AIMAG( del2 ), AIMAG( fprime ) )

    fprime_right_end_Cmplx = CMPLX( fprime_r, fprime_i, KIND=8 )

  END FUNCTION fprime_right_end_Cmplx

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

  FUNCTION fprime_interior( del1, del2, fprime )

    REAL (KIND=8), INTENT( IN ) :: del1, del2, fprime
    REAL (KIND=8)               :: fprime_interior

    ! check if derivative is within the trust region, project into it if not

    IF ( del1 * del2 > 0.0 ) THEN
      ! adjacent secant slopes have the same sign, enforce monotonicity
      IF ( del1 > 0.0 ) THEN
        fprime_interior = MIN( MAX(fprime, 0.0D0), 3.0D0 * MIN(del1, del2) )
      ELSE
        fprime_interior = MAX( MIN(fprime, 0.0D0), 3.0D0 * MAX(del1, del2) )
      END IF
    ELSE
      ! force the interpolant to have an extrema here
      fprime_interior = 0.0D0;
    END IF

  END FUNCTION fprime_interior

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

  FUNCTION fprime_left_end( del1, del2, fprime )

    REAL (KIND=8), INTENT( IN ) :: del1, del2, fprime
    REAL (KIND=8)               :: fprime_left_end

    fprime_left_end = fprime

    IF ( del1 * fprime <= 0.0D0 ) THEN
       ! set derivative to zero if the sign differs from sign of secant slope
       fprime_left_end = 0.0;
    ELSE IF ( ( del1 * del2 <= 0.0D0 ) .AND. ( ABS( fprime ) > ABS( 3.0D0 * del1 ) ) ) THEN
       ! adjust derivative value to enforce monotonicity
       fprime_left_end = 3.0D0 * del1;
    END IF

  END FUNCTION fprime_left_end

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

  FUNCTION fprime_right_end( del1, del2, fprime )

    ! This is essentially the same as fprime_left_end( del2, del1, fprime )
    ! Written separately for clarity

    REAL (KIND=8), INTENT( IN ) :: del1, del2, fprime
    REAL (KIND=8)               :: fprime_right_end

    fprime_right_end = fprime

    IF ( del2 * fprime <= 0.0D0 ) THEN
       ! set derivative to zero if the sign differs from sign of secant slope
       fprime_right_end = 0.0;
    ELSE IF ( ( del1 * del2 <= 0.0D0 ) .AND. ( ABS( fprime ) > ABS( 3.0D0 * del2 ) ) ) THEN
       ! adjust derivative value to enforce monotonicity
       fprime_right_end = 3.0D0 * del2;
    END IF

  END FUNCTION fprime_right_end

END MODULE pchipmod


!######################################################################
      subroutine HJ_WENO_dx(op)
!######################################################################
      use vars
      use multidata
      implicit none
      INTEGER :: I,J,K,L,k_star,np,nq,nr,op,ib,pll
      REAL, pointer, DIMENSION(:,:,:)::FI
      REAL :: e,Q1,Q2,Q3,c_star,v1,v2,v3,v4,v5,v11,v22,v33,v44,v55,S1,S2
     &,S3,a1,a2,a3,w1,w2,w3
      pll=pl_ex+1
      do ib=1,nbp

       select case (op)
        Case (1)
          fi => dom(ib)%u
          np=dom(ib)%ieu+pll; nq=dom(ib)%jeu+pll; nr=dom(ib)%keu+pll
        Case (2)
          fi => dom(ib)%v
          np=dom(ib)%iev+pll; nq=dom(ib)%jev+pll; nr=dom(ib)%kev+pll
        Case (3)
          fi => dom(ib)%w
          np=dom(ib)%iew+pll; nq=dom(ib)%jew+pll; nr=dom(ib)%kew+pll
       end select

!
!.....Compute Dividierte Differenzen
!
      DO K=1,NR
       DO I=1,NP-1
        DO J=1,NQ
           dom(ib)%D1(i,j,k) = (FI(i+1,j,k) - FI(i,j,k))/dom(ib)%dx
        END DO
       END DO
      END DO
!
!..... COMPUTE DERIVATIVE OF PHI (5-th Ord.)
!

      dom(ib)%dphi_dxplus = 0.0
      dom(ib)%dphi_dxminus = 0.0

      DO K=1,NR
       DO I=1,NP-6
        DO J=1,NQ
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
           L=I

           v1 = dom(ib)%D1(L+5,j,k)
           v2 = dom(ib)%D1(L+4,j,k)
           v3 = dom(ib)%D1(L+3,j,k)
           v4 = dom(ib)%D1(L+2,j,k)
           v5 = dom(ib)%D1(L+1,j,k)

           v11 = v1**2
           v22 = v2**2
           v33 = v3**2
           v44 = v4**2
           v55 = v5**2

           e = (1.0E-6) * MAX(v11,v22,v33,v44,v55) + 1.0E-99

      S1 = (13.0/12.0)*(v1-2.0*v2+v3)**2 + 0.25*(v1-4.0*v2+3.0*v3)**2
      S2 = (13.0/12.0)*(v2-2.0*v3+v4)**2 + 0.25*(v2-v4)**2
      S3 = (13.0/12.0)*(v3-2.0*v4+v5)**2 + 0.25*(3.0*v3-4.0*v4+v5)**2

           a1 = 0.1/(e+S1)**2
           a2 = 0.6/(e+S2)**2
           a3 = 0.3/(e+S3)**2

           w1 = a1/(a1+a2+a3)
           w2 = a2/(a1+a2+a3)
           w3 = a3/(a1+a2+a3)

      dom(ib)%dphi_dxplus(i+3,j,k) = w1*(v1*(1.0/3.0)-v2*(7.0/6.0)+
     &v3*(11.0/6.0)) + w2*(-v2*(1.0/6.0)+v3*(5.0/6.0)+v4*(1.0/3.0))+
     &w3*(v3*(1.0/3.0)+v4*(5.0/6.0)-v5*(1.0/6.0))
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
           L=I-1

           v1 = dom(ib)%D1(L+1,j,k)
           v2 = dom(ib)%D1(L+2,j,k)
           v3 = dom(ib)%D1(L+3,j,k)
           v4 = dom(ib)%D1(L+4,j,k)
           v5 = dom(ib)%D1(L+5,j,k)

           v11 = v1**2
           v22 = v2**2
           v33 = v3**2
           v44 = v4**2
           v55 = v5**2

           e = (1.0E-6) * MAX(v11,v22,v33,v44,v55) + 1.0E-99

      S1 = (13.0/12.0)*(v1-2.0*v2+v3)**2 + 0.25*(v1-4.0*v2+3.0*v3)**2
      S2 = (13.0/12.0)*(v2-2.0*v3+v4)**2 + 0.25*(v2-v4)**2
      S3 = (13.0/12.0)*(v3-2.0*v4+v5)**2 + 0.25*(3.0*v3-4.0*v4+v5)**2

           a1 = 0.1/(e+S1)**2
           a2 = 0.6/(e+S2)**2
           a3 = 0.3/(e+S3)**2

           w1 = a1/(a1+a2+a3)
           w2 = a2/(a1+a2+a3)
           w3 = a3/(a1+a2+a3)

      dom(ib)%dphi_dxminus(i+3,j,k) = w1*(v1*(1.0/3.0)-v2*(7.0/6.0)+
     &v3*(11.0/6.0)) + w2*(-v2*(1.0/6.0)+v3*(5.0/6.0)+v4*(1.0/3.0))+
     &w3*(v3*(1.0/3.0)+v4*(5.0/6.0)-v5*(1.0/6.0))
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        END DO
       END DO
      END DO

      end do

      RETURN
      end subroutine HJ_WENO_dx
!######################################################################
      subroutine HJ_WENO_dy(op)
!######################################################################
      use vars
      use multidata
      implicit none
      INTEGER :: I,J,K,L,k_star,np,nq,nr,op,ib,pll
      REAL, pointer, DIMENSION(:,:,:)::FI
      REAL :: e,Q1,Q2,Q3,c_star,v1,v2,v3,v4,v5,v11,v22,v33,v44,v55,S1,S2
     &,S3,a1,a2,a3,w1,w2,w3
      pll=pl_ex+1
      do ib=1,nbp

       select case (op)
        Case (1)
          fi => dom(ib)%u
          np=dom(ib)%ieu+pll; nq=dom(ib)%jeu+pll; nr=dom(ib)%keu+pll
        Case (2)
          fi => dom(ib)%v
          np=dom(ib)%iev+pll; nq=dom(ib)%jev+pll; nr=dom(ib)%kev+pll
        Case (3)
          fi => dom(ib)%w
          np=dom(ib)%iew+pll; nq=dom(ib)%jew+pll; nr=dom(ib)%kew+pll
       end select

!
!.....Compute Dividierte Differenzen
!
      DO K=1,NR
       DO I=1,NP
        DO J=1,NQ-1
           dom(ib)%D1(i,j,k) = (FI(i,j+1,k) - FI(i,j,k))/dom(ib)%dy
        END DO
       END DO
      END DO
!
!..... COMPUTE DERIVATIVE OF PHI (5-th Ord.)
!

      dom(ib)%dphi_dyplus = 0.0
      dom(ib)%dphi_dyminus = 0.0

      DO K=1,NR
       DO I=1,NP
        DO J=1,NQ-6
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
           L=J

           v1 = dom(ib)%D1(i,L+5,k)
           v2 = dom(ib)%D1(i,L+4,k)
           v3 = dom(ib)%D1(i,L+3,k)
           v4 = dom(ib)%D1(i,L+2,k)
           v5 = dom(ib)%D1(i,L+1,k)

           v11 = v1**2
           v22 = v2**2
           v33 = v3**2
           v44 = v4**2
           v55 = v5**2

           e = (1.0E-6) * MAX(v11,v22,v33,v44,v55) + 1.0E-99

      S1 = (13.0/12.0)*(v1-2.0*v2+v3)**2 + 0.25*(v1-4.0*v2+3.0*v3)**2
      S2 = (13.0/12.0)*(v2-2.0*v3+v4)**2 + 0.25*(v2-v4)**2
      S3 = (13.0/12.0)*(v3-2.0*v4+v5)**2 + 0.25*(3.0*v3-4.0*v4+v5)**2

           a1 = 0.1/(e+S1)**2
           a2 = 0.6/(e+S2)**2
           a3 = 0.3/(e+S3)**2

           w1 = a1/(a1+a2+a3)
           w2 = a2/(a1+a2+a3)
           w3 = a3/(a1+a2+a3)

      dom(ib)%dphi_dyplus(i,j+3,k) = w1*(v1*(1.0/3.0)-v2*(7.0/6.0)+
     &v3*(11.0/6.0)) + w2*(-v2*(1.0/6.0)+v3*(5.0/6.0)+v4*(1.0/3.0))+
     &w3*(v3*(1.0/3.0)+v4*(5.0/6.0)-v5*(1.0/6.0))
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
           L=J-1

           v1 = dom(ib)%D1(i,L+1,k)
           v2 = dom(ib)%D1(i,L+2,k)
           v3 = dom(ib)%D1(i,L+3,k)
           v4 = dom(ib)%D1(i,L+4,k)
           v5 = dom(ib)%D1(i,L+5,k)

           v11 = v1**2
           v22 = v2**2
           v33 = v3**2
           v44 = v4**2
           v55 = v5**2

           e = (1.0E-6) * MAX(v11,v22,v33,v44,v55) + 1.0E-99

      S1 = (13.0/12.0)*(v1-2.0*v2+v3)**2 + 0.25*(v1-4.0*v2+3.0*v3)**2
      S2 = (13.0/12.0)*(v2-2.0*v3+v4)**2 + 0.25*(v2-v4)**2
      S3 = (13.0/12.0)*(v3-2.0*v4+v5)**2 + 0.25*(3.0*v3-4.0*v4+v5)**2

           a1 = 0.1/(e+S1)**2
           a2 = 0.6/(e+S2)**2
           a3 = 0.3/(e+S3)**2

           w1 = a1/(a1+a2+a3)
           w2 = a2/(a1+a2+a3)
           w3 = a3/(a1+a2+a3)

      dom(ib)%dphi_dyminus(i,j+3,k) = w1*(v1*(1.0/3.0)-v2*(7.0/6.0)+
     &v3*(11.0/6.0)) + w2*(-v2*(1.0/6.0)+v3*(5.0/6.0)+v4*(1.0/3.0))+
     &w3*(v3*(1.0/3.0)+v4*(5.0/6.0)-v5*(1.0/6.0))
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        END DO
       END DO
      END DO

      end do

      RETURN
      end subroutine HJ_WENO_dy
!######################################################################
      subroutine HJ_WENO_dz(op)
!######################################################################
      use vars
      use multidata
      implicit none
      INTEGER :: I,J,K,L,k_star,np,nq,nr,op,ib,pll
      REAL, pointer, DIMENSION(:,:,:)::FI
      REAL :: e,Q1,Q2,Q3,c_star,v1,v2,v3,v4,v5,v11,v22,v33,v44,v55,S1,S2
     &,S3,a1,a2,a3,w1,w2,w3
      pll=pl_ex+1
      do ib=1,nbp

       select case (op)
        Case (1)
          fi => dom(ib)%u
          np=dom(ib)%ieu+pll; nq=dom(ib)%jeu+pll; nr=dom(ib)%keu+pll
        Case (2)
          fi => dom(ib)%v
          np=dom(ib)%iev+pll; nq=dom(ib)%jev+pll; nr=dom(ib)%kev+pll
        Case (3)
          fi => dom(ib)%w
          np=dom(ib)%iew+pll; nq=dom(ib)%jew+pll; nr=dom(ib)%kew+pll
       end select

!
!.....Compute Dividierte Differenzen
!
      DO K=1,NR-1
       DO I=1,NP
        DO J=1,NQ
           dom(ib)%D1(i,j,k) = (FI(i,j,k+1) - FI(i,j,k))/dom(ib)%dz
        END DO
       END DO
      END DO
!
!..... COMPUTE DERIVATIVE OF PHI (5-th Ord.)
!

      dom(ib)%dphi_dzplus = 0.0
      dom(ib)%dphi_dzminus = 0.0

      DO K=1,NR-6
       DO I=1,NP
        DO J=1,NQ
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
            L=K

           v1 = dom(ib)%D1(i,j,L+5)
           v2 = dom(ib)%D1(i,j,L+4)
           v3 = dom(ib)%D1(i,j,L+3)
           v4 = dom(ib)%D1(i,j,L+2)
           v5 = dom(ib)%D1(i,j,L+1)

           v11 = v1**2
           v22 = v2**2
           v33 = v3**2
           v44 = v4**2
           v55 = v5**2

           e = (1.0E-6) * MAX(v11,v22,v33,v44,v55) + 1.0E-99

      S1 = (13.0/12.0)*(v1-2.0*v2+v3)**2 + 0.25*(v1-4.0*v2+3.0*v3)**2
      S2 = (13.0/12.0)*(v2-2.0*v3+v4)**2 + 0.25*(v2-v4)**2
      S3 = (13.0/12.0)*(v3-2.0*v4+v5)**2 + 0.25*(3.0*v3-4.0*v4+v5)**2

           a1 = 0.1/(e+S1)**2
           a2 = 0.6/(e+S2)**2
           a3 = 0.3/(e+S3)**2

           w1 = a1/(a1+a2+a3)
           w2 = a2/(a1+a2+a3)
           w3 = a3/(a1+a2+a3)

      dom(ib)%dphi_dzplus(i,j,k+3) = w1*(v1*(1.0/3.0)-v2*(7.0/6.0)+
     &v3*(11.0/6.0)) + w2*(-v2*(1.0/6.0)+v3*(5.0/6.0)+v4*(1.0/3.0))+
     &w3*(v3*(1.0/3.0)+v4*(5.0/6.0)-v5*(1.0/6.0))
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
           L=K-1

           v1 = dom(ib)%D1(i,j,L+1)
           v2 = dom(ib)%D1(i,j,L+2)
           v3 = dom(ib)%D1(i,j,L+3)
           v4 = dom(ib)%D1(i,j,L+4)
           v5 = dom(ib)%D1(i,j,L+5)

           v11 = v1**2
           v22 = v2**2
           v33 = v3**2
           v44 = v4**2
           v55 = v5**2

           e = (1.0E-6) * MAX(v11,v22,v33,v44,v55) + 1.0E-99

      S1 = (13.0/12.0)*(v1-2.0*v2+v3)**2 + 0.25*(v1-4.0*v2+3.0*v3)**2
      S2 = (13.0/12.0)*(v2-2.0*v3+v4)**2 + 0.25*(v2-v4)**2
      S3 = (13.0/12.0)*(v3-2.0*v4+v5)**2 + 0.25*(3.0*v3-4.0*v4+v5)**2

           a1 = 0.1/(e+S1)**2
           a2 = 0.6/(e+S2)**2
           a3 = 0.3/(e+S3)**2

           w1 = a1/(a1+a2+a3)
           w2 = a2/(a1+a2+a3)
           w3 = a3/(a1+a2+a3)

      dom(ib)%dphi_dzminus(i,j,k+3) = w1*(v1*(1.0/3.0)-v2*(7.0/6.0)+
     &v3*(11.0/6.0)) + w2*(-v2*(1.0/6.0)+v3*(5.0/6.0)+v4*(1.0/3.0))+
     &w3*(v3*(1.0/3.0)+v4*(5.0/6.0)-v5*(1.0/6.0))
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        END DO
       END DO
      END DO

      end do

      RETURN
      end subroutine HJ_WENO_dz
!######################################################################


C$Procedure    NPEDLN ( Nearest point on ellipsoid to line )

      SUBROUTINE NPEDLN ( A, B, C, LINEPT, LINEDR, PNEAR, DIST )

C$ Abstract
C
C     Find nearest point on a triaxial ellipsoid to a specified line,
C     and the distance from the ellipsoid to the line.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     ELLIPSES
C
C$ Keywords
C
C     ELLIPSOID
C     GEOMETRY
C     MATH
C
C$ Declarations

      INTEGER               UBEL
      PARAMETER           ( UBEL = 9 )

      INTEGER               UBPL
      PARAMETER           ( UBPL = 4 )

      DOUBLE PRECISION      A
      DOUBLE PRECISION      B
      DOUBLE PRECISION      C
      DOUBLE PRECISION      LINEPT ( 3 )
      DOUBLE PRECISION      LINEDR ( 3 )
      DOUBLE PRECISION      PNEAR  ( 3 )
      DOUBLE PRECISION      DIST

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     A          I   Length of ellipsoid's semi-axis in the x direction
C     B          I   Length of ellipsoid's semi-axis in the y direction
C     C          I   Length of ellipsoid's semi-axis in the z direction
C     LINEPT     I   Point on line
C     LINEDR     I   Direction vector of line
C     PNEAR      O   Nearest point on ellipsoid to line
C     DIST       O   Distance of ellipsoid from line
C     UBEL       P   Upper bound of array containing SPICELIB ellipse.
C     UBPL       P   Upper bound of array containing SPICELIB plane.
C
C$ Detailed_Input
C
C     A,
C     B,
C     C              are the lengths of the semi-axes of a triaxial
C                    ellipsoid which is centered at the origin and
C                    oriented so that its axes lie on the x-, y- and
C                    z- coordinate axes.  A, B, and C are the lengths of
C                    the semi-axes that point in the x, y, and z
C                    directions respectively.
C
C     LINEPT
C     LINEDR         are, respectively, a point and a direction vector
C                    that define a line.  The line is the set of vectors
C
C                       LINEPT   +   t * LINEDR
C
C                    where t is any real number.
C
C$ Detailed_Output
C
C     PNEAR          is the point on the ellipsoid that is closest to
C                    the line, if the line doesn't intersect the
C                    ellipsoid.
C
C                    If the line intersects the ellipsoid, PNEAR will
C                    be a point of intersection.  If LINEPT is outside
C                    of the ellipsoid, PNEAR will be the closest point
C                    of intersection.  If LINEPT is inside the
C                    ellipsoid, PNEAR will not necessarily be the
C                    closest point of intersection.
C
C
C     DIST           is the distance of the line from the ellipsoid.
C                    This is the minimum distance between any point on
C                    the line and any point on the ellipsoid.
C
C                    If the line intersects the ellipsoid, DIST is zero.
C
C$ Parameters
C
C     UBEL           is the upper bound of the array used to contain
C                    a SPICELIB ellipse.  See the ELLIPSES Required
C                    Reading for details.
C
C     UBPL           is the upper bound of the array used to contain
C                    a SPICELIB plane.  See the PLANES Required Reading
C                    for details.
C
C$ Exceptions
C
C     If this routine detects an error, the output arguments NEARP and
C     DIST are not modified.
C
C     1)  If the length of any semi-axis of the ellipsoid is
C         non-positive, the error SPICE(INVALIDAXISLENGTH) is signalled.
C
C     2)  If the line's direction vector is the zero vector, the error
C         SPICE(ZEROVECTOR) is signalled.
C
C     3)  If the length of any semi-axis of the ellipsoid is zero after
C         the semi-axis lengths are scaled by the reciprocal of the
C         magnitude of the longest semi-axis and then squared, the error
C         SPICE(DEGENERATECASE) is signalled.
C
C     4)  If the input ellipsoid is extremely flat or needle-shaped
C         and has its shortest axis close to perpendicular to the input
C         line, numerical problems could cause this routine's algorithm
C         to fail, in which case the error SPICE(DEGENERATECASE) is
C         signalled.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     For any ellipsoid and line, if the line does not intersect the
C     ellipsoid, there is a unique point on the ellipsoid that is
C     closest to the line.  Therefore, the distance DIST between
C     ellipsoid and line is well-defined.  The unique line segment of
C     length DIST that connects the line and ellipsoid is normal to
C     both of these objects at its endpoints.
C
C     If the line intersects the ellipsoid, the distance between the
C     line and ellipsoid is zero.
C
C$ Examples
C
C     1)   We can find the distance between an instrument optic axis ray
C          and the surface of a body modelled as a tri-axial ellipsoid
C          using this routine.  If the instrument position and pointing
C          unit vector in body-fixed coordinates are
C
C             LINEPT = ( 1.0D6,  2.0D6,  3.0D6 )
C
C          and
C
C             LINEDR = ( -4.472091234D-1
C                        -8.944182469D-1,
C                        -4.472091234D-3  )
C
C          and the body semi-axes lengths are
C
C             A = 7.0D5
C             B = 7.0D5
C             C = 6.0D5,
C
C          then the call to NPEDLN
C
C             CALL NPEDLN ( A,      B,      C,
C            .              LINEPT, LINEDR,
C            .              PNEAR,  DIST        )
C
C          yields a value for PNEAR, the nearest point on the body to
C          the optic axis ray, of
C
C
C             (  -1.6333110792340931E+03,
C                -3.2666222157820771E+03,
C                 5.9999183350006724E+05  )
C
C          and a value for DIST, the distance to the ray, of
C
C             2.3899679338299707E+06
C
C          (These results were obtained on a PC-Linux system under g77.)
C
C          In some cases, it may not be clear that the closest point
C          on the line containing an instrument boresight ray is on
C          the boresight ray itself; the point may lie on the ray
C          having the same vertex as the boresight ray and pointing in
C          the opposite direction.  To rule out this possibility, we
C          can make the following test:
C
C             C
C             C     Find the difference vector between the closest point
C             C     on the ellpsoid to the line containing the boresight
C             C     ray and the boresight ray's vertex.  Find the
C             C     angular separation between this difference vector
C             C     and the boresight ray.  If the angular separation
C             C     does not exceed pi/2, we have the nominal geometry.
C             C     Otherwise, we have an error.
C             C
C                   CALL  VSUB ( PNEAR,  LINEPT,  DIFF )
C                   SEP = VSEP ( DIFF,   LINEDR        )
C
C                   IF (  SEP .LE. HALFPI()  ) THEN
C
C                      [ perform normal processing ]
C
C                   ELSE
C
C                      [ handle error case ]
C
C                   END IF
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.3.0, 15-NOV-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in VSCL calls.  Changed exponents to DOUBLE PRECISION type
C        in the test for underflow of squared, scaled axis lengths.
C
C-    SPICELIB Version 1.2.1, 06-DEC-2002 (NJB)
C
C        Outputs shown in header example have been corrected to
C        be consistent with those produced by this routine.
C
C-    SPICELIB Version 1.2.0, 25-NOV-1992 (NJB)
C
C        Bug fix:  in the intercept case, PNEAR is now properly
C        re-scaled prior to output.  Also, an error in the $Examples
C        section was corrected.
C
C-    SPICELIB Version 1.1.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.1.0, 04-DEC-1990 (NJB)
C
C        Error message and description changed for non-positive
C        axis length error.
C
C-    SPICELIB Version 1.0.0, 02-NOV-1990 (NJB)
C
C-&

C$ Index_Entries
C
C     distance between line and ellipsoid
C     distance between line of sight and body
C     nearest point on ellipsoid to line
C
C-&

C$ Revisions
C
C-    SPICELIB Version 1.3.0, 15-NOV-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in VSCL calls.  Changed exponents to DOUBLE PRECISION type
C        in the test for underflow of squared, scaled axis lengths.
C
C-    SPICELIB Version 1.2.0, 25-NOV-1992 (NJB)
C
C        Bug fix:  in the intercept case, PNEAR is now properly
C        re-scaled prior to output.  Formerly, it was returned without
C        having been re-scaled.
C
C        Also, an error in the $Examples section was corrected:  the
C        line
C
C           CALL  VSUB ( LINEPT,  PNEAR,  DIFF )
C
C        was replaced by
C
C           CALL  VSUB ( PNEAR,  LINEPT,  DIFF )
C
C        The in-line comments were re-arranged slightly, and the claim
C        that the inverse orthogonal projection of PRJNPT is guaranteed
C        to exist was removed. (The check for this exception was already
C        being done.)
C
C
C-    SPICELIB Version 1.1.0, 04-DEC-1990 (NJB)
C
C        Error message and description changed for non-positive
C        axis length error.  The former message and description did
C        not match, and the description was incorrect:  it described
C        `zero-length', rather than `non-positive' axes as invalid.
C
C-&

C
C     SPICELIB functions
C
      LOGICAL               FAILED
      LOGICAL               RETURN

C
C     Local variables
C
      DOUBLE PRECISION      CANDPL ( UBPL )
      DOUBLE PRECISION      CAND   ( UBEL )
      DOUBLE PRECISION      OPPDIR (    3 )
      DOUBLE PRECISION      PRJPL  ( UBPL )
      DOUBLE PRECISION      MAG
      DOUBLE PRECISION      NORMAL (    3 )
      DOUBLE PRECISION      PRJEL  ( UBEL )
      DOUBLE PRECISION      PRJPT  (    3 )
      DOUBLE PRECISION      PRJNPT (    3 )
      DOUBLE PRECISION      PT     ( 3, 2 )
      DOUBLE PRECISION      SCALE
      DOUBLE PRECISION      SCLA
      DOUBLE PRECISION      SCLB
      DOUBLE PRECISION      SCLC
      DOUBLE PRECISION      SCLPT  (    3 )
      DOUBLE PRECISION      UDIR   (    3 )

      INTEGER               I

      LOGICAL               FOUND  (    2 )
      LOGICAL               IFOUND
      LOGICAL               XFOUND

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      ELSE
         CALL CHKIN ( 'NPEDLN' )
      END IF

C
C     The algorithm used in this routine has two parts.  The first
C     part handles the case where the input line and ellipsoid
C     intersect.  Our procedure is simple in that case; we just
C     call SURFPT twice, passing it first one ray determined by the
C     input line, then a ray pointing in the opposite direction.
C     The second part of the algorithm handles the case where SURFPT
C     doesn't find an intersection.
C
C     Finding the nearest point on the ellipsoid to the line, when the
C     two do not intersect, is a matter of following four steps:
C
C     1)  Find the points on the ellipsoid where the surface normal
C         is normal to the line's direction.  This set of points is
C         an ellipse centered at the origin.  The point we seek MUST
C         lie on this `candidate' ellipse.
C
C     2)  Project the candidate ellipse onto a plane that is normal
C         to the line's direction.  This projection preserves
C         distance from the line; the nearest point to the line on
C         this new ellipse is the projection of the nearest point to
C         the line on the candidate ellipse, and these two points are
C         exactly the same distance from the line.  If computed using
C         infinite-precision arithmetic, this projection would be
C         guaranteed to be non-degenerate as long as the input
C         ellipsoid were non-degenerate.  This can be verified by
C         taking the inner product of the scaled normal to the candidate
C         ellipse plane and the line's unitized direction vector
C         (these vectors are called NORMAL and UDIR in the code below);
C         the inner product is strictly greater than 1 if the ellipsoid
C         is non-degenerate.
C
C     3)  The nearest point on the line to the projected ellipse will
C         be contained in the plane onto which the projection is done;
C         we find this point and then find the nearest point to it on
C         the projected ellipse.  The distance between these two points
C         is the distance between the line and the ellipsoid.
C
C     4)  Finally, we find the point on the candidate ellipse that was
C         projected to the nearest point to the line on the projected
C         ellipse that was found in step 3.  This is the nearest point
C         on the ellipsoid to the line.
C
C
C
C
C                      Glossary of Geometric Variables
C
C
C            A,
C            B,
C            C           Input ellipsoid's semi-axis lengths.
C
C            POINT       Point of intersection of line and ellipsoid
C                        if the intersection is non-empty.
C
C            CANDPL      Plane containing candidate ellipse.
C
C            NORMAL      Normal vector to the candidate plane CANDPL.
C
C            CAND        Candidate ellipse.
C
C            LINEPT,
C            LINEDR,     Point and direction vector on input line.
C
C            UDIR        Unitized line direction vector.
C
C            PRJPL       Projection plane; the candidate ellipse is
C                        projected onto this plane to yield PRJEL.
C
C            PRJEL       Projection of the candidate ellipse CAND onto
C                        the projection plane PRJEL.
C
C            PRJPT       Projection of line point.
C
C            PRJNPT      Nearest point on projected ellipse to
C                        projection of line point.
C
C            PNEAR       Nearest point on ellipsoid to line.
C
C

C
C     We need a valid normal vector.
C
      CALL UNORM ( LINEDR, UDIR, MAG )

      IF ( MAG .EQ. 0 ) THEN

         CALL SETMSG( 'Line direction vector is the zero vector. ' )
         CALL SIGERR( 'SPICE(ZEROVECTOR)'                          )
         CALL CHKOUT( 'NPEDLN'                                     )
         RETURN

C
C     The ellipsoid's semi-axes must have positive length.
C
      ELSE IF (         ( A .LE. 0.D0 )
     .           .OR.   ( B .LE. 0.D0 )
     .           .OR.   ( C .LE. 0.D0 )   )   THEN

         CALL SETMSG ( 'Semi-axes: A = #,  B = #,  C = #.'  )
         CALL ERRDP  ( '#', A                               )
         CALL ERRDP  ( '#', B                               )
         CALL ERRDP  ( '#', C                               )
         CALL SIGERR ( 'SPICE(INVALIDAXISLENGTH)'           )
         CALL CHKOUT ( 'NPEDLN'                             )
         RETURN

      END IF

C
C     Scale the semi-axes lengths for better numerical behavior.
C     If squaring any one of the scaled lengths causes it to
C     underflow to zero, we have an error.  Otherwise, scale the
C     point on the input line too.
C
      SCALE  =  MAX ( DABS(A), DABS(B), DABS(C) )

      SCLA   =  A / SCALE
      SCLB   =  B / SCALE
      SCLC   =  C / SCALE

      IF (       ( SCLA**2.D0  .EQ.  0.D0 )
     .     .OR.  ( SCLB**2.D0  .EQ.  0.D0 )
     .     .OR.  ( SCLC**2.D0  .EQ.  0.D0 )   )   THEN

         CALL SETMSG ( 'Semi-axis too small:  A = #, B = #, C = #. ' )
         CALL ERRDP  ( '#', A                                        )
         CALL ERRDP  ( '#', B                                        )
         CALL ERRDP  ( '#', C                                        )
         CALL SIGERR ( 'SPICE(DEGENERATECASE)'                       )
         CALL CHKOUT ( 'NPEDLN'                                      )
         RETURN

      END IF

C
C     Scale LINEPT.  Because SCALE might be a very small number,
C     we avoid computing 1/SCALE; that's why we don't call VSCL here.
C
      SCLPT(1)  =  LINEPT(1) / SCALE
      SCLPT(2)  =  LINEPT(2) / SCALE
      SCLPT(3)  =  LINEPT(3) / SCALE

C
C     Hand off the intersection case to SURFPT.  SURFPT determines
C     whether rays intersect a body, so we treat the line as a pair
C     of rays.
C
      CALL VMINUS ( UDIR, OPPDIR )

      CALL SURFPT ( SCLPT, UDIR,   SCLA, SCLB, SCLC, PT(1,1), FOUND(1) )
      CALL SURFPT ( SCLPT, OPPDIR, SCLA, SCLB, SCLC, PT(1,2), FOUND(2) )

      DO I = 1, 2

         IF ( FOUND(I) ) THEN

            DIST  =  0.0D0

            CALL VSCL   ( SCALE,    PT(1,I),  PNEAR )
            CALL CHKOUT ( 'NPEDLN'                  )
            RETURN

         END IF

      END DO

C
C     Getting here means the line doesn't intersect the ellipsoid.
C
C     Find the candidate ellipse CAND.  NORMAL is a normal vector to
C     the plane containing the candidate ellipse.   Mathematically the
C     ellipse must exist, since it's the intersection of an ellipsoid
C     centered at the origin and a plane containing the origin.  Only
C     numerical problems can prevent the intersection from being found.
C
C
      NORMAL(1)  =  UDIR(1) / SCLA**2
      NORMAL(2)  =  UDIR(2) / SCLB**2
      NORMAL(3)  =  UDIR(3) / SCLC**2

      CALL NVC2PL ( NORMAL, 0.D0, CANDPL )

      CALL INEDPL ( SCLA, SCLB, SCLC, CANDPL, CAND, XFOUND )

      IF ( .NOT. XFOUND ) THEN
         CALL SETMSG ( 'Candidate ellipse could not be found.'  )
         CALL SIGERR ( 'SPICE(DEGENERATECASE)'                  )
         CALL CHKOUT ( 'NPEDLN'                                 )
         RETURN
      END IF

C
C     Project the candidate ellipse onto a plane orthogonal to the
C     line.  We'll call the plane PRJPL and the projected ellipse PRJEL.
C
      CALL NVC2PL ( UDIR,  0.D0,   PRJPL )
      CALL PJELPL ( CAND,  PRJPL,  PRJEL )

C
C     Find the point on the line lying in the projection plane, and
C     then find the near point PRJNPT on the projected ellipse.  Here
C     PRJPT is the point on the line lying in the projection plane.
C     The distance between PRJPT and PRJNPT is DIST.
C
C
      CALL VPRJP  ( SCLPT,   PRJPL,  PRJPT         )
      CALL NPELPT ( PRJPT,   PRJEL,  PRJNPT,  DIST )

      IF ( FAILED() ) THEN
         CALL CHKOUT ( 'NPEDLN' )
         RETURN
      END IF

C
C     Find the near point PNEAR on the ellipsoid by taking the inverse
C     orthogonal projection of PRJNPT; this is the point on the
C     candidate ellipse that projects to PRJNPT.  Note that the
C     output DIST was computed in step 3 and needs only to be re-scaled.
C
C     The inverse projection of PNEAR ought to exist, but may not
C     be calculable due to numerical problems (this can only happen
C     when the input ellipsoid is extremely flat or needle-shaped).
C
      CALL VPRJPI ( PRJNPT, PRJPL, CANDPL, PNEAR, IFOUND )

      IF ( .NOT. IFOUND ) THEN
         CALL SETMSG ( 'Inverse projection could not be found.'  )
         CALL SIGERR ( 'SPICE(DEGENERATECASE)'                   )
         CALL CHKOUT ( 'NPEDLN'                                  )
         RETURN
      END IF

C
C     Undo the scaling.
C
      CALL VSCLIP ( SCALE, PNEAR )

      DIST = SCALE * DIST

      CALL CHKOUT ( 'NPEDLN' )
      RETURN
      END


      SUBROUTINE FD4n(X, Y)
      USE global
      IMPLICIT NONE
      REAL*8 :: Y(1,NXP4), X(1,NXP4)
      INTEGER ::  IC
      DO 111 IC = 3,NXP2
         Y(1,IC) = (8*X(1,IC+1) - 8*X(1,IC-1) - X(1,IC+2) &
     &   + X(1,IC-2))/(12*DX)
  111 CONTINUE
      RETURN
      END


*----------------------------------------------------------------------*
      subroutine check_diag(ndim,nvec,mat,eigenvec,eigenval,s_mat)
*----------------------------------------------------------------------*
*     Check if eigenvec are really eigenvectors of mat associated
*     to the eigenvalues eigenval, giving a report
*
*     ndim - dimension of the matrix
*     nvec - number of vectors
*     mat - the ndim x ndim matrix to be diagonalised
*     eigenvec - ndim x nvec matrix with eigenvectors
*     eigenval - nvec vector with eigenvalues
*
*     yuri, oct 2014
*----------------------------------------------------------------------*
      implicit none

      include 'stdunit.h'

      integer, intent(in) ::
     &     ndim, nvec
      real(8), intent(in) ::
     &     mat(ndim,ndim)
      real(8), intent(in) ::
     &     eigenvec(ndim,nvec), eigenval(nvec)
      real(8), intent(in), optional ::
     &     S_mat(ndim,ndim)

      integer ::
     &     i,j,k
      real(8) ::
     &     l_vec(ndim,nvec), m_vec(ndim,nvec), rmsd(nvec)

      do i=1,ndim
       do j=1,nvec
        m_vec(i,j) = 0d0
        do k=1,ndim
         m_vec(i,j) = m_vec(i,j) + mat(i,k)*eigenvec(k,j)
        end do
       end do
      end do

      do i=1,ndim
       rmsd(nvec) = 0d0
       do j=1,nvec
        if (present(S_mat)) then
         l_vec(i,j) = 0.0d0
         do k=1,ndim
          l_vec(i,j) = l_vec(i,j) + S_mat(i,k)*eigenvec(k,j)
         end do
        else
         l_vec(i,j) = eigenvec(i,j)
        end if
        l_vec(i,j) = eigenval(j)*l_vec(i,j)
        rmsd(j) = rmsd(j) + (l_vec(i,j)-m_vec(i,j))**2
       end do
       rmsd(j) = sqrt(rmsd(j)/nvec)
      end do

      write(lulog,*) "====================="
      write(lulog,*) "   check_diag"
      write(lulog,*) "Initial matrix, H:"
      do i=1,ndim
       write(lulog,*) mat(i,:)
      end do
      write(lulog,*) "---"
      if (present(S_mat)) then
       write(lulog,*) "Overlap matrix, S:"
       do i=1,ndim
        write(lulog,*) S_mat(i,:)
       end do
       write(lulog,*) "---"
      end if
      write(lulog,*) "Proposed eigenvalues, E:"
      write(lulog,*) eigenval(:)
      write(lulog,*) "---"
      write(lulog,*) "Proposed eigenvectors, v:"
      do i=1,ndim
       write(lulog,*) eigenvec(i,:)
      end do
      write(lulog,*) "---"
      write(lulog,*) "H x v:"
      do i=1,ndim
       write(lulog,*) m_vec(i,:)
      end do
      write(lulog,*) "---"
      if (present(S_mat)) then
       write(lulog,*) "E x S x v:"
      else
       write(lulog,*) "E x v:"
      end if
      do i=1,ndim
       write(lulog,*) l_vec(i,:)
      end do
      write(lulog,*) "---"
      write(lulog,*) "Root mean square deviations:"
      write(lulog,*) rmsd(:)
      write(lulog,*) "---"
      write(lulog,*) "====================="

      end


      FUNCTION functa  (accer,afact,nacce,ttime)
!********************************************************************
!
!***  accelerogram interpolation
!
!********************************************************************
      IMPLICIT NONE

      INTEGER (kind=4),INTENT(IN) :: nacce
      REAL    (kind=8),INTENT(IN) :: accer(*),afact,ttime
      REAL (kind=8) :: functa

      INTEGER (kind=4) :: n,np1
      REAL    (kind=8) :: t

      IF(ttime <= 0 ) THEN
        functa = 0d0
      ELSE
        t = ttime/afact+1d0
        n   = INT(t)
        IF (n < nacce) THEN
          np1 = n+1
          t   = t - REAL(n,kind=8)
          functa = accer(n)*(1d0-t) + t*accer(np1)
        ELSE
          functa = 0d0
        END IF
      END IF
      RETURN
      END FUNCTION functa


! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

subroutine sub1
  implicit none

  INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(12,307) !< double precision

  INTEGER,  PARAMETER :: nbndsw   = 14 !< number of spectral bands in sw model
  INTEGER,  PARAMETER :: jpb1     = 16 !< first band in sw
  INTEGER,  PARAMETER :: jpb2     = 29 !< last band in sw

  REAL(dp), PARAMETER :: wavenum2(jpb1:jpb2) = (/ &
    3250._dp, 4000._dp, 4650._dp, 5150._dp, 6150._dp, 7700._dp, 8050._dp, &
    12850._dp,16000._dp,22650._dp,29000._dp,38000._dp,50000._dp, 2600._dp/)

  REAL(dp), PARAMETER :: delwave(jpb1:jpb2)  = (/ &
       650._dp,  750._dp,  650._dp,  500._dp, 1000._dp, 1550._dp,  350._dp, &
       4800._dp, 3150._dp, 6650._dp, 6350._dp, 9000._dp,12000._dp, 1780._dp/)

  REAL (dp), PARAMETER     :: nir_vis_boundary   = 14500._dp

  INTEGER :: i
  REAL(dp),parameter :: frc_vis(1:nbndsw) = MAX(0.0_dp, MIN(1.0_dp, &
    (/ ((wavenum2(i+jpb1-1) - nir_vis_boundary) / delwave(i+jpb1-1), i = 1, nbndsw) /) ))

  PRINT *,frc_vis

END

subroutine sub2
  implicit none

  INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(12,307) !< double precision

  INTEGER,  PARAMETER :: nbndsw   = 14 !< number of spectral bands in sw model
  INTEGER,  PARAMETER :: jpb1     = 16 !< first band in sw
  INTEGER,  PARAMETER :: jpb2     = 29 !< last band in sw

  REAL(dp), PARAMETER :: wavenum2(jpb1:jpb2) = (/ &
    3250._dp, 4000._dp, 4650._dp, 5150._dp, 6150._dp, 7700._dp, 8050._dp, &
    12850._dp,16000._dp,22650._dp,29000._dp,38000._dp,50000._dp, 2600._dp/)

  REAL(dp), PARAMETER :: delwave(jpb1:jpb2)  = (/ &
       650._dp,  750._dp,  650._dp,  500._dp, 1000._dp, 1550._dp,  350._dp, &
       4800._dp, 3150._dp, 6650._dp, 6350._dp, 9000._dp,12000._dp, 1780._dp/)

  REAL (dp), PARAMETER     :: nir_vis_boundary   = 14500._dp
  INTEGER :: i

  REAL(dp), PARAMETER :: temp1(1:nbndsw)  = delwave
  REAL(dp), PARAMETER :: temp2(1:nbndsw)  = wavenum2

  REAL(dp), PARAMETER :: frc_vis(1:nbndsw) = MAX(0.0_dp, MIN(1.0_dp, &
    (/ ((temp2(i) - nir_vis_boundary) / temp1(i), i = 1, nbndsw) /) ))
  real(dp),parameter::x=frc_vis(9)

  PRINT *,"frc_vis:",frc_vis

END

call sub1
call sub2
print *, "PASS"
end


    module mod_quaternions
    use mod_vectors
    implicit none (type, external)

    enum, bind(c)
        enumerator :: vector_scalar_layout
        enumerator :: scalar_vector_layout
    end enum

    type quaternion
        real(wp) :: data(4)
    contains
        procedure :: layout => q_layout
        procedure :: vector => q_vector
        procedure :: scalar => q_scalar
        procedure :: unit => q_unit
        procedure :: sum_sq => q_sum_sq
        procedure :: mag => q_mag
        procedure :: axis => q_axis
        procedure :: angle => q_angle
        procedure :: rot => q_rot_matrix
        procedure, pass :: write => q_write
        procedure, pass :: read => q_read
        generic, public :: write(formatted) => write
        generic, public :: read(formatted)  => read
    end type

    type(quaternion), parameter :: q_zero = quaternion([0d0,0d0,0d0,0d0])
    type(quaternion), parameter :: q_eye = quaternion([0d0,0d0,0d0,1d0])

    interface rot
        procedure :: q_rot_matrix, q_axis_angle, q_rot_vector
    end interface

    interface inv
        procedure :: q_inv
    end interface

    interface operator (.o.)
        procedure :: q_mul
    end interface

    interface dot_product
        procedure :: q_dot
    end interface

    interface norm2
        procedure :: q_mag
    end interface

    interface matmul
        procedure :: q_mul_matrix_left !, q_mul_matrix_right
    end interface

    interface assignment (=)
        procedure asgn_quat_from_array, asgn_array_from_quat
    end interface

    interface operator (+)
        procedure :: q_add
    end interface
    interface operator (-)
        procedure :: q_neg, q_sub
    end interface
    interface operator (*)
        procedure :: q_scale_left, q_scale_right
    end interface
    interface operator (/)
        procedure :: q_div
    end interface

    interface show
        procedure :: q_show
    end interface

    contains

    !-- QUATERNIONS
    !
    pure subroutine asgn_quat_from_array(q, a)
    type(quaternion), intent(out) :: q
    real(wp), intent(in) :: a(4)
        q = quaternion( a )
    end subroutine

    pure subroutine asgn_array_from_quat(a, q)
    real(wp), intent(out) :: a(4)
    type(quaternion), intent(in) :: q
        a = q%data
    end subroutine

    pure function q_layout(q) result(u)
    class(quaternion), intent(in) :: q
    integer :: u
        u = vector_scalar_layout
    end function

    pure function q_angle(q) result(u)
    class(quaternion), intent(in) :: q
    real(wp) :: u, c, s
        c = q%data(4)
        s = norm2(q%data(1:3))
        u = 2d0*atan(s/c)
    end function

    pure function q_axis(q) result(k)
    class(quaternion), intent(in) :: q
    real(wp) :: k(3), m, s2
        k = q%data(1:3)
        s2 = q%data(4)**2
        if(s2<1.0_wp-1.0e-9_wp) then
            m = sqrt(1.0_wp - s2)
        else
            m = norm2(k)
        end if
        k = k/m
    end function

    elemental function q_vector(q) result(v)
    class(quaternion), intent(in) :: q
    type(vector) :: v
        v = vector(q%data(1:3))
    end function

    elemental function q_scalar(q) result(s)
    class(quaternion), intent(in) :: q
    real(wp) :: s
        s = q%data(4)
    end function

    pure function q_axis_angle(axis,angle,layout) result(q)
    type(vector), intent(in) :: axis
    real(wp), intent(in) :: angle
    integer, optional, intent(in) :: layout
    type(quaternion) :: q
        if( present(layout) .and. layout == scalar_vector_layout) then
            q%data = [ cos(angle/2), axis%data*sin(angle/2) ]
        else
            q%data = [ axis%data*sin(angle/2), cos(angle/2) ]
        end if
    end function

    pure function q_rot_matrix(q) result(R)
    class(quaternion), intent(in) :: q
    real(wp) :: R(3,3)
    real(wp) :: v(3), s, vx(3,3), vxvx(3,3)
        v = q%data(1:3)
        s = q%data(4)
        vx = a_cross_op(v)
        vxvx = -a_mmoi(v)
        R = eye3 + 2*s*vx + 2*vxvx
    end function

    pure function q_rot_vector(q, t) result(u)
    type(quaternion), intent(in) :: q
    real(wp), intent(in) :: t(3)
    real(wp) :: u(3)
    real(wp) :: v(3), s, vxt(3), vxvxt(3)
        v = q%data(1:3)
        s = q%data(4)
        vxt = v .x. t
        vxvxt = v .x. vxt
        u = t + 2*s*vxt + 2*vxvxt
    end function

    pure function q_inv(q) result(qinv)
    type(quaternion), intent(in) :: q
    real(wp) :: qi(4), qm2
    type(quaternion) :: qinv
        qm2 = q%sum_sq()
        qinv%data = [-q%data(1:3)/qm2,q%data(4)/qm2]
    end function
    !
    pure function q_mul(q_1, q_2) result(q_3)
    type(quaternion), intent(in) :: q_1, q_2
    type(quaternion) :: q_3
    real(wp) :: qop(4,4)
        qop(:,1) = [ q_1%data(4), q_1%data(3),-q_1%data(2),-q_1%data(1)]
        qop(:,2) = [-q_1%data(3), q_1%data(4), q_1%data(1),-q_1%data(2)]
        qop(:,3) = [ q_1%data(2),-q_1%data(1), q_1%data(4),-q_1%data(3)]
        qop(:,4) = [ q_1%data(1), q_1%data(2), q_1%data(3), q_1%data(4)]
        q_3 %data = matmul(qop, q_2%data)
    end function

    pure function q_der(q, omg) result(qp)
    type(quaternion), intent(in) :: q
    type(vector), intent(in) :: omg
    type(quaternion) :: q_w, qp
        q_w%data = [ omg%data/2, 0d0]
        qp = q_mul(q_w, q)
    end function

    pure function q_omg(q,qp) result(omg)
    type(quaternion), intent(in) :: q, qp
    type(vector) :: omg
    real(wp) :: v(3), vp(3), s, sp
        s = q%data(4)
        v = q%data(1:3)
        sp = qp%data(4)
        vp = qp%data(1:3)

        omg%data = 2*(s*vp-sp*v+(v .x. vp))
    end function

    pure function q_step_omg(q,omg,h) result(q_next)
    type(quaternion), intent(in) :: q
    type(vector), intent(in) :: omg
    real(wp), intent(in) :: h
    real(wp) :: u
    type(vector) :: k
    type(quaternion) :: q_w, qp, q_next
    real(wp), parameter :: rot_tol = 1d-4*deg
        u = h*norm2(omg%data)
        if( u>rot_tol) then
            k = (h/u)*omg
            q_w = q_axis_angle(k, u)
            q_next = q_mul(q_w, q)
        else
            qp = q_der(q, omg)
            q_next = q + h*qp
        end if
    end function

    pure function q_step_qp(q,qp,h) result(q_next)
    type(quaternion), intent(in) :: q, qp
    real(wp), intent(in) :: h
    real(wp) :: u, eps
    type(vector) :: k, omg
    type(quaternion) :: q_w, q_next
    real(wp), parameter :: rot_tol = 1d-4*deg
        eps = q%sum_sq()-1d0
        if( eps>rot_tol ) then
            omg = q_omg(q, qp)
            u = norm2(omg%data)
            k = omg/u
            q_w = q_axis_angle(k, u)
            q_next = q_mul(q_w, q)
        else
            q_next = q + h*qp
        end if
    end function

    elemental function q_dot(q_1,q_2) result(m)
    type(quaternion), intent(in) :: q_1, q_2
    real(wp) :: m
        m = dot_product(q_1%data, q_2%data)
    end function
    elemental function q_sum_sq(q) result(m2)
    class(quaternion), intent(in) :: q
    real(wp) :: m2
        m2 = q%data(1)**2 + q%data(2)**2 + q%data(3)**2 + q%data(4)**2
    end function
    elemental function q_mag(q) result(m)
    class(quaternion), intent(in) :: q
    real(wp) :: m
        m = sqrt(q_sum_sq(q))
    end function
    elemental function q_unit(q) result(q_u)
    class(quaternion), intent(in) :: q
    type(quaternion) :: q_u
    real(wp) :: m2
        m2 = q_sum_sq(q)
        if( m2 >= 1.0e-11_wp ) then
            q_u = q/sqrt(m2)
        else
            q_u = q
        end if
    end function
    elemental function q_add(q_1,q_2) result(q_3)
    type(quaternion), intent(in) :: q_1, q_2
    type(quaternion) :: q_3
        q_3 = quaternion( q_1%data + q_2%data )
    end function
    elemental function q_sub(q_1,q_2) result(q_3)
    type(quaternion), intent(in) :: q_1, q_2
    type(quaternion) :: q_3
        q_3 = quaternion( q_1%data - q_2%data )
    end function
    elemental function q_neg(q_1) result(q_3)
    type(quaternion), intent(in) :: q_1
    type(quaternion) :: q_3
        q_3 = quaternion( -q_1%data )
    end function
    elemental function q_scale_left(f, q_1) result(q_3)
    real(wp), intent(in) :: f
    type(quaternion), intent(in) :: q_1
    type(quaternion) :: q_3
        q_3 = quaternion( f*q_1%data )
    end function
    elemental function q_scale_right(q_1, f) result(q_3)
    type(quaternion), intent(in) :: q_1
    real(wp), intent(in) :: f
    type(quaternion) :: q_3
        q_3 = quaternion( q_1%data*f )
    end function
    elemental function q_div(q_1, f) result(q_3)
    type(quaternion), intent(in) :: q_1
    real(wp), intent(in) :: f
    type(quaternion) :: q_3
        q_3 = quaternion( q_1%data/f )
    end function

    pure function q_mul_matrix_left(A, v) result(w)
    real(wp), intent(in) :: A(4,4)
    type(quaternion), intent(in) :: v
    type(quaternion) :: w
        w = quaternion( matmul(A, v%data ) )
    end function

    subroutine q_write (q, unit, iotype, v_list, iostat, iomsg)
    class(quaternion), intent(in) :: q
    integer, intent(in) :: unit
    character(*), intent(in) :: iotype
    integer, intent(in)  :: v_list(:)
    integer, intent(out) :: iostat
    character(*), intent(inout) :: iomsg
    character(len=:), allocatable :: fmt
        if( iotype == 'LISTDIRECTED' ) then
            write (unit, *, iostat=iostat) q%data
        else
            fmt = '(a,' // iotype(3:) // ',a,' // iotype(3:) // ',a,' // iotype(3:) // ',a,' // iotype(3:) // ',a)'
            write (unit, fmt, iostat=iostat) "<",q%data(1),", ",q%data(2),", ",q%data(3),": ",q%data(4),">"
        end if
    end subroutine

    subroutine q_read (q, unit, iotype, v_list, iostat, iomsg)
    class(quaternion), intent(inout) :: q
    integer, intent(in) :: unit
    character(*), intent(in) :: iotype
    integer, intent(in)  :: v_list(:)
    integer, intent(out) :: iostat
    character(*), intent(inout) :: iomsg
    character(len=:), allocatable :: fmt
        read (unit, *, iostat=iostat) q%data
    end subroutine

    subroutine q_show(label,q,fmt)
    character(len=*), intent(in) :: label
    type(quaternion), intent(in) :: q
    character(len=*), optional, intent(in) :: fmt
        if(present(fmt)) then
            print '(a,DT "' // fmt // '")', label, q
        else
            print '(a,DT "g0")', label, q
        end if
    end subroutine

    end module


************************************************************************
*
*     Function PTILE                                    Called by: PCTL
*
*     calculate the requested percentile from a sorted vector
*     (Beyer, 1987 p. 518.)
*
*     local variables
*     ---------------
*     NP       index corresponding to the desired percentile
*     WGHT     weight factor used to interpolate between the two
*              closest values when the vector index of the desired
*              percentile is not an integer
*
************************************************************************
      DOUBLE PRECISION FUNCTION PTILE(X2,NUM,PCTILE)
*
*     subroutine arguments
*
      INTEGER*4 NUM
      DOUBLE PRECISION PCTILE,X2(*)
*
*     local vars
*
      INTEGER*4 I
      DOUBLE PRECISION NP,WGHT
*
*     For data sorted in ascending order, the Jth percentile is
*     defined as the ((N+1)J/100)th value.  When this quantity is not
*     an integer, the Jth percentile is interpolated from the two
*     closest values.  The weighting factor for interpolation, WGHT,
*     is equal to the noninteger fractional portion of NP. IF statement
*     is required to prevent interpolation past the end of the data set
*     (e.g. the 99 percentile of some small data sets may
*
      NP = DBLE(NUM+1)*PCTILE
      I = INT(NP)
      WGHT = NP-INT(NP)

      IF (I+1 .LE. NUM) THEN
         PTILE = (1.0D0-WGHT)*X2(I)+WGHT*X2(I+1)
      ELSE
         PTILE = X2(I)
      ENDIF

      RETURN
      END