subroutine r8mat_expm1 ( n, a, e )

!*****************************************************************************80
!
!! R8MAT_EXPM1 is essentially MATLAB's built-in matrix exponential algorithm.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    26 November 2011
!
!  Author:
!
!    Cleve Moler, Charles Van Loan
!
!  Reference:
!
!    Cleve Moler, Charles VanLoan,
!    Nineteen Dubious Ways to Compute the Exponential of a Matrix,
!    Twenty-Five Years Later,
!    SIAM Review,
!    Volume 45, Number 1, March 2003, pages 3-49.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the dimension of the matrix.
!
!    Input, real ( kind = 8 ) A(N,N), the matrix.
!
!    Output, real ( kind = 8 ) E(N,N), the estimate for exp(A).
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ) a(n,n)
  real ( kind = 8 ) a2(n,n)
  real ( kind = 8 ) a_norm
  real ( kind = 8 ) c
  real ( kind = 8 ) d(n,n)
  real ( kind = 8 ) e(n,n)
  integer ( kind = 4 ) ee
  integer ( kind = 4 ) k
  logical p
  integer ( kind = 4 ) , parameter :: q = 6
  real ( kind = 8 ) r8_log_2
  real ( kind = 8 ) r8mat_norm_li
  integer ( kind = 4 ) s
  real ( kind = 8 ) x(n,n)

  a2(1:n,1:n) = a(1:n,1:n)

  a_norm = r8mat_norm_li ( n, n, a2 )

  ee = int ( r8_log_2 ( a_norm ) ) + 1

  s = max ( 0, ee + 1 )

  a2(1:n,1:n) = a2(1:n,1:n) / 2.0D+00**s

  x(1:n,1:n) = a2(1:n,1:n)

  c = 0.5D+00

  call r8mat_identity ( n, e )
  e(1:n,1:n) = e(1:n,1:n) + c * a2(1:n,1:n)

  call r8mat_identity ( n, d )
  d(1:n,1:n) = d(1:n,1:n) - c * a2(1:n,1:n)

  p = .true.

  do k = 2, q

    c = c * real ( q - k + 1, kind = 8 ) &
      / real ( k * ( 2 * q - k + 1 ), kind = 8 )

    x(1:n,1:n) = matmul ( a2(1:n,1:n), x(1:n,1:n) )

    e(1:n,1:n) = e(1:n,1:n) + c * x(1:n,1:n)

    if ( p ) then
      d(1:n,1:n) = d(1:n,1:n) + c * x(1:n,1:n)
    else
      d(1:n,1:n) = d(1:n,1:n) - c * x(1:n,1:n)
    end if

    p = .not. p

  end do
!
!  E -> inverse(D) * E
!
  call r8mat_minvm ( n, n, d, e, e )
!
!  E -> E^(2*S)
!
  do k = 1, s
    e(1:n,1:n) = matmul ( e(1:n,1:n), e(1:n,1:n) )
  end do

  return
end

subroutine r8mat_expm2 ( n, a, e )
!*****************************************************************************80
!
!! R8MAT_EXPM2 uses the Taylor series for the matrix exponential.
!
!  Discussion:
!
!    Formally,
!
!      exp ( A ) = I + A + 1/2 A^2 + 1/3! A^3 + ...
!
!    This function sums the series until a tolerance is satisfied.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    26 November 2011
!
!  Author:
!
!    Cleve Moler, Charles Van Loan
!
!  Reference:
!
!    Cleve Moler, Charles VanLoan,
!    Nineteen Dubious Ways to Compute the Exponential of a Matrix,
!    Twenty-Five Years Later,
!    SIAM Review,
!    Volume 45, Number 1, March 2003, pages 3-49.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the dimension of the matrix.
!
!    Input, real ( kind = 8 ) A(N,N), the matrix.
!
!    Output, real ( kind = 8 ) E(N,N), the estimate for exp(A).
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ) a(n,n)
  real ( kind = 8 ) e(n,n)
  real ( kind = 8 ) f(n,n)
  integer ( kind = 4 ) k
  logical r8mat_is_insignificant

  e(1:n,1:n) = 0.0D+00

  call r8mat_identity ( n, f )

  k = 1

  do

    if ( r8mat_is_insignificant ( n, n, e, f ) ) then
      exit
    end if

    e(1:n,1:n) = e(1:n,1:n) + f(1:n,1:n)

    f(1:n,1:n) = matmul ( a(1:n,1:n), f(1:n,1:n) ) / real ( k, kind = 8 )
    k = k + 1

  end do

  return
end


program Stooge
  implicit none

  integer :: i
  integer :: array(50) = (/ (i, i = 50, 1, -1) /) ! Reverse sorted array

  call Stoogesort(array)
  write(*,"(10i5)") array

contains

recursive subroutine Stoogesort(a)
  integer, intent(in out) :: a(:)
  integer :: j, t, temp

   j = size(a)
   if(a(j) < a(1)) then
     temp = a(j)
     a(j) = a(1)
     a(1) = temp
   end if

  if(j > 2) then
    t = j / 3
    call Stoogesort(a(1:j-t))
    call Stoogesort(a(1+t:j))
    call Stoogesort(a(1:j-t))
  end if

end subroutine
end program


c
c  routines adapted from Numerical Recipes
c
c  reichle, 20 Apr 01
c
c
c  ***********************************************************************
c
c  ------- documentation from C function ---------
c
c  LU decomposition after Numerical Recipes
c
c  Given a matrix a[1..n][1..n], this routine replaces it by the
c  LU decomposition of a rowwise permutation of itself. a and n are
c  inputs. a is output, arranged as in equation (2.3.14) (see book).
c  indx[1..n] is an output vector that records the row permutation
c  effected by the partial pivoting; This routine is used in combination
c  with lubksb to solve linear equations or invert a matrix.
c
c  edited 20 Apr 01, reichle
c
c  - eliminated d (for computation of determinant)
c  - eliminated np (can use automatic arrays nowadays...)
c
c  edited 03 Jun 02, reichle
c
c  - eliminated parameter NMAX, using dynamic allocation
c
c  -----------------------------------------------------
c
      SUBROUTINE ludcmp(a,n,indx)
      INTEGER n,indx(n)
      REAL a(n,n),TINY
      PARAMETER (TINY=1.0e-20)
      INTEGER i,imax,j,k
      REAL aamax,dum,sum,vv(n)
      do 12 i=1,n
         aamax=0.
         do 11 j=1,n
            if (abs(a(i,j)).gt.aamax) aamax=abs(a(i,j))
 11      continue
         if (aamax.eq.0.) pause 'singular matrix in ludcmp'
         vv(i)=1./aamax
 12   continue
      do 19 j=1,n
         do 14 i=1,j-1
            sum=a(i,j)
            do 13 k=1,i-1
               sum=sum-a(i,k)*a(k,j)
 13         continue
            a(i,j)=sum
 14      continue
         aamax=0.
         do 16 i=j,n
            sum=a(i,j)
           do 15 k=1,j-1
              sum=sum-a(i,k)*a(k,j)
 15        continue
           a(i,j)=sum
           dum=vv(i)*abs(sum)
           if (dum.ge.aamax) then
              imax=i
              aamax=dum
           endif
 16     continue
        if (j.ne.imax)then
           do 17 k=1,n
              dum=a(imax,k)
              a(imax,k)=a(j,k)
              a(j,k)=dum
 17        continue
           vv(imax)=vv(j)
        endif
        indx(j)=imax
        if(a(j,j).eq.0.)a(j,j)=TINY
        if(j.ne.n)then
           dum=1./a(j,j)
           do 18 i=j+1,n
              a(i,j)=a(i,j)*dum
 18        continue
        endif
 19   continue
      return
      END

c  ***********************************************************************
c
c  ------- documentation from C function ---------
c
c  LU backsubstitution after Numerical Recipes
c
c  Solves the set of n linear equations A X = B. Here a[1..n][1..n] is
c  input, not as the matrix A but rather as its LU decomposition,
c  determined by the routine ludcmp. indx[1..n] is input as the permutation
c  vector returned by ludcmp. b[1..n] is input as the right-hand side
c  vector B, and returns the solution vector X. a,n, and indx ar not
c  modified by this routine and can be left in place for successive calls
c  with different right-hand sides b. This routine takes into account
c  the possibility that b will begin with many zero elements, so it is
c  efficient for use in matrix inversion.
c
c  edited 20 Apr 01, reichle
c
c  - eliminated np (can use automatic arrays nowadays...)
c
c  -----------------------------------------------------
c
      SUBROUTINE lubksb(a,n,indx,b)
      INTEGER n,indx(n)
      REAL a(n,n),b(n)
      INTEGER i,ii,j,ll
      REAL sum
      ii=0
      do 12 i=1,n
         ll=indx(i)
         sum=b(ll)
         b(ll)=b(i)
         if (ii.ne.0)then
            do 11 j=ii,i-1
               sum=sum-a(i,j)*b(j)
 11         continue
         else if (sum.ne.0.) then
            ii=i
         endif
         b(i)=sum
 12   continue
      do 14 i=n,1,-1
         sum=b(i)
         do 13 j=i+1,n
            sum=sum-a(i,j)*b(j)
 13      continue
         b(i)=sum/a(i,i)
 14   continue
      return
      END
