      program dnbdr6
c
c     ... Construct matrices A and M in LAPACK-style band form.
c         The matrix A is a block tridiagonal matrix.  Each
c         diagonal block is a tridiagonal matrix with
c         4 on the diagonal, 1-rho*h/2 on the subdiagonal and
c         1+rho*h/2 on the superdiagonal.  Each subdiagonal block
c         of A is an identity matrix.  The matrix M is the
c         tridiagonal matrix with 4 on the diagonal and 1 on the
c         subdiagonal and superdiagonal.
c
c     ... Define COMPLEX shift SIGMA=(SIGMAR,SIGMAI), SIGMAI .ne. zero.
c
c     ... Call dnband  to find eigenvalues LAMBDA closest to SIGMA
c         such that
c                 A*x = LAMBDA*M*x.
c
c     ... Use mode 4 of DNAUPD .
c
c\BeginLib
c
c\Routines called:
c     dnband   ARPACK banded eigenproblem solver.
c     dlapy2   LAPACK routine to compute sqrt(x**2+y**2) carefully.
c     dlaset   LAPACK routine to initialize a matrix to zero.
c     daxpy    Level 1 BLAS that computes y <- alpha*x+y.
c     dnrm2    Level 1 BLAS that computes the norm of a vector.
c     dgbmv    Level 2 BLAS that computes the band matrix vector product.
c
c\Author
c     Danny Sorensen
c     Richard Lehoucq
c     Chao Yang
c     Dept. of Computational &
c     Applied Mathematics
c     Rice University
c     Houston, Texas
c
c\SCCS Information: @(#)
c FILE: nbdr6.F   SID: 2.5   DATE OF SID: 08/26/96   RELEASE: 2
c
c\Remarks
c     1. None
c
c\EndLib
c
c---------------------------------------------------------------------
c
c     %-------------------------------------%
c     | Define leading dimensions for all   |
c     | arrays.                             |
c     | MAXN   - Maximum size of the matrix |
c     | MAXNEV - Maximum number of          |
c     |          eigenvalues to be computed |
c     | MAXNCV - Maximum number of Arnoldi  |
c     |          vectors stored             |
c     | MAXBDW - Maximum bandwidth          |
c     %-------------------------------------%
c
      integer          maxn, maxnev, maxncv, maxbdw, lda,
     &                 lworkl, ldv
      parameter        ( maxn = 1000, maxnev = 25, maxncv=50,
     &                   maxbdw=50, lda = maxbdw, ldv = maxn )
c
c     %--------------%
c     | Local Arrays |
c     %--------------%
c
      integer          iparam(11), iwork(maxn)
      logical          select(maxncv)
      Double precision
     &                 a(lda,maxn), m(lda,maxn), rfac(lda,maxn),
     &                 workl(3*maxncv*maxncv+6*maxncv), workd(3*maxn),
     &                 workev(3*maxncv), v(ldv, maxncv),
     &                 resid(maxn), d(maxncv, 3), ax(maxn), mx(maxn)
      Complex*16
     &                 cfac(lda, maxn), workc(maxn)
c
c     %---------------%
c     | Local Scalars |
c     %---------------%
c
      character        which*2, bmat
      integer          nev, ncv, ku, kl, info, i, j, ido,
     &                 n, nx, lo, idiag, isup, isub, mode, maxitr,
     &                 nconv
      logical          rvec, first
      Double precision
     &                 tol, rho, h, sigmar, sigmai
c
c     %------------%
c     | Parameters |
c     %------------%
c
      Double precision
     &                 one, zero, two
      parameter        (one = 1.0D+0 , zero = 0.0D+0 ,
     &                  two = 2.0D+0 )
c
c     %--------------------%
c     | Intrinsic function |
c     %--------------------%
c
      intrinsic         abs
c
c     %-----------------------------%
c     | BLAS & LAPACK routines used |
c     %-----------------------------%
c
      Double precision
     &                  dlapy2 , dnrm2
      external          dlapy2 , dnrm2 , dgbmv , daxpy
c
c     %-----------------------%
c     | Executable Statements |
c     %-----------------------%
c
c     %-----------------------------------------------------%
c     | The number NX is the size of each diagonal block of |
c     | A.  The number N(=NX*NX) is the dimension of the    |
c     | matrix.  The number N(=NX*NX) is the dimension of   |
c     | the matrix.  A generalized eigenvalue problem is    |
c     | solved (BMAT = 'G').  NEV numbers of eigenvalues    |
c     | closest to the COMPLEX shift (SIGMAR,SIGMAI)        |
c     | (WHICH='LM') and their corresponding eigenvectors   |
c     | are computed. The user can modify NX, NEV, NCV,     |
c     | WHICH to solve problems of different sizes, and     |
c     | to get different parts the spectrum. However, the   |
c     | following rules must be satisfied:                  |
c     |                   N <= MAXN                         |
c     |                 NEV <= MAXNEV                       |
c     |           NEV + 2 <= NCV <= MAXNCV                  |
c     %-----------------------------------------------------%
c
      nx  = 10
      n    = nx*nx
      nev  = 4
      ncv  = 10
      if ( n .gt. maxn ) then
         print *, ' ERROR with _NBDR6: N is greater than MAXN '
         go to 9000
      else if ( nev .gt. maxnev ) then
         print *, ' ERROR with _NBDR6: NEV is greater than MAXNEV '
         go to 9000
      else if ( ncv .gt. maxncv ) then
         print *, ' ERROR with _NBDR6: NCV is greater than MAXNCV '
         go to 9000
      end if
      bmat = 'G'
      which = 'LM'
      sigmar = 4.0D-1
      sigmai = 6.0D-1
c
c     %-----------------------------------------------------%
c     | The work array WORKL is used in DNAUPD  as           |
c     | workspace.  Its dimension LWORKL is set as          |
c     | illustrated below.  The parameter TOL determines    |
c     | the stopping criterion. If TOL<=0, machine          |
c     | precision is used.  The variable IDO is used for    |
c     | reverse communication, and is initially set to 0.   |
c     | Setting INFO=0 indicates that a random vector is    |
c     | generated in DNAUPD  to start the Arnoldi iteration. |
c     %-----------------------------------------------------%
c
      lworkl  = 3*ncv**2+6*ncv
      tol  = zero
      ido  = 0
      info = 0
c
c     %---------------------------------------------------%
c     | IPARAM(3) specifies the maximum number of Arnoldi |
c     | iterations allowed.  Mode 4 of DNAUPD  is used     |
c     | (IPARAm(7) = 4). All these options can be changed |
c     | by the user. For details, see the documentation   |
c     | in dnband .                                        |
c     %---------------------------------------------------%
c
      maxitr = 300
      mode = 4
c
      iparam(3) = maxitr
      iparam(7) = mode
c
c     %--------------------------------------------%
c     | Construct matrices A and M in LAPACK-style |
c     | banded form.                               |
c     %--------------------------------------------%
c
c     %---------------------------------------------%
c     | Zero out the workspace for banded matrices. |
c     %---------------------------------------------%
c
      call dlaset ('A', lda, n, zero, zero, a, lda)
      call dlaset ('A', lda, n, zero, zero, m, lda)
      call dlaset ('A', lda, n, zero, zero, rfac, lda)
c
c     %-------------------------------------%
c     | KU, KL are number of superdiagonals |
c     | and subdiagonals within the band of |
c     | matrices A and M.                   |
c     %-------------------------------------%
c
      kl   = nx
      ku   = nx
c
c     %---------------%
c     | Main diagonal |
c     %---------------%
c
      idiag = kl+ku+1
      do 30 j = 1, n
         a(idiag,j) = 4.0D+0
         m(idiag,j) = 4.0D+0
  30  continue
c
c     %-------------------------------------%
c     | First subdiagonal and superdiagonal |
c     %-------------------------------------%
c
      isup = kl+ku
      isub = kl+ku+2
      h = one / dble (nx+1)
      rho = 1.0D+2
      do 50 i = 1, nx
        lo = (i-1)*nx
        do 40 j = lo+1, lo+nx-1
           a(isub,j+1) = -one+h*rho/two
           a(isup,j) = -one-h*rho/two
  40    continue
  50  continue
c
      do 60 j = 1, n-1
         m(isub,j+1) = one
         m(isup,j) = one
  60  continue
c
c     %------------------------------------%
c     | KL-th subdiagonal and KU-th super- |
c     | diagonal.                          |
c     %------------------------------------%
c
      isup = kl+1
      isub = 2*kl+ku+1
      do 80 i = 1, nx-1
         lo = (i-1)*nx
         do 70 j = lo+1, lo+nx
            a(isup,nx+j)  = -one
            a(isub,j) = -one
 70      continue
 80   continue
c
c     %------------------------------------------------%
c     | Call ARPACK banded solver to find eigenvalues  |
c     | and eigenvectors. The real parts of the        |
c     | eigenvalues are returned in the first column   |
c     | of D, the imaginary parts are returned in the  |
c     | second column of D.  Eigenvectors are returned |
c     | in the first NCONV (=IPARAM(5)) columns of V.  |
c     %------------------------------------------------%
c
      rvec = .true.
      call dnband (rvec, 'A', select, d, d(1,2), v, ldv, sigmar,
     &     sigmai, workev, n, a, m, lda, rfac, cfac, ku, kl,
     &     which, bmat, nev, tol, resid, ncv, v, ldv, iparam,
     &     workd, workl, lworkl, workc, iwork, info)
c
      if ( info .eq. 0) then
c
c        %-----------------------------------%
c        | Print out convergence information |
c        %-----------------------------------%
c
         nconv = iparam(5)
c
         print *, ' '
         print *, ' _NBDR6 '
         print *, ' ====== '
         print *, ' '
         print *, ' The size of the matrix is ', n
         print *, ' Number of eigenvalue requested is ', nev
         print *, ' The number of Arnoldi vectors generated',
     &            ' (NCV) is ', ncv
         print *, ' The number of converged Ritz values is ',
     &              nconv
         print *, ' What portion of the spectrum ', which
         print *, ' The number of Implicit Arnoldi ',
     &              ' update taken is ', iparam(3)
         print *, ' The number of OP*x is ', iparam(9)
         print *, ' The convergence tolerance is ', tol
         print *, ' '
c
c        %----------------------------%
c        | Compute the residual norm. |
c        |    ||  A*x - lambda*x ||   |
c        %----------------------------%
c
         first = .true.
         do 90 j = 1, nconv
c
            if ( d(j,2) .eq. zero ) then
c
c              %--------------------%
c              | Ritz value is real |
c              %--------------------%
c
               call dgbmv ('Notranspose', n, n, kl, ku, one,
     &                    a(kl+1,1), lda, v(1,j), 1, zero,
     &                    ax, 1)
               call dgbmv ('Notranspose', n, n, kl, ku, one,
     &                    m(kl+1,1), lda, v(1,j), 1, zero,
     &                    mx, 1)
               call daxpy (n, -d(j,1), mx, 1, ax, 1)
               d(j,3) = dnrm2 (n, ax, 1)
               d(j,3) = d(j,3) / abs(d(j,1))
c
            else if ( first ) then
c
c              %------------------------%
c              | Ritz value is complex  |
c              | Residual of one Ritz   |
c              | value of the conjugate |
c              | pair is computed.      |
c              %------------------------%
c
               call dgbmv ('Notranspose', n, n, kl, ku, one,
     &                    a(kl+1,1), lda, v(1,j), 1, zero,
     &                    ax, 1)
               call dgbmv ('Notranspose', n, n, kl, ku, one,
     &                    m(kl+1,1), lda, v(1,j), 1, zero,
     &                    mx, 1)
               call daxpy (n, -d(j,1), mx, 1, ax, 1)
               call dgbmv ('Notranspose', n, n, kl, ku, one,
     &                    m(kl+1,1), lda, v(1,j+1), 1, zero,
     &                    mx, 1)
               call daxpy (n, d(j,2), mx, 1, ax, 1)
               d(j,3) = dnrm2 (n, ax, 1)
               call dgbmv ('Notranspose', n, n, kl, ku, one,
     &                    a(kl+1,1), lda, v(1,j+1), 1, zero,
     &                    ax, 1)
               call dgbmv ('Notranspose', n, n, kl, ku, one,
     &                    m(kl+1,1), lda, v(1,j+1), 1, zero,
     &                    mx, 1)
               call daxpy (n, -d(j,1), mx, 1, ax, 1)
               call dgbmv ('Notranspose', n, n, kl, ku, one,
     &                    m(kl+1,1), lda, v(1,j), 1, zero,
     &                    mx, 1)
               call daxpy (n, -d(j,2), mx, 1, ax, 1)
               d(j,3) = dlapy2 ( d(j,3), dnrm2 (n, ax, 1) )
               d(j,3) = d(j,3) / dlapy2 (d(j,1),d(j,2))
               d(j+1,3) = d(j,3)
               first = .false.
            else
               first = .true.
            end if
c
 90      continue

         call dmout (6, nconv, 3, d, maxncv, -6,
     &             'Ritz values (Real,Imag) and relative residuals')
      else
c
c        %-------------------------------------%
c        | Either convergence failed, or there |
c        | is error.  Check the documentation  |
c        | for dnband .                         |
c        %-------------------------------------%
c
          print *, ' '
          print *, ' Error with _nband, info= ', info
          print *, ' Check the documentation of _nband '
          print *, ' '
c
      end if
c
 9000 end


MODULE mo_percentile

  ! This module provides routines for median and percentiles.

  ! Written   Matthias Cuntz,              Mar 2011
  ! Modified, Juliane Mai,                 Jul 2012 - different interpolation schemes in percentiles
  !           Matthias Cuntz, Juliane Mai, Jul 2012 - uses previous of ksmallest to half execution time
  !           Matthias Cuntz,              May 2014 - removed numerical recipes

  ! License
  ! -------
  ! This file is part of the JAMS Fortran package, distributed under the MIT License.
  !
  ! Copyright (c) 2011-2014 Matthias Cuntz, Juliane Mai, Stephan Thober - mc (at) macu (dot) de
  !
  ! Permission is hereby granted, free of charge, to any person obtaining a copy
  ! of this software and associated documentation files (the "Software"), to deal
  ! in the Software without restriction, including without limitation the rights
  ! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  ! copies of the Software, and to permit persons to whom the Software is
  ! furnished to do so, subject to the following conditions:
  !
  ! The above copyright notice and this permission notice shall be included in all
  ! copies or substantial portions of the Software.
  !
  ! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  ! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  ! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  ! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  ! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  ! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
  ! SOFTWARE.

  USE mo_kind, ONLY: i4, sp, dp

  Implicit NONE

  PUBLIC :: median          ! Median
  PUBLIC :: n_element       ! The n-th smallest value in an array
  PUBLIC :: percentile      ! The value below which a certain percent of the input fall
  PUBLIC :: qmedian         ! Quick median calculation, rearranges input

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

  !     NAME
  !         median

  !     PURPOSE
  !         Returns the median of the values in an array.
  !         If size is even, then the mean of the size/2 and size/2+1 element is the median.
  !
  !         If an optinal mask is given, values only on those locations that correspond
  !         to true values in the mask are used.

  !     CALLING SEQUENCE
  !         out = median(vec,mask=mask)

  !     INTENT(IN)
  !         real(sp/dp) :: vec(:)     1D-array with input numbers

  !     INTENT(INOUT)
  !         None

  !     INTENT(OUT)
  !         real(sp/dp) :: out        median of values in input array

  !     INTENT(IN), OPTIONAL
  !         logical     :: mask(:)    1D-array of logical values with size(vec).
  !                                   If present, only those locations in vec corresponding to the true values in mask are used.

  !     INTENT(INOUT), OPTIONAL
  !         None

  !     INTENT(OUT), OPTIONAL
  !         None

  !     RESTRICTIONS
  !         None

  !     EXAMPLE
  !         vec = (/ 1.,2.,3.,4.,5.,6.,7.,8.,9.,10. /)
  !         ! Returns 5.5
  !         out = median(vec)
  !         -> see also example in test directory

  !     LITERATURE
  !         None

  !     HISTORY
  !         Written,  Matthias Cuntz, Mar 2011
  !         Modified, Matthias Cuntz, Juliane Mai, Jul 2012 - uses previous of ksmallest to half execution time
  INTERFACE median
     MODULE PROCEDURE median_sp, median_dp
  END INTERFACE median

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

  !     NAME
  !         n_element

  !     PURPOSE
  !         Returns the n-th smallest value in an array.
  !
  !         If an optinal mask is given, values only on those locations that correspond
  !         to true values in the mask are used.

  !     CALLING SEQUENCE
  !         out = n_element(vec, n, mask=mask, before=before, previous=previous, after=after, next=next)

  !     INTENT(IN)
  !         real(sp/dp) :: vec(:)     1D-array with input numbers

  !     INTENT(INOUT)
  !         None

  !     INTENT(OUT)
  !         real(sp/dp) :: out        n-th smallest value in input array

  !     INTENT(IN), OPTIONAL
  !         integer(i4) :: n          index of sorted array
  !         logical     :: mask(:)    1D-array of logical values with size(vec).
  !                                   If present, only those locations in vec corresponding to the true values in mask are used.

  !     INTENT(INOUT), OPTIONAL
  !         None

  !     INTENT(OUT), OPTIONAL
  !         real(sp/dp) :: before      (n-1)-th smallest value in input array, e.g. for median/percentile calculations
  !         real(sp/dp) :: previous    same as before
  !         real(sp/dp) :: after       (n+1)-th smallest value in input array
  !         real(sp/dp) :: next        same as after

  !     RESTRICTIONS
  !         None

  !     EXAMPLE
  !         vec = (/ 1.,2.,3.,4.,5.,6.,7.,8.,9.,10. /)
  !         ! Returns 4
  !         out = n_element(vec,4)
  !         -> see also example in test directory

  !     LITERATURE
  !         Niklaus Wirth. "Algorithms and Data Structures". Prentice-Hall, Inc., 1985. ISBN 0-13-022005-1.

  !     HISTORY
  !         Written,  Matthias Cuntz, May 2014 - based on qmedian
  INTERFACE n_element
     MODULE PROCEDURE n_element_dp, n_element_sp
  END INTERFACE n_element

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

  !     NAME
  !         percentile

  !     PURPOSE
  !         Returns the value below which a certain percent of array values fall.
  !
  !         If an optinal mask is given, values only on those locations that correspond
  !         to true values in the mask are used.
  !
  !         Different definitions can be applied to interpolate the stepwise CDF of the given data.
  !         (1) Inverse empirical CDF (no interpolation, default MATHEMATICA)
  !         (2) Linear interpolation (California method)
  !         (3) Element numbered closest
  !         (4) Linear interpolation (hydrologist method)
  !         (5) Mean-based estimate (Weibull method, default IMSL)
  !         (6) Mode-based estimate
  !         (7) Median-based estimate
  !         (8) normal distribution estimate
  !
  !         See: http://reference.wolfram.com/mathematica/tutorial/BasicStatistics.html

  !     CALLING SEQUENCE
  !         out = percentile(vec,k,mask=mask,mode_in=mode)

  !     INTENT(IN)
  !         real(sp/dp) :: vec(:)     1D-array with input numbers
  !         real(sp/dp) :: k[(:)]     Percentage of percentile, can be 1 dimensional

  !     INTENT(INOUT)
  !         None

  !     INTENT(OUT)
  !         real(sp/dp) :: out[(size(k))]   k-th percentile of values in input array, can be
  !                                         1 dimensional corresponding to k

  !     INTENT(IN), OPTIONAL
  !         logical     :: mask(:)    1D-array of logical values with size(vec).
  !                                   If present, only those locations in vec corresponding to the true values in mask are used.
  !         integer(i4) :: mode_in    Specifies the interpolation scheme applied.
  !                                   Default:
  !                                       Inverse empirical CDF (no interpolation, default Mathematica)
  !                                       mode_in = 1_i4

  !     INTENT(INOUT), OPTIONAL
  !         None

  !     INTENT(OUT), OPTIONAL
  !         None

  !     RESTRICTIONS
  !         None

  !     EXAMPLE
  !         vec = (/ 1.,2.,3.,4.,5.,6.,7.,8.,9.,10. /)
  !         ! Returns 10.
  !         out = percentile(vec,95.)
  !         ! Returns (10.,8)
  !         out = percentile(vec,(/95.,80./))
  !         -> see also example in test directory

  !     LITERATURE
  !         None

  !     HISTORY
  !         Written,  Matthias Cuntz, Mar  2011
  !         Modified, Stephan Thober, Dec  2011 - added 1 dimensional version
  !                   Juliane Mai,    July 2012 - different interpolation schemes
  !         Modified, Matthias Cuntz, Juliane Mai, Jul 2012 - uses previous of ksmallest to half execution time
  INTERFACE percentile
     MODULE PROCEDURE percentile_0d_sp, percentile_0d_dp, percentile_1d_sp, percentile_1d_dp
  END INTERFACE percentile

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

  !     NAME
  !         qmedian

  !     PURPOSE
  !         Quick calculation of the median thereby rearranging the input array.

  !     CALLING SEQUENCE
  !         out = qmedian(vec)

  !     INTENT(IN)
  !         None

  !     INTENT(INOUT)
  !         real(sp/dp) :: vec(:)     1D-array with input numbers.
  !                                   Wil be rearranged on output.

  !     INTENT(OUT)
  !         real(sp/dp) :: out        median of values in input array

  !     INTENT(IN), OPTIONAL
  !         None

  !     INTENT(INOUT), OPTIONAL
  !         None

  !     INTENT(OUT), OPTIONAL
  !         None

  !     RESTRICTIONS
  !         None

  !     EXAMPLE
  !         vec = (/ 1.,2.,3.,4.,5.,6.,7.,8.,9.,10. /)
  !         ! Returns 5.5
  !         out = qmedian(vec)
  !         -> see also example in test directory

  !     LITERATURE
  !         Niklaus Wirth. "Algorithms and Data Structures". Prentice-Hall, Inc., 1985. ISBN 0-13-022005-1.

  !     HISTORY
  !         Written, Filip Hroch as part of Munipack: http://munipack.physics.muni.cz
  !         Modified, Matthias Cuntz, Jul 2012 - function, k=n/2+1
  !         Modified, Matthias Cuntz, Juliane Mai, Jul 2012 - real median for even n
  INTERFACE qmedian
     MODULE PROCEDURE qmedian_sp, qmedian_dp
  END INTERFACE qmedian

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

  PRIVATE

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

CONTAINS

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

  FUNCTION median_dp(arrin, mask)

    IMPLICIT NONE

    REAL(dp),    DIMENSION(:),           INTENT(IN) :: arrin
    LOGICAL,     DIMENSION(:), OPTIONAL, INTENT(IN) :: mask
    REAL(dp)                                        :: median_dp

    INTEGER(i4) :: n
    REAL(dp), DIMENSION(:), ALLOCATABLE :: arr
    REAL(dp) :: tmp

    if (present(mask)) then
       n = count(mask)
       allocate(arr(n))
       arr = pack(arrin,mask)

       if (n < 2) stop 'median_dp: n < 2'

       if (mod(n,2) == 0) then ! Even
          median_dp = n_element(arr,n/2+1,previous=tmp)
          median_dp = 0.5_dp*(median_dp+tmp)
       else ! Odd
          median_dp = n_element(arr,(n+1)/2)
       endif

       deallocate(arr)
    else
       n = size(arrin)
       if (n < 2) stop 'median_dp: n < 2'

       if (mod(n,2) == 0) then ! Even
          median_dp = n_element(arrin,n/2+1,previous=tmp)
          median_dp = 0.5_dp*(median_dp+tmp)
       else ! Odd
          median_dp = n_element(arrin,(n+1)/2)
       endif
    endif

  END FUNCTION median_dp

  FUNCTION median_sp(arrin, mask)

    IMPLICIT NONE

    REAL(sp),    DIMENSION(:),           INTENT(IN) :: arrin
    LOGICAL,     DIMENSION(:), OPTIONAL, INTENT(IN) :: mask
    REAL(sp)                                        :: median_sp

    INTEGER(i4) :: n
    REAL(sp), DIMENSION(:), ALLOCATABLE :: arr
    REAL(sp) :: tmp

    if (present(mask)) then
       n = count(mask)
       allocate(arr(n))
       arr = pack(arrin,mask)

       if (n < 2) stop 'median_sp: n < 2'

       if (mod(n,2) == 0) then ! Even
          median_sp = n_element(arr,n/2+1,previous=tmp)
          median_sp = 0.5_sp*(median_sp+tmp)
       else ! Odd
          median_sp = n_element(arr,(n+1)/2)
       endif

       deallocate(arr)
    else
       n = size(arrin)
       if (n < 2) stop 'median_sp: n < 2'

       if (mod(n,2) == 0) then ! Even
          median_sp = n_element(arrin,n/2+1,previous=tmp)
          median_sp = 0.5_sp*(median_sp+tmp)
       else ! Odd
          median_sp = n_element(arrin,(n+1)/2)
       endif
    endif

  END FUNCTION median_sp

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

  function n_element_dp(idat, n, mask, before, after, previous, next)

    IMPLICIT NONE

    real(dp),    dimension(:), intent(in)            :: idat
    integer(i4),               intent(in)            :: n
    logical,     dimension(:), optional, intent(in)  :: mask
    real(dp),                  optional, intent(out) :: before
    real(dp),                  optional, intent(out) :: after
    real(dp),                  optional, intent(out) :: previous
    real(dp),                  optional, intent(out) :: next
    real(dp)                                         :: n_element_dp

    real(dp), dimension(:), allocatable :: dat
    real(dp) :: w
    integer(i4) :: nn, k
    integer(i4) :: l,r,i,j

    if (present(mask)) then
       nn = count(mask)
       allocate(dat(nn))
       dat = pack(idat,mask)
    else
       nn = size(idat)
       allocate(dat(nn))
       dat = idat
    endif

    if (n < 1)  stop 'n_element_dp: n < 1'
    if (n > nn) stop 'n_element_dp: n > size(pack(dat,mask))'

    dat = idat
    nn = size(dat)
    k = n !nn/2 + 1
    l = 1
    r = nn
    do while( l < r )
       n_element_dp = dat(k)
       i = l
       j = r
       do
          do while( dat(i) < n_element_dp )
             i = i + 1
          enddo
          do while( n_element_dp < dat(j) )
             j = j - 1
          enddo
          if ( i <= j ) then
             w      = dat(i)
             dat(i) = dat(j)
             dat(j) = w
             i = i + 1
             j = j - 1
          endif
          if ( i > j ) exit
       enddo
       if ( j < k ) l = i
       if ( k < i ) r = j
    enddo
    ! if (mod(nn,2) == 0) then
    !    n_element_dp = 0.5_dp*(dat(k) + maxval(dat(:k-1)))
    ! else
    !    n_element_dp = dat(k)
    ! endif
    n_element_dp = dat(k)

    if (present(before))   before   = maxval(dat(:k-1))
    if (present(previous)) previous = maxval(dat(:k-1))
    if (present(after))    after    = minval(dat(k+1:))
    if (present(next))     next     = minval(dat(k+1:))

    deallocate(dat)

  end function n_element_dp

  function n_element_sp(idat, n, mask, before, after, previous, next)

    IMPLICIT NONE

    real(sp),    dimension(:), intent(in)            :: idat
    integer(i4),               intent(in)            :: n
    logical,     dimension(:), optional, intent(in)  :: mask
    real(sp),                  optional, intent(out) :: before
    real(sp),                  optional, intent(out) :: after
    real(sp),                  optional, intent(out) :: previous
    real(sp),                  optional, intent(out) :: next
    real(sp)                                         :: n_element_sp

    real(sp), dimension(:), allocatable :: dat
    real(sp) :: w
    integer(i4) :: nn, k
    integer(i4) :: l,r,i,j

    if (present(mask)) then
       nn = count(mask)
       allocate(dat(nn))
       dat = pack(idat,mask)
    else
       nn = size(idat)
       allocate(dat(nn))
       dat = idat
    endif

    if (n < 1)  stop 'n_element_sp: n < 1'
    if (n > nn) stop 'n_element_sp: n > size(pack(dat,mask))'

    dat = idat
    nn = size(dat)
    k = n !nn/2 + 1
    l = 1
    r = nn
    do while( l < r )
       n_element_sp = dat(k)
       i = l
       j = r
       do
          do while( dat(i) < n_element_sp )
             i = i + 1
          enddo
          do while( n_element_sp < dat(j) )
             j = j - 1
          enddo
          if ( i <= j ) then
             w      = dat(i)
             dat(i) = dat(j)
             dat(j) = w
             i = i + 1
             j = j - 1
          endif
          if ( i > j ) exit
       enddo
       if ( j < k ) l = i
       if ( k < i ) r = j
    enddo
    ! if (mod(nn,2) == 0) then
    !    n_element_sp = 0.5_sp*(dat(k) + maxval(dat(:k-1)))
    ! else
    !    n_element_sp = dat(k)
    ! endif
    n_element_sp = dat(k)

    if (present(before))   before   = maxval(dat(:k-1))
    if (present(previous)) previous = maxval(dat(:k-1))
    if (present(after))    after    = minval(dat(k+1:))
    if (present(next))     next     = minval(dat(k+1:))

    deallocate(dat)

  end function n_element_sp

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

  FUNCTION percentile_0d_dp(arrin,k,mask,mode_in)

    IMPLICIT NONE

    REAL(dp),    DIMENSION(:),           INTENT(IN) :: arrin
    REAL(dp),                            INTENT(IN) :: k
    LOGICAL,     DIMENSION(:), OPTIONAL, INTENT(IN) :: mask
    INTEGER(i4),               OPTIONAL, INTENT(IN) :: mode_in
    REAL(dp)                                        :: percentile_0d_dp

    INTEGER(i4)                         :: n, nn1, nn2
    INTEGER(i4)                         :: mode
    REAL(dp)                            :: kk, ks1, ks2
    REAL(dp), DIMENSION(:), ALLOCATABLE :: arr

    if (present(mask)) then
       n = count(mask)
    else
       n = size(arrin)
    endif

    if (present(mode_in)) then
       mode = mode_in
    else
       ! Default : Inverse empirical CDF
       mode = 1_i4
    end if

    if (n < 2) stop 'percentile_0d_dp: n < 2'

    select case (mode)
       ! Inverse empirical CDF: Mathematica default
    case(1_i4)
       kk = k/100._dp*real(n,dp)
       nn1 = min(n, max(1_i4,ceiling(kk,kind=i4)))
       nn2 = nn1

       ! Linear interpolation (California method)
    case(2_i4)
       kk  = k/100._dp*real(n,dp)
       nn1 = min(n, max(1_i4,  floor(kk,kind=i4)))
       nn2 = min(n, max(1_i4,ceiling(kk,kind=i4)))

       ! Element numbered closest
    case(3_i4)
       kk = 0.5_dp+k/100._dp*real(n,dp)
       nn1 = min(n, max(1_i4,floor(kk,kind=i4)))
       nn2 = nn1

       ! Linear interpolation (hydrologist method)
    case(4_i4)
       kk  = 0.5_dp+k/100._dp*(real(n,dp))
       nn1 = min(n, max(1_i4,  floor(kk,kind=i4)))
       nn2 = min(n, max(1_i4,ceiling(kk,kind=i4)))

       ! Mean-based estimate (Weibull method): IMSL default
    case(5_i4)
       kk  = k/100._dp*(real(n,dp)+1._dp)
       nn1 = min(n, max(1_i4,  floor(kk,kind=i4)))
       nn2 = min(n, max(1_i4,ceiling(kk,kind=i4)))

       ! Mode-based estimate
    case(6_i4)
       kk  = 1.0_dp+k/100._dp*(real(n,dp)-1._dp)
       nn1 = min(n, max(1_i4,  floor(kk,kind=i4)))
       nn2 = min(n, max(1_i4,ceiling(kk,kind=i4)))

       ! Median-based estimate
    case(7_i4)
       kk  = 1.0_dp/3.0_dp+k/100._dp*(real(n,dp)+1.0_dp/3.0_dp)
       nn1 = min(n, max(1_i4,  floor(kk,kind=i4)))
       nn2 = min(n, max(1_i4,ceiling(kk,kind=i4)))

       ! Normal distribution estimate
    case(8_i4)
       kk  = 3.0_dp/8.0_dp+k/100._dp*(real(n,dp)+1.0_dp/4.0_dp)
       nn1 = min(n, max(1_i4,  floor(kk,kind=i4)))
       nn2 = min(n, max(1_i4,ceiling(kk,kind=i4)))

       ! No valid mode
    case default
       stop 'percentile_0d_dp: mode > 8 not implemented'

    end select

    if (present(mask)) then
       allocate(arr(n))
       arr = pack(arrin,mask)
       if (nn1 .eq. nn2) then
          ! no interpolation
          percentile_0d_dp = n_element(arr,nn1)
       else
          ! interpolation
          ks2 = n_element(arr,nn2,previous=ks1)
          percentile_0d_dp = ks1 + (ks2-ks1)*(kk-real(nn1,dp))
       end if
       deallocate(arr)
    else
       if (nn1 .eq. nn2) then
          ! no interpolation
          percentile_0d_dp = n_element(arrin,nn1)
       else
          ! interpolation
          ks2 = n_element(arrin,nn2,previous=ks1)
          percentile_0d_dp = ks1 + (ks2-ks1)*(kk-real(nn1,dp))
       end if
    endif

  END FUNCTION percentile_0d_dp

  FUNCTION percentile_0d_sp(arrin,k,mask,mode_in)

    IMPLICIT NONE

    REAL(sp),    DIMENSION(:),           INTENT(IN) :: arrin
    REAL(sp),                            INTENT(IN) :: k
    LOGICAL,     DIMENSION(:), OPTIONAL, INTENT(IN) :: mask
    INTEGER(i4),               OPTIONAL, INTENT(IN) :: mode_in
    REAL(sp)                                        :: percentile_0d_sp

    INTEGER(i4)                         :: n, nn1, nn2
    INTEGER(i4)                         :: mode
    REAL(sp)                            :: kk, ks1, ks2
    REAL(sp), DIMENSION(:), ALLOCATABLE :: arr

    if (present(mask)) then
       n = count(mask)
    else
       n = size(arrin)
    endif

    if (present(mode_in)) then
       mode = mode_in
    else
       ! Default : Inverse empirical CDF
       mode = 1_i4
    end if

    if (n < 2) stop 'percentile_0d_sp: n < 2'

    select case (mode)
       ! Inverse empirical CDF: Mathematica default
    case(1_i4)
       kk = k/100._sp*real(n,sp)
       nn1 = min(n, max(1_i4,ceiling(kk,kind=i4)))
       nn2 = nn1

       ! Linear interpolation (California method)
    case(2_i4)
       kk  = k/100._sp*real(n,sp)
       nn1 = min(n, max(1_i4,  floor(kk,kind=i4)))
       nn2 = min(n, max(1_i4,ceiling(kk,kind=i4)))

       ! Element numbered closest
    case(3_i4)
       kk = 0.5_sp+k/100._sp*real(n,sp)
       nn1 = min(n, max(1_i4,floor(kk,kind=i4)))
       nn2 = nn1

       ! Linear interpolation (hydrologist method)
    case(4_i4)
       kk  = 0.5_sp+k/100._sp*(real(n,sp))
       nn1 = min(n, max(1_i4,  floor(kk,kind=i4)))
       nn2 = min(n, max(1_i4,ceiling(kk,kind=i4)))

       ! Mean-based estimate (Weibull method): IMSL default
    case(5_i4)
       kk  = k/100._sp*(real(n,sp)+1._sp)
       nn1 = min(n, max(1_i4,  floor(kk,kind=i4)))
       nn2 = min(n, max(1_i4,ceiling(kk,kind=i4)))

       ! Mode-based estimate
    case(6_i4)
       kk  = 1.0_sp+k/100._sp*(real(n,sp)-1._sp)
       nn1 = min(n, max(1_i4,  floor(kk,kind=i4)))
       nn2 = min(n, max(1_i4,ceiling(kk,kind=i4)))

       ! Median-based estimate
    case(7_i4)
       kk  = 1.0_sp/3.0_sp+k/100._sp*(real(n,sp)+1.0_sp/3.0_sp)
       nn1 = min(n, max(1_i4,  floor(kk,kind=i4)))
       nn2 = min(n, max(1_i4,ceiling(kk,kind=i4)))

       ! Normal distribution estimate
    case(8_i4)
       kk  = 3.0_sp/8.0_sp+k/100._sp*(real(n,sp)+1.0_sp/4.0_sp)
       nn1 = min(n, max(1_i4,  floor(kk,kind=i4)))
       nn2 = min(n, max(1_i4,ceiling(kk,kind=i4)))

       ! No valid mode
    case default
       stop 'percentile_0d_sp: mode > 8 not implemented'

    end select

    if (present(mask)) then
       allocate(arr(n))
       arr = pack(arrin,mask)
       if (nn1 .eq. nn2) then
          ! no interpolation
          percentile_0d_sp = n_element(arr,nn1)
       else
          ! interpolation
          ks2 = n_element(arr,nn2,previous=ks1)
          percentile_0d_sp = ks1 + (ks2-ks1)*(kk-real(nn1,sp))
       end if
       deallocate(arr)
    else
       if (nn1 .eq. nn2) then
          ! no interpolation
          percentile_0d_sp = n_element(arrin,nn1)
       else
          ! interpolation
          ks2 = n_element(arrin,nn2,previous=ks1)
          percentile_0d_sp = ks1 + (ks2-ks1)*(kk-real(nn1,sp))
       end if
    endif

  END FUNCTION percentile_0d_sp

  function percentile_1d_dp(arrin,k,mask,mode_in)

    IMPLICIT NONE

    REAL(dp),    DIMENSION(:),           INTENT(IN) :: arrin
    REAL(dp),    DIMENSION(:),           INTENT(IN) :: k
    LOGICAL,     DIMENSION(:), OPTIONAL, INTENT(IN) :: mask
    INTEGER(i4),               OPTIONAL, INTENT(IN) :: mode_in

    REAL(dp),    DIMENSION(size(k))                 :: percentile_1d_dp

    INTEGER(i4)                            :: i, n
    INTEGER(i4)                            :: mode
    INTEGER(i4), DIMENSION(size(k))        :: nn1, nn2
    REAL(dp),    DIMENSION(size(k))        :: kk
    REAL(dp)                               :: ks1, ks2
    REAL(dp),    DIMENSION(:), ALLOCATABLE :: arr

    if (present(mask)) then
       n = count(mask)
    else
       n = size(arrin)
    endif

    if (present(mode_in)) then
       mode = mode_in
    else
       ! Default : Inverse empirical CDF
       mode = 1_i4
    end if

    ! check consistency
    !if (size(k) > size(arr)) stop 'percentile_1d_dp: more Quantiles than data: size(k) > size(arr)'
    if (n < 2) stop 'percentile_1d_dp: n < 2'

    select case (mode)
       ! Inverse empirical CDF: Mathematica default
    case(1_i4)
       kk(:) = k(:)/100._dp*real(n,dp)
       nn1(:) = min(n, max(1_i4,ceiling(kk(:),kind=i4)))
       nn2 = nn1

       ! Linear interpolation (California method)
    case(2_i4)
       kk(:)  = k(:)/100._dp*real(n,dp)
       nn1(:) = min(n, max(1_i4,  floor(kk(:),kind=i4)))
       nn2(:) = min(n, max(1_i4,ceiling(kk(:),kind=i4)))

       ! Element numbered closest
    case(3_i4)
       kk(:) = 0.5_dp+k(:)/100._dp*real(n,dp)
       nn1(:) = min(n, max(1_i4,floor(kk(:),kind=i4)))
       nn2 = nn1

       ! Linear interpolation (hydrologist method)
    case(4_i4)
       kk(:)  = 0.5_dp+k(:)/100._dp*(real(n,dp))
       nn1(:) = min(n, max(1_i4,  floor(kk(:),kind=i4)))
       nn2(:) = min(n, max(1_i4,ceiling(kk(:),kind=i4)))

       ! Mean-based estimate (Weibull method): IMSL default
    case(5_i4)
       kk(:)  = k(:)/100._dp*(real(n,dp)+1._dp)
       nn1(:) = min(n, max(1_i4,  floor(kk(:),kind=i4)))
       nn2(:) = min(n, max(1_i4,ceiling(kk(:),kind=i4)))

       ! Mode-based estimate
    case(6_i4)
       kk(:)  = 1.0_dp+k(:)/100._dp*(real(n,dp)-1._dp)
       nn1(:) = min(n, max(1_i4,  floor(kk(:),kind=i4)))
       nn2(:) = min(n, max(1_i4,ceiling(kk(:),kind=i4)))

       ! Median-based estimate
    case(7_i4)
       kk(:)  = 1.0_dp/3.0_dp+k(:)/100._dp*(real(n,dp)+1.0_dp/3.0_dp)
       nn1(:) = min(n, max(1_i4,  floor(kk(:),kind=i4)))
       nn2(:) = min(n, max(1_i4,ceiling(kk(:),kind=i4)))

       ! Normal distribution estimate
    case(8_i4)
       kk(:)  = 3.0_dp/8.0_dp+k(:)/100._dp*(real(n,dp)+1.0_dp/4.0_dp)
       nn1(:) = min(n, max(1_i4,  floor(kk(:),kind=i4)))
       nn2(:) = min(n, max(1_i4,ceiling(kk(:),kind=i4)))

       ! No valid mode
    case default
       stop 'percentile_1d_dp: mode > 8 not implemented'

    end select

    if (present(mask)) then
       allocate(arr(n))
       arr = pack(arrin,mask)
       do i=1, size(k)
          if (nn1(i) .eq. nn2(i)) then
             ! no interpolation
             percentile_1d_dp(i) = n_element(arr,nn1(i))
          else
             ! interpolation
             ks2 = n_element(arr,nn2(i),previous=ks1)
             percentile_1d_dp(i) = ks1 + (ks2-ks1)*(kk(i)-real(nn1(i),dp))
          end if
       end do
       deallocate(arr)
    else
       do i=1, size(k)
          if (nn1(i) .eq. nn2(i)) then
             ! no interpolation
             percentile_1d_dp(i) = n_element(arrin,nn1(i))
          else
             ! interpolation
             ks2 = n_element(arrin,nn2(i),previous=ks1)
             percentile_1d_dp(i) = ks1 + (ks2-ks1)*(kk(i)-real(nn1(i),dp))
          end if
       end do
    endif

  END function percentile_1d_dp

  function percentile_1d_sp(arrin,k,mask,mode_in)

    IMPLICIT NONE

    REAL(sp),    DIMENSION(:),           INTENT(IN) :: arrin
    REAL(sp),    DIMENSION(:),           INTENT(IN) :: k
    LOGICAL,     DIMENSION(:), OPTIONAL, INTENT(IN) :: mask
    INTEGER(i4),               OPTIONAL, INTENT(IN) :: mode_in

    REAL(sp),    DIMENSION(size(k))                 :: percentile_1d_sp

    INTEGER(i4)                            :: i, n
    INTEGER(i4)                            :: mode
    INTEGER(i4), DIMENSION(size(k))        :: nn1, nn2
    REAL(sp),    DIMENSION(size(k))        :: kk
    REAL(sp)                               :: ks1, ks2
    REAL(sp),    DIMENSION(:), ALLOCATABLE :: arr

    if (present(mask)) then
       n = count(mask)
    else
       n = size(arrin)
    endif

    if (present(mode_in)) then
       mode = mode_in
    else
       ! Default : Inverse empirical CDF
       mode = 1_i4
    end if

    ! check consistency
    !if (size(k) > size(arr)) stop 'percentile_1d_sp: more Quantiles than data: size(k) > size(arr)'
    if (n < 2) stop 'percentile_1d_sp: n < 2'

    select case (mode)
       ! Inverse empirical CDF: Mathematica default
    case(1_i4)
       kk(:) = k(:)/100._sp*real(n,sp)
       nn1(:) = min(n, max(1_i4,ceiling(kk(:),kind=i4)))
       nn2 = nn1

       ! Linear interpolation (California method)
    case(2_i4)
       kk(:)  = k(:)/100._sp*real(n,sp)
       nn1(:) = min(n, max(1_i4,  floor(kk(:),kind=i4)))
       nn2(:) = min(n, max(1_i4,ceiling(kk(:),kind=i4)))

       ! Element numbered closest
    case(3_i4)
       kk(:) = 0.5_sp+k(:)/100._sp*real(n,sp)
       nn1(:) = min(n, max(1_i4,floor(kk(:),kind=i4)))
       nn2 = nn1

       ! Linear interpolation (hydrologist method)
    case(4_i4)
       kk(:)  = 0.5_sp+k(:)/100._sp*(real(n,sp))
       nn1(:) = min(n, max(1_i4,  floor(kk(:),kind=i4)))
       nn2(:) = min(n, max(1_i4,ceiling(kk(:),kind=i4)))

       ! Mean-based estimate (Weibull method): IMSL default
    case(5_i4)
       kk(:)  = k(:)/100._sp*(real(n,sp)+1._sp)
       nn1(:) = min(n, max(1_i4,  floor(kk(:),kind=i4)))
       nn2(:) = min(n, max(1_i4,ceiling(kk(:),kind=i4)))

       ! Mode-based estimate
    case(6_i4)
       kk(:)  = 1.0_sp+k(:)/100._sp*(real(n,sp)-1._sp)
       nn1(:) = min(n, max(1_i4,  floor(kk(:),kind=i4)))
       nn2(:) = min(n, max(1_i4,ceiling(kk(:),kind=i4)))

       ! Median-based estimate
    case(7_i4)
       kk(:)  = 1.0_sp/3.0_sp+k(:)/100._sp*(real(n,sp)+1.0_sp/3.0_sp)
       nn1(:) = min(n, max(1_i4,  floor(kk(:),kind=i4)))
       nn2(:) = min(n, max(1_i4,ceiling(kk(:),kind=i4)))

       ! Normal distribution estimate
    case(8_i4)
       kk(:)  = 3.0_sp/8.0_sp+k(:)/100._sp*(real(n,sp)+1.0_sp/4.0_sp)
       nn1(:) = min(n, max(1_i4,  floor(kk(:),kind=i4)))
       nn2(:) = min(n, max(1_i4,ceiling(kk(:),kind=i4)))

       ! No valid mode
    case default
       stop 'percentile_1d_sp: mode > 8 not implemented'

    end select

    if (present(mask)) then
       allocate(arr(n))
       arr = pack(arrin,mask)
       do i=1, size(k)
          if (nn1(i) .eq. nn2(i)) then
             ! no interpolation
             percentile_1d_sp(i) = n_element(arr,nn1(i))
          else
             ! interpolation
             ks2 = n_element(arr,nn2(i),previous=ks1)
             percentile_1d_sp(i) = ks1 + (ks2-ks1)*(kk(i)-real(nn1(i),sp))
          end if
       end do
       deallocate(arr)
    else
       do i=1, size(k)
          if (nn1(i) .eq. nn2(i)) then
             ! no interpolation
             percentile_1d_sp(i) = n_element(arrin,nn1(i))
          else
             ! interpolation
             ks2 = n_element(arrin,nn2(i),previous=ks1)
             percentile_1d_sp(i) = ks1 + (ks2-ks1)*(kk(i)-real(nn1(i),sp))
          end if
       end do
    endif

  END function percentile_1d_sp

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

  function qmedian_dp(dat)

    IMPLICIT NONE

    real(dp), dimension(:), intent(inout) :: dat
    real(dp) :: qmedian_dp

    real(dp) :: w
    integer(i4) :: n,k
    integer(i4) :: l,r,i,j

    n = size(dat)
    k = n/2 + 1
    l = 1
    r = n
    do while( l < r )
       qmedian_dp = dat(k)
       i = l
       j = r
       do
          do while( dat(i) < qmedian_dp )
             i = i + 1
          enddo
          do while( qmedian_dp < dat(j) )
             j = j - 1
          enddo
          if ( i <= j ) then
             w      = dat(i)
             dat(i) = dat(j)
             dat(j) = w
             i = i + 1
             j = j - 1
          endif
          if ( i > j ) exit
       enddo
       if ( j < k ) l = i
       if ( k < i ) r = j
    enddo
    if (mod(n,2) == 0) then
       qmedian_dp = 0.5_dp*(dat(k) + maxval(dat(:k-1)))
    else
       qmedian_dp = dat(k)
    endif

  end function qmedian_dp

  function qmedian_sp(dat)

    IMPLICIT NONE

    real(sp), dimension(:), intent(inout) :: dat
    real(sp) :: qmedian_sp

    real(sp) :: w
    integer(i4) :: n,k
    integer(i4) :: l,r,i,j

    n = size(dat)
    k = n/2 + 1
    l = 1
    r = n
    do while( l < r )
       qmedian_sp = dat(k)
       i = l
       j = r
       do
          do while( dat(i) < qmedian_sp )
             i = i + 1
          enddo
          do while( qmedian_sp < dat(j) )
             j = j - 1
          enddo
          if ( i <= j ) then
             w      = dat(i)
             dat(i) = dat(j)
             dat(j) = w
             i = i + 1
             j = j - 1
          endif
          if ( i > j ) exit
       enddo
       if ( j < k ) l = i
       if ( k < i ) r = j
    enddo
    if (mod(n,2) == 0) then
       qmedian_sp = 0.5_sp*(dat(k) + maxval(dat(:k-1)))
    else
       qmedian_sp = dat(k)
    endif

  end function qmedian_sp

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

END MODULE mo_percentile


!*****************************************************************
!*  Sorts a sparse matrix with rows IA, colums IB and            *
!*  elements RA, all of length N, in ascending order, rows first *
!*  then columns by the Heapsort method                          *
!* ------------------------------------------------------------- *
!* INPUTS:                                                       *
!*	    N	  size of tables IA, IB and RA                   *
!*          IA	  rowindex to be sorted                          *
!*          IB	  columnindex to be sorted                       *
!*          RA	  matrix element                                 *
!* OUTPUT:                                                       *
!*	    IA    rowindex table sorted in ascending order       *
!*	    IB    columnindex table sorted in ascending order    *
!*	    RA    matrix element table sorted                    *
!*                                                               *
!* NOTE: The Heapsort method is a N Log2 N routine,              *
!*       and can be used for very large arrays.                  *
!*                                                               *
!* ORIGINAL CODE: Numerical Recipes (C) Press et al.             *
!* Modified for sparse matrices by Frank Everdij 19/02/2008      *
!*****************************************************************

SUBROUTINE HEAPSORT2(IA,IB,IC,N)

  implicit none
  integer IA(N), IB(N), IC(N), N

  integer IIA, IIB, IIC, I, J, L, IR

  L=N/2+1
  IR=N
  !The index L will be decremented from its initial value during the
  !"hiring" (heap creation) phase. Once it reaches 1, the index IR
  !will be decremented from its initial value down to 1 during the
  !"retirement-and-promotion" (heap selection) phase.
10 continue
  if(L > 1)then
    L=L-1
    IIA=IA(L)
    IIB=IB(L)
    IIC=IC(L)
  else
    IIA=IA(IR)
    IIB=IB(IR)
    IIC=IC(IR)
    IA(IR)=IA(1)
    IB(IR)=IB(1)
    IC(IR)=IC(1)
    IR=IR-1
    if(IR.eq.1)then
      IA(1)=IIA
      IB(1)=IIB
      IC(1)=IIC
      return
    end if
  end if
  I=L
  J=L+L
20 if(J.le.IR)then
  if(J < IR)then
    if((IA(J) < IA(J+1)) .or. ((IA(J) .eq. IA(J+1)) .and. (IB(J) < IB(J+1))))  J=J+1
  end if
  if((IIA < IA(J)) .or. ((IIA .eq. IA(J)) .and. (IIB < IB(J)))) then
    IA(I)=IA(J)
    IB(I)=IB(J)
    IC(I)=IC(J)
    I=J; J=J+J
  else
    J=IR+1
  end if
  goto 20
  end if
  IA(I)=IIA
  IB(I)=IIB
  IC(I)=IIC
  goto 10
END

SUBROUTINE HEAPSORT3(RA,RB,N)

  implicit none
  integer N
  real(8) RA(N), RB(N)

  integer I, J, L, IR
  real(8) RRA, RRB

  L=N/2+1
  IR=N
  !The index L will be decremented from its initial value during the
  !"hiring" (heap creation) phase. Once it reaches 1, the index IR
  !will be decremented from its initial value down to 1 during the
  !"retirement-and-promotion" (heap selection) phase.
10 continue
  if(L > 1)then
    L=L-1
    RRA=RA(L)
    RRB=RB(L)
  else
    RRA=RA(IR)
    RRB=RB(IR)
    RA(IR)=RA(1)
    RB(IR)=RB(1)
    IR=IR-1
    if(IR.eq.1)then
      RA(1)=RRA
      RB(1)=RRB
      return
    end if
  end if
  I=L
  J=L+L
20 if(J.le.IR)then
  if(J < IR)then
    if((RA(J) < RA(J+1)) .or. ((RA(J) == RA(J+1)) .and. (RB(J) < RB(J+1))))  J=J+1
  end if
  if((RRA < RA(J)) .or. ((RRA == RA(J)) .and. (RRB < RB(J)))) then
    RA(I)=RA(J)
    RB(I)=RB(J)
    I=J; J=J+J
  else
    J=IR+1
  end if
  goto 20
  end if
  RA(I)=RRA
  RB(I)=RRB
  goto 10
END


PROGRAM main
!
! Purpose:
!  Just for homework 7 in chapter6
!
! Record of revisions:
!    Date   Programmer  Description of change
!    ====   ==========  =====================
!  04/12/17  hopeful       Original code
!
IMPLICIT NONE

INTEGER :: dec

! test
call test(256)
call test(63)
call test(140)
call test(768)

WRITE (*,'(A)') 'Please input a integer between 0 and 1023:'
READ  (*,*) dec
call test(dec)
END PROGRAM main

SUBROUTINE test(dec)
IMPLICIT NONE

INTEGER :: dec
CHARACTER*10, EXTERNAL :: dec2bin

WRITE (*,'(A,I4,A,A)') 'The Binary number of ', dec , ' is ', dec2bin(dec)

END SUBROUTINE test

CHARACTER(len=*) FUNCTION dec2bin(dec)
IMPLICIT NONE

INTEGER :: dec
INTEGER :: ndec
INTEGER :: I

ndec = dec
DO I = LEN(dec2bin), 0, -1
    WRITE (dec2bin(I:I),'(I1)') mod(ndec,2)
    ndec = ndec / 2
    !IF (ndec == 0) EXIT
END DO
!WRITE (*,'(B10)') dec

RETURN
END FUNCTION dec2bin


      SUBROUTINE TB01UY( JOBZ, N, M1, M2, P, A, LDA, B, LDB, C, LDC,
     $                   NCONT, INDCON, NBLK, Z, LDZ, TAU, TOL, IWORK,
     $                   DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To find a controllable realization for the linear time-invariant
C     multi-input system
C
C             dX/dt = A * X + B1 * U1 + B2 * U2,
C                Y  = C * X,
C
C     where A, B1, B2 and C are N-by-N, N-by-M1, N-by-M2, and P-by-N
C     matrices, respectively, and A and [B1,B2] are reduced by this
C     routine to orthogonal canonical form using (and optionally
C     accumulating) orthogonal similarity transformations, which are
C     also applied to C.  Specifically, the system (A, [B1,B2], C) is
C     reduced to the triplet (Ac, [Bc1,Bc2], Cc), where
C     Ac = Z' * A * Z, [Bc1,Bc2] = Z' * [B1,B2], Cc = C * Z,  with
C
C             [ Acont     *    ]                [ Bcont1, Bcont2 ]
C        Ac = [                ],   [Bc1,Bc1] = [                ],
C             [   0    Auncont ]                [   0        0   ]
C
C        and
C
C                [ A11 A12  . . .  A1,p-2 A1,p-1 A1p ]
C                [ A21 A22  . . .  A2,p-2 A2,p-1 A2p ]
C                [ A31 A32  . . .  A3,p-2 A3,p-1 A3p ]
C                [  0  A42  . . .  A4,p-2 A4,p-1 A4p ]
C        Acont = [  .   .   . . .    .      .     .  ],
C                [  .   .     . .    .      .     .  ]
C                [  .   .       .    .      .     .  ]
C                [  0   0   . . .  Ap,p-2 Ap,p-1 App ]
C
C                    [ B11 B12 ]
C                    [  0  B22 ]
C                    [  0   0  ]
C                    [  0   0  ]
C        [Bc1,Bc2] = [  .   .  ],
C                    [  .   .  ]
C                    [  .   .  ]
C                    [  0   0  ]
C
C     where the blocks  B11, B22, A31, ..., Ap,p-2  have full row ranks and
C     p is the controllability index of the pair (A,[B1,B2]).  The size of the
C     block  Auncont  is equal to the dimension of the uncontrollable
C     subspace of the pair (A,[B1,B2]).
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOBZ    CHARACTER*1
C             Indicates whether the user wishes to accumulate in a
C             matrix Z the orthogonal similarity transformations for
C             reducing the system, as follows:
C             = 'N':  Do not form Z and do not store the orthogonal
C                     transformations;
C             = 'F':  Do not form Z, but store the orthogonal
C                     transformations in the factored form;
C             = 'I':  Z is initialized to the unit matrix and the
C                     orthogonal transformation matrix Z is returned.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the original state-space representation,
C             i.e., the order of the matrix A.  N >= 0.
C
C     M1      (input) INTEGER
C             The number of system inputs in U1, or of columns of B1.
C             M1 >= 0.
C
C     M2      (input) INTEGER
C             The number of system inputs in U2, or of columns of B2.
C             M2 >= 0.
C
C     P       (input) INTEGER
C             The number of system outputs, or of rows of C.  P >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the original state dynamics matrix A.
C             On exit, the leading N-by-N part of this array contains
C             the transformed state dynamics matrix Ac = Z'*A*Z. The
C             leading NCONT-by-NCONT diagonal block of this matrix,
C             Acont, is the state dynamics matrix of a controllable
C             realization for the original system. The elements below
C             the second block-subdiagonal are set to zero.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension
C             (LDB,M1+M2)
C             On entry, the leading N-by-(M1+M2) part of this array must
C             contain the compound input matrix B = [B1,B2], where B1 is
C             N-by-M1 and B2 is N-by-M2.
C             On exit, the leading N-by-(M1+M2) part of this array
C             contains the transformed compound input matrix [Bc1,Bc2] =
C             Z'*[B1,B2]. The leading NCONT-by-(M1+M2) part of this
C             array, [Bcont1, Bcont2], is the compound input matrix of
C             a controllable realization for the original system.
C             All elements below the first block-diagonal are set to
C             zero.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the output matrix C.
C             On exit, the leading P-by-N part of this array contains
C             the transformed output matrix Cc, given by C * Z.
C
C     LDC     INTEGER
C             The leading dimension of the array C.  LDC >= MAX(1,P).
C
C     NCONT   (output) INTEGER
C             The order of the controllable state-space representation.
C
C     INDCON  (output) INTEGER
C             The controllability index of the controllable part of the
C             system representation.
C
C     NBLK    (output) INTEGER array, dimension (2*N)
C             The leading INDCON elements of this array contain the
C             orders of the diagonal blocks of Acont. INDCON is always
C             an even number, and the INDCON/2 odd and even components
C             of NBLK have decreasing values, respectively.
C             Note that some elements of NBLK can be zero.
C
C     Z       (output) DOUBLE PRECISION array, dimension (LDZ,N)
C             If JOBZ = 'I', then the leading N-by-N part of this
C             array contains the matrix of accumulated orthogonal
C             similarity transformations which reduces the given system
C             to orthogonal canonical form.
C             If JOBZ = 'F', the elements below the diagonal, with the
C             array TAU, represent the orthogonal transformation matrix
C             as a product of elementary reflectors. The transformation
C             matrix can then be obtained by calling the LAPACK Library
C             routine DORGQR.
C             If JOBZ = 'N', the array Z is not referenced and can be
C             supplied as a dummy array (i.e., set parameter LDZ = 1 and
C             declare this array to be Z(1,1) in the calling program).
C
C     LDZ     INTEGER
C             The leading dimension of the array Z. If JOBZ = 'I' or
C             JOBZ = 'F', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1.
C
C     TAU     (output) DOUBLE PRECISION array, dimension (MIN(N,M1+M2))
C             The elements of TAU contain the scalar factors of the
C             elementary reflectors used in the reduction of [B1,B2]
C             and A.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance to be used in rank determinations when
C             transforming (A, [B1,B2]). If the user sets TOL > 0, then
C             the given value of TOL is used as a lower bound for the
C             reciprocal condition number (see the description of the
C             argument RCOND in the SLICOT routine MB03OD);  a
C             (sub)matrix whose estimated condition number is less than
C             1/TOL is considered to be of full rank.  If the user sets
C             TOL <= 0, then an implicitly computed, default tolerance,
C             defined by  TOLDEF = N*N*EPS,  is used instead, where EPS
C             is the machine precision (see LAPACK Library routine
C             DLAMCH).
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (MAX(M1,M2))
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.  LDWORK >= 1, and
C             LDWORK >= MAX(N, 3*MAX(M1,M2), P), if MIN(N,M1+M2) > 0.
C             For optimum performance LDWORK should be larger.
C
C             If LDWORK = -1, then a workspace query is assumed; the
C             routine only calculates the optimal size of the DWORK
C             array, returns this value as the first entry of the DWORK
C             array, and no error message related to LDWORK is issued by
C             XERBLA.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The implemented algorithm [1] represents a specialization of the
C     controllability staircase algorithm of [2] to the special structure
C     of the input matrix B = [B1,B2].
C
C     REFERENCES
C
C     [1] Varga, A.
C         Reliable algorithms for computing minimal dynamic covers.
C         Proc. CDC'2003, Hawaii, 2003.
C
C     [2] Varga, A.
C         Numerically stable algorithm for standard controllability
C         form determination.
C         Electronics Letters, vol. 17, pp. 74-75, 1981.
C
C     NUMERICAL ASPECTS
C                               3
C     The algorithm requires 0(N ) operations and is backward stable.
C
C     FURTHER COMMENTS
C
C     If the system matrices A and B are badly scaled, it would be
C     useful to scale them with SLICOT routine TB01ID, before calling
C     the routine.
C
C     CONTRIBUTOR
C
C     A. Varga, DLR Oberpfaffenhofen, March 2003.
C
C     REVISIONS
C
C     A. Varga, DLR Oberpfaffenhofen, April 2003, December 2006.
C     V. Sima, December 2016, April 2017.
C
C     KEYWORDS
C
C     Controllability, minimal realization, orthogonal canonical form,
C     orthogonal transformation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         JOBZ
      INTEGER           INDCON, INFO, LDA, LDB, LDC, LDWORK, LDZ, M1,
     $                  M2, N, NCONT, P
      DOUBLE PRECISION  TOL
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), TAU(*),
     $                  Z(LDZ,*)
      INTEGER           IWORK(*), NBLK(*)
C     .. Local Scalars ..
      LOGICAL           B1RED, LJOBF, LJOBI, LJOBZ, LQUERY
      INTEGER           IQR, ITAU, J, JB2, JQR, M, MCRT, MCRT1,
     $                  MCRT2, MINWRK, NCRT, NI, NJ, RANK, WRKOPT
      DOUBLE PRECISION  ANORM, BNORM, FNRM, FNRM2, FNRMA, TOLDEF
C     .. Local Arrays ..
      DOUBLE PRECISION  SVAL(3)
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH, DLANGE
      EXTERNAL          DLAMCH, DLANGE, LSAME
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DLACPY, DLAPMT, DLASET, DORGQR, DORMQR,
     $                  MB01PD, MB03OY, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, INT, MAX, MIN
C     ..
C     .. Executable Statements ..
C
      INFO  = 0
      LJOBF = LSAME( JOBZ, 'F' )
      LJOBI = LSAME( JOBZ, 'I' )
      LJOBZ = LJOBF.OR.LJOBI
      M = M1 + M2
C
C     Test the input scalar arguments.
C
      IF( .NOT.LJOBZ .AND. .NOT.LSAME( JOBZ, 'N' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( M1.LT.0 ) THEN
         INFO = -3
      ELSE IF( M2.LT.0 ) THEN
         INFO = -4
      ELSE IF( P.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -11
      ELSE IF( LDZ.LT.1 .OR. ( LJOBZ .AND. LDZ.LT.N ) ) THEN
         INFO = -16
      ELSE
         IF( MIN( N, M ).EQ.0 ) THEN
            MINWRK = 1
         ELSE
            MINWRK = MAX( N, 3*MAX( M1, M2 ), P )
         END IF
C
         LQUERY = LDWORK.LT.0
         IF( LQUERY ) THEN
            MCRT = MAX( M1, M2 )
            RANK = MIN( N, MCRT )
            CALL DORMQR( 'Left', 'Transpose', N, MCRT, RANK, B, LDB,
     $                   TAU, B, LDB, DWORK, -1, INFO )
            WRKOPT = MAX( MINWRK, INT( DWORK(1) ) )
            CALL DORMQR( 'Left', 'Transpose', N, N, RANK, B, LDB, TAU,
     $                   A, LDA, DWORK, -1, INFO )
            WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) )
            CALL DORMQR( 'Right', 'No transpose', P, N, RANK, B, LDB,
     $                   TAU, C, LDC, DWORK, -1, INFO )
            WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) )
            IF( LJOBI .AND. N.GT.0 ) THEN
               CALL DORGQR( N, N, N-1, Z, LDZ, TAU, DWORK, -1, INFO )
               WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) )
            END IF
         ELSE IF( LDWORK.LT.MINWRK ) THEN
            INFO = -21
         END IF
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'TB01UY', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         DWORK(1) = WRKOPT
         RETURN
      END IF
