PROGRAM CEI_EXAMPLE
! Gael de Oliveira, Ricardo Pereira, Feb. 2015
! We follow implicit type rules REAL(A-H,O-Z), INTEGER(I-N)

! Start by including the data (file generated from matlab
! with custom script)
     INCLUDE 'CEI_DATA.f90'
! Typical variable declarations found in the include (together with data)
!    INTEGER N_HK, N_RT, N_TPPT
!    REAL, DIMENSION(1,11) :: HK_RANGE
!    REAL, DIMENSION(1,11) :: RT_RANGE
!    REAL, DIMENSION(1,11) :: TPPT_RANGE
!    REAL, DIMENSION(11,11,11) :: CEI_TABLE

! Define CEI evaluation point
      HK   = 8.0
      RT   = 1000.0
      TPPT = 0.5

! Set Search Variables to allow for easy fudging without compromising data integrity
! (Xfoil's Fortran programming style does not specify intent!)
! This does not allow warning but is probaly more efficient than if constructs, and
! much more compact to write! Assumes range vectors are growing monotonically!
      HK_S   = MAX(HK     , HK_RANGE(1,1)       )
      HK_S   = MIN(HK_S   , HK_RANGE(1,N_HK)    )

      RT_S   = MAX(RT     , RT_RANGE(1,1)       )
      RT_S   = MIN(RT_S   , RT_RANGE(1,N_RT)    )

      TPPT_S = MAX(TPPT   , TPPT_RANGE(1,1)     )
      TPPT_S = MIN(TPPT_S , TPPT_RANGE(1,N_TPPT))

      WRITE(*,*) 'REQUESTED POINT:'
      WRITE(*,1100) HK  , RT  , TPPT
      WRITE(*,*) 'SEARCHED POINT:'
      WRITE(*,1100) HK_S, RT_S, TPPT_S
      WRITE(*,*) 'START SEARCH:'
! SEARCH ALGORITHM
! Look for upper nearest neighbour of desired CEI point in (HK,RT,TPPT) space
! This code is a bit a hard to understand (deep nesting) but fairly efficient for a
! simple algorithm (in terms of theorethical computational complexity, might still
! pose efficiency issues on architectures with inneficient execution control, but
! I seem to remember that x64 is fairly good at that!)
      DO 100 I_HK=2,N_HK
        ! Check if we are in proper HK interval
        IF (HK_S .LE. HK_RANGE(1,I_HK)) THEN
          ! Loop through RT only if that is the case (and not otherwise)
          DO 200 I_RT=2,N_RT
            ! Check if we are in proper RT interval
            IF (RT_S .LE. RT_RANGE(1,I_RT)) THEN
              ! Loop through TPPT only if that is the case (and not otherwise)
              DO 300 I_TPPT=2,N_TPPT
                ! Check if we are in proper TPPT interval
                IF (TPPT_S .LE.  TPPT_RANGE(1,I_TPPT)) THEN
                  ! Write some output
                  WRITE(*,1000) I_HK, I_RT, I_TPPT
                  WRITE(*,1100) HK_RANGE(1,I_HK) , RT_RANGE(1,I_RT), TPPT_RANGE(1,I_TPPT)
                  ! Store lower bound (_0 subscript at I-1 index)
                  HK_0   = HK_RANGE(1,I_HK-1)
                  RT_0   = RT_RANGE(1,I_RT-1)
                  TPPT_0 = TPPT_RANGE(1,I_RT-1)
                  ! Store upper bound (_1 subscript at I   index)

                  ! And leave loop
                  GOTO 500
                ENDIF
 300          CONTINUE
            ENDIF
 200      CONTINUE
        ENDIF
 100  CONTINUE

 500  WRITE(*,*) 'FOUND UPPER NEIGHBOUR!!!'

      WRITE(*,1000) I_HK, I_RT, I_TPPT
      WRITE(*,1100) HK_RANGE(1,I_HK) , RT_RANGE(1,I_RT), TPPT_RANGE(1,I_TPPT)

 1000 FORMAT('I_HK=', I12  , '   I_RT=', I12  , '   I_TPPT=', I12)
 1100 FORMAT('  HK=', F12.4, '     RT=', F12.1, '     TPPT=', F12.4)

END PROGRAM


MODULE ran001
!
!  Purpose:
!    To declare data shared between subs random0 and seed.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    11/22/06    S. J. Chapman        Original code
!
IMPLICIT NONE
SAVE
INTEGER :: n = 9876
END MODULE ran001

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

SUBROUTINE random0 ( ran )
!
!  Purpose:
!    Subroutine to generate a pseudorandom number with a uniform
!    distribution in the range 0. <= ran < 1.0.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    11/22/06    S. J. Chapman        Original code
!
USE ran001                     ! Shared seed
IMPLICIT NONE

! Data dictionary: declare calling parameter types & definitions
REAL, INTENT(OUT) :: ran       ! Random number

! Calculate next number
n = MOD (8121 * n + 28411, 134456 )

! Generate random value from this number
ran = REAL(n) / 134456.

END SUBROUTINE random0

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

SUBROUTINE seed ( iseed )
!
!  Purpose:
!    To set the seed for random number generator random0.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    11/22/06    S. J. Chapman        Original code
!
USE ran001                     ! Shared seed
IMPLICIT NONE

! Data dictionary: declare calling parameter types & definitions
INTEGER, INTENT(IN) :: iseed   ! Value to initialize sequence

! Set seed
n = ABS ( iseed )

END SUBROUTINE seed


	FUNCTION PR_HGKM  ( value )
C************************************************************************
C* PR_HGKM								*
C*									*
C* This function multiplies a value by a thousand.  It can be used to	*
C* compute meters from kilometers.					*
C*									*
C* REAL PR_HGKM  ( VALUE )						*
C*									*
C* Input parameters:							*
C*	VALUE		REAL	 	Value				*
C*									*
C* Output parameters:							*
C*	PR_HGKM		REAL		Value * 1000			*
C**									*
C* Log:									*
C* I. Graffman/RDS	11/84	Original source				*
C* I. Graffman/RDS	12/87	GEMPAK4					*
C* G. Huffman/GSC	7/88	Documentation				*
C* S. Schotz/GSC	10/89   Documentation				*
C************************************************************************
        INCLUDE    'GEMPRM.PRM'
        INCLUDE    'ERMISS.FNC'
C------------------------------------------------------------------------
C*	Check for missing values.
C*
	IF  ( ERMISS ( value ) )  THEN
	    PR_HGKM = RMISSD
	  ELSE
	    PR_HGKM = value * 1000.
	END IF
C*
	RETURN
	END


! -*- f95 -*-

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

! --------------------------------------------------------------------
! SUBROUTINE  autocorr_1d
!     Compute the autocorrelation of a signal with the specified lag
!
!     Input
!     n            : integer(long)
!     x(n)         : real(double), array to compute autocorrelation for
!     lag          : integer(long), lag for the autocorrelation, in samples
!     normalize    : integer(int), normalize the autocorrelation
!
!     Output
!     ac(n, p) : real(8)
! --------------------------------------------------------------------
subroutine autocorr_1d(n, x, lag, normalize, ac) bind(C, name="autocorr_1d")
    use, intrinsic :: iso_c_binding
    use utility, only : mean_sd_1d
    implicit none
    integer(c_long), intent(in) :: n, lag
    real(c_double), intent(in) :: x(n)
    integer(c_int), intent(in) :: normalize
    real(c_double), intent(out) :: ac
    ! local
    integer(c_long) :: i
    real(c_double) :: mean1, mean2, std1, std2

    ac = 0._c_double

    if (normalize == 1_c_int) then
        call mean_sd_1d(n - lag, x(:n - lag), mean1, std1)
        call mean_sd_1d(n - lag, x(lag + 1:), mean2, std2)

        do i=1_c_long, n - lag
            ac = ac + (x(i) - mean1) * (x(i + lag) - mean2)
        end do
        ac = ac / ((n - lag - 1) * std1 * std2)
    else
        call mean_sd_1d(n - lag, x(:n - lag), mean1, std1)
        call mean_sd_1d(n - lag, x(lag + 1:), mean2, std2)

        do i=1_c_long, n - lag
            ac = ac + x(i) * x(i + lag)
        end do
        ac = ac / (std1 * std2)
    end if
end subroutine

! --------------------------------------------------------------------
! SUBROUTINE  cid_1d
!     Compute the complexity invariant distance metric for a signal
!
!     Input
!     n            : integer(long)
!     x(n)         : real(double), array to compute over
!     normalize    : integer(int), normalize the complexity invariant distance
!
!     Output
!     cid : real(double)
! --------------------------------------------------------------------
subroutine cid_1d(n, x, normalize, cid) bind(C, name='cid_1d')
    use, intrinsic :: iso_c_binding
    use utility, only : mean_sd_1d
    implicit none
    integer(c_long), intent(in) :: n
    real(c_double), intent(in) :: x(n)
    integer(c_int), intent(in) :: normalize
    real(c_double), intent(out) :: cid
    ! local
    integer(c_long) :: i
    real(c_double) :: mean, sd

    cid = 0._c_double;

    do i=1, n - 1
        cid = cid + (x(i + 1) - x(i))**2
    end do
    if (normalize == 1) then
        call mean_sd_1d(n, x, mean, sd)
        cid = cid / sd**2
    end if
    cid = sqrt(cid)
end subroutine

! --------------------------------------------------------------------
! SUBROUTINE  permutation_entropy_1d
!     Compute the permutation entropy of a 1d array
!
!     In
!     n           : integer(long)
!     x(n)        : real(double), array of values of length n
!     order       : integer(long), order (number of values) of each embedding vector
!     delay       : integer(long), number of samples to skip when extracting each embedding vector
!     normalize   : integer(int), normalize the permutation entropy
!
!     Out
!     pe  : real(double), computed permutation entropy
! --------------------------------------------------------------------
subroutine permutation_entropy_1d(n, x, order, delay, normalize, pe) bind(C, name="permutation_entropy_1d")
    use, intrinsic :: iso_c_binding
    use utility, only : embed_sort, unique
    implicit none
    integer(c_long), intent(in) :: n, order, delay
    real(c_double), intent(in) :: x(n)
    integer(c_int), intent(in) :: normalize
    real(c_double), intent(out) :: pe
    ! local
    integer(c_long) :: i, nsi, n_unq
    integer(c_long) :: sorted_idx(n - (order - 1) * delay, order)
    real(c_double) :: hashval(n - (order - 1) * delay)
    real(c_double) :: unq_vals(n - (order - 1) * delay)
    real(c_double) :: unq_counts(n - (order - 1) * delay)
    real(c_double), parameter :: log2 = dlog(2._c_double)

    nsi = n - (order - 1) * delay

    call embed_sort(n, nsi, x, order, delay, sorted_idx)

    hashval = 0._c_double
    do i=1, order
        hashval = hashval + order**(i-1) * sorted_idx(:, i)
    end do

    unq_counts = 0._c_double
    call unique(nsi, hashval, unq_vals, unq_counts, n_unq)

    unq_counts = unq_counts / sum(unq_counts)

    pe = -sum(unq_counts(:n_unq) * dlog(unq_counts(:n_unq)) / log2)

    if (normalize == 1) then
        pe = pe / (dlog(product((/(real(i, 8), i=1, order)/))) / log2)
    end if
end subroutine

! --------------------------------------------------------------------
! SUBROUTINE  sample_entropy_1d
!     Compute the sample entropy of a signal
!
!     Input
!     n      : integer(long)
!     x(n)   : real(double), array to compute sample entropy on
!     L      : integer(long), length of sets to compare
!     r      : real(double), maximum set distance
!
!     Output
!     samp_ent : real(double), sample entropy
! --------------------------------------------------------------------
subroutine sample_entropy_1d(n, x, L, r, samp_ent) bind(C, name="sample_entropy_1d")
    use, intrinsic :: iso_c_binding
    use, intrinsic :: iso_fortran_env, only: stdout=>output_unit
    implicit none
    integer(c_long), intent(in) :: n, L
    real(c_double), intent(in) :: x(n), r
    real(c_double), intent(out) :: samp_ent
    ! local
    real(c_double) :: x1, A, B
    integer(c_long) :: i, ii, i2, run(n)

    A = 0._c_double
    B = 0._c_double
    run = 0_c_long
    do i = 1, n - 1
        x1 = x(i)
        do ii = 1, n - i
            i2 = ii + i
            if (abs(x(i2) - x1) < r) then
                run(ii) = run(ii) + 1

                if (run(ii) >= L) then
                    A = A + 1._c_double
                end if
                if (run(ii) >= (L - 1)) then
                    if (i2 < n) then
                        B = B + 1._c_double
                    end if
                end if
            else
                run(ii) = 0_c_long
            end if
        end do
    end do

    if (L == 1) then
        samp_ent = -log(A / (n * (n - 1) / 2._c_double))
    else
        samp_ent = -log(A / B)
    end if
end subroutine

! --------------------------------------------------------------------
! SUBROUTINE  signal_entropy_1d
!     Compute the signal entropy of a 1d signal
!
!     Input
!     n      : integer(long)
!     x(n)   : real(double), array to compute signal entropy for
!
!     Output
!     ent : real(double)
! --------------------------------------------------------------------
subroutine signal_entropy_1d(n, x, ent) bind(C, name="signal_entropy_1d")
    use, intrinsic :: iso_c_binding
    use utility, only : histogram, mean_sd_1d
    implicit none
    integer(c_long), intent(in) :: n
    real(c_double), intent(out) :: x(n)
    real(c_double), intent(out) :: ent
    ! local
    real(c_double) :: d(3), nbias, cnt
    real(c_double) :: estimate, stdev, mean, logf
    integer(c_long) :: i, sqrt_n
    integer(c_long) :: h(ceiling(sqrt(real(n))))

    sqrt_n = ceiling(sqrt(real(n, c_double)))

    call mean_sd_1d(n, x, mean, stdev)

    if (stdev == 0._c_double) then
        stdev = 1._c_double  ! ensure no 0 division
    end if

    call histogram(n, sqrt_n, x, d, h)
    d(1:2) = d(1:2) / stdev

    if (d(1) == d(2)) then
        ent = 0._c_double
        return
    end if

    cnt = 0._c_double
    estimate = 0._c_double

    do i = 1, int(d(3), c_long)
        if (h(i) > 0) then
            logf = log(real(h(i), c_double))
        else
            logf = 0._c_double
        end if

        cnt = cnt + h(i)
        estimate = estimate - h(i) * logf
    end do

    nbias = -(d(3) - 1._c_double) / (2._c_double * cnt)
    estimate = estimate / cnt + log(cnt) + log((d(2) - d(1)) / d(3)) - nbias

    ent = exp(estimate**2) - 2._c_double
end subroutine

! --------------------------------------------------------------------
! SUBROUTINE  dominant_freq_1d
!     Compute the dominant frequency of a signal, in the specified range
!
!     Input
!     n        : integer(long)
!     x(n)     : real(double), array to compute signal entropy for
!     nfft     : integer(long), number of points to use in the FFT computation
!     fs       : real(double), sampling frequency in Hz
!     low_cut  : real(double), low frequency cutoff for the range to use
!     hi_cut   : real(double), high frequency cutoff for the range to use
!
!     Output
!     df : real(double)
! --------------------------------------------------------------------
subroutine dominant_freq_1d(n, x, fs, nfft, low_cut, hi_cut, df) bind(C, name="dominant_freq_1d")
    use, intrinsic :: iso_c_binding
    use real_fft, only : execute_real_forward
    implicit none
    integer(c_long) :: n, nfft
    real(c_double), intent(in) :: x(n), low_cut, hi_cut, fs
    real(c_double), intent(out) :: df
    ! local
    real(c_double), parameter :: log2 = log(2._c_double)
    integer(c_long) :: ihcut, ilcut, imax, ier
    real(c_double) :: sp_norm(nfft + 1)
    real(c_double) :: sp_hat(2 * nfft + 2), y(2 * nfft)

    ! find the cutoff indices for the high and low cutoffs
    ihcut = min(floor(hi_cut / (fs / 2) * (nfft - 1) + 1, c_long), nfft + 1)
    ilcut = max(ceiling(low_cut / (fs / 2) * (nfft - 1) + 1, c_long), 1_c_long)

    if (ihcut > nfft) then
        ihcut = nfft
    end if

    y = 0._c_double
    y(:n) = x
    sp_hat = 0._c_double
    call execute_real_forward(2 * nfft, y, 1.0_c_double, sp_hat, ier)

    sp_norm = sp_hat(1:2 * nfft + 2:2)**2 + sp_hat(2:2 * nfft + 2:2)**2
    sp_norm = sp_norm / sum(sp_norm(ilcut:ihcut)) + 1.d-10

    ! find the maximum index
    imax = maxloc(sp_norm(ilcut:ihcut), dim=1) + ilcut - 1

    df = fs * (imax - 1._c_double) / nfft / 2._c_double

end subroutine

! --------------------------------------------------------------------
! SUBROUTINE  dominant_freq_value_1d
!     Compute the dominant frequency value (spectral power) of a signal, in the specified range
!
!     Input
!     n        : integer(long)
!     x(n)     : real(double), array to compute signal entropy for
!     nfft     : integer(long), number of points to use in the FFT computation
!     fs       : real(double), sampling frequency in Hz
!     low_cut  : real(double), low frequency cutoff for the range to use
!     hi_cut   : real(double), high frequency cutoff for the range to use
!
!     Output
!     dfval : real(double)
! --------------------------------------------------------------------
subroutine dominant_freq_value_1d(n, x, fs, nfft, low_cut, hi_cut, dfval) bind(C, name="dominant_freq_value_1d")
    use, intrinsic :: iso_c_binding
    use real_fft, only : execute_real_forward
    implicit none
    integer(c_long) :: n, nfft
    real(c_double), intent(in) :: x(n), low_cut, hi_cut, fs
    real(c_double), intent(out) :: dfval
    ! local
    real(c_double), parameter :: log2 = log(2._c_double)
    integer(c_long) :: ihcut, ilcut, ier
    real(c_double) :: sp_norm(nfft + 1)
    real(c_double) :: sp_hat(2 * nfft + 2), y(2 * nfft)

    ! find the cutoff indices for the high and low cutoffs
    ihcut = min(floor(hi_cut / (fs / 2) * (nfft - 1) + 1, c_long), nfft + 1)
    ilcut = max(ceiling(low_cut / (fs / 2) * (nfft - 1) + 1, c_long), 1_c_long)

    if (ihcut > nfft) then
        ihcut = nfft
    end if

    y = 0._c_double
    y(:n) = x
    sp_hat = 0._c_double
    call execute_real_forward(2 * nfft, y, 1.0_c_double, sp_hat, ier)

    sp_norm = sp_hat(1:2 * nfft + 2:2)**2 + sp_hat(2:2 * nfft + 2:2)**2
    sp_norm = sp_norm / sum(sp_norm(ilcut:ihcut)) + 1.d-10
    ! find the maximum value
    dfval = maxval(sp_norm(ilcut:ihcut))
end subroutine

! --------------------------------------------------------------------
! SUBROUTINE  power_spectral_sum_1d
!     Compute the sum of the spectral power in a 1hz range (+- 0.5hz) around the
!     dominant frequency
!
!     Input
!     n        : integer(long)
!     x(n)     : real(double), array to compute signal entropy for
!     nfft     : integer(long), number of points to use in the FFT computation
!     fs       : real(double), sampling frequency in Hz
!     low_cut  : real(double), low frequency cutoff for the range to use
!     hi_cut   : real(double), high frequency cutoff for the range to use
!
!     Output
!     pss : real(double)
! --------------------------------------------------------------------
subroutine power_spectral_sum_1d(n, x, fs, nfft, low_cut, hi_cut, pss) bind(C, name="power_spectral_sum_1d")
    use, intrinsic :: iso_c_binding
    use real_fft, only : execute_real_forward
    implicit none
    integer(c_long), intent(in) :: n, nfft
    real(c_double), intent(in) :: x(n), fs, low_cut, hi_cut
    real(c_double), intent(out) :: pss
    ! local
    real(c_double), parameter :: log2 = log(2._c_double)
    integer(c_long) :: i, ihcut, ilcut, ier, imax
    real(c_double) :: sp_norm(nfft + 1)
    real(c_double) :: sp_hat(2 * nfft + 2), y(2 * nfft)

    ! find the cutoff indices for the high and low cutoffs
    ihcut = min(floor(hi_cut / (fs / 2) * (nfft - 1) + 1, c_long), nfft + 1)
    ilcut = max(ceiling(low_cut / (fs / 2) * (nfft - 1) + 1, c_long), 1_c_long)

    if (ihcut > nfft) then
        ihcut = nfft
    end if

    pss = 0._c_double  ! ensure starts at 0

    y = 0._c_double
    y(:n) = x
    sp_hat = 0._c_double
    call execute_real_forward(2 * nfft, y, 1.0_c_double, sp_hat, ier)

    sp_norm = sp_hat(1:2*nfft+2:2)**2 + sp_hat(2:2*nfft+2:2)**2
    sp_norm = sp_norm / sum(sp_norm(ilcut:ihcut)) + 1.d-10

    ! find the maximum index.  minus 2 to account for adding min 1 (ilcut) and then shifting to 0
    ! at the first index
    imax = maxloc(sp_norm(ilcut:ihcut), dim=1) + ilcut - 1

    ! adjust ilcut and ihcut so they correspond to fmax +- 0.5Hz
    ilcut = max(imax - ceiling(0.5 * real(nfft, c_double) / fs * 2._c_double), 1_c_long)
    ihcut = min(imax + floor(0.5 * real(nfft, c_double) / fs * 2._c_double), nfft)

    do i=ilcut, ihcut
        pss = pss + sp_norm(i)
    end do
end subroutine

! --------------------------------------------------------------------
! SUBROUTINE  spectral_entropy_1d
!     Compute the spectral entropy of the specified frequency range
!
!     Input
!     n        : integer(long)
!     x(n)     : real(double), array to compute signal entropy for
!     nfft     : integer(long), number of points to use in the FFT computation
!     fs       : real(double), sampling frequency in Hz
!     low_cut  : real(double), low frequency cutoff for the range to use
!     hi_cut   : real(double), high frequency cutoff for the range to use
!
!     Output
!     sEnt : real(double)
! --------------------------------------------------------------------
subroutine spectral_entropy_1d(n, x, fs, nfft, low_cut, hi_cut, sEnt) bind(C, name="spectral_entropy_1d")
    use, intrinsic :: iso_c_binding
    use real_fft, only : execute_real_forward
    implicit none
    integer(c_long), intent(in) :: n, nfft
    real(c_double), intent(in) :: x(n), low_cut, hi_cut, fs
    real(c_double), intent(out) :: sEnt
    ! local
    real(c_double), parameter :: log2 = log(2._c_double)
    integer(c_long) :: i, ihcut, ilcut, ier
    real(c_double) :: sp_norm(nfft + 1), sp_hat(2 * nfft + 2), log2_idx_cut
    real(c_double) :: y(2 * nfft)

    ! find the cutoff indices for the high and low cutoffs
    ihcut = min(floor(hi_cut / (fs / 2) * (nfft - 1) + 1, c_long), nfft + 1)
    ilcut = max(ceiling(low_cut / (fs / 2) * (nfft - 1) + 1, c_long), 1_c_long)

    if (ihcut > nfft) then
        ihcut = nfft
    end if
    log2_idx_cut = log(real(ihcut - ilcut + 1, c_double)) / log2

    sEnt = 0._c_double
    y = 0._c_double
    y(:n) = x
    sp_hat = 0._c_double
    call execute_real_forward(2 * nfft, y, 1.0_c_double, sp_hat, ier)

    sp_norm = sp_hat(1:2*nfft+2:2)**2 + sp_hat(2:2*nfft+2:2)**2
    sp_norm = sp_norm / sum(sp_norm(ilcut:ihcut)) + 1.d-10

    do i=ilcut, ihcut
        sEnt = sEnt - log(sp_norm(i)) / log2 * sp_norm(i)
    end do
    sEnt = sEnt / log2_idx_cut
end subroutine

! --------------------------------------------------------------------
! SUBROUTINE  spectral_flatness_1d
!     Compute the spectral flatness of the specified frequency range
!
!     Input
!     n        : integer(long)
!     x(n)     : real(double), array to compute signal entropy for
!     nfft     : integer(long), number of points to use in the FFT computation
!     fs       : real(double), sampling frequency in Hz
!     low_cut  : real(double), low frequency cutoff for the range to use
!     hi_cut   : real(double), high frequency cutoff for the range to use
!
!     Output
!     df : real(double)
! --------------------------------------------------------------------
subroutine spectral_flatness_1d(n, x, fs, nfft, low_cut, hi_cut, sFlat) bind(C, name="spectral_flatness_1d")
    use, intrinsic :: iso_c_binding
    use real_fft, only : execute_real_forward
    use utility, only : gmean
    implicit none
    integer(c_long), intent(in) :: n, nfft
    real(c_double), intent(in) :: x(n), low_cut, hi_cut, fs
    real(c_double), intent(out) :: sFlat
    ! local
    real(c_double), parameter :: log2 = log(2._c_double)
    integer(c_long) :: ihcut, ilcut, ier
    real(c_double) :: sp_norm(nfft+1)
    real(c_double) :: sp_hat(2 * nfft+2), y(2*nfft), mean

    ! find the cutoff indices for the high and low cutoffs
    ihcut = min(floor(hi_cut / (fs / 2._c_double) * (nfft - 1) + 1, c_long), nfft + 1)
    ilcut = max(ceiling(low_cut / (fs / 2._c_double) * (nfft - 1) + 1, c_long), 1_c_long)

    if (ihcut > nfft) then
        ihcut = nfft
    end if

    y = 0._c_double
    y(:n) = x
    sp_hat = 0._c_double
    call execute_real_forward(2 * nfft, y, 1._c_double, sp_hat, ier)

    sp_norm = sp_hat(1:2*nfft+2:2)**2 + sp_hat(2:2*nfft+2:2)**2
    sp_norm = sp_norm / sum(sp_norm(ilcut:ihcut)) + 1.d-10

    mean = sum(sp_norm(ilcut:ihcut)) / (ihcut - ilcut + 1)
    call gmean(ihcut - ilcut + 1, sp_norm(ilcut:ihcut), sFlat)
    sFlat = 10._c_double * log(sFlat / mean) / log(10._c_double)
end subroutine

! --------------------------------------------------------------------
! SUBROUTINE  jerk_1d
!     Compute the jerk metric for a 1d signal
!
!     Input
!     n      : integer(long)
!     x(n)   : real(double), array to compute for
!     fs     : real(double), sampling frequency, in Hz
!
!     Output
!     jerk : real(double)
! --------------------------------------------------------------------
subroutine jerk_1d(n, x, fs, jerk) bind(C, name="jerk_1d")
    use, intrinsic :: iso_c_binding
    implicit none
    integer(c_long), intent(in) :: n
    real(c_double), intent(in) :: x(n), fs
    real(c_double), intent(out) :: jerk
    ! local
    integer(c_long) :: i
    real(c_double) :: amp, jsum, xold

    jsum = 0._c_double
    xold = x(1)
    amp = abs(xold)
    do i=2, n
        jsum = jsum + (x(i) - xold)**2
        if (abs(x(i)) > amp) then
            amp = abs(x(i))
        end if
        xold = x(i)
    end do
    jerk = jsum / (720._c_double * amp**2) * fs
end subroutine

! --------------------------------------------------------------------
! SUBROUTINE  dimensionless_jerk_1d
!     Compute the jerk metric, but dimensionless, for a signal
!
!     Input
!     n      : integer(long), axis dimension
!     x(n)   : real(double), array to compute for
!     stype  : integer(long), type of signal input. 1=velocity, 2=acceleration, 3=jerk
!
!     Output
!     djerk : real(double)
! --------------------------------------------------------------------
subroutine dimensionless_jerk_1d(n, x, stype, djerk) bind(C, name="dimensionless_jerk_1d")
    use, intrinsic :: iso_c_binding
    implicit none
    integer(c_long), intent(in) :: n, stype
    real(c_double), intent(in) :: x(n)
    real(c_double), intent(out) :: djerk
    ! local
    integer(c_long) :: i
    real(c_double) :: amp, jsum

    jsum = 0._c_double
    amp = abs(x(1))

    if (stype == 1) then
        do i=2, n-1
            jsum = jsum + (x(i-1) - 2._c_double * x(i) + x(i+1))**2
            if (abs(x(i)) > amp) then
                amp = abs(x(i))
            end if
        end do
        if (abs(x(n)) > amp) then
            amp = abs(x(n))
        end if
        djerk = -(n**3 * jsum) / amp**2
    else if (stype == 2) then
        do i=2, n
            jsum = jsum + (x(i) - x(i-1))**2
            if (abs(x(i)) > amp) then
                amp = abs(x(i))
            end if
        end do
        djerk = -(n * jsum) / amp**2
    else if (stype == 3) then
        do i=1, n
            jsum = jsum + x(i)**2
            if (abs(x(i)) > amp) then
                amp = abs(x(i))
            end if
        end do
        djerk = -jsum / (n * amp**2)
    end if
end subroutine

! --------------------------------------------------------------------
! SUBROUTINE  range_count_1d
!     Compute the percentage of samples that lie within the specified range
!
!     Input
!     n      : integer(long)
!     x(n)   : real(double), array to compute for
!     xmin   : real(double), range min value
!     xmax   : real(double), range max value
!
!     Output
!     rcp : real(double)
! --------------------------------------------------------------------
subroutine range_count_1d(n, x, xmin, xmax, rcp) bind(C, name="range_count_1d")
    use, intrinsic :: iso_c_binding
    implicit none
    integer(c_long), intent(in) :: n
    real(c_double), intent(in) :: x(n), xmin, xmax
    real(c_double), intent(out) :: rcp
    ! local
    integer(c_long) :: i

    rcp = 0._c_double
    do i=1, n
        if ((x(i) >= xmin) .AND. (x(i) < xmax)) then
            rcp = rcp + 1._c_double
        end if
    end do
    rcp = rcp / n

end subroutine

! --------------------------------------------------------------------
! SUBROUTINE  ratio_beyond_r_sigma_1d
!     Compute the percentage of samples farther away than r * SD from the mean
!
!     Input
!     n      : integer(long)
!     x(n)   : real(double), array to compute for
!     r      : real(double), factor to multiply SD by
!
!     Output
!     rbrs : real(double)
! --------------------------------------------------------------------
subroutine ratio_beyond_r_sigma_1d(n, x, r, rbrs) bind(C, name="ratio_beyond_r_sigma_1d")
    use, intrinsic :: iso_c_binding
    use utility, only : mean_sd_1d
    implicit none
    integer(c_long), intent(in) :: n
    real(c_double), intent(in) :: x(n), r
    real(c_double), intent(out) :: rbrs
    ! local
    real(c_double) :: mean, stdev

    call mean_sd_1d(n, x, mean, stdev)

    stdev = stdev * r

    rbrs = real(count(abs(x - mean) > stdev), c_double) / n
end subroutine

! --------------------------------------------------------------------
! SUBROUTINE  linear_regression_1d
!     Compute the linear regression and the slope
!
!     Input
!     n      : integer(long)
!     y(n)   : real(double), array to compute for
!     fs     : real(double), sampling frequency for the array
!
!     Output
!     slope : real(double)
! --------------------------------------------------------------------
subroutine linear_regression_1d(n, y, fs, slope) bind(C, name="linear_regression_1d")
    use, intrinsic :: iso_c_binding
    implicit none
    integer(c_long), intent(in) :: n
    real(c_double), intent(in) :: y(n), fs
    real(c_double), intent(out) :: slope
    ! local
    integer(c_long) :: i
    real(c_double) :: ssxm, ssxym, ky, Ex, Ey, Exy

    ! The variance of a time series with N elements and sampling frequency fs
    ! can be expressed using the sum of natural numbers up to n-1 divided by the fs
    ! and the sum of squares natural numbers up to n-1 divided by fs**2
    ! kx = 0  ! since the first time value is 0
    ! Ex = (n - 1) * n / (2 * fs)
    ! Exy = ((n - 1) * n * (2 * n - 1)) / (6 * fs**2)
    ! ssxm = (Exy - Ex**2 / n) / n  ! biased estimator

    ! ssxm = (((n - 1) * n * (2 * n - 1) / (6 * fs**2)) - (((n-1)**2 * n**2) / (4 * n * fs**2))) / n
    ! ssxm = ((n - 1) * n * (2 * n - 1) / (6 * n * fs**2)) - (((n-1)**2 * n**2) / (4 * n**2 * fs**2))
    ! ssxm = ((n - 1) * (2 * n - 1) / (6 * fs**2)) - ((n-1)**2 / (4 * fs**2))

    ! ssxm = (2*n**2 - 3*n + 1) / (6 * fs**2) - ((n**2 - 2 * n + 1) / (4 * fs**2))
    ! ssxm = (4 * n**2 - 6 * n + 2) / (12 * fs**2) - ((3 * n**2 - 6 * n + 3) / (12 * fs**2))
    ! ssxm = (4 * n**2 - 6 * n + 2 - 3 * n**2 + 6 * n - 3) / (12 * fs**2)
    ssxm = (n**2 - 1) / (12._c_double * fs**2)
    ! need Ex though for linear regression computation
    Ex = (n - 1) * n / (2._c_double * fs)

    ky = y(1)
    Ey = 0._c_double
    Exy = 0._c_double

    do i=2, n
        Ey = Ey + (y(i) - ky)
        Exy = Exy + ((i-1) / fs) * (y(i) - ky)
    end do
    ssxym = (Exy - (Ex * Ey) / n) / n

    slope = ssxym / ssxm
end subroutine

! --------------------------------------------------------------------
! SUBROUTINE  SPARC
!     Compute the spectral arc length measure of smoothness
!
!     Input
!     n            : integer(long), axis dimension
!     x(n)         : real(double), array to compute for
!     fs           : real(double), sampling frequency in Hz
!     padlevel     : integer(long), amount of zero-padding for the FFT
!     fc           : real(double), frequency cutoff (Hz) to lowpass filter
!     amp_thresh   : real(double), normalized power spectra threshold for the arc
!                                  length calculation
!
!     Output
!     sal   : real(double)
! --------------------------------------------------------------------
subroutine sparc_1d(n, x, fs, padlevel, fc, amp_thresh, sal) bind(C, name="sparc_1d")
    use, intrinsic :: iso_c_binding
    use real_fft, only : execute_real_forward
    implicit none
    integer(c_long), intent(in) :: n, padlevel
    real(c_double), intent(in) :: x(n), fs, fc, amp_thresh
    real(c_double), intent(out) :: sal
    ! local
    integer(c_long) :: nfft, i, ixf, inxi, inxf, ier
    real(c_double) :: freq_factor
    real(c_double) :: Mf(2**(ceiling(log(real(n))/log(2.0)) + padlevel-1)+1)
    real(c_double) :: y(2**(ceiling(log(real(n))/log(2.0)) + padlevel))
    real(c_double) :: sp_hat(2**(ceiling(log(real(n))/log(2.0)) + padlevel)+2)

    ier = 0_c_long

    nfft = 2**(ceiling(log(real(n))/log(2.0)) + padlevel)

    ! frequency cutoff index. This will essentially function as a low-pass filter
    ! to remove high frequency noise from affecting the next step
    ixf = min(ceiling(fc / (0.5_c_double * fs) * (nfft / 2)), int(nfft / 2 + 1, c_long))

    sal = 0._c_double

    ! compute fft
    sp_hat = 0._c_double
    y = 0._c_double
    y(:n) = x
    call execute_real_forward(nfft, y, 1._c_double, sp_hat, ier)
    if (ier /= 0_c_long) return

    ! normalize the FFT response
    do i = 1, nfft + 2, 2
        Mf((i + 1) / 2) = sqrt(sp_hat(i)**2 + sp_hat(i + 1)**2)
    end do
    Mf = Mf / maxval(Mf)

    inxi = 1_c_long
    inxf = ixf

    do while ((Mf(inxi) < amp_thresh) .AND. (inxi < (nfft / 2 + 1)))
        inxi = inxi + 1
    end do
    do while ((Mf(inxf) < amp_thresh) .AND. (inxf > 1))
        inxf = inxf - 1
    end do

    ! compute the arc length
    freq_factor = 1._c_double / real(inxf - inxi, c_double)**2

    do i = inxi + 1, inxf
        sal = sal - sqrt(freq_factor + (Mf(i) - Mf(i - 1))**2)
    end do
end subroutine


!> This is a three dimensional sph code. the followings are the
!>  basic parameters needed in this code or calculated by this code.
!>
!>     mass-- mass of particles                                      [in]
!>     ntotal-- total particle number ues                            [in]
!>     dt--- time step used in the time integration                  [in]
!>     itype-- types of particles                                    [in]
!>     x-- coordinates of particles                              [in/out]
!>     vx-- velocities of particles                              [in/out]
!>     rho-- densities of particles                              [in/out]
!>     p-- pressure  of particles                                [in/out]
!>     u-- internal energy of particles                          [in/out]
!>     hsml-- smoothing lengths of particles                     [in/out]
!>     c-- sound velocity of particles                              [out]
!>     s-- entropy of particles                                     [out]
!>     e-- total energy of particles                                [out]

program sph

    use sph_kind, only: rk
    use parameter
    implicit none

    !> 在模拟中所使用的粒子总数
    !> number of particles in simulation
    integer :: ntotal
    !> 粒子的类型(1: ideal gas; 2: water)
    !> types of particles
    integer :: itype(maxn)
    integer :: maxtimestep
    integer :: d, m, i, yesorno
    real(rk) :: x(dim, maxn), vx(dim, maxn), mass(maxn), rho(maxn), p(maxn), &
                u(maxn), c(maxn), s(maxn), e(maxn), hsml(maxn), dt
    !> 时间记录点
    !> time records
    real(rk) :: s1, s2

    call time_print()
    call cpu_time(s1)

    if (shocktube) dt = 0.005_rk
    if (shearcavity) dt = 5.e-5_rk
    call input(x, vx, mass, rho, p, u, itype, hsml, ntotal)
1   write (*, *) '  ***************************************************'
    write (*, *) '          please input the maximal time steps '
    write (*, *) '  ***************************************************'
    read (*, *) maxtimestep
    call time_integration(x, vx, mass, rho, p, u, c, s, e, itype, hsml, ntotal, maxtimestep, dt)

    !> 输出最后一个时间布的求解信息
    call output(x, vx, mass, rho, p, u, c, itype, hsml, ntotal)

    write (*, *) '  ***************************************************'
    write (*, *) ' are you going to run more time steps ? (0=no, 1=yes)'
    write (*, *) '  ***************************************************'
    read (*, *) yesorno
    if (yesorno /= 0) goto 1
    call time_print()
    call cpu_time(s2)
    write (*, "(A,F0.1)") '        elapsed cpu time (seconds) = ', s2 - s1
    write (*, *) 'all finish!'

end program sph


MODULE module_wkppc_constants

     REAL, PARAMETER :: navgdro = 6.022e23

     REAL, PARAMETER :: &
           mwh = 1.0079, mwo = 15.9994, mwair = 28.97

     REAL, PARAMETER :: mwh2o = 2*mwh + mwo

      REAL, PARAMETER :: dens2con_a = 1.e-3 &
                                   * (1./mwair) &
                                   * navgdro

      REAL, PARAMETER :: dens2con_w = 1.e-3 &
                                    * (1./mwh2o) &
                                    * navgdro
     REAL, PARAMETER :: rtols=1.E-3
     REAL, PARAMETER :: atols=1.
END MODULE module_wkppc_constants


*> \brief \b SGET53
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE SGET53( A, LDA, B, LDB, SCALE, WR, WI, RESULT, INFO )
*
*       .. Scalar Arguments ..
*       INTEGER            INFO, LDA, LDB
*       REAL               RESULT, SCALE, WI, WR
*       ..
*       .. Array Arguments ..
*       REAL               A( LDA, * ), B( LDB, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SGET53  checks the generalized eigenvalues computed by SLAG2.
*>
*> The basic test for an eigenvalue is:
*>
*>                              | det( s A - w B ) |
*>     RESULT =  ---------------------------------------------------
*>               ulp max( s norm(A), |w| norm(B) )*norm( s A - w B )
*>
*> Two "safety checks" are performed:
*>
*> (1)  ulp*max( s*norm(A), |w|*norm(B) )  must be at least
*>      safe_minimum.  This insures that the test performed is
*>      not essentially  det(0*A + 0*B)=0.
*>
*> (2)  s*norm(A) + |w|*norm(B) must be less than 1/safe_minimum.
*>      This insures that  s*A - w*B  will not overflow.
*>
*> If these tests are not passed, then  s  and  w  are scaled and
*> tested anyway, if this is possible.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] A
*> \verbatim
*>          A is REAL array, dimension (LDA, 2)
*>          The 2x2 matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of A.  It must be at least 2.
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*>          B is REAL array, dimension (LDB, N)
*>          The 2x2 upper-triangular matrix B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of B.  It must be at least 2.
*> \endverbatim
*>
*> \param[in] SCALE
*> \verbatim
*>          SCALE is REAL
*>          The "scale factor" s in the formula  s A - w B .  It is
*>          assumed to be non-negative.
*> \endverbatim
*>
*> \param[in] WR
*> \verbatim
*>          WR is REAL
*>          The real part of the eigenvalue  w  in the formula
*>          s A - w B .
*> \endverbatim
*>
*> \param[in] WI
*> \verbatim
*>          WI is REAL
*>          The imaginary part of the eigenvalue  w  in the formula
*>          s A - w B .
*> \endverbatim
*>
*> \param[out] RESULT
*> \verbatim
*>          RESULT is REAL
*>          If INFO is 2 or less, the value computed by the test
*>             described above.
*>          If INFO=3, this will just be 1/ulp.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          =0:  The input data pass the "safety checks".
*>          =1:  s*norm(A) + |w|*norm(B) > 1/safe_minimum.
*>          =2:  ulp*max( s*norm(A), |w|*norm(B) ) < safe_minimum
*>          =3:  same as INFO=2, but  s  and  w  could not be scaled so
*>               as to compute the test.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup single_eig
*
*  =====================================================================
      SUBROUTINE SGET53( A, LDA, B, LDB, SCALE, WR, WI, RESULT, INFO )
*
*  -- LAPACK test routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB
      REAL               RESULT, SCALE, WI, WR
*     ..
*     .. Array Arguments ..
      REAL               A( LDA, * ), B( LDB, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0, ONE = 1.0 )
*     ..
*     .. Local Scalars ..
      REAL               ABSW, ANORM, BNORM, CI11, CI12, CI22, CNORM,
     $                   CR11, CR12, CR21, CR22, CSCALE, DETI, DETR, S1,
     $                   SAFMIN, SCALES, SIGMIN, TEMP, ULP, WIS, WRS
*     ..
*     .. External Functions ..
      REAL               SLAMCH
      EXTERNAL           SLAMCH
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SQRT
*     ..
*     .. Executable Statements ..
*
*     Initialize
*
      INFO = 0
      RESULT = ZERO
      SCALES = SCALE
      WRS = WR
      WIS = WI
*
*     Machine constants and norms
*
      SAFMIN = SLAMCH( 'Safe minimum' )
      ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
      ABSW = ABS( WRS ) + ABS( WIS )
      ANORM = MAX( ABS( A( 1, 1 ) )+ABS( A( 2, 1 ) ),
     $        ABS( A( 1, 2 ) )+ABS( A( 2, 2 ) ), SAFMIN )
      BNORM = MAX( ABS( B( 1, 1 ) ), ABS( B( 1, 2 ) )+ABS( B( 2, 2 ) ),
     $        SAFMIN )
*
*     Check for possible overflow.
*
      TEMP = ( SAFMIN*BNORM )*ABSW + ( SAFMIN*ANORM )*SCALES
      IF( TEMP.GE.ONE ) THEN
*
*        Scale down to avoid overflow
*
         INFO = 1
         TEMP = ONE / TEMP
         SCALES = SCALES*TEMP
         WRS = WRS*TEMP
         WIS = WIS*TEMP
         ABSW = ABS( WRS ) + ABS( WIS )
      END IF
      S1 = MAX( ULP*MAX( SCALES*ANORM, ABSW*BNORM ),
     $     SAFMIN*MAX( SCALES, ABSW ) )
*
*     Check for W and SCALE essentially zero.
*
      IF( S1.LT.SAFMIN ) THEN
         INFO = 2
         IF( SCALES.LT.SAFMIN .AND. ABSW.LT.SAFMIN ) THEN
            INFO = 3
            RESULT = ONE / ULP
            RETURN
         END IF
*
*        Scale up to avoid underflow
*
         TEMP = ONE / MAX( SCALES*ANORM+ABSW*BNORM, SAFMIN )
         SCALES = SCALES*TEMP
         WRS = WRS*TEMP
         WIS = WIS*TEMP
         ABSW = ABS( WRS ) + ABS( WIS )
         S1 = MAX( ULP*MAX( SCALES*ANORM, ABSW*BNORM ),
     $        SAFMIN*MAX( SCALES, ABSW ) )
         IF( S1.LT.SAFMIN ) THEN
            INFO = 3
            RESULT = ONE / ULP
            RETURN
         END IF
      END IF
*
*     Compute C = s A - w B
*
      CR11 = SCALES*A( 1, 1 ) - WRS*B( 1, 1 )
      CI11 = -WIS*B( 1, 1 )
      CR21 = SCALES*A( 2, 1 )
      CR12 = SCALES*A( 1, 2 ) - WRS*B( 1, 2 )
      CI12 = -WIS*B( 1, 2 )
      CR22 = SCALES*A( 2, 2 ) - WRS*B( 2, 2 )
      CI22 = -WIS*B( 2, 2 )
*
*     Compute the smallest singular value of s A - w B:
*
*                 |det( s A - w B )|
*     sigma_min = ------------------
*                 norm( s A - w B )
*
      CNORM = MAX( ABS( CR11 )+ABS( CI11 )+ABS( CR21 ),
     $        ABS( CR12 )+ABS( CI12 )+ABS( CR22 )+ABS( CI22 ), SAFMIN )
      CSCALE = ONE / SQRT( CNORM )
      DETR = ( CSCALE*CR11 )*( CSCALE*CR22 ) -
     $       ( CSCALE*CI11 )*( CSCALE*CI22 ) -
     $       ( CSCALE*CR12 )*( CSCALE*CR21 )
      DETI = ( CSCALE*CR11 )*( CSCALE*CI22 ) +
     $       ( CSCALE*CI11 )*( CSCALE*CR22 ) -
     $       ( CSCALE*CI12 )*( CSCALE*CR21 )
      SIGMIN = ABS( DETR ) + ABS( DETI )
      RESULT = SIGMIN / S1
      RETURN
*
*     End of SGET53
*
      END


      subroutine gclc(phio,lamo,phi,lam,x,y)
c -- gclc converts from geodetic coordinates, phi,lam to local
c    coordinates, x,y
c    correction is made for the change of radius with ellipticity
c    and for the difference between geodetic and geocentric
c    coordinates
c    accuracy should be to within 10 meters in 100 km for
c    latitudes up to about 70 degrees
c        phio - lat. of coordinate origin
c        lamo - long. of coordinate origin
c        phi - lat. of point to convert
c        lam - long. of point to convert
c        x - x coordinate (north) of converted point
c        y - y coordinate (east) of converted point
      real phio(3),lamo(3),phi(3),lam(3)
      data r,e,po180/6378.163,0.0033670033,0.017453293/
      fr(t) = 1.-e*sin(t)**2
      conv(x,y,z) = (x+y/60.+z/3600.)*po180
      xlat = conv(phi(1),phi(2),phi(3))
      ylon = conv(lam(1),lam(2),lam(3))
      jmp = 1
      go to 120
c
 100  continue
      y = rho*(zlon-ylon)*cos(xlat-crlat)
      x = rho*(xlat-zlat)/cdist
      return
      entry lcgc(phio,lamo,phi,lam,x,y)
      jmp = 2
      go to 120
c
 110  continue
      xlat = x*cdist/rho+zlat
      xl = xlat/po180
      t1 = abs(xl)+.5e-09
      xl = sign(t1,xl)
      phi(1) = aint(xl)
      rmin = (xl-phi(1))*60.
      phi(2) = aint(rmin)
      phi(3) = (rmin-phi(2))*60.
      ylon = zlon-y/(rho*cos(xlat-crlat))
      yl = ylon/po180
      t1 = abs(yl)+.5e-09
      yl = sign(t1,yl)
      lam(1) = aint(yl)
      rmin = (yl-lam(1))*60.
      lam(2) = aint(rmin)
      lam(3) = (rmin-lam(2))*60.
      return
 120  continue
      zlat = conv(phio(1),phio(2),phio(3))
      zlon = conv(lamo(1),lamo(2),lamo(3))
      crlat = atan(e*sin(2.*zlat)/fr(zlat))
      zgcl = zlat-crlat
      a = fr(zgcl)
      rho = r*a
      b = (e*sin(2.*zgcl)/a)**2+1.
      c = 2.*e*cos(2.*zgcl)*a+(e*sin(2.*zgcl))**2
      cdist = c/(a**2*b)+1.
      go to (100,110), jmp
      end

c $Id$


!-----------------------------------------------------------------------------
!
! FACET
!
! The subroutine FACET calculates the aspect and the slope (positive
! downward) of the steepest direction within a given triangle (facet).
!
!-----------------------------------------------------------------------------

subroutine facet(e0,e1,e2,r,s_max_facet)

use mpar

implicit none

real(kind=REP) pi
real(kind=REP) s1,s2,e0,e1,e2,r,s_max_facet,sp,sd,s1_10,s1_11

pi=4.0_REP*datan(1.0_REP)

s1=(e0-e1)/delta_x ! delta_x=delta_y
s2=(e1-e2)/delta_x ! delta_x=delta_y
if (abs(s1).lt.epsilon(s1)) then
   if (s2.ge.0.0_REP) then
      r=+pi/2.0_REP ! valore di comodo per s1=s2=0
   else ! if (s2.lt.0.0E0) then
      r=-pi/2.0_REP
   end if
else
   r=datan(s2/s1)
end if
sp=dsqrt(s1**2.0_REP+s2**2.0_REP)
sd=(e0-e2)/dsqrt(delta_x**2.0_REP+delta_y**2.0_REP)

if (r.ge.0.0_REP.and.r.le.pi/4.0_REP.and.s1.ge.0.0_REP) then
   s_max_facet=sp
else
   if (s1.gt.sd) then
      s_max_facet=s1
      r=0.0_REP
   else
      s_max_facet=sd
      r=pi/4.0_REP
   end if
end if

return
end subroutine facet


program test_matmul
    use utils
    use sub
    integer nn
    real(8), dimension(5000,5000) :: a, b, c
    real all_time1, all_time2
    real time_init
    real time21, time22
    real    ::  T1,T2
    real    ::  dt1, dt2, dt3
    all_time1 = sys_time()
    print *, 'Test matmul'
    call cpu_time(T1)
    CALL RANDOM_NUMBER(a)
    CALL RANDOM_NUMBER(b)
    call cpu_time(T2)
    dt1 = T2-T1
    print *, "init time = ", dt1
    print *, "         n","   cpu time", "         sys time", "      cpu/sys time"
    do nn = 500, 2500, 200
        time_init = sys_time()
        call cpu_time(T1)
        call matmul(a,b,c,nn)
        call cpu_time(T2)
        time_matmul = sys_time() - time_init
        dt2 = T2-T1

        print *, nn, dt2,  time_matmul, dt2/time_matmul
    end do
    all_time2 = sys_time()
    print *,"all time =", all_time2 - all_time1

end program test_matmul