c
c
c ********** EOF ******************************************************


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                          Spherepack                           *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!
! ... file isfvpgc.f
!
!     this file includes documentation and code for
!     subroutine isfvpgc          i
!
! ... files which must be loaded with isfvpgc.f
!
!     type_SpherepackUtility.f, type_RealPeriodicFastFourierTransform.f, vhsgc.f, shagc.f, compute_gaussian_latitudes_and_weights.f
!
!
!     subroutine isfvpgc(nlat, nlon, isym, nt, sf, vp, idv, jdv, as, bs, av, bv,
!    +                   mdb, ndb, wvhsgc, lvhsgc, work, lwork, ierror)
!
!     given the scalar spherical harmonic coefficients as, bs precomputed
!     by shagc for the scalar stream function sf and av, bv precomputed by
!     shagc for the scalar velocity potenital vp, subroutine isfvpgc computes
!     the vector field (v, w) corresponding to sf and vp.  w is the east
!     longitudinal and v is the colatitudinal component of the vector field.
!     (v, w) is expressed in terms of sf, vp by the helmholtz relations (in
!     mathematical spherical coordinates):
!
!          v = -1/sin(theta)*d(vp)/dlambda + d(st)/dtheta
!
!          w =  1/sin(theta)*d(st)/dlambda + d(vp)/dtheta
!
!     required legendre functions are recomputed rather than stored as
!     they are in subroutine isfvpgs.  v(i, j) and w(i, j) are given at
!     the i(th) gaussian colatitude point (see compute_gaussian_latitudes_and_weights) theta(i) and east
!     longitude lambda(j) = (j-1)*2.*pi/nlon on the sphere.
!
!     input parameters
!
!     nlat   the number of points in the gaussian colatitude grid on the
!            full sphere. these lie in the interval (0, pi) and are computed
!            in radians in theta(1) <...< theta(nlat) by subroutine compute_gaussian_latitudes_and_weights.
!            if nlat is odd the equator will be included as the grid point
!            theta((nlat + 1)/2).  if nlat is even the equator will be
!            excluded as a grid point and will lie half way between
!            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
!            note: on the half sphere, the number of grid points in the
!            colatitudinal direction is nlat/2 if nlat is even or
!            (nlat + 1)/2 if nlat is odd.
!
!     nlon   the number of distinct londitude points.  nlon determines
!            the grid increment in longitude as 2*pi/nlon. for example
!            nlon = 72 for a five degree grid. nlon must be greater than
!            3.  the efficiency of the computation is improved when nlon
!            is a product of small prime numbers.
!
!
!     isym   a parameter which determines whether the vector field is
!            computed on the full or half sphere as follows:
!
!      = 0
!
!            the symmetries/antsymmetries described in isym=1, 2 below
!            do not exist in sf, vp about the equator.  in this case v
!            and w are not necessarily symmetric or antisymmetric about
!            equator.  v and w are computed on the entire sphere.
!            i.e., in arrays sf(i, j), vp(i, j) for i=1, ..., nlat and
!            j=1, ..., nlon.
!
!      = 1
!
!            vp is antisymmetric and sf is symmetric about the equator.
!            in this case v is symmetric and w antisymmetric about
!            the equator and are computed for the northern hemisphere
!            only.  i.e., if nlat is odd the v(i, j), w(i, j) are computed
!            for i=1, ..., (nlat + 1)/2 and for j=1, ..., nlon.  if nlat is
!            even then v(i, j), w(i, j) are computed for i=1, ..., nlat/2
!            and j=1, ..., nlon.
!
!      = 2
!
!            vp is symmetric and sf is antisymmetric about the equator.
!            in this case v is antisymmetric and w symmetric about
!            the equator and are computed for the northern hemisphere
!            only.  i.e., if nlat is odd the v(i, j), w(i, j) are computed
!            for i=1, ..., (nlat + 1)/2 and for j=1, ..., nlon.  if nlat is
!            even then v(i, j), w(i, j) are computed for i=1, ..., nlat/2
!            and j=1, ..., nlon.
!
!     nt     nt is the number of scalar and vector fields.  some
!            computational efficiency is obtained for multiple fields. arrays
!            can be three dimensional corresponding to an indexed multiple
!            vector field.  in this case multiple vector synthesis will
!            be performed to compute (v, w) for each field.  the
!            third index is the synthesis index which assumes the values
!            k=1, ..., nt.  for a single synthesis set nt = 1.  the
!            description of the remaining parameters is simplified by
!            assuming that nt=1 or that all the arrays are two dimensional.
!
!     idv    the first dimension of the arrays v, w as it appears in
!            the program that calls isfvpgc. if isym = 0 then idv
!            must be at least nlat.  if isym = 1 or 2 and nlat is
!            even then idv must be at least nlat/2. if isym = 1 or 2
!            and nlat is odd then idv must be at least (nlat + 1)/2.
!
!     jdv    the second dimension of the arrays v, w as it appears in
!            the program that calls isfvpgc. jdv must be at least nlon.
!
!     as, bs  two or three dimensional arrays (see input parameter nt)
!            that contain the spherical harmonic coefficients of
!            the scalar field sf as computed by subroutine shagc.
!
!     av, bv  two or three dimensional arrays (see input parameter nt)
!            that contain the spherical harmonic coefficients of
!            the scalar field vp as computed by subroutine shagc.
!
!     mdb    the first dimension of the arrays as, bs, av, bv as it
!            appears in the program that calls isfvpgc. mdb must be at
!            least min(nlat, nlon/2) if nlon is even or at least
!            min(nlat, (nlon + 1)/2) if nlon is odd.
!
!     ndb    the second dimension of the arrays as, bs, av, bv as it
!            appears in the program that calls isfvpgc. ndb must be at
!            least nlat.
!
!     wvhsgc an array which must be initialized by subroutine vhsgci.
!            once initialized, wvhsgc can be used repeatedly by isfvpgc
!            as long as nlon and nlat remain unchanged.  wvhsgc must
!            not bel altered between calls of isfvpgc.
!
!
!     lvhsgc the dimension of the array wvhsgc as it appears in the
!            program that calls isfvpgc. define
!
!               l1 = min(nlat, nlon/2) if nlon is even or
!               l1 = min(nlat, (nlon + 1)/2) if nlon is odd
!
!            and
!
!               l2 = nlat/2        if nlat is even or
!               l2 = (nlat + 1)/2    if nlat is odd
!
!            then lvhsgc must be at least
!
!
!               4*nlat*l2+3*max(l1-2, 0)*(2*nlat-l1-1)+nlon+15
!
!
!     work   a work array that does not have to be saved.
!
!     lwork  the dimension of the array work as it appears in the
!            program that calls isfvpgc. define
!
!               l1 = min(nlat, nlon/2) if nlon is even or
!               l1 = min(nlat, (nlon + 1)/2) if nlon is odd
!
!            and
!
!               l2 = nlat/2                    if nlat is even or
!               l2 = (nlat + 1)/2                if nlat is odd
!
!            if isym = 0 then lwork must be at least
!
!               nlat*(2*nt*nlon+max(6*l2, nlon)+4*l1*nt+1)
!
!            if isym = 1 or 2 then lwork must be at least
!
!               l2*(2*nt*nlon+max(6*nlat, nlon))+nlat*(4*l1*nt+1)
!
!     **************************************************************
!
!     output parameters
!
!    v, w    two or three dimensional arrays (see input parameter nt)
!           that contains the vector field corresponding to the stream
!           function sf and velocity potential vp whose coefficients,
!           as, bs (for sf) and av, bv (for vp), were precomputed by
!           subroutine shagc.  v(i, j) and w(i, j) are given at the
!           i(th) gaussian colatitude point theta(i) and east longitude
!           point lambda(j) = (j-1)*2*pi/nlon.  the index ranges are
!           defined above at the input parameter isym.
!
!
!    ierror = 0  no errors
!           = 1  error in the specification of nlat
!           = 2  error in the specification of nlon
!           = 3  error in the specification of isym
!           = 4  error in the specification of nt
!           = 5  error in the specification of idv
!           = 6  error in the specification of jdv
!           = 7  error in the specification of mdb
!           = 8  error in the specification of ndb
!           = 9  error in the specification of lvhsgc
!           = 10 error in the specification of lwork
! **********************************************************************
!
module module_isfvpgc

    use spherepack_precision, only: &
        wp, & ! working precision
        ip ! integer precision

    use vector_synthesis_routines, only: &
        vhsgc

    ! Explicit typing only
    implicit none

    ! Everything is private unless stated otherwise
    private
    public :: isfvpgc

contains

    subroutine isfvpgc(nlat, nlon, isym, nt, v, w, idv, jdv, as, bs, av, bv, &
        mdb, ndb, wvhsgc, lvhsgc, work, lwork, ierror)

        integer(ip) :: nlat, nlon, isym, nt, idv, jdv, mdb, ndb, lvhsgc, lwork, ierror
        real(wp) :: v(idv, jdv, nt), w(idv, jdv, nt)
        real(wp) :: as(mdb, ndb, nt), bs(mdb, ndb, nt)
        real(wp) :: av(mdb, ndb, nt), bv(mdb, ndb, nt)
        real(wp) :: wvhsgc(lvhsgc), work(lwork)
        integer(ip) :: l1, l2, mn, is, lwk, iwk, lwmin
        integer(ip) :: ibr, ibi, icr, ici
        !
        ! Check calling arguments
        !
        ierror = 1
        if (nlat < 3) return
        ierror = 2
        if (nlon < 4) return
        ierror = 3
        if (isym < 0 .or. isym > 2) return
        ierror = 4
        if (nt < 0) return
        ierror = 5
        l2 = (nlat + 1)/2
        if ((isym == 0 .and. idv<nlat) .or. &
            (isym>0 .and. idv<l2)) return
        ierror = 6
        if (jdv < nlon) return
        ierror = 7
        l1 = min(nlat, (nlon + 1)/2)
        if (mdb < min(nlat, (nlon+2)/2)) return
        ierror = 8
        if (ndb < nlat) return
        ierror = 9
        lwmin = 4*nlat*l2+3*max(l1-2, 0)*(2*nlat-l1+1)+nlon+15
        if (lvhsgc < lwmin) return
        ierror = 10
        if (isym == 0) then
            lwmin = nlat*(2*nt*nlon+max(6*l2, nlon)+4*l1*nt+1)
        else
            lwmin = l2*(2*nt*nlon+max(6*nlat, nlon))+nlat*(4*l1*nt+1)
        end if
        if (lwork < lwmin) return
        !
        !     set first dimension for br, bi, cr, ci (as required by vhsgc)
        !
        mn = l1*nlat*nt
        ierror = 0
        !
        ! Set workspace pointer indices
        !
        ibr = 1
        ibi = ibr+mn
        icr = ibi+mn
        ici = icr+mn
        is = ici+mn
        iwk = is+nlat
        lwk = lwork-4*mn-nlat
        call isfvpgc1(nlat, nlon, isym, nt, v, w, idv, jdv, as, bs, av, bv, mdb, &
            ndb, work(ibr), work(ibi), work(icr), work(ici), l1, work(is), &
            wvhsgc, lvhsgc, work(iwk), lwk, ierror)

    contains

        subroutine isfvpgc1(nlat, nlon, isym, nt, v, w, idv, jdv, as, bs, av, bv, &
            mdb, ndb, br, bi, cr, ci, mab, fnn, wvhsgc, lvhsgc, wk, lwk, ierror)

            integer(ip) :: nlat, nlon, isym, nt, idv, jdv, mdb, ndb, mab, lvhsgc, lwk, ierror
            real(wp) :: v(idv, jdv, nt), w(idv, jdv, nt)
            real(wp) :: as(mdb, ndb, nt), bs(mdb, ndb, nt)
            real(wp) :: av(mdb, ndb, nt), bv(mdb, ndb, nt)
            real(wp) :: br(mab, nlat, nt), bi(mab, nlat, nt)
            real(wp) :: cr(mab, nlat, nt), ci(mab, nlat, nt)
            real(wp) :: wvhsgc(lvhsgc), wk(lwk), fnn(nlat)
            integer(ip) :: n, m, mmax, k, ityp
            !
            !     set coefficient multiplyers
            !
            do n=2, nlat
                fnn(n) = -sqrt(real(n*(n-1)))
            end do
            mmax = min(nlat, (nlon + 1)/2)
            !
            !     compute (v, w) coefficients from as, bs, av, bv
            !
            do k=1, nt
                do n=1, nlat
                    do m=1, mab
                        br(m, n, k) = 0.0
                        bi(m, n, k) = 0.0
                        cr(m, n, k) = 0.0
                        ci(m, n, k) = 0.0
                    end do
                end do
                !
                ! Compute m=0 coefficients
                !
                do n=2, nlat
                    br(1, n, k) = -fnn(n)*av(1, n, k)
                    bi(1, n, k) = -fnn(n)*bv(1, n, k)
                    cr(1, n, k) =  fnn(n)*as(1, n, k)
                    ci(1, n, k) =  fnn(n)*bs(1, n, k)
                end do
                !
                !     compute m>0 coefficients using vector spherepack value for mmax
                !
                do m=2, mmax
                    do n=m, nlat
                        br(m, n, k) = -fnn(n)*av(m, n, k)
                        bi(m, n, k) = -fnn(n)*bv(m, n, k)
                        cr(m, n, k) =  fnn(n)*as(m, n, k)
                        ci(m, n, k) =  fnn(n)*bs(m, n, k)
                    end do
                end do
            end do
            !
            !     synthesize br, bi, cr, ci into (v, w)
            !
            select case (isym)
                case (0)
                    ityp = 0
                case (1)
                    ityp = 3
                case (2)
                    ityp = 6
            end select

            call vhsgc(nlat, nlon, ityp, nt, v, w, idv, jdv, br, bi, cr, ci, &
                mab, nlat, wvhsgc, ierror)

        end subroutine isfvpgc1

    end subroutine isfvpgc

end module module_isfvpgc


! chk_erf.f90 --
!     Check if the compiler support the new error and error-complement functions (erf, erfc, erfc_scaled)
!
!     Note: there is a whole list of such special functions defined for the Fortran 2008 standard, not
!     all of them are tested here
!
program chk_erf
    implicit none

    real, dimension(9) :: x = (/ -5.0, -2.0, -1.0, -0.5, 0.0, 0.5, 1.0, 2.0, 5.0 /)
    integer            :: i, n

    write( *, '(a)' ) 'Selected values for the error function and its relatives:'

    write( *, '(5a12)' ) 'x', 'erf', 'erfc', 'erfc scaled'
    do i = 1,size(x)
        write( *, '(f12.4,3e12.4)' ) x(i), erf(x(i)), erfc(x(i)), erfc_scaled(x(i))
    enddo
end program chk_erf


PROGRAM mcerzo

! Code converted using TO_F90 by Alan Miller
! Date: 2004-06-28  Time: 12:58:10