C
      NCONT  = 0
      INDCON = 0
C
C     Quick return if possible.
C
      IF( N.EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
C     Calculate the absolute norms of A and B (used for scaling).
C
      ANORM = DLANGE( 'M', N, N, A, LDA, DWORK )
      BNORM = DLANGE( 'M', N, M, B, LDB, DWORK )
C
C     Return if matrix B is zero.
C
      IF( BNORM.EQ.ZERO ) THEN
         IF( LJOBI ) THEN
            CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
         ELSE IF( LJOBF .AND. N.GT.1 ) THEN
            CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, Z(2,1), LDZ )
            CALL DLASET( 'Full', MIN( N, M ), 1, ZERO, ZERO, TAU, N )
         END IF
         DWORK(1) = ONE
         RETURN
      END IF
C
C     Scale (if needed) the matrices A and B.
C
      CALL MB01PD( 'S', 'G', N, N, 0, 0, ANORM, 0, NBLK, A, LDA, INFO )
      CALL MB01PD( 'S', 'G', N, M, 0, 0, BNORM, 0, NBLK, B, LDB, INFO )
C
C     Compute the Frobenius norm of B1 (used for rank estimation of B1).
C     In the loop, then use the Frobenius norm of B2 and then of A.
C
      FNRM  = DLANGE( 'F', N, M1, B, LDB, DWORK )
      FNRMA = DLANGE( 'F', N, N,  A, LDA, DWORK )
      IF( M2.GT.0 ) THEN
         FNRM2 = DLANGE( 'F', N, M2, B(1,M1+1), LDB, DWORK )
      ELSE
         FNRM2 = ZERO
      END IF