!     ===============================================================
!     Purpose : This program evaluates the complex zeros of error
!     function erf(z) using subroutine CERZO
!     Input:    NT --- Total number of zeros
!     Example:  NT = 10

!     n     complex zeros of erf(z)     n     complex zeros of erf(z)
!     ------------------------------------------------------------------
!     -
!     1   1.450616163 + i 1.880943000   6   4.158998400 + i 4.435571444
!     2   2.244659274 + i 2.616575141   7   4.516319400 + i 4.780447644
!     3   2.839741047 + i 3.175628100   8   4.847970309 + i 5.101588043
!     4   3.335460735 + i 3.646174376   9   5.158767908 + i 5.403332643
!     5   3.769005567 + i 4.060697234  10   5.452192201 + i 5.688837437
!     ===============================================================

IMPLICIT DOUBLE PRECISION (e,p,w)
IMPLICIT COMPLEX *16 (c,z)
DIMENSION zo(100)
WRITE(*,*)'Please Enter NT '
!      READ(*,*)NT
nt=10
WRITE(*,20)nt
CALL cerzo(nt,zo)
WRITE(*,*)'  *****    Please Wait ...    *****'
WRITE(*,*)
WRITE(*,*)'  n        Complex zeros of erf(z)'
WRITE(*,*)'-------------------------------------'
DO  i=1,nt
  WRITE(*,30) i,zo(i)
END DO
20   FORMAT(2X,'NT=',i3)
30   FORMAT(1X,i3,2X,f13.8,2X,2H+i,f13.8)
END PROGRAM mcerzo

SUBROUTINE cerzo(nt,zo)

!     ===============================================================
!     Purpose : Evaluate the complex zeros of error function erf(z)
!     using the modified Newton's iteration method
!     Input :   NT --- Total number of zeros
!     Output:   ZO(L) --- L-th zero of erf(z), L=1,2,...,NT
!     Routine called: CERF for computing erf(z) and erf'(z)
!     ===============================================================

IMPLICIT DOUBLE PRECISION (e,p,w)
IMPLICIT COMPLEX *16 (c,z)
INTEGER, INTENT(IN)                      :: nt
COMPLEX, INTENT(OUT)                     :: zo(nt)

zo=0.0
w=0.0
pi=3.141592653589793D0
DO  nr=1,nt
  pu=DSQRT(pi*(4.0D0*nr-0.5D0))
  pv=pi*DSQRT(2.0D0*nr-0.25D0)
  px=0.5*pu-0.5*DLOG(pv)/pu
  py=0.5*pu+0.5*DLOG(pv)/pu
  z=CMPLX(px,py)
  it=0
  DO WHILE (1==1)
    15     it=it+1
    CALL cerf(z,zf,zd)
    zp=(1.0D0,0.0D0)
    DO  i=1,nr-1
      zp=zp*(z-zo(i))
    END DO
    zfd=zf/zp
    zq=(0.0D0,0.0D0)
    DO  i=1,nr-1
      zw=(1.0D0,0.0D0)
      DO  j=1,nr-1
        IF (j /= i) THEN
          zw=zw*(z-zo(j))
        END IF
      END DO
      zq=zq+zw
    END DO
    zgd=(zd-zq*zfd)/zp
    z=z-zfd/zgd
    w0=w
    w=CDABS(z)
    IF (it <= 50.AND.DABS((w-w0)/w) > 1.0D-11) EXIT
  END DO
  zo(nr)=z
END DO
RETURN
END SUBROUTINE cerzo

SUBROUTINE cerf(z,cer,cder)

!     ==========================================================
!     Purpose: Compute complex Error function erf(z) & erf'(z)
!     Input:   z   --- Complex argument of erf(z)
!     x   --- Real part of z
!     y   --- Imaginary part of z
!     Output:  CER --- erf(z)
!     CDER --- erf'(z)
!     ==========================================================

IMPLICIT DOUBLE PRECISION (a-h,o-z)
COMPLEX *16, INTENT(IN)                  :: z
COMPLEX *16, INTENT(OUT)                 :: cer
COMPLEX *16, INTENT(OUT)                 :: cder

w=0.0
w1=0.0
w2=0.0
eps=1.0D-12
pi=3.141592653589793D0
x=REAL(z)
y=DIMAG(z)
x2=x*x
IF (x <= 3.5D0) THEN
  er=1.0D0
  r=1.0D0
  DO  k=1,100
    r=r*x2/(k+0.5D0)
    er=er+r
    IF (DABS(er-w) <= eps*DABS(er)) EXIT
    w=er
  END DO
  15    c0=2.0D0/DSQRT(pi)*x*DEXP(-x2)
  er0=c0*er
ELSE
  er=1.0D0
  r=1.0D0
  DO  k=1,12
    r=-r*(k-0.5D0)/x2
    er=er+r
  END DO
  c0=DEXP(-x2)/(x*DSQRT(pi))
  er0=1.0D0-c0*er
END IF
IF (y == 0.0D0) THEN
  ERR=er0
  eri=0.0D0
ELSE
  cs=DCOS(2.0D0*x*y)
  ss=DSIN(2.0D0*x*y)
  er1=DEXP(-x2)*(1.0D0-cs)/(2.0D0*pi*x)
  ei1=DEXP(-x2)*ss/(2.0D0*pi*x)
  er2=0.0D0
  DO  n=1,100
    er2=er2+DEXP(-.25D0*n*n)/(n*n+4.0D0*x2)*(2.0D0*x  &
        -2.0D0*x*DCOSH(n*y)*cs+n*DSINH(n*y)*ss)
    IF (DABS((er2-w1)/er2) < eps) EXIT
    w1=er2
  END DO
  30    c0=2.0D0*DEXP(-x2)/pi
  ERR=er0+er1+c0*er2
  ei2=0.0D0
  DO  n=1,100
    ei2=ei2+DEXP(-.25D0*n*n)/(n*n+4.0D0*x2)*(2.0D0*x  &
        *DCOSH(n*y)*ss+n*DSINH(n*y)*cs)
    IF (DABS((ei2-w2)/ei2) < eps) EXIT
    w2=ei2
  END DO
  40    eri=ei1+c0*ei2
END IF
cer=CMPLX(ERR,eri)
cder=2.0D0/DSQRT(pi)*CDEXP(-z*z)
RETURN
END SUBROUTINE cerf


C PROGRAM FOR MONTE CARLO INTEGRATION
C GAURAV RUDRA MALIK, R.NO:23
	F(X)=X**2+1
	G(L)=MOD(1956*L + 178592,67529)
	WRITE(*,*)'INPUT THE UPPER AND LOWER LIMITS'
	READ(*,*)A,B
	WRITE(*,*)'ENTER THE NUMBER OF HITS'
	READ(*,*)N
	WRITE(*,*)'ENTER THE SEED'
	READ(*,*)Q
	DO 1 I=1,N
	Q=G(Q)
	X=Q/67529
	Y=A+(B-A)*X
	S=S+F(Y)/N
1	ENDDO
	WRITE(*,*)'THE INTEGRAL IS FOUND TO BE:',S
	STOP
	END

Result

 INPUT THE UPPER AND LOWER LIMITS
0
1
 ENTER THE NUMBER OF HITS
10000
 ENTER THE SEED
456
 THE INTEGRAL IS FOUND TO BE:  1.33563066


subroutine sseuler(neqn,t0,u0,h,t,u,e)
!
! Subroutine sseuler computes an ODE solution by the
! modified Euler method for one step along the solution
! (by calls to derv to define the ODE derivative vector).
! It also estimates the truncation error of the solution,
! and applies this estimate as a correction to the
! solution vector.
!
! Argument list
!
! neqn number of first order ODEs
!
! t0 initial value of independent variable
!
! u0 initial condition vector of length neqn
!
! h integration step
!
! t independent variable
!
! u ODE solution vector of length neqn after
! one modified Euler step
!
! e estimate of truncation error of the solu-
! tion vector
!
! Double precision coding is used
implicit double precision(a-h,o-z)
!
! Size the arrays
parameter(neq=500)
dimension ut(neq),ut0(neq)
dimension u0(neqn), u(neqn), e(neqn)
!
! Derivative vector at initial (base) point
call derv(neqn,t0,u0,ut0)
!
! First order (Euler) step
do i=1,neqn
u(i)=u0(i)+ut0(i)*h
end do
t=t0+h
!
! Derivative vector at advance point
call derv(neqn,t,u,ut)
!
! Second order step
do i=1,neqn
!
! Truncation error estimate
e(i)=(ut(i)-ut0(i))*h/2.0d0
!
! Second order (modified Euler) solution vector
u(i)=u(i)+e(i)
end do
return
!
! End of sseuler
end


module genquad

! Allows a general weight function (as specified by an external function) for integration.
!   Returns the Gaussian quadrature weights and abscissae corresponding to the
!   set of orthogonal polynomials associated with this weight.
! See:
! Gnauchi, in: "Orthogonal Polynomials: Theory and Practice", Nevai (Ed.). Kluwer, 1990.
! Wheeler, Rocky Mountain Journal of Mathematics, Vol 4, p. 287 (1974)
!
! Written by: George Wilkie (gwilkie@umd.edu)
!

  implicit none

  public :: get_quadrature_rule

  private

  real,dimension(:),allocatable:: a_poly, b_poly
  logical:: inf_flag1, inf_flag2
  real:: epsfac = 1.0
  integer:: poly_type, poly_order

contains
!> Accepts a weighting function (with only one argument), defined as external,
!! calculates the modified moments, and returns the abscissae and weights for a new
!! scheme based on polynomials orthogonal to the given weight function. The method is
!! that of Wheeler. Also described in Numerical Recipes, 3rd ed. section 4.6.2 and 4.6.3.
  subroutine get_quadrature_rule ( &
    wgt_func, &        !< Input: Suitable integration weights as a single-argument function.
                       !!   Defined as "external" in calling routine!
    N_out,&            !< Input: The number of integration points desired
    v0,&               !< Input: The left boundary of the integration domain
    vf,&               !< Input: The right boundary of the integration domain
    out_abscissae, &   !< Output: The abscissae (quadrature points) for integration
    out_wgts, &        !< Output: The integration weights
    inf_flag1_in, &    !< Optional: Set to true to make lower bound -inf
    inf_flag2_in)      !< Optional: Set to true to make upper bound +inf

    use quadpack, only: qagi, qags

    implicit none
    real, external:: wgt_func
    integer,intent(in):: N_out
    real,intent(in):: v0, vf
    real,dimension(1:), intent(inout):: out_abscissae, out_wgts
    logical,optional,intent(in):: inf_flag1_in, inf_flag2_in
    real,dimension(0:N_out):: alpha,beta
    integer:: i, nerr, ier, neval, n
    real:: errest, moment1, moment2

    if( present(inf_flag1_in)) then
       inf_flag1 = inf_flag1_in
    else
       inf_flag1 = .false.
    end if
    if( present(inf_flag2_in)) then
       inf_flag2 = inf_flag2_in
    else
       inf_flag2 = .false.
    end if

    ! Initialize arrays
    call init_general_quad(N_out)

    call set_poly_type()

    ! Calculate the recursion coefficients for the polynomials orthogonal with respect to
    ! new_wgt_fcn
    call calculate_new_coeffs(N_out)

!    b_poly(0) = 0.0

    if (poly_type .EQ. 0) then
       call qags( wgt_x,v0,vf,epsfac*epsilon(0.0),epsfac*epsilon(0.0),moment1,errest,neval,ier)
       call qags( wgt_func,v0,vf,epsfac*epsilon(0.0),epsfac*epsilon(0.0),moment2,errest,neval,ier)
       b_poly(0) = moment2
       a_poly(0) =  moment1/moment2
       poly_order = 1
       call qags( poly_sqx,v0,vf,epsfac*epsilon(0.0),epsfac*epsilon(0.0),moment1,errest,neval,ier)
       call qags( poly_sq,v0,vf,epsfac*epsilon(0.0),epsfac*epsilon(0.0),moment2,errest,neval,ier)
       a_poly(1) = moment1/moment2
       poly_order = 0
       call qags( poly_sq,v0,vf,epsfac*epsilon(0.0),epsfac*epsilon(0.0),moment1,errest,neval,ier)
       b_poly(1) = moment2/moment1
       do n = 2,N_out-1
          poly_order = n
          call qags( poly_sqx,v0,vf,epsfac*epsilon(0.0),epsfac*epsilon(0.0),moment1,errest,neval,ier)
          call qags( poly_sq,v0,vf,epsfac*epsilon(0.0),epsfac*epsilon(0.0),moment2,errest,neval,ier)
          a_poly(n) = moment1/moment2
          poly_order = n-1
          call qags( poly_sq,v0,vf,epsfac*epsilon(0.0),epsfac*epsilon(0.0),moment1,errest,neval,ier)
          b_poly(n) = moment2/moment1
       end do

    else if (poly_type .EQ. 1) then
       call qagi( wgt_x,v0,1,epsfac*epsilon(0.0),epsfac*epsilon(0.0),moment1,errest,neval,ier)
       call qagi( wgt_func,v0,1,epsfac*epsilon(0.0),epsfac*epsilon(0.0),moment2,errest,neval,ier)
       b_poly(0) = moment2
       a_poly(0) =  moment1/moment2
       poly_order = 1
       call qagi( poly_sqx,v0,1,epsfac*epsilon(0.0),epsfac*epsilon(0.0),moment1,errest,neval,ier)
       call qagi( poly_sq,v0,1,epsfac*epsilon(0.0),epsfac*epsilon(0.0),moment2,errest,neval,ier)

       a_poly(1) = moment1/moment2
       poly_order = 0
       call qagi( poly_sq,v0,1,epsfac*epsilon(0.0),epsfac*epsilon(0.0),moment1,errest,neval,ier)
       b_poly(1) = moment2/moment1
       do n = 2,N_out-1
          poly_order = n
          call qagi( poly_sqx,v0,1,epsfac*epsilon(0.0),epsfac*epsilon(0.0),moment1,errest,neval,ier)
          call qagi( poly_sq,v0,1,epsfac*epsilon(0.0),epsfac*epsilon(0.0),moment2,errest,neval,ier)
          a_poly(n) = moment1/moment2
          poly_order = n-1
          call qagi( poly_sq,v0,1,epsfac*epsilon(0.0),epsfac*epsilon(0.0),moment1,errest,neval,ier)
          b_poly(n) = moment2/moment1
       end do

    else if (poly_type .EQ. 2) then
       call qagi( wgt_x,v0,2,epsfac*epsilon(0.0),epsfac*epsilon(0.0),moment1,errest,neval,ier)
       call qagi( wgt_func,v0,2,epsfac*epsilon(0.0),epsfac*epsilon(0.0),moment2,errest,neval,ier)
       b_poly(0) = moment2
       a_poly(0) =  moment1/moment2
       poly_order = 1
       call qagi( poly_sqx,v0,2,epsfac*epsilon(0.0),epsfac*epsilon(0.0),moment1,errest,neval,ier)
       call qagi( poly_sq,v0,2,epsfac*epsilon(0.0),epsfac*epsilon(0.0),moment2,errest,neval,ier)
       a_poly(1) = moment1/moment2
       poly_order = 0
       call qagi( poly_sq,v0,2,epsfac*epsilon(0.0),epsfac*epsilon(0.0),moment1,errest,neval,ier)
       b_poly(1) = moment2/moment1
       do n = 2,N_out-1
          poly_order = n
          call qagi( poly_sqx,v0,2,epsfac*epsilon(0.0),epsfac*epsilon(0.0),moment1,errest,neval,ier)
          call qagi( poly_sq,v0,2,epsfac*epsilon(0.0),epsfac*epsilon(0.0),moment2,errest,neval,ier)
          a_poly(n) = moment1/moment2
          poly_order = n-1
          call qagi( poly_sq,v0,2,epsfac*epsilon(0.0),epsfac*epsilon(0.0),moment1,errest,neval,ier)
          b_poly(n) = moment2/moment1
       end do
    end if

    call solve_jacobi_matrix(N_out,out_abscissae,out_wgts)

    call finish_general_quad()

contains

   real function wgt_x(x)
     implicit none
     real,intent(in):: x
     wgt_x = wgt_func(x)*x
     return
   end function wgt_x

   real function poly_sqx(x)
     implicit none
     real,intent(in):: x
     real:: ym1,y,temp
     integer:: i,j

     ym1 = 0.0
     y = 1.0
     do i = 1,poly_order
       temp = y
       y = (x-a_poly(i-1))*y - b_poly(i-1)*ym1
       ym1 = temp
     end do
     poly_sqx = wgt_func(x)*y*y*x
     return
   end function poly_sqx

   real function poly_sq(x)
     implicit none
     real,intent(in):: x
     real:: ym1,y,temp
     integer:: i,j

     ym1 = 0.0
     y = 1.0
     do i = 1,poly_order
       temp = y
       y = (x-a_poly(i-1))*y - b_poly(i-1)*ym1
       ym1 = temp
     end do
     poly_sq = wgt_func(x)*y*y
     return
   end function poly_sq

  end subroutine get_quadrature_rule

   subroutine set_poly_type()
     implicit none

     if ( (.NOT. inf_flag1) .AND. (.NOT. inf_flag2)) then
        ! Finite domain
        poly_type = 0
     else if ( (.NOT. inf_flag1) .AND. inf_flag2 ) then
        ! Semi-infinite domain
        poly_type = 1
     else if ( inf_flag1 .AND. (.NOT. inf_flag2) ) then
        ! Semi-infinite domain
        poly_type = -1
     else
       ! Infinite domain
       poly_type = 2
     end if

   end subroutine set_poly_type

!> Evaluates a polynomial given recursion coefficients
   real function evaluate_poly(a,b,n,x)
     implicit none
     real,dimension(0:),intent(in):: a,b
     real,intent(in):: x
     integer,intent(in):: n
     real:: y, ym1, temp
     integer:: i,j

     ym1 = 0.0
     y = 1.0
     do i = 1,n
        temp = y
        y = (x-a(i-1))*y - b(i-1)*ym1
        ym1 = temp
     end do

     evaluate_poly = y
     return

   end function evaluate_poly

!> Uses Wheeler's algorithm to obtain the recurrence relation for the new polynomials
!! given the recurrence relation and modified moments of a given set of polynomials (here
!! we use Legendre)
   subroutine calculate_new_coeffs(N)
     implicit none
     integer, intent(in):: N
     integer:: k
     real:: moment1, moment2

     b_poly(0) = 0.0

     if (poly_type .EQ. 1) then

     end if

     contains

    end subroutine calculate_new_coeffs

   subroutine init_general_quad (N)
     implicit none
     integer,intent(in):: N

     allocate(a_poly(0:N-1)); a_poly = 0.0
     allocate(b_poly(0:N-1)); b_poly = 0.0

   end subroutine init_general_quad

!> Finds the eigenvalues and eigenvectors for a symmetric tridiagonal matrix and interprets
!! them as the absissae and weights for Gaussian quadrature. See Numerical Recipes, 3rd Ed.
!! section 4.6.2. Uses the LAPACK routine, given as an external source file.
  subroutine solve_jacobi_matrix(N,abscissae,wgts)
    implicit none
    integer,intent(in):: N
    real,dimension(1:),intent(inout):: abscissae,wgts

    real*8, dimension(0:N-1):: a_use, b_use
    real*8 ,dimension(1:N,1:N):: eigenvectors
    real*8,dimension(1:4*N):: workspace

    integer:: info, i

    b_use = sqrt(b_poly(0:N-1))
    a_use = a_poly(0:N-1)

    call DSTEQR('I',N,a_use(0:N-1),b_use(1:N-1),eigenvectors(1:N,1:N),N,workspace(1:4*N),info)

    if (info .NE. 0) then
       write(*,*) "ERROR: LAPACK returned error code ", info, " in genquad routine."
       write(*,*) "QUADPACK probably couldn't handle large numbers for resolution = ", N
       write(*,*) "Try compiling with quadruple (16-bit) precision."
       write(*,*) "diagonal = ", a_poly(0:N-1)
       write(*,*) "off-diagonal = sqrt ", b_poly(0:N-1)
       write(*,*) "output abscissae = ", a_use
       write(*,*) "output wights = ", (eigenvectors(1,N-i+1)**2,i=1,N)
       stop
    end if

    do i = 1,N
!       abscissae(i) = a_use(N-i)
!       wgts(i) = b_poly(0)* eigenvectors(1,N-i+1)**2
       abscissae(i) = a_use(i-1)
       wgts(i) = b_poly(0)* eigenvectors(1,i)**2
    end do

  end subroutine

   subroutine finish_general_quad
     implicit none

     if(allocated(a_poly)) deallocate(a_poly)
     if(allocated(b_poly)) deallocate(b_poly)

   end subroutine finish_general_quad

end module genquad


SUBROUTINE BuildStencil_1D_Uneven(Nx,rank,x,fx)
!
! A function to compute finite-difference coefficients for the first
! 2*alpha derivatives of a function on a variably spaced grid x(1:N) using
! 2*alpha+1 neighboring points.  N  sets of
! coefficients are returned where set 1,2,...,alpha are one-sided schemes
! at the left end, alpha+1,...,N-alpha are centered schemes, and
! N-alpha+1,...,N  are one-sided schemes at the right end.
!
! By Allan P. Engsig-Karup.
  USE Precision
  IMPLICIT NONE

  INTEGER :: Nx, n, m, ip, alpha, rank,  lwork, info
  INTEGER :: ipiv(rank)
  REAL(kind=long) :: one=1._long, dxmin, fact
  REAL(kind=long) :: fx(rank,rank,Nx), x(Nx), work(5*rank*rank), dx(Nx),   &
       factorial(0:rank-1), mat(rank,rank)

  lwork=5*rank*rank
  alpha=(rank-1)/2

  factorial(0)=one
  Do n=1,rank-1
     factorial(n)=factorial(n-1)*real(n,long)
  END Do
  ! Scale each column of the matrix by the appropriate power of dx_min.
  dxMin=1.E10
  do m=1,Nx-1
     dx(m)=x(m+1)-x(m);
     dxMin=min(abs(dx(m)),dxMin)
  end do
  fact=one/dxMin
  ! One-sided schemes for the left end-points.
  do ip=1,alpha
     do m=1,rank
        do n=1,rank
           mat(m,n)=(fact*(x(m)-x(ip)))**(n-1)/factorial(n-1)
        end do
     end do

     CALL dgetrf(rank,rank,mat,rank,ipiv,info)
     IF(info/=0)THEN
        PRINT *, 'Problems with L-U of the finite-difference matrix',info,info
        STOP
     END IF
     CALL dgetri(rank,mat,rank,ipiv,work,lwork,info)
     IF(info/=0)THEN                    ! and invert it
        PRINT *, 'Problems with inversion of the finite-difference matrix',info,info
        STOP
     END IF
     ! Re-scale by the dx factor and re-order.
     Do n=2,rank
        Do m=1,rank
           fx(m,n,ip)=fact**(n-1)*mat(n,m)
        END Do
     END Do
  end do
  ! The centered schemes
  do ip=alpha+1,Nx-alpha
     DO m=-alpha,alpha
        Do n=1,rank
           mat(m+alpha+1,n)=(fact*(x(ip+m)-x(ip)))**(n-1)/factorial(n-1);
        end Do
     end DO
     CALL dgetrf(rank,rank,mat,rank,ipiv,info)
     IF(info/=0)THEN
        PRINT *, 'Problems with L-U of the finite-difference matrix',info,info
        STOP
     END IF
     CALL dgetri(rank,mat,rank,ipiv,work,lwork,info)
     IF(info/=0)THEN                    ! and invert it
        PRINT *, 'Problems with inversion of the finite-difference matrix',info,info
        STOP
     END IF
     ! Re-scale by the dx factor.
     Do n=2,rank
        Do m=1,rank
           fx(m,n,ip)=fact**(n-1)*mat(n,m)
        END Do
     END Do
  end do

  ! One-sided schemes for the right end-points.
  Do ip=Nx-alpha+1,Nx
     Do n=1,rank
        Do m=1,rank
           mat(m,n)=(fact*(x(Nx-rank+m)-x(ip)))**(n-1)/factorial(n-1);
        end Do
     end Do
     CALL dgetrf(rank,rank,mat,rank,ipiv,info)
     IF(info/=0)THEN
        PRINT *, 'Problems with L-U of the finite-difference matrix',info,info
        STOP
     END IF
     CALL dgetri(rank,mat,rank,ipiv,work,lwork,info)
     IF(info/=0)THEN                    ! and invert it
        PRINT *, 'Problems with inversion of the finite-difference matrix',info,info
        STOP
     END IF