C
      TOLDEF = TOL
      IF( TOLDEF.LE.ZERO ) THEN
C
C        Use the default tolerance in controllability determination.
C
         TOLDEF = DBLE( N*N )*DLAMCH( 'EPSILON' )
      END IF
C
      WRKOPT = 1
      NI = 0
      NJ = 0
      ITAU = 1
      NCRT = N
      MCRT1 = M1
      MCRT2 = M2
      MCRT = MCRT1
      IQR  = 1
      JQR = 1
      B1RED = .TRUE.
      JB2 = MIN( M1+1, M )
C
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of real workspace needed at that point in the
C     code, as well as the preferred amount for good performance.
C     NB refers to the optimal block size for the immediately
C     following subroutine, as returned by ILAENV.)
C
   10 CONTINUE
C
C        Rank-revealing QR decomposition with column pivoting.
C        The calculation is performed in NCRT rows of B starting from
C        the row IQR.
C        Workspace: 3*MAX(MCRT1,MCRT2).
C
         CALL MB03OY( NCRT, MCRT, B(IQR,JQR), LDB, TOLDEF, FNRM, RANK,
     $                SVAL, IWORK, TAU(ITAU), DWORK, INFO )
C
         IF( RANK.EQ.0 ) THEN
            IF( B1RED ) THEN
               IF( MCRT2.GT.0 ) THEN
                  B1RED  = .NOT.B1RED
                  INDCON = INDCON + 1
                  NBLK(INDCON) = 0
                  IF( INDCON.EQ.1 ) THEN
                     FNRM = FNRM2
                  ELSE IF( INDCON.GT.2 ) THEN
                     NJ = NJ + MCRT
                  END IF
                  MCRT1 = 0
                  MCRT  = MCRT2
                  JQR   = JB2
                  IF( INDCON.GE.2 ) THEN
                     IF( INDCON.EQ.2 )
     $                  FNRM = FNRMA
                     CALL DLACPY( 'G', NCRT, MCRT, A(NCONT+1,NJ+1),
     $                            LDA, B(IQR,JQR), LDB )
                     CALL DLASET( 'G', NCRT, MCRT, ZERO, ZERO,
     $                            A(NCONT+1,NJ+1), LDA )
                  END IF
                  GO TO 10
               END IF
            ELSE
               IF( MCRT1.GT.0 ) THEN
                  B1RED  = .NOT.B1RED
                  INDCON = INDCON + 1
                  NBLK(INDCON) = 0
                  MCRT2 = 0
                  MCRT  = MCRT1
                  JQR   = 1
                  IF( INDCON.GE.2 ) THEN
                     IF( INDCON.EQ.2 ) THEN
                        FNRM = FNRMA
                     ELSE IF( INDCON.GT.2 ) THEN
                        NJ = NJ + MCRT
                     END IF
                     CALL DLACPY( 'G', NCRT, MCRT, A(NCONT+1,NJ+1),
     $                            LDA, B(IQR,JQR), LDB )
                     CALL DLASET( 'G', NCRT, MCRT, ZERO, ZERO,
     $                            A(NCONT+1,NJ+1), LDA )
                  END IF
                  GO TO 10
               END IF
               INDCON = INDCON - 1
            END IF
         ELSE
            NI     = NCONT
            NCONT  = NCONT + RANK
            INDCON = INDCON + 1
            NBLK(INDCON) = RANK