! Re-scale by the dx factor.
     Do n=2,rank
        Do m=1,rank
           fx(m,n,ip)=fact**(n-1)*mat(n,m)
        END Do
     END Do
  end do

  RETURN
END SUBROUTINE BuildStencil_1D_Uneven


!----------------------------------------------------------------------
! Module: tools_const
!> Purpose: usual constants
!>

!> Author: Benjamin Menetrier
!>

!> Licensing: this code is distributed under the CeCILL-C license
!>

!> Copyright © 2017 METEO-FRANCE
!----------------------------------------------------------------------
module tools_const

use tools_missing, only: msr,isnotmsr
implicit none

! Constants
real,parameter :: pi=acos(-1.0)    !< Pi
real,parameter :: deg2rad=pi/180.0 !< Degree to radian
real,parameter :: rad2deg=180.0/pi !< Radian to degree
real,parameter :: req=6.371e6      !< Earth radius
real,parameter :: epsilon=1.0e-12  !< Small parameter
real,parameter :: ps=101325.0      !< Reference surface pressure

private
public :: pi,deg2rad,rad2deg,req,ps,epsilon
public :: lonmod,sphere_dist,vector_product,vector_triple_product

contains

!----------------------------------------------------------------------
! Function: lonmod
!> Purpose: set longitude between -pi and pi
!----------------------------------------------------------------------
real function lonmod(lon)

implicit none

! Passed variables
real,intent(in) :: lon !< Longitude

! Check bounds
lonmod = lon
if (lonmod>pi) then
   lonmod = lonmod-2.0*pi
elseif (lonmod<-pi) then
   lonmod = lonmod+2.0*pi
end if

end function lonmod

!----------------------------------------------------------------------
! Function: sphere_dist
!> Purpose: compute the great-circle distance between two points
!----------------------------------------------------------------------
subroutine sphere_dist(lon_i,lat_i,lon_f,lat_f,dist)

implicit none

! Passed variable
real,intent(in) :: lon_i !< Initial point longitude (radian)
real,intent(in) :: lat_i !< Initial point latitude (radian)
real,intent(in) :: lon_f !< Final point longitude (radian)
real,intent(in) :: lat_f !< Final point longilatitudetude (radian)
real,intent(out) :: dist !< Great-circle distance

! Check that there is no missing value
if (isnotmsr(lon_i).and.isnotmsr(lat_i).and.isnotmsr(lon_f).and.isnotmsr(lat_f)) then
   ! Great-circle distance using Vincenty formula on the sphere
    dist = req*atan2(sqrt((cos(lat_f)*sin(lon_f-lon_i))**2+(cos(lat_i)*sin(lat_f)-sin(lat_i)*cos(lat_f)*cos(lon_f-lon_i))**2),sin(lat_i)*sin(lat_f)+cos(lat_i)*cos(lat_f)*cos(lon_f-lon_i))
else
   call msr(dist)
end if

end subroutine sphere_dist

!----------------------------------------------------------------------
! Subroutine: vector_product
!> Purpose: compute normalized vector product
!----------------------------------------------------------------------
subroutine vector_product(v1,v2,vp)

implicit none

! Passed variables
real,intent(in) :: v1(3)  !< First vector
real,intent(in) :: v2(3)  !< Second vector
real,intent(out) :: vp(3) !< Vector product

! Local variable
real :: r

! Vector product
vp(1) = v1(2)*v2(3)-v1(3)*v2(2)
vp(2) = v1(3)*v2(1)-v1(1)*v2(3)
vp(3) = v1(1)*v2(2)-v1(2)*v2(1)

! Normalization
r = sqrt(sum(vp**2))
if (r>0.0) vp = vp/r

end subroutine vector_product

!----------------------------------------------------------------------
! Subroutine: vector_triple_product
!> Purpose: compute vector triple product
!----------------------------------------------------------------------
subroutine vector_triple_product(v1,v2,v3,p)

implicit none

! Passed variables
real,intent(in) :: v1(3) !< First vector
real,intent(in) :: v2(3) !< Second vector
real,intent(in) :: v3(3) !< Third vector
real,intent(out) :: p    !< Triple product

! Local variable
real :: vp(3)

! Vector product
vp(1) = v1(2)*v2(3)-v1(3)*v2(2)
vp(2) = v1(3)*v2(1)-v1(1)*v2(3)
vp(3) = v1(1)*v2(2)-v1(2)*v2(1)

! Scalar product
p = sum(vp*v3)

end subroutine vector_triple_product

end module tools_const


!=======================================================================
! Created by
!     Keurfon Luu <keurfon.luu@mines-paristech.fr>
!     MINES ParisTech - Centre de Géosciences
!     PSL - Research University
!=======================================================================

program example_cluster2d

    use forlab, only: IPRE, RPRE, rng, chol, randn, repmat, vertcat, savetxt, &
                      mean, num2str, zeros, gmm, kmeans, mbkmeans, &
                      silhouette, dbindex

    implicit none

    integer(kind=IPRE) :: i, j, k, itermax, kmax
    integer(kind=IPRE), dimension(:), allocatable :: idx
    real(kind=RPRE) :: perc = 0.2
    real(kind=RPRE), dimension(:), allocatable :: x, y, mu, sil, db
    real(kind=RPRE), dimension(:, :), allocatable :: A, B, L, R, Sigma, means
    character(len=:), allocatable :: outdir, method

    ! Output directory
    outdir = "cluster2d/"
    call system("mkdir -p "//outdir)

    ! Initialize random number generation
    call rng()

    ! Create 2D data
    print *, "Creating 2D data:"

    ! Cluster 1
    Sigma = reshape([3., 0., 0., 0.5], [2, 2])
    L = chol(Sigma)
    R = randn(2, 500)
    mu = [3., 3.]
    B = transpose(matmul(L, R) + repmat(mu, size(R, 2)))
    A = B

    ! Cluster 2
    Sigma = reshape([1., 0., 0., 1.], [2, 2])
    L = chol(Sigma)
    R = randn(2, 400)
    mu = [-3., 3.]
    B = transpose(matmul(L, R) + repmat(mu, size(R, 2)))
    A = vertcat(A, B)

    ! Cluster 3
    Sigma = reshape([2., 0., 0., 1.], [2, 2])
    L = chol(Sigma)
    R = randn(2, 600)
    mu = [6., -3.]
    B = transpose(matmul(L, R) + repmat(mu, size(R, 2)))
    A = vertcat(A, B)

    ! Cluster 4
    Sigma = reshape([1., 0., 0., 1.5], [2, 2])
    L = chol(Sigma)
    R = randn(2, 500)
    mu = [0., 0.]
    B = transpose(matmul(L, R) + repmat(mu, size(R, 2)))
    A = vertcat(A, B)

    call savetxt(outdir//"data.txt", A)
    print *, "Data saved in "//outdir

    ! Clustering
    k = 4
    itermax = 500
    method = "gmm"

    print * ; print *, "Clustering using "//method//":"
    select case (method)
    case ("kmeans")
        idx = kmeans(A, k, means=means, itermax=itermax)
    case ("mbkmeans")
        idx = mbkmeans(A, k, perc=perc, means=means, itermax=itermax)
    case ("gmm")
        idx = gmm(A, k, means=means, itermax=itermax)
    end select

    call savetxt(outdir//"index.txt", idx)
    call savetxt(outdir//"means.txt", means)
    print *, "Clustering results saved in "//outdir

    ! Cluster analysis: compute several indices for different K
    kmax = 20
    sil = zeros(kmax)
    db = zeros(kmax)

    print * ; print *, "Performing cluster analysis:"
    !$omp parallel do default(shared) private(idx, means)
    do i = 1, kmax
        idx = kmeans(A, i, means=means, itermax=itermax)
        sil(i) = mean(silhouette(A, idx))
        db(i) = dbindex(A, idx, means)
    end do
    !$end omp parallel do

    call savetxt(outdir//"silhouette.txt", sil)
    call savetxt(outdir//"db.txt", db)
    print *, "Cluster analysis results saved in "//outdir

    print * ; print *, "Run script /utils/view_cluster2d.py to check results."

    print *

end program example_cluster2d


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Spherepack                            *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!     6/98
!
!     a program for testing all vorticity and ivnerse vorticity routines
!
!
!     (1) first set a stream function and velocity potential scalar fields as
!         polys in x, y, z restricted to the sphere
!
!     (2) derive a vector field (v, w) from (1)
!
!     (3) compute the vorticity vt of (2) and compare with the vorticity
!         computed analytically
!
!     (4) compute vector field (ve, we) using br, bi, cr, ci from (v, w) with
!         br=bi=0.0
!
!     (5) invert the vorticity in (3) and compare with (4)
!
program tvrt

    use spherepack

    ! Explicit typing only
    implicit none

    real(wp) :: cosp
    real(wp) :: cost
    real(wp) :: d2xdp2
    real(wp) :: d2xdt2
    real(wp) :: d2ydp2
    real(wp) :: d2ydt2
    real(wp) :: d2zdp2
    real(wp) :: d2zdt2
    real(wp) :: dlat
    real(wp) :: dphi

    real(wp) :: dxdp
    real(wp) :: dxdt
    real(wp) :: dydp
    real(wp) :: dydt
    real(wp) :: dzdp
    real(wp) :: dzdt
    real(wp) :: err2
    real(wp) :: err2v
    real(wp) :: err2w
    integer(ip) :: i
    integer(ip) :: icase
    integer(ip) :: ierror
    integer(ip) :: j
    integer(ip) :: k
    integer(ip) :: nmax
    real(wp) :: phi

    real(wp) :: sinp
    real(wp) :: sint
    real(wp) :: theta
    real(wp) :: vte
    real(wp) :: x
    real(wp) :: y
    real(wp) :: z
    !
    !     set dimensions with parameter statements
    integer(ip), parameter :: nlat= 24, nlon= 14, nt = 3
    integer(ip), parameter :: isym = 0, ityp = 0
    integer(ip), parameter :: mdab = (nlon+2)/2, mdc = (nlon + 1)/2
    real(wp), dimension(mdc, nlat, nt)  :: br, bi, cr, ci
    real(wp), dimension(mdab, nlat, nt) :: a, b
    real(wp), dimension(nlat, nlon, nt) :: vt, v, w, ve, we
    real(wp), dimension(nlat)           :: thetag, dwts
    real(wp)                            :: pertrb(nt)
    real(wp), allocatable               :: wavetable(:)
    real(wp), parameter                 :: ZERO = 0.0_wp, TWO = 2.0_wp

    ! Set dimension variables
    nmax = max(nlat, nlon)
    call iout(nlat, "nlat")
    call iout(nlon, "nlon")
    call iout(nt, "  nt")
    !
    !     set equally spaced colatitude and longitude increments
    !
    dphi = TWO_PI/nlon
    dlat = PI/(nlat-1)
    !
    !     compute nlat gaussian points in thetag
    !
    call compute_gaussian_latitudes_and_weights(nlat, thetag, dwts, ierror)

    call name("gaqd")
    call iout(ierror, " error_flag = ")
    call vecout(thetag, "gaussian_latitudes", nlat)
    !
    !     test all vorticity subroutines
    !
    do icase=1, 4
        call name("****")
        call name("****")
        call iout(icase, "icas")
        !
        !
        !     set scalar stream and velocity potential fields as polys in x, y, z
        !     and then set v, w from st, sv scalar fields
        !
        do k=1, nt
            do j=1, nlon
                phi = real(j - 1, kind=wp) * dphi
                sinp = sin(phi)
                cosp = cos(phi)
                do i=1, nlat
                    select case (icase)
                        case (0:2)
                            theta = real(i -1, kind=wp) * dlat
                        case default
                            theta=thetag(i)
                    end select
                    cost = cos(theta)
                    sint = sin(theta)
                    x = sint*cosp
                    y = sint*sinp
                    z = cost
                    dxdt = cost*cosp
                    dxdp = -sint*sinp
                    dydt = cost*sinp
                    dydp = sint*cosp
                    dzdt = -sint
                    dzdp = ZERO
                    select case (k)
                        case (1)
                            !              st(i, j, k) = x
                            !              sv(i, j, k) = y
                            !
                            !          v = -1/sin(theta)*dstdp + dsvdt
                            !
                            !          w =  1/sin(theta)*dsvdp + dstdt
                            !
                            v(i, j, k) = sinp + cost * sinp
                            w(i, j, k) = cosp + cost * cosp
                            vt(i, j, k) = -TWO * sint * cosp
                        case (2)
                            !              st = y
                            !              sv = z
                            v(i, j, k) = -cosp-sint
                            w(i, j, k) = cost * sinp
                            !         sint*vt = -dvdp + sint*dwdt + cost*w
                            !                 = sinp + sint*(-sint*sinp)+cost*cost*sinp
                            !                 = sinp + (cost**2-sint**2)*sinp
                            vt(i, j, k) = -TWO * sint * sinp
                        case (3)
                            !           st = x
                            !           sv = z
                            v(i, j, k) = sinp - sint
                            w(i, j, k) = cost * cosp
                            !     sint*vt = -cosp-sint*sint*sinp+cost*cost*cosp
                            !             = -cosp + (1-2.*sint**2)*cosp =
                            vt(i, j, k) = -TWO * sint * cosp
                    end select
                end do
            end do
        end do

        if (icase==1) then

            call name("**ec")
            !
            !     analyze vector field
            !
            call initialize_vhaec(nlat, nlon, wavetable, ierror)
            call name("vhai")
            call iout(ierror, "error_flag = ")

            call vhaec(nlat, nlon, isym, nt, v, w, nlat, nlon, br, bi, cr, ci, mdc, &
                nlat, wavetable, ierror)
            call name("vha ")
            call iout(ierror, "error_flag = ")

            !     compute vorticity of (v, w) in vt
            !

            call initialize_shsec(nlat, nlon, wavetable, ierror)

            call name("vrti")
            call iout(ierror, "error_flag = ")

            call vrtec(nlat, nlon, isym, nt, vt, nlat, nlon, cr, ci, mdc, nlat, &
                wavetable, ierror)

            call name("vrt ")
            call iout(ierror, "error_flag = ")
            call iout(nlat, "nlat")
            call iout(nlon, "nlon")

        else if (icase==2) then

            call name("**es")
            call initialize_shses(nlat, nlon, wavetable, ierror)

            call name("vrti")
            call iout(ierror, "error_flag = ")

            call vrtes(nlat, nlon, isym, nt, vt, nlat, nlon, cr, ci, mdc, nlat, &
                wavetable, ierror)

            call name("vrt ")
            call iout(ierror, "error_flag = ")

        else if (icase == 3) then

            call name("**gc")

            call initialize_shsgc(nlat, nlon, wavetable, ierror)

            call name("vrti")
            call iout(ierror, "error_flag = ")

            call vrtgc(nlat, nlon, isym, nt, vt, nlat, nlon, cr, ci, mdc, nlat, &
                wavetable, ierror)

            call name("vrt ")
            call iout(ierror, "error_flag = ")

        else if (icase == 4) then

            call name("**gs")

            call initialize_shsgs(nlat, nlon, wavetable, ierror)

            call name("vrti")
            call iout(ierror, "error_flag = ")

            call vrtgs(nlat, nlon, isym, nt, vt, nlat, nlon, cr, ci, mdc, nlat, &
                wavetable, ierror)

            call name("vrt ")
            call iout(ierror, "error_flag = ")
        end if

        !     compute "error" in vt
        !
        err2 = ZERO
        do k=1, nt
            do j=1, nlon
                phi = real(j - 1, kind=wp) * dphi
                sinp = sin(phi)
                cosp = cos(phi)
                do i=1, nlat
                    select case (icase)
                        case (0:2)
                            theta = real(i - 1, kind=wp) * dlat
                        case default
                            theta=thetag(i)
                    end select
                    cost = cos(theta)
                    sint = sin(theta)
                    x = sint*cosp
                    y = sint*sinp
                    z = cost
                    dxdt = cost*cosp
                    d2xdt2 = -sint*cosp
                    dxdp = -sint*sinp
                    d2xdp2 = -sint*cosp
                    dydt = cost*sinp
                    d2ydt2 = -sint*sinp
                    dydp = sint*cosp
                    d2ydp2 = -sint*sinp
                    dzdt = -sint
                    d2zdt2 = -cost
                    dzdp = ZERO
                    d2zdp2 = ZERO
                    select case (k)
                        case (1, 3)
                            vte = -TWO * sint * cosp
                        case (2)
                            vte = -TWO * sint * sinp
                    end select
                    err2 = err2 + (vt(i, j, k)-vte)**2
                end do
            end do
        end do
        err2 = sqrt(err2/(nt*nlat*nlon))
        call vout(err2, "err2")

        !     now recompute (v, w) inverting vt using ivrt(ec, es, gc, gs)
        !     and compare with (ve, we) generated by synthesizing br, bi, cr, ci
        !     with br=bi=0.0
        br = ZERO
        bi = ZERO

        select case (icase)
            case (1)

                call name("**ec")

                !
                !     set vector field (ve, we) with br=bi=0.0 for comparison with inverted vt
                !
                call initialize_vhsec(nlat, nlon, wavetable, ierror)
                call name("initialize_vhsec")
                call iout(ierror, "error_flag = ")

                call vhsec(nlat, nlon, ityp, nt, ve, we, nlat, nlon, br, bi, cr, ci, &
                    mdc, nlat, wavetable, ierror)

                call name("vhsec")
                call iout(ierror, "error_flag = ")

                call initialize_shaec(nlat, nlon, wavetable, ierror)
                call name("initialize_shaec")
                call iout(ierror, "error_flag = ")

                call shaec(nlat, nlon, isym, nt, vt, nlat, nlon, a, b, &
                    mdab, nlat, wavetable, ierror)
                call name("shaec")
                call iout(ierror, "error_flag = ")

                call initialize_vhsec(nlat, nlon, wavetable, ierror)
                call name("initialize_vhsec")
                call iout(ierror, "error_flag = ")

                call ivrtec(nlat, nlon, isym, nt, v, w, nlat, nlon, a, b, &
                    mdab, nlat, wavetable, pertrb, ierror)
                call name("ivrtec")
                call iout(ierror, "error_flag = ")
                call vout(pertrb, "prtb")
            case (2)

                call name("**es")
                !
                !     set vector field (ve, we) with br=bi=0.0 for comparison with inverted vt
                !
                call initialize_vhses(nlat, nlon, wavetable, ierror)
                call name("vhsi")
                call iout(ierror, "error_flag = ")

                call vhses(nlat, nlon, ityp, nt, ve, we, nlat, nlon, br, bi, cr, ci, &
                    mdc, nlat, wavetable, ierror)
                call name("vhs ")
                call iout(ierror, "error_flag = ")

                call initialize_shaes(nlat, nlon, wavetable, ierror)
                call name("shai")
                call iout(ierror, "error_flag = ")

                call shaes(nlat, nlon, isym, nt, vt, nlat, nlon, a, b, &
                    mdab, nlat, wavetable, ierror)
                call name("sha ")
                call iout(ierror, "error_flag = ")

                call initialize_vhses(nlat, nlon, wavetable, ierror)
                call name("ivti")
                call iout(ierror, "error_flag = ")

                call ivrtes(nlat, nlon, isym, nt, v, w, nlat, nlon, a, b, &
                    mdab, nlat, wavetable, pertrb, ierror)
                call name("ivrt")
                call iout(ierror, "error_flag = ")
                call vout(pertrb, "prtb")
            case (3)

                call name("**gc")
                !
                !     set vector field (ve, we) with br=bi=0.0 for comparison with inverted vt
                !
                call initialize_vhsgc(nlat, nlon, wavetable, ierror)
                call name("initialize_vhsgc")
                call iout(ierror, "error_flag = ")

                call vhsgc(nlat, nlon, ityp, nt, ve, we, nlat, nlon, br, bi, cr, ci, &
                    mdc, nlat, wavetable, ierror)

                call name("vhsgc")
                call iout(ierror, "error_flag = ")

                call initialize_shagc(nlat, nlon, wavetable, ierror)
                call name("initialize_shagc")
                call iout(ierror, "error_flag = ")

                call shagc(nlat, nlon, isym, nt, vt, nlat, nlon, a, b, &
                    mdab, nlat, wavetable, ierror)
                call name("shagc")
                call iout(ierror, "error_flag = ")

                call initialize_vhsgc(nlat, nlon, wavetable, ierror)
                call name("initialize_vhsgc")
                call iout(ierror, "error_flag = ")

                call ivrtgc(nlat, nlon, isym, nt, v, w, nlat, nlon, a, b, &
                    mdab, nlat, wavetable, pertrb, ierror)

                call name("ivrtgc")
                call iout(ierror, "error_flag = ")
                call vout(pertrb, "prtb")
            case (4)

                call name("**gs")
                !
                !     set vector field (ve, we) with br=bi=0.0 for comparison with inverted vt
                !
                call initialize_vhsgs(nlat, nlon, wavetable, ierror)
                call name("vhsi")
                call iout(ierror, "error_flag = ")

                call vhsgs(nlat, nlon, ityp, nt, ve, we, nlat, nlon, br, bi, cr, ci, &
                    mdc, nlat, wavetable, ierror)
                call name("vhs ")
                call iout(ierror, "error_flag = ")

                call initialize_shags(nlat, nlon, wavetable, ierror)
                call name("shai")
                call iout(ierror, "error_flag = ")

                call shags(nlat, nlon, isym, nt, vt, nlat, nlon, a, b, &
                    mdab, nlat, wavetable, ierror)
                call name("sha ")
                call iout(ierror, "error_flag = ")

                call initialize_vhsgs(nlat, nlon, wavetable, ierror)
                call name("ivti")
                call iout(ierror, "error_flag = ")

                call ivrtgs(nlat, nlon, isym, nt, v, w, nlat, nlon, a, b, &
                    mdab, nlat, wavetable, pertrb, ierror)
                call name("ivrt")
                call iout(ierror, "error_flag = ")
                call vout(pertrb, "prtb")
        end select

        !
        !     compare this v, w with ve, we
        !
        err2v = ZERO
        err2w = ZERO
        do k=1, nt
            do j=1, nlon
                do i=1, nlat
                    err2v = err2v + (v(i, j, k)-ve(i, j, k))**2
                    err2w = err2w + (w(i, j, k)-we(i, j, k))**2
                end do
            end do
        end do
        err2v = sqrt(err2v/(nlat*nlon*nt))
        err2w = sqrt(err2w/(nlat*nlon*nt))
        call vout(err2v, "errv")
        call vout(err2w, "errw")
    !
    !     end of icase loop
    !
    end do

    ! Release memory
    deallocate (wavetable)

end program tvrt


!##############################################################################
! PROGRAM AlternativeArrays
!
! ## Alternative forms of array value assignments
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
program AlternativeArrays

    implicit none
    integer, parameter :: n = 8
    real*8 :: x(0:n), y(0:n), z(0:n, 0:n)
    integer :: j, k

    ! initialize x
    do j = 0, n
        x(j) = 1d0/dble(n)*dble(j)
    enddo

    ! give y the values of x plus 1
    y(:) = x(:) + 1d0

    ! calculate z
    do j = 0, n
        do k = 0, n
            z(j, k) = x(j)**2 + y(k)
        enddo
    enddo

    ! output table of values
    write(*,'(a,9f7.2)')'    X/Y | ', y(:)
    write(*,'(a)')'        | '
    do j = 0, n
        write(*,'(f7.2,a,9f7.2)')x(j),' | ', z(j, :)
    enddo

end program


program cd
!  Test the circ_disp function in statistical

use statistical

integer,parameter :: n=10
real(8) :: a(n)
integer :: i

!  Generate random angles in range 0 - 360
do i=1,n
   a(i) = rand()*360.
enddo

write(*,*) 'd of random angles:',circ_dispers(a)

!  Generate angles normally distributed about 0
do i=1,n
   a(i) = exp(-real(i-n)**2)*360.
enddo

write(*,*) 'd of ''normal'' angles:',circ_dispers(a)

end program


c     program DRDTCST
c>> 1996-06-05 DRDTCST Krogh Fixes for conversion to C.
c>> 1996-05-28 DRDTCST Krogh Moved formats up.
c>> 1994-10-19 DRDTCST Krogh  Changes to use M77CON
c>> 1994-08-09 DRDTCST WVS Remove '0' from format
c>> 1992-04-22 DRDTCST CAO commented program statement
c>> 1989-05-08 DRDTCST FTK, CLL
c>> 1989-05-04 DRDTCST FTK, CLL
c Driver to demonstrate DTCST
c     ------------------------------------------------------------------
c--D replaces "?": DR?TCST, ?TCST
c     ------------------------------------------------------------------
      double precision F(65), S(32), T, TTIME
      double precision DELTAT, DELTAO, OMEGA, FTRUE, SIN1,COS1
      double precision PI, ZERO, ONE
      integer    K, KSKIP, M, MS, N, ND, MA(1)
      parameter (M = 6)
c      parameter (N = 2 ** M + 1)
      parameter (N = 65)
      parameter (ND = 1)
      parameter (KSKIP = 10)
      parameter (PI = 3.1415926535897932384D0)
      parameter (ZERO = 0.D0)
      parameter (ONE = 1.D0)
      data TTIME / 10.D0 /
      data MA / M /
 1000 format (/'  K', 4X, 'OMEGA', 8X, 'COMPUTED', 9X, 'TRUE')
 1001 format (1X, I3, 1P,E13.5, 2E15.7)
c     ------------------------------------------------------------------
      SIN1 = SIN (ONE)
      COS1 = COS (ONE)
      DELTAT = TTIME / DBLE(N - 1)
      DELTAO = DBLE(KSKIP) * (PI / TTIME)
      T = ZERO
c                 Compute (TTIME / 2 ) * F(T)
      F(1) = TTIME / PI
      do 10 K = 2, N
         T = T + DELTAT
         F(K) = TTIME * SINH(T) / SINH(PI * T)
   10 continue
c
      MS = 0
      call DTCST (F, 'C', 'A', MA, ND, MS, S)
c
      OMEGA = ZERO
      write (*, 1000)
      do 20 K = 1, N, KSKIP
         FTRUE = SIN1 / (COSH(OMEGA) + COS1)
         write (*, 1001) K, OMEGA, F(K), FTRUE
         OMEGA = OMEGA + DELTAO
   20 continue
      stop
      end


    Program zppequ_example

!     ZPPEQU Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use blas_interfaces, Only: zdscal
      Use lapack_example_aux, Only: nagf_blas_zddscl, &
        nagf_file_print_matrix_complex_packed_comp
      Use lapack_interfaces, Only: zppequ
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Real (Kind=dp), Parameter :: one = 1.0_dp
      Real (Kind=dp), Parameter :: thresh = 0.1_dp
      Integer, Parameter :: nin = 5, nout = 6
      Character (1), Parameter :: uplo = 'U'
!     .. Local Scalars ..
      Real (Kind=dp) :: amax, big, scond, small
      Integer :: i, ifail, info, j, jinc, jj, n
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: ap(:)
      Real (Kind=dp), Allocatable :: s(:)
      Character (1) :: clabs(1), rlabs(1)
!     .. Intrinsic Procedures ..
      Intrinsic :: epsilon, radix, real, tiny
!     .. Executable Statements ..
      Write (nout, *) 'ZPPEQU Example Program Results'
      Write (nout, *)
      Flush (nout)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n

      Allocate (ap((n*(n+1))/2), s(n))

!     Read the upper or lower triangular part of the matrix A from
!     data file

      If (uplo=='U') Then
        Read (nin, *)((ap(i+(j*(j-1))/2),j=i,n), i=1, n)
      Else If (uplo=='L') Then
        Read (nin, *)((ap(i+((2*n-j)*(j-1))/2),j=1,i), i=1, n)
      End If

!     Print the matrix A

!     ifail: behaviour on error exit
!             =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
      ifail = 0
      Call nagf_file_print_matrix_complex_packed_comp(uplo, &
        'Non-unit diagonal', n, ap, 'Bracketed', '1P,E10.2', 'Matrix A', &
        'Integer', rlabs, 'Integer', clabs, 80, 0, ifail)

      Write (nout, *)

!     Compute diagonal scaling factors
      Call zppequ(uplo, n, ap, s, scond, amax, info)

      If (info>0) Then
        Write (nout, 100) 'Diagonal element', info, ' of A is non positive'
      Else

!       Print SCOND, AMAX and the scale factors

        Write (nout, 110) 'SCOND =', scond, ', AMAX =', amax
        Write (nout, *)
        Write (nout, *) 'Diagonal scaling factors'
        Write (nout, 120) s(1:n)
        Write (nout, *)
        Flush (nout)

!       Compute values close to underflow and overflow

        small = tiny(1.0E0_dp)/(epsilon(1.0E0_dp)*real(radix(1.0E0_dp),kind=dp &
          ))
        big = one/small
        If ((scond<thresh) .Or. (amax<small) .Or. (amax>big)) Then

!         Scale A

          If (uplo=='U') Then

            jj = 1
            Do j = 1, n
              Call zdscal(j, s(j), ap(jj), 1)
              Call nagf_blas_zddscl(j, s, 1, ap(jj), 1)
              jj = jj + j
            End Do
          Else If (uplo=='L') Then
            jj = 1
            jinc = n
            Do j = 1, n
              Call zdscal(jinc, s(j), ap(jj), 1)
              Call nagf_blas_zddscl(jinc, s(j), 1, ap(jj), 1)
              jj = jj + jinc
              jinc = jinc - 1
            End Do
          End If

!         Print the scaled matrix

          ifail = 0
          Call nagf_file_print_matrix_complex_packed_comp(uplo, &
            'Non-unit diagonal', n, ap, 'Bracketed', 'F8.4', 'Scaled matrix', &
            'Integer', rlabs, 'Integer', clabs, 80, 0, ifail)

        End If
      End If

100   Format (1X, A, I4, A)
110   Format (1X, 2(A,1P,E8.1))
120   Format ((1X,1P,7E11.1))
    End Program


!Demo of simple Fizzbuzz
!For simplicity I have not formatted the
!print statements, so the output is not pretty
!but it does work

PROGRAM FIZZBUZZ

IMPLICIT NONE

INTEGER:: i=0

DO i=1, 100
  IF(MOD(i, 3) .EQ. 0 .AND. MOD(i, 5) .NE. 0) PRINT*, "Fizz"
  IF(MOD(i, 5) .EQ. 0 .AND. MOD(i, 3) .NE. 0) PRINT*, "Buzz"
  IF(MOD(i, 15) .EQ. 0) PRINT*, "FizzBuzz"
  IF(MOD(i, 3) .NE. 0 .AND. MOD(i, 5) .NE. 0) PRINT*, i

ENDDO

END PROGRAM


C     Calculate the tetrahedron of least volume that encloses the points
C       (XP(J),YP(J),ZP(J)), J=1,2,...,NP. Our method requires the origin
C       to be strictly inside the convex hull of these points. There are
C       twelve variables that define the four faces of each tetrahedron
C       that is considered. Each face has the form ALPHA*X+BETA*Y+GAMMA*Z=1,
C       the variables X(3K-2), X(3K-1) and X(3K) being the values of ALPHA,
C       BETA and GAMMA for the K-th face, K=1,2,3,4. Let the set T contain
C       all points in three dimensions that can be reached from the origin
C       without crossing a face. Because the volume of T may be infinite,
C       the objective function is the smaller of FMAX and the volume of T,
C       where FMAX is set to an upper bound on the final volume initially.
C       There are 4*NP linear constraints on the variables, namely that each
C       of the given points (XP(J),YP(J),ZP(J)) shall be in T. Let XS = min
C       XP(J), YS = min YP(J), ZS = min ZP(J) and SS = max XP(J)+YP(J)+ZP(J),
C       where J runs from 1 to NP. The initial values of the variables are
C       X(1)=1/XS, X(5)=1/YS, X(9)=1/ZS, X(2)=X(3)=X(4)=X(6)=X(7) =X(8)=0
C       and X(10)=X(11)=X(12)=1/SS, which satisfy the linear constraints,
C       and which provide the bound FMAX=(SS-XS-YS-ZS)**3/6. Other details
C       of the test calculation are given below, including the choice of
C       the data points (XP(J),YP(J),ZP(J)), J=1,2,...,NP. The smaller final
C       value of the objective function in the case NPT=35 shows that the
C       problem has local minima.
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON FMAX
      DIMENSION XP(50),YP(50),ZP(50),A(12,200),B(200),X(12),W(500000)
C
C     Set some constants.
C
      ONE=1.0D0
      TWO=2.0D0
      ZERO=0.0D0
      PI=4.0D0*DATAN(ONE)
      IA=12
      N=12
C
C     Set the data points.
C
      NP=50
      SUMX=ZERO
      SUMY=ZERO
      SUMZ=ZERO
      DO 10 J=1,NP
      THETA=DFLOAT(J-1)*PI/DFLOAT(NP-1)
      XP(J)=DCOS(THETA)*DCOS(TWO*THETA)
      SUMX=SUMX+XP(J)
      YP(J)=DSIN(THETA)*DCOS(TWO*THETA)
      SUMY=SUMY+YP(J)
      ZP(J)=DSIN(TWO*THETA)
   10 SUMZ=SUMZ+ZP(J)
      SUMX=SUMX/DFLOAT(NP)
      SUMY=SUMY/DFLOAT(NP)
      SUMZ=SUMZ/DFLOAT(NP)
      DO 20 J=1,NP
      XP(J)=XP(J)-SUMX
      YP(J)=YP(J)-SUMY
   20 ZP(J)=ZP(J)-SUMZ
C
C     Set the linear constraints.
C
      M=4*NP
      DO 30 K=1,M
      B(K)=ONE
      DO 30 I=1,N
   30 A(I,K)=ZERO
      DO 40 J=1,NP
      DO 40 I=1,4
      K=4*J+I-4
      IW=3*I
      A(IW-2,K)=XP(J)
      A(IW-1,K)=YP(J)
   40 A(IW,K)=ZP(J)
C
C     Set the initial vector of variables. The JCASE=1,6 loop gives six
C       different choices of NPT when LINCOA is called.
C
      XS=ZERO
      YS=ZERO
      ZS=ZERO
      SS=ZERO
      DO 50 J=1,NP
      XS=DMIN1(XS,XP(J))
      YS=DMIN1(YS,YP(J))
      ZS=DMIN1(ZS,ZP(J))
   50 SS=DMAX1(SS,XP(J)+YP(J)+ZP(J))
      FMAX=(SS-XS-YS-ZS)**3/6.0D0
      DO 80 JCASE=1,6
      DO 60 I=2,8
   60 X(I)=ZERO
      X(1)=ONE/XS
      X(5)=ONE/YS
      X(9)=ONE/ZS
      X(10)=ONE/SS
      X(11)=ONE/SS
      X(12)=ONE/SS
C
C     Call of LINCOA, which provides the printing given at the end of this
C       note.
C
      NPT=5*JCASE+10
      RHOBEG=1.0D0
      RHOEND=1.0D-6
      IPRINT=1
      MAXFUN=10000
      PRINT 70, NPT,RHOEND
   70 FORMAT (//4X,'Output from LINCOA with  NPT =',I4,
     1  '  and  RHOEND =',1PD12.4)
      CALL LINCOA (N,NPT,M,A,IA,B,X,RHOBEG,RHOEND,IPRINT,MAXFUN,W)
   80 CONTINUE
      STOP
      END


Module Mathlib
  contains
  Recursive Function det(A,col,row) Result(D)
    Integer row, col, idxRows(row-1), idxCOLS(col-1)
    Real(8) A(col,row), D
    Integer m, n, k, c, f
    m=row
    n=col
    If (m>1) Then
      D = 0;
      Do k=1,m
        idxCOLS = sitdiff([1:m],m,k)
        idxROWS = [2:n]
        c = col-1
        f = row-1
        D = D + (-1)**(1+k) * A(k,1) * det(A(idxCOLS,idxROWS),c,f)
      EndDo
    Else
      D = A(1,1)
    EndIf
  End Function det

  Function sitdiff(A,n,k) Result (B)
    Integer n,d,k
    Integer A(:),B(n-1)
    If(k .eq. 1) Then
      B = A(k+1:n)
    ElseIf(k .eq. n) Then
      B = A(1:k-1)
    Else
      B = A((/1:k-1,k+1:n/))
    EndIf
  End Function sitdiff

  Function inv(A,row) Result (inv_A)
    Integer row,m(row-1),n(row-1)
    Real(8) A(row,row),inv_A(row,row)
    Do i=1,row
      Do j=1,row
        m = sitdiff([1:row],row,i)
        n = sitdiff([1:row],row,j)
        inv_A(i,j) = (-1)**(i+j)*det(A(m,n),row-1,row-1)
      Enddo
    Enddo
    inv_A = inv_A/det(A,row,row)
    inv_A = tran(inv_A,row,row)
  End function inv

  Function arange(n) Result(a)
    Integer i, n, a(n)
    Do i = 1, n
      a(i) = i
    Enddo
  End function arange

  Function tran(A,col,row) Result(t_A)
    Integer row,col
    Real(8) t_A(row,col),A(col,row)
    Do i=1,col
      Do j=1,row
        t_A(j,i)=A(i,j)
      Enddo
    Enddo
  End function tran

  Subroutine output_mat(A,row,col)
    Integer row,col
    Real(8) A(row,col)
    Character(12) ftmp
    Write(ftmp,'(I3,A9)') col,"(F16.8,x)"
    Do i = 1,row
       Write(6,ftmp) A(:,i)
    Enddo
  End subroutine output_mat

End module Mathlib


	FUNCTION PR_ALTI  ( altm )
C************************************************************************
C* PR_ALTI								*
C*									*
C* This function computes ALTI from ALTM.  The following equation is	*
C* used:								*
C*									*
C*            ALTI = ALTM * 29.921 / 1013.25				*
C*									*
C* REAL PR_ALTI ( ALTM )						*
C*									*
C* Input parameters:							*
C*	ALTM		REAL	 	Altimeter in millibars		*
C*									*
C* Output parameters:							*
C*	PR_ALTI		REAL		Altimeter in inches		*
C**									*
C* Log:									*
C* I. Graffman/RDS	11/84						*
C* I. Graffman/RDS	12/87	GEMPAK4					*
C* G. Huffman/GSC       7/88    Modify documentation			*
C************************************************************************
        INCLUDE    'GEMPRM.PRM'
        INCLUDE    'ERMISS.FNC'
C------------------------------------------------------------------------
C*	Check for bad data.
C
	IF  ( ERMISS ( altm ) )  THEN
	    PR_ALTI = RMISSD
	    RETURN
	END IF
C
C*	Calculate.
C
	PR_ALTI = altm * 29.921 / 1013.25
C*
	RETURN
	END


program conway
  implicit none
  integer :: a(2**20)  ! The sequence a(n)
  real    :: b(2**20)  ! The sequence a(n)/n
  real    :: v         ! Max value in the range [2*i, 2**(i+1)]
  integer :: nl(1)     ! The location of v in the array b(n)
  integer :: i, N, first, second, last, m

  ! Populate a(n) and b(n)
  a(1:2) = [1, 1]
  b(1:2) = [1.0e0, 0.5e0]
  N = 2
  do i=1,2**20
     last = a(N)
     first = a(last)
     second = a(N-last+1)
     N = N+1
     a(N:N) = first + second
     b(N:N) = a(N:N)/real(N)
  end do

  ! Calculate the max values in the logarithmic ranges
  m = 0
  do i=1,19
     v = maxval(b(2**i:2**(i+1)))
     nl = maxloc(b(2**i:2**(i+1)))
     write(*,'(2(a,i0),a,f8.6,a,i0)') &
          'Max. between 2**', i,      &
          ' and 2**', (i+1),          &
          ' is ', v,                  &
          ' at n = ', 2**i+nl(1)-1
     if (m == 0 .and. v < 0.55e0) then
        m = i-1
     end if
  end do

  ! Calculate Mallows number
  do i=2**(m+1), 2**m,-1
     if (b(i) > 0.55e0) then
        exit
     end if
  end do
  write(*,'(a,i0)') 'Mallows number = ',i

end program conway


subroutine qinit(meqn,mbc,mx,xlower,dx,q,maux,aux)

    ! Set initial conditions for the q array.
    ! This default version simply sets eta = max(h + b,0)

    ! For more specific initial conditions
    !  copy this to an application directory and
    !  loop over all grid cells to set values of q(1:meqn, 1:mx).

    use geoclaw_module, only: grav  !uncomment if needed
    use grid_module, only: xgrid,zgrid,mx_grid

    implicit none

    integer, intent(in) :: meqn,mbc,mx,maux
    real(kind=8), intent(in) :: xlower,dx
    real(kind=8), intent(in) :: aux(maux,1-mbc:mx+mbc)
    real(kind=8), intent(inout) :: q(meqn,1-mbc:mx+mbc)

    !locals
    integer :: i
    real(kind=8) :: xcell,x0,width,eta,xoff,x0sech2

    width = 80.e3
    x0sech2 = -200e3  ! initial center of sech2

    do i=1,mx
      xcell = 0.5*(xgrid(i) + xgrid(i+1))
      xoff = xcell-x0sech2
      if ((abs(xoff) < x0-width)) then
          eta = 0.d0
        else
          eta = (2.d0 / (exp(3.d0*xoff/width) + exp(-3.d0*xoff/width)))**2
        endif
      q(1,i) = max(0.0, eta - aux(1,i))
      q(2,i) = eta*sqrt(grav*q(1,i))  ! right-going

   enddo

end subroutine qinit


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2015 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
!     calculate the maximal admissible pressure ratio pt2/pt1
!
!     1) assuming M2=1 for adiabatic respectively M2=1/dsqrt(kappa)
!        for isotherm pipe choking
!        M1 is calculated iteratively using a dichotomy scheme
!
!     2)the ratio of the critical pressure ratio
!       Qred_1/Qred_2crit=Pt2/Pt1=D(M1)/D(M2_crit)
!       is computed
!       [D(M)=M*(1+0.5*(kappa-1)*M)**(-0.5*(kappa+1)/(kappa-1))]
!       (general gas equation)
!
!     author: Yannick Muller
!
      subroutine pt2zpt1_crit(pt2,pt1,Tt1,lambda,kappa,r,l,d,
     &     inv,pt2zpt1_c,Qred_crit,crit,icase,M1)
!
      implicit none
!
      logical crit
!
      integer inv,icase,i
!
      real*8 pt2,pt1,lambda,kappa,l,d,M1,pt2zpt1,pt2zpt1_c,
     &     km1,kp1,kp1zk,Tt1,r,xflow_crit,Qred_crit,fmin,
     &     f,fmax,M1_min,M1_max,lld
!
      intent(in) pt2,pt1,Tt1,lambda,kappa,r,l,d,
     &     inv,icase
!
      intent(inout) Qred_crit,crit,pt2zpt1_c
!
      crit=.false.
!
!     useful variables and constants
!
      km1=kappa-1.d0
      kp1=kappa+1.d0
      kp1zk=kp1/kappa
      lld=lambda*l/d
!
!     adiabatic case
!
      if(icase.eq.0) then
!
!        computing M1 using dichotomy method (dividing the interval with the function
!        root iteratively by 2)
!
         i=1
!
         M1_min=0.001d0
         M1_max=1
!
         fmin=(1.d0-M1_min**2)*(kappa*M1_min**2)**(-1)
     &        +0.5d0*kp1zk*log((0.5d0*kp1)*M1_min**2
     &        *(1+0.5d0*km1*M1_min**2)**(-1))-lld
!
         fmax=(1.d0-M1_max**2)*(kappa*M1_max**2)**(-1)
     &        +0.5d0*kp1zk*log((0.5d0*kp1)*M1_max**2
     &        *(1+0.5d0*km1*M1_max**2)**(-1))-lld
         do
            i=i+1
            M1=(M1_min+M1_max)*0.5d0
!
            f=(1.d0-M1**2)*(kappa*M1**2)**(-1)
     &           +0.5d0*kp1zk*log((0.5d0*kp1)*M1**2
     &           *(1+0.5d0*km1*M1**2)**(-1))-lld
!
            if(abs(f).le.1E-6) then
               exit
            endif
            if(i.gt.50) then
               exit
            endif
!
            if(fmin*f.le.0.d0) then
               M1_max=M1
               fmax=f
            else
               M1_min=M1
               fmin=f
            endif
         enddo
!
         Pt2zpt1_c=M1*(0.5d0*kp1)**(0.5*kp1/km1)
     &        *(1+0.5d0*km1*M1**2)**(-0.5d0*kp1/km1)
!
!     isothermal case
!
      elseif (icase.eq.1) then
!
!        computing M1 using dichotomy method for choked conditions M2=1/dsqrt(kappa)
!        (1.d0-kappa*M1**2)/(kappa*M1**2)+log(kappa*M1**2)-lambda*l/d=0
!
         i=1
!
         M1_min=0.1d0
         M1_max=1/dsqrt(kappa)
!
         fmin=(1.d0-kappa*M1_min**2)/(kappa*M1_min**2)
     &        +log(kappa*M1_min**2)-lambda*l/d
!
         fmax=(1.d0-kappa*M1_max**2)/(kappa*M1_max**2)
     &        +log(kappa*M1_max**2)-lambda*l/d
!
         do
            i=i+1
            M1=(M1_min+M1_max)*0.5d0
!
            f=(1.d0-kappa*M1**2)/(kappa*M1**2)
     &           +log(kappa*M1**2)-lambda*l/d
!
            if((abs(f).le.1E-5).or.(i.ge.50)) then
               exit
            endif
!
            if(fmin*f.le.0.d0) then
               M1_max=M1
               fmax=f
            else
               M1_min=M1
               fmin=f
            endif
         enddo
!
!        computing the critical pressure ratio in the isothermal case
!        pt=A*dsqrt(kappa)/(xflow*dsqrt(kappa Tt))*
!           M*(1+0.5d0*(kappa-1)M**2)**(-0.5d0*(kappa+1)/(kappa-1))
!        and forming the pressure ratio between inlet and outlet(choked)
!
c         Pt2zPt1_c=dsqrt(Tt2/Tt1)*M1*dsqrt(kappa)*((1+0.5d0*km1/kappa)
c     &        /(1+0.5d0*km1*M1**2))**(0.5d0*(kappa+1)/km1)
         Pt2zPt1_c=M1*dsqrt(kappa)*((1+0.5d0*km1/kappa)
     &        /(1+0.5d0*km1*M1**2))**(0.5d0*(kappa+1)/km1+0.5d0)
!
      endif
!
      pt2zpt1=pt2/pt1
      if(Pt2zPt1.le.Pt2zPt1_c) then
         crit=.true.
      endif
!
      Qred_crit=M1*dsqrt(kappa/r)
     &     *(1+0.5d0*km1*M1**2)**(-0.5d0*kp1/km1)
!
      return
      end