C
C           Premultiply the appropriate block row of B2 by Q'.
C           Workspace: need   MCRT2;
C                      prefer MCRT2*NB.
C
            IF( INDCON.LT.2 ) THEN
               FNRM = FNRM2
               CALL DORMQR( 'Left', 'Transpose', NCRT, MCRT2, RANK,
     $                      B(IQR,JQR), LDB, TAU(ITAU),
     $                      B(NI+1,JB2), LDB, DWORK, LDWORK, INFO )
               WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) )
            END IF
C
C           Premultiply and postmultiply the appropriate block row
C           and block column of A by Q' and Q, respectively.
C           Workspace: need   N;
C                      prefer N*NB.
C
            CALL DORMQR( 'Left', 'Transpose', NCRT, N-NJ, RANK,
     $                   B(IQR,JQR), LDB, TAU(ITAU), A(NI+1,NJ+1), LDA,
     $                   DWORK, LDWORK, INFO )
            WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) )
C
C           Workspace: need   N;
C                      prefer N*NB.
C
            CALL DORMQR( 'Right', 'No transpose', N, NCRT, RANK,
     $                   B(IQR,JQR), LDB, TAU(ITAU), A(1,NI+1), LDA,
     $                   DWORK, LDWORK, INFO )
            WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) )
C
C           Postmultiply the appropriate block column of C by Q.
C           Workspace: need   P;
C                      prefer P*NB.
C
            CALL DORMQR( 'Right', 'No transpose', P, NCRT, RANK,
     $                   B(IQR,JQR), LDB, TAU(ITAU), C(1,NI+1), LDC,
     $                   DWORK, LDWORK, INFO )
            WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) )
C
C           If required, save transformations.
C
            IF( LJOBZ .AND. NCRT.GT.1 ) THEN
               CALL DLACPY( 'L', NCRT-1, MIN( RANK, NCRT-1 ),
     $                      B(IQR+1,JQR), LDB, Z(NI+2,ITAU), LDZ )
            END IF
C
C           Zero the subdiagonal elements of the current matrix.
C
            IF( RANK.GT.1 )
     $         CALL DLASET( 'L', RANK-1, RANK-1, ZERO, ZERO,
     $                      B(IQR+1,JQR), LDB )
C
C           Backward permutation of the columns of B or A.
C
            IF( INDCON.LE.2 ) THEN
               IF( INDCON.EQ.2 )
     $            FNRM = FNRMA
               CALL DLAPMT( .FALSE., RANK, MCRT, B(IQR,JQR), LDB,
     $                      IWORK )
               IQR = IQR + RANK
            ELSE
               DO 20 J = 1, MCRT
                  CALL DCOPY( RANK, B(IQR,JQR+J-1), 1,
     $                        A(NI+1,NJ+IWORK(J)), 1 )
   20          CONTINUE
            END IF
C
            ITAU = ITAU + RANK
            IF( RANK.NE.NCRT ) THEN
               IF( INDCON.GT.2 )
     $            NJ = NJ + MCRT
               IF( B1RED ) THEN
                  MCRT1 = RANK
                  MCRT  = MCRT2
                  JQR   = JB2
               ELSE
                  MCRT2 = RANK
                  MCRT  = MCRT1
                  JQR   = 1
               END IF
               NCRT = NCRT - RANK
               IF( INDCON.GE.2 ) THEN
                  CALL DLACPY( 'G', NCRT, MCRT, A(NCONT+1,NJ+1), LDA,
     $                         B(IQR,JQR), LDB )
                  CALL DLASET( 'G', NCRT, MCRT, ZERO, ZERO,
     $                         A(NCONT+1,NJ+1), LDA )
               END IF
               B1RED = .NOT.B1RED
               GO TO 10
            ELSE
               IF( B1RED ) THEN
                  INDCON = INDCON + 1
                  NBLK(INDCON) = 0
               END IF
            END IF
         END IF
C     End loop 10.
C
C     If required, accumulate transformations.
C     Workspace: need N;  prefer N*NB.
C
      IF( LJOBI ) THEN
         CALL DORGQR( N, N, MAX( 1, ITAU-1 ), Z, LDZ, TAU, DWORK,
     $                LDWORK, INFO )
         WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) )
      END IF
C
C     Annihilate the trailing blocks of B1 and B2.
C
      IF( NBLK(1).LT.N )
     $   CALL DLASET( 'G', N-NBLK(1), M1, ZERO, ZERO,
     $                B(NBLK(1)+1,1), LDB )
      IF( IQR.LE.N )
     $   CALL DLASET( 'G', N-IQR+1, M2, ZERO, ZERO, B(IQR,JB2), LDB )
C
C     Annihilate the trailing elements of TAU, if JOBZ = 'F'.
C
      IF( LJOBF ) THEN
         DO 30 J = ITAU, MIN( N, M )
            TAU(J) = ZERO
   30    CONTINUE
      END IF
C
C     Undo scaling of A and B.
C
      CALL MB01PD( 'U', 'G', N, N, 0, 0, ANORM, 0, NBLK, A, LDA, INFO )
      CALL MB01PD( 'U', 'G', NBLK(1)+NBLK(2), M, 0, 0, BNORM, 0, NBLK,
     $             B, LDB, INFO )
C
C     Set optimal workspace dimension.
C
      DWORK(1) = WRKOPT
      RETURN
C *** Last line of TB01UY ***
      END


program parameter_example
  integer, parameter :: &
    number_of_states = 50, &
    number_of_senators_per_state = 2, &
    number_of_senators = &
    number_of_states*number_of_senators_per_state

  print*, &
    "There are", number_of_states, &
    "states in the united stated of america"
  print*, &
    "From this we can calculate that there are"
  print*, number_of_senators, &
    "senators in the united states senate."
end program parameter_example


  program create_Hamming_window

! create a "pseudo plane wave" source file using tapering based on a Hamming window

! Dimitri Komatitsch, CNRS Marseille, France, February 2014,
! based on discussions with Paul Cristini, also from CNRS Marseille, France.

  implicit none

! pi
  double precision, parameter :: PI = 3.141592653589793d0

  integer, parameter :: NSOURCES = 1000

! the plane wave will extend in the vertical direction from zmin to zmax
! and its amplitude in between will vary as a Hamming apodization window
  double precision, parameter :: xs_center = -0.1d0
  double precision, parameter :: zs_center = 0.07d0
  double precision, parameter :: zs_size   = 0.43d0
  double precision, parameter :: zs_min = zs_center - zs_size/2.d0
  double precision, parameter :: zs_max = zs_center + zs_size/2.d0

! angle in degrees by which we rotate the plane wave
  double precision, parameter :: angle_rotate_source = -45.d0 * (PI / 180.d0)

  double precision, parameter :: factor_max = 1.d10

  integer :: isource

  double precision :: x,hamming,xs,zs,xval,zval,xprime,zprime

  do isource = 1,NSOURCES

! Hamming apodization window
! see e.g. http://docs.scipy.org/doc/numpy/reference/generated/numpy.hamming.html
! and http://www.mathworks.fr/fr/help/signal/ref/hamming.html
    x = dble(isource - 1) / dble(NSOURCES - 1)
    hamming = 0.54d0 - 0.46d0*cos(2*PI*x)

    xs = xs_center
    zs = zs_min + x * zs_size

! subtract the position of the center of rotation
    xval = xs - xs_center
    zval = zs - zs_center

! rotate it
    xprime = xval*cos(angle_rotate_source) - zval*sin(angle_rotate_source)
    zprime = xval*sin(angle_rotate_source) + zval*cos(angle_rotate_source)

! add the position of the center of rotation back
    xprime = xprime + xs_center
    zprime = zprime + zs_center

    write(*,*) '# source ',isource
    write(*,*) 'source_surf                     = .false.'
    write(*,*) 'xs                              = ',xprime
    write(*,*) 'zs                              = ',zprime
    write(*,*) 'source_type                     = 1'
    write(*,*) 'time_function_type              = 1'
    write(*,*) 'f0                              = 1.d6'
    write(*,*) 't0                              = 0.d0'
    write(*,*) 'angleforce                      = 0.0'
    write(*,*) 'Mxx                             = 1.'
    write(*,*) 'Mzz                             = 1.'
    write(*,*) 'Mxz                             = 0.'
    write(*,*) 'factor                          = ',factor_max * hamming

  enddo

  end program create_Hamming_window


       SUBROUTINE FFTFWD(A,M)
! COMPUTES AND RETURNS THE FORWARD FFT.  THIS IS BASICALLY THE ONE TAKEN
! FROM OPPENHEIM AND SCHAFER, PAGE 331.
! ARGUMENTS:
! A - THE COMPLEX INPUT ARRAY TO BE TRANSFORMED.  THIS IS ALSO THE OUTPUT!!
! M - THE POWER OF 2 OF THE FFT.  THERE MUST BE 2**M COMPLEX POINTS IN A.
!
      COMPLEX A(1),U,W,T
      DATA PI/3.1415926535/
      N=2**M
      NV2=N/2
      NM1=N-1
      J=1
      DO I=1,NM1    !   was do 7
         IF( i .LT. j ) THEN
             T=A(J)
             A(J)=A(I)
             A(I)=T
         ENDIF
         K=NV2
6        IF( k .LT. j ) THEN
             J=J-K
             K=K/2
             GOTO 6
         ENDIF
         J=J+K
7     ENDDO
      LE=1
      DO L=1,M    !  was DO 20
         LE1=LE
         LE=2*LE
         U=(1.,0.)
         B=PI/FLOAT(LE1)
         W=CMPLX(COS(B),SIN(B))
         DO J=1,LE1    ! was do 20
            DO I=J,N,LE   ! was do 10
               IP=I+LE1
               T=A(IP)*U
               A(IP)=A(I)-T
               A(I)=A(I)+T
10          ENDDO
20          U=U*W
         ENDDO
      ENDDO    !   U is reset on each interation of the loop
      RETURN
      END


      REAL*8 FUNCTION PKFTBV(NBITS,IBIT)

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    PKFTBV
C   PRGMMR: JATOR            ORG: NP12       DATE: 2005-11-29
C
C ABSTRACT:  THIS FUNCTION COMPUTES AND RETURNS THE VALUE EQUIVALENT
C   TO THE SETTING OF BIT# IBIT WITHIN A FLAG TABLE OF NBITS BITS.
C   IF THE COMPUTATION FAILS FOR ANY REASON, THEN THE VALUE BMISS
C   (10E10) IS RETURNED.  NOTE THAT THIS SUBROUTINE IS THE LOGICAL
C   INVERSE OF BUFRLIB SUBROUTINE UPFTBV.
C
C PROGRAM HISTORY LOG:
C 2005-11-29  J. ATOR    -- ORIGINAL VERSION
C
C USAGE:    PKFTBV (NBITS,IBIT)
C   INPUT ARGUMENT LIST:
C     NBITS    - INTEGER: NUMBER OF BITS IN FLAG TABLE
C     IBIT     - INTEGER: NUMBER OF BIT TO BE SET WITHIN FLAG TABLE
C
C   OUTPUT ARGUMENT LIST:
C     PKFTBV   - REAL*8: VALUE EQUIVALENT TO THE SETTING OF BIT# IBIT
C                WITHIN A FLAG TABLE OF NBITS BITS.
C
C REMARKS:
C    THIS ROUTINE CALLS:        None
C    THIS ROUTINE IS CALLED BY: None
C                               Normally called only by application
C                               programs.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C   MACHINE:  PORTABLE TO ALL PLATFORMS
C
C$$$

      INCLUDE 'bufrlib.prm'

C----------------------------------------------------------------------
C----------------------------------------------------------------------

      IF((NBITS.LE.0).OR.(IBIT.LE.0).OR.(IBIT.GT.NBITS)) THEN
          PKFTBV = BMISS
      ELSE
          PKFTBV = (2.)**(NBITS-IBIT)
      ENDIF

      RETURN
      END


module fluxlimiter_module

  use amrex_fort_module, only : rt => amrex_real
  implicit none

  integer, save :: limiter = 0
  integer, save :: closure = 0

  real(rt)        , parameter :: OneThird = 1.e0_rt/3.e0_rt, TwoThirds=2.e0_rt/3.e0_rt, &
       OneSixth=1.e0_rt/6.e0_rt, TwoNinths=2.e0_rt/9.e0_rt, FiveNinths=5.e0_rt/9.e0_rt

  contains

    subroutine init_fluxlimiter_module(limiter_in, closure_in)
      use amrex_fort_module, only : rt => amrex_real
      implicit none
      integer, intent(in) :: limiter_in, closure_in
      limiter = limiter_in
      closure = closure_in
    end subroutine init_fluxlimiter_module

    function FLDlambda(r, limiter_in)
      use amrex_fort_module, only : rt => amrex_real
      integer, intent(in), optional :: limiter_in
      real(rt)        , intent(in) :: r
      real(rt)         :: FLDlambda
      integer :: limiter_local
      if (present(limiter_in))then
         limiter_local = limiter_in
      else
         limiter_local = limiter
      end if
      if (limiter_local .eq. 0) then ! no limiter
         FLDlambda = OneThird
      else if (limiter_local < 10) then  ! approximate LP, [123]
         FLDlambda = (2.e0_rt + r) / (6.e0_rt + r * (3.e0_rt + r))
      else if (limiter_local < 20) then  ! Bruenn, 1[123]
         FLDlambda = 1.e0_rt / (3.e0_rt + r)
      else if (limiter_local < 30) then  ! Larsen's square root, 2[123]
         FLDlambda = 1.e0_rt / sqrt(9.e0_rt + r**2)
      else if (limiter_local < 40) then  ! Minerbo, 3[123]
         if (r .lt. 1.5e0_rt) then
            FLDlambda = 2.e0_rt/(3.e0_rt + sqrt(9.e0_rt+12.e0_rt*r**2))
         else
            FLDlambda = 1.e0_rt/(1.e0_rt+r+sqrt(1.e0_rt+2.e0_rt*r))
         end if
      else
         print *, "Unknown limiter ", limiter_local
         stop
      endif
    end function FLDlambda

    function Edd_factor(lambda) result(f)
      use amrex_fort_module, only : rt => amrex_real
      real(rt)        , intent(in) :: lambda
      real(rt)         :: f
      if (closure .eq. 0) then
         f = lambda
      else if (closure .eq. 1) then
         f = OneThird
      else if (closure .eq. 2) then
         f = 1.e0_rt - 2.e0_rt * lambda
      else if (closure .eq. 3) then ! lambda + (lambda*R)**2
         if (limiter .eq. 0) then ! no limiter
            f = OneThird
         else if (limiter < 10) then  ! approximate LP, [123]
            f = lambda + 0.25e0_rt*((1.e0_rt-3.e0_rt*lambda) + &
                 sqrt((1.e0_rt-3.e0_rt*lambda)*(1.e0_rt+5.e0_rt*lambda)))**2
         else if (limiter < 20) then  ! Bruenn, 1[123]
            f = 1.0e0_rt - 5.e0_rt*lambda + 9.e0_rt*lambda**2
         else if (limiter < 30) then  ! Larsen's square root, 2[123]
            f = 1.0e0_rt + lambda - 9.e0_rt*lambda**2
         else if (limiter < 40) then  ! Minerbo
            if (lambda .gt. TwoNinths) then
               f = OneThird
            else
               f = 1.e0_rt + 3.e0_rt*lambda - 2.e0_rt*sqrt(2.e0_rt*lambda)
            end if
         else
            print *, "Unknown limiter ", limiter
            stop
         endif
      else if (closure .eq. 4) then ! 1/3 + 2/3*(lambda*R)**2
         if (limiter .eq. 0) then ! no limiter
            f = OneThird
         else if (limiter < 10) then  ! approximate LP, [123]
            f = OneThird + OneSixth*((1.e0_rt-3.e0_rt*lambda) + &
                 sqrt((1.e0_rt-3.e0_rt*lambda)*(1.e0_rt+5.e0_rt*lambda)))**2
         else if (limiter < 20) then  ! Bruenn, 1[123]
            f = OneThird + TwoThirds*(1.0e0_rt - 6.e0_rt*lambda + 9.e0_rt*lambda**2)
         else if (limiter < 30) then  ! Larsen's square root, 2[123]
            f = OneThird + TwoThirds*(1.0e0_rt - 9.e0_rt*lambda**2)
         else if (limiter < 40) then  ! Minerbo
            if (lambda .gt. TwoNinths) then
               f = FiveNinths - TwoThirds*lambda
            else
               f = OneThird + TwoThirds*(1.e0_rt + 2.e0_rt*lambda - 2.e0_rt*sqrt(2.e0_rt*lambda))
            end if
         else
            print *, "Unknown limiter ", limiter
            stop
         endif
      end if
    end function Edd_factor

    function FLDalpha(lam) result(alpha)
      use amrex_fort_module, only : rt => amrex_real
      real(rt)        , intent(in) :: lam
      real(rt)         :: alpha, R, omtl, cr
      omtl = max(0.e0_rt, 1.e0_rt-3.e0_rt*lam)
      if (limiter .eq. 0) then ! no limiter
         R = 0.e0_rt
      else if (limiter < 10) then  ! approximate LP, [123]
         R = (omtl + sqrt(omtl*(1.e0_rt+5.e0_rt*lam))) / (2.e0_rt*lam+1.e-50_rt)
      else if (limiter < 20) then  ! Bruenn, 1[123]
         R =omtl/(lam+1.e-50_rt)
      else if (limiter < 30) then  ! Larsen's square root, 2[123]
         R = sqrt(omtl*(1.e0_rt+3.e0_rt*lam)) / (lam+1.e-50_rt)
      else if (limiter < 40) then  ! Minerbo
         if (lam .gt. TwoNinths) then
            R = sqrt(omtl/3.e0_rt) / (lam+1.e-50_rt)
         else
            R = 1.e0_rt/(lam+1.e-50_rt) - sqrt(2.e0_rt/(lam+1.e-50_rt))
         end if
      else
         print *, "Unknown limiter ", limiter
         stop
      endif

      if (R .lt. 1.e-6_rt) then
         alpha = 0.25e0_rt
      else if ( R .gt. 300.e0_rt) then
         alpha = 0.5e0_rt
      else
         cr = cosh(R)
         alpha = cr*log(cr) / (2.e0_rt*R*sinh(R))
      end if
    end function FLDalpha

end module fluxlimiter_module

subroutine ca_initfluxlimiter(limiter, closure)  bind(C, name="ca_initfluxlimiter")
  use fluxlimiter_module, only : init_fluxlimiter_module
  use amrex_fort_module, only : rt => amrex_real
  implicit none
  integer, intent(in) :: limiter, closure
  call init_fluxlimiter_module(limiter, closure)
end subroutine ca_initfluxlimiter


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c Compute the correlation coefficient rho for every pixel in the search
c area and return in matrix R.

c This version of compute_R ignores pixels in data gaps or off the
c edge in the calculation of rho.

      subroutine compute_R_gap(A,ia,ja,B,ib,jb,R,ir,jr)
      implicit none
c Inputs...
      integer ia,ja
      integer*2 A(-ia:ia,-ja:ja)	!shape template.
      integer ib,jb
      integer*2 B(-ib:ib,-jb:jb)	!search window centered at D(snom,lnom)
      integer ir,jr
c Output...
      real*4 R(-ir:ir,-jr:jr)		!rho for every pixel in search area

c Local variables...
      integer ii,jj		!window W is centered over B(ii,jj)
      integer i,j
      integer aij		!aij = A(i,j)
      integer wij		!wij = B(i+ii,j+jj)
      real sa,sw,sa2,saw,sw2	!sums of A and W
      real meana,meanw		!mean of A and mean of W
      real vara,varw,covaw	!variance of A and W and covariance of A and W
      real*4 fract
      integer narea		!number of pixels in correlation window
      real n			!number of valid pixels in correlation window

      narea = (2*ia+1)*(2*ja+1)	!total number of pixels in template A
      fract = 0.5		!fraction of pixels required for computation

c Compute rho for every pixel in the search area...

      do 20 jj=-jr,jr		!search area row index
      do 10 ii=-ir,ir		!search area column index
      sa = 0
      sw = 0
      sa2 = 0
      saw = 0
      sw2 = 0
      n = 0

c     ...compute rho for window W centered at B(ii,jj)
      do j=-ja,ja		!shape template row index
         do i=-ia,ia		!shape template col index
            aij = A(i,j)	!pixel in A
            wij = B(i+ii,j+jj)	!corresponding pixel in W
            if (wij.ge.0) then	!do if the pixel is valid
               sa = sa + aij
               sw = sw + wij
               sa2 = sa2 + aij**2
               saw = saw +aij*wij
               sw2 = sw2 + wij**2
               n = n + 1
            endif
         enddo
      enddo

      R(ii,jj) = -999		!initialize as invalid
      if (n.lt.fract*narea) goto 10	!reject if too few valid pixels
      meanw = sw/n
      varw = sw2/n - meanw**2	!variance of B
      if (varw.le.0) goto 10	!if no pulse, rho has no meaning.
      meana = sa/n
      vara = sa2/n - meana**2	!variance of A
      covaw = saw/n - meana*meanw
      R(ii,jj) = covaw/sqrt(vara*varw)
   10 continue
   20 continue

      return
      end