module ranlib_poisson

contains

function sexpo ( )

    !*****************************************************************************80
    !
    !! SEXPO samples the standard exponential distribution.
    !
    !  Discussion:
    !
    !   This procedure corresponds to algorithm SA in the reference.
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    31 March 2013
    !
    !  Author:
    !
    !    Original FORTRAN77 version by Barry Brown, James Lovato.
    !    FORTRAN90 version by John Burkardt.
    !
    !  Reference:
    !
    !    Joachim Ahrens, Ulrich Dieter,
    !    Computer Methods for Sampling From the
    !    Exponential and Normal Distributions,
    !    Communications of the ACM,
    !    Volume 15, Number 10, October 1972, pages 873-882.
    !
    !  Parameters:
    !
    !    Output, real ( kind = 4 ) SEXPO, a random deviate from the standard
    !    exponential distribution.
    !
      implicit none

      real ( kind = 4 ) a
      integer ( kind = 4 ) i
      real ( kind = 4 ) q(8)
      real ( kind = 4 ) r4_uni_01
      real ( kind = 4 ) sexpo
      real ( kind = 4 ) u
      real ( kind = 4 ) umin
      real ( kind = 4 ) ustar

      save q

      data q / &
           0.6931472E+00, &
           0.9333737E+00, &
           0.9888778E+00, &
           0.9984959E+00, &
           0.9998293E+00, &
           0.9999833E+00, &
           0.9999986E+00, &
           0.9999999E+00 /

      a = 0.0E+00
      u = r4_uni_01 ( )

      do

        u = u + u

        if ( 1.0E+00 < u ) then
          exit
        end if

        a = a + q(1)

      end do

      u = u - 1.0E+00

      if ( u <= q(1) ) then
        sexpo = a + u
        return
      end if

      i = 1
      ustar = r4_uni_01 ( )
      umin = ustar

      do

        ustar = r4_uni_01 ( )
        umin = min ( umin, ustar )
        i = i + 1

        if ( u <= q(i) ) then
          exit
        end if

      end do

      sexpo = a + umin * q(1)

      return
end function sexpo

function snorm ( )

!*****************************************************************************80
!
!! SNORM samples the standard normal distribution.
!
!  Discussion:
!
!    This procedure corresponds to algorithm FL, with M = 5, in the reference.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    31 March 2013
!
!  Author:
!
!    Original FORTRAN77 version by Barry Brown, James Lovato.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Joachim Ahrens, Ulrich Dieter,
!    Extensions of Forsythe's Method for Random
!    Sampling from the Normal Distribution,
!    Mathematics of Computation,
!    Volume 27, Number 124, October 1973, page 927-937.
!
!  Parameters:
!
!    Output, real ( kind = 4 ) SNORM, a random deviate from the distribution.
!
  implicit none

  real ( kind = 4 ) a(32)
  real ( kind = 4 ) aa
  real ( kind = 4 ) d(31)
  real ( kind = 4 ) h(31)
  integer ( kind = 4 ) i
  real ( kind = 4 ) r4_uni_01
  real ( kind = 4 ) s
  real ( kind = 4 ) snorm
  real ( kind = 4 ) t(31)
  real ( kind = 4 ) tt
  real ( kind = 4 ) u
  real ( kind = 4 ) ustar
  real ( kind = 4 ) w
  real ( kind = 4 ) y

  save a
  save d
  save h
  save t

  data a / &
        0.0000000E+00, 0.3917609E-01, 0.7841241E-01, 0.1177699E+00, &
        0.1573107E+00, 0.1970991E+00, 0.2372021E+00, 0.2776904E+00, &
        0.3186394E+00, 0.3601299E+00, 0.4022501E+00, 0.4450965E+00, &
        0.4887764E+00, 0.5334097E+00, 0.5791322E+00, 0.6260990E+00, &
        0.6744898E+00, 0.7245144E+00, 0.7764218E+00, 0.8305109E+00, &
        0.8871466E+00, 0.9467818E+00, 1.009990E+00,  1.077516E+00, &
        1.150349E+00,  1.229859E+00,  1.318011E+00,  1.417797E+00, &
        1.534121E+00,  1.675940E+00,  1.862732E+00,  2.153875E+00 /

  data d / &
        0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
        0.0000000E+00, 0.2636843E+00, 0.2425085E+00, 0.2255674E+00, &
        0.2116342E+00, 0.1999243E+00, 0.1899108E+00, 0.1812252E+00, &
        0.1736014E+00, 0.1668419E+00, 0.1607967E+00, 0.1553497E+00, &
        0.1504094E+00, 0.1459026E+00, 0.1417700E+00, 0.1379632E+00, &
        0.1344418E+00, 0.1311722E+00, 0.1281260E+00, 0.1252791E+00, &
        0.1226109E+00, 0.1201036E+00, 0.1177417E+00, 0.1155119E+00, &
        0.1134023E+00, 0.1114027E+00, 0.1095039E+00 /

  data h / &
        0.3920617E-01, 0.3932705E-01, 0.3950999E-01, 0.3975703E-01, &
        0.4007093E-01, 0.4045533E-01, 0.4091481E-01, 0.4145507E-01, &
        0.4208311E-01, 0.4280748E-01, 0.4363863E-01, 0.4458932E-01, &
        0.4567523E-01, 0.4691571E-01, 0.4833487E-01, 0.4996298E-01, &
        0.5183859E-01, 0.5401138E-01, 0.5654656E-01, 0.5953130E-01, &
        0.6308489E-01, 0.6737503E-01, 0.7264544E-01, 0.7926471E-01, &
        0.8781922E-01, 0.9930398E-01, 0.1155599E+00, 0.1404344E+00, &
        0.1836142E+00, 0.2790016E+00, 0.7010474E+00 /

  data t / &
        0.7673828E-03, 0.2306870E-02, 0.3860618E-02, 0.5438454E-02, &
        0.7050699E-02, 0.8708396E-02, 0.1042357E-01, 0.1220953E-01, &
        0.1408125E-01, 0.1605579E-01, 0.1815290E-01, 0.2039573E-01, &
        0.2281177E-01, 0.2543407E-01, 0.2830296E-01, 0.3146822E-01, &
        0.3499233E-01, 0.3895483E-01, 0.4345878E-01, 0.4864035E-01, &
        0.5468334E-01, 0.6184222E-01, 0.7047983E-01, 0.8113195E-01, &
        0.9462444E-01, 0.1123001E+00, 0.1364980E+00, 0.1716886E+00, &
        0.2276241E+00, 0.3304980E+00, 0.5847031E+00 /

  u = r4_uni_01 ( )
  if ( u <= 0.5E+00 ) then
    s = 0.0E+00
  else
    s = 1.0E+00
  end if
  u = 2.0E+00 * u - s
  u = 32.0E+00 * u
  i = int ( u )
  if ( i == 32 ) then
    i = 31
  end if
!
!  Center
!
  if ( i /= 0 ) then

    ustar = u - real ( i )
    aa = a(i)

    do

      if ( t(i) < ustar ) then

        w = ( ustar - t(i) ) * h(i)

        y = aa + w

        if ( s /= 1.0E+00 ) then
          snorm = y
        else
          snorm = -y
        end if

        return

      end if

      u = r4_uni_01 ( )
      w = u * ( a(i+1) - aa )
      tt = ( 0.5E+00 * w + aa ) * w

      do

        if ( tt < ustar ) then
          y = aa + w
          if ( s /= 1.0E+00 ) then
            snorm = y
          else
            snorm = -y
          end if
          return
        end if

        u = r4_uni_01 ( )

        if ( ustar < u ) then
          exit
        end if

        tt = u
        ustar = r4_uni_01 ( )

      end do

      ustar = r4_uni_01 ( )

    end do
!
!  Tail
!
  else

    i = 6
    aa = a(32)

    do

      u = u + u

      if ( 1.0E+00 <= u ) then
        exit
      end if

      aa = aa + d(i)
      i = i + 1

    end do

    u = u - 1.0E+00
    w = u * d(i)
    tt = ( 0.5E+00 * w + aa ) * w

    do

      ustar = r4_uni_01 ( )

      if ( tt < ustar ) then
        y = aa + w
        if ( s /= 1.0E+00 ) then
          snorm = y
        else
          snorm = -y
        end if
        return
      end if

      u = r4_uni_01 ( )

      if ( u <= ustar ) then
        tt = u
      else
        u = r4_uni_01 ( )
        w = u * d(i)
        tt = ( 0.5E+00 * w + aa ) * w
      end if

    end do

  end if

end function snorm

function ignpoi ( mu )

!*****************************************************************************80
!
!! IGNPOI generates a Poisson random deviate.
!
!  Discussion:
!
!    This procedure generates a single random deviate from a Poisson
!    distribution with given mean.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    01 April 2013
!
!  Author:
!
!    Original FORTRAN77 version by Barry Brown, James Lovato.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Joachim Ahrens, Ulrich Dieter,
!    Computer Generation of Poisson Deviates
!    From Modified Normal Distributions,
!    ACM Transactions on Mathematical Software,
!    Volume 8, Number 2, June 1982, pages 163-179.
!
!  Parameters:
!
!    Input, real ( kind = 4 ) MU, the mean of the Poisson distribution
!    from which a random deviate is to be generated.
!
!    Output, integer ( kind = 4 ) IGNPOI, a random deviate from
!    the distribution.
!
  implicit none

  real ( kind = 4 ), parameter :: a0 = -0.5E+00
  real ( kind = 4 ), parameter :: a1 =  0.3333333E+00
  real ( kind = 4 ), parameter :: a2 = -0.2500068E+00
  real ( kind = 4 ), parameter :: a3 =  0.2000118E+00
  real ( kind = 4 ), parameter :: a4 = -0.1661269E+00
  real ( kind = 4 ), parameter :: a5 =  0.1421878E+00
  real ( kind = 4 ), parameter :: a6 = -0.1384794E+00
  real ( kind = 4 ), parameter :: a7 =  0.1250060E+00
  real ( kind = 4 ) b1
  real ( kind = 4 ) b2
  real ( kind = 4 ) c
  real ( kind = 4 ) c0
  real ( kind = 4 ) c1
  real ( kind = 4 ) c2
  real ( kind = 4 ) c3
  real ( kind = 4 ) d
  real ( kind = 4 ) del
  real ( kind = 4 ) difmuk
  real ( kind = 4 ) e
  real ( kind = 4 ) fact(10)
  real ( kind = 4 ) fk
  real ( kind = 4 ) fx
  real ( kind = 4 ) fy
  real ( kind = 4 ) g
  integer ( kind = 4 ) ignpoi
  !integer ( kind = 4 ) j
  integer ( kind = 4 ) k
  integer ( kind = 4 ) kflag
  integer ( kind = 4 ) l
  integer ( kind = 4 ) m
  real ( kind = 4 ) mu
  !real ( kind = 4 ) muold
  !real ( kind = 4 ) muprev
  real ( kind = 4 ) omega
  real ( kind = 4 ) p
  real ( kind = 4 ) p0
  real ( kind = 4 ) px
  real ( kind = 4 ) py
  real ( kind = 4 ) q
  real ( kind = 4 ) r4_uni_01
  real ( kind = 4 ) s
  !real ( kind = 4 ) sexpo
  !real ( kind = 4 ) snorm
  real ( kind = 4 ) t
  real ( kind = 4 ) u
  real ( kind = 4 ) v
  real ( kind = 4 ) x
  real ( kind = 4 ) xx

  save fact

  data fact / 1.0E+00, 1.0E+00, 2.0E+00, 6.0E+00, 24.0E+00, &
    120.0E+00, 720.0E+00, 5040.0E+00, 40320.0E+00, 362880.0E+00 /
!
!  Start new table and calculate P0.
!
  if ( mu < 10.0E+00 ) then

    m = max ( 1, int ( mu ) )
    p = exp ( - mu )
    q = p
    p0 = p
!
!  Uniform sample for inversion method.
!
    do

      u = r4_uni_01 ( )
      ignpoi = 0

      if ( u <= p0 ) then
        return
      end if

!
!  Creation of new Poisson probabilities.
!
      do k = 1, 35
        p = p * mu / real ( k )
        q = q + p
        if ( u <= q ) then
          ignpoi = k
          return
        end if
      end do

    end do

  else
    s = sqrt ( mu )
    d = 6.0E+00 * mu * mu
    l = int ( mu - 1.1484E+00 )
!
!  Normal sample.
!
    g = mu + s * snorm ( )

    if ( 0.0E+00 <= g ) then

      ignpoi = int ( g )
!
!  Immediate acceptance if large enough.
!
      if ( l <= ignpoi ) then
        return
      end if
!
!  Squeeze acceptance.
!
      fk = real ( ignpoi )
      difmuk = mu - fk
      u = r4_uni_01 ( )

      if ( difmuk * difmuk * difmuk <= d * u ) then
        return
      end if

    end if
!
!  Preparation for steps P and Q.
!
    omega = 0.3989423E+00 / s
    b1 = 0.04166667E+00 / mu
    b2 = 0.3E+00 * b1 * b1
    c3 = 0.1428571E+00 * b1 * b2
    c2 = b2 - 15.0E+00 * c3
    c1 = b1 - 6.0E+00 * b2 + 45.0E+00 * c3
    c0 = 1.0E+00 - b1 + 3.0E+00 * b2 - 15.0E+00 * c3
    c = 0.1069E+00 / mu
    if ( 0.0E+00 <= g ) then

      kflag = 0

      if ( ignpoi < 10 ) then

        px = -mu
        py = mu ** ignpoi / fact(ignpoi+1)

      else

        del = 0.8333333E-01 / fk
        del = del - 4.8E+00 * del * del * del
        v = difmuk / fk

        if ( 0.25E+00 < abs ( v ) ) then
          px = fk * log ( 1.0E+00 + v ) - difmuk - del
        else
          px = fk * v * v * ((((((( a7 &
            * v + a6 ) &
            * v + a5 ) &
            * v + a4 ) &
            * v + a3 ) &
            * v + a2 ) &
            * v + a1 ) &
            * v + a0 ) - del
        end if

        py = 0.3989423E+00 / sqrt ( fk )

      end if
      x = ( 0.5E+00 - difmuk ) / s
      xx = x * x
      fx = -0.5E+00 * xx
      fy = omega * ((( c3 * xx + c2 ) * xx + c1 ) * xx + c0 )

      if ( kflag <= 0 ) then

        if ( fy - u * fy <= py * exp ( px - fx ) ) then
          return
        end if

      else

        if ( c * abs ( u ) <= py * exp ( px + e ) - fy * exp ( fx + e ) ) then
          return
        end if

      end if

    end if
!
!  Exponential sample.
!
    do
      e = sexpo ( )
      u = 2.0E+00 * r4_uni_01 ( ) - 1.0E+00
      if ( u < 0.0E+00 ) then
        t = 1.8E+00 - abs ( e )
      else
        t = 1.8E+00 + abs ( e )
      end if

      if ( t <= -0.6744E+00 ) then
        cycle
      end if

      ignpoi = int ( mu + s * t )
      fk = real ( ignpoi )
      difmuk = mu - fk

      kflag = 1
!
!  Calculation of PX, PY, FX, FY.
!
      if ( ignpoi < 10 ) then

        px = -mu
        py = mu ** ignpoi / fact(ignpoi+1)

      else

        del = 0.8333333E-01 / fk
        del = del - 4.8E+00 * del * del * del
        v = difmuk / fk

        if ( 0.25E+00 < abs ( v ) ) then
          px = fk * log ( 1.0E+00 + v ) - difmuk - del
        else
          px = fk * v * v * ((((((( a7 &
            * v + a6 ) &
            * v + a5 ) &
            * v + a4 ) &
            * v + a3 ) &
            * v + a2 ) &
            * v + a1 ) &
            * v + a0 ) - del
        end if

        py = 0.3989423E+00 / sqrt ( fk )

      end if
      x = ( 0.5E+00 - difmuk ) / s
      xx = x * x
      fx = -0.5E+00 * xx
      fy = omega * ((( c3 * xx + c2 ) * xx + c1 ) * xx + c0 )

      if ( kflag <= 0 ) then

        if ( fy - u * fy <= py * exp ( px - fx ) ) then
          return
        end if

      else

        if ( c * abs ( u ) <= py * exp ( px + e ) - fy * exp ( fx + e ) ) then
          return
        end if

      end if

    end do

  end if

end function ignpoi

end module ranlib_poisson


      SUBROUTINE slave( bufl, nlong, bufs, nshort, nsamps, thres, index,
     &   aves, avel, iprint )
!   Short-long average amplitude picker.
!   buf - the data array
!   nsamps - the number of samples in buf
!   nshort - the number of samples in the short average window.
!   nlong - the number of samples in the long average window.
!   thres - the threshold ratio of short/long that defines a pick
!   index - the index of the pick in buf.  The index is the "center" of
!           the window when (short average) / (long average) exceeded
!           thres.  An index of 0 means thres was never exceed (pick
!           failed).
!   aves - the computed short average of the window when the ratio
!          exceed thres.
!   avel - the computed long window average.
!
!  Copyrighted and written by:  Paul Henkart,
!  SCRIPPS INSTITUTION OF OCEANOGRAPHY, September 1995
!  All Rights Reserved.
!
!  mod 8 Jan 03 - Skip the short window if it's 0.
!
      REAL bufl(1), bufs(1), thres, aves, avel
      INTEGER nlong, nshort, nsamps, index
      REAL sum, avelong, aveshort, shortn, ratio
      INTEGER index1, index2, i
      LOGICAL iprint
!
      ratio = thres
      sum = 0.
      DO i = 1, nlong
         sum = sum + ABS(bufl(i))
      ENDDO
      avelong = sum / FLOAT(nlong)
      avel = avelong
      shortn = FLOAT(nshort)
      sum = 0.
      DO i = 1, nshort
         sum = sum + ABS(bufs(i))
      ENDDO
      aveshort = sum / shortn
      index = 0
      index1 = 1
      DO index2 = nshort+1, nsamps
         IF( iprint ) PRINT *,' short=',aveshort,' long=',avelong,
     &       ' ratio=',ABS(aveshort / avelong)
         IF( aveshort .NE. 0. .AND. avelong .NE. 0. ) THEN
             IF( ABS(aveshort / avelong) .GT. ratio ) THEN
                 index = index1 + nshort / 2
                 aves = aveshort
                 RETURN
             ENDIF
         ENDIF
         sum = sum - ABS(bufs(index1)) + ABS(bufs(index2))
         aveshort = sum / shortn
         index1 = index1 + 1
      ENDDO
      RETURN
      END


      SUBROUTINE MAGPHA( A, B )
C*****
C THIS SUBROUTINE FORMS THE MAGNITUDE OF (A,B) AND STORES IT IN A...
C THE PHASE OF (X=A, Y=B) IS THEN FORMED AND THE RESULT STORED IN B...
C*****
      COMMON /CONDAS/ CONSTS(5)
C
      EQUIVALENCE ( CONSTS(3) , RADEG  )
C
      VALUE = SQRT( A**2 + B**2 )
      IF( VALUE ) 10,20,10
   10 PHASE = ATAN2( B, A ) * RADEG
      GO TO 30
   20 PHASE = 0.0E0
      GO TO 40
   30 IF( PHASE .LT. (-0.00005E0) ) PHASE = PHASE + 360.0E0
   40 A = VALUE
      B = PHASE
      RETURN
      END


 MODULE GDSWZD05_MOD
!$$$  MODULE DOCUMENTATION BLOCK
!
! $Revision: 71314 $
!
! MODULE:  GDSWZD05_MOD  GDS WIZARD MODULE FOR POLAR STEREOGRAPHIC
!                        AZIMUTHAL GRIDS.
!   PRGMMR: GAYNO     ORG: W/NMC23       DATE: 2015-01-21
!
! ABSTRACT: - CONVERT FROM EARTH TO GRID COORDINATES OR VICE VERSA
!             (SPHERICAL OR ELLIPTICAL EARTH).
!           - COMPUTE VECTOR ROTATION SINES AND COSINES.
!             (SPHERICAL OR ELLIPTICAL EARTH).
!           - COMPUTE MAP JACOBIANS (SPHERICAL EARTH).
!           - COMPUTE GRID BOX AREA (SPHERICAL EARTH).
!
! PROGRAM HISTORY LOG:
!   2015-01-21  GAYNO   INITIAL VERSION FROM A MERGER OF
!                       ROUTINES GDSWIZ05 AND GDSWZD05.
!
! USAGE:  "USE GDSWZD05_MOD"  THEN CALL THE PUBLIC DRIVER
!         ROUTINE "GDSWZD05".
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
!
 IMPLICIT NONE

 PRIVATE

 PUBLIC                          :: GDSWZD05

 REAL,             PARAMETER     :: RERTH=6.3712E6
 REAL,             PARAMETER     :: RERTH_WGS84=6.378137E6
 REAL,             PARAMETER     :: PI=3.14159265358979
 REAL,             PARAMETER     :: DPR=180./PI
 REAL,             PARAMETER     :: PI2=PI/2.0
 REAL,             PARAMETER     :: PI4=PI/4.0
 REAL,             PARAMETER     :: E2=.00669437999013  ! wgs84 datum
 REAL,             PARAMETER     :: SLAT=60.0  ! standard latitude according
                                               ! to grib 1 standard
 REAL,             PARAMETER     :: SLATR=SLAT/DPR

 INTEGER                         :: IROT

 REAL                            :: DE2, DR2, DXS, DYS, H, ORIENT

 CONTAINS

 SUBROUTINE GDSWZD05(KGDS,IOPT,NPTS,FILL,XPTS,YPTS,RLON,RLAT,NRET, &
                     CROT,SROT,XLON,XLAT,YLON,YLAT,AREA)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  GDSWZD05   GDS WIZARD FOR POLAR STEREOGRAPHIC AZIMUTHAL
!   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-04-10
!
! ABSTRACT: THIS SUBPROGRAM DECODES THE GRIB GRID DESCRIPTION SECTION
!           (PASSED IN INTEGER FORM AS DECODED BY SUBPROGRAM W3FI63)
!           AND RETURNS ONE OF THE FOLLOWING:
!             (IOPT=+1) EARTH COORDINATES OF SELECTED GRID COORDINATES
!             (IOPT=-1) GRID COORDINATES OF SELECTED EARTH COORDINATES
!           FOR POLAR STEREOGRAPHIC AZIMUTHAL PROJECTIONS.
!           IF THE SELECTED COORDINATES ARE MORE THAN ONE GRIDPOINT
!           BEYOND THE THE EDGES OF THE GRID DOMAIN, THEN THE RELEVANT
!           OUTPUT ELEMENTS ARE SET TO FILL VALUES.
!           THE ACTUAL NUMBER OF VALID POINTS COMPUTED IS RETURNED TOO.
!           OPTIONALLY, THE VECTOR ROTATIONS, MAP JACOBIANS, AND
!           GRID BOX AREAS MAY BE RETURNED AS WELL.  ROUTINE WORKS
!           FOR BOTH SPHERICAL AND ELLIPTICAL EARTHS WITH THE
!           EXCEPTION OF THE MAP JACOBIANS AND GRID BOX AREAS, WHICH
!           ARE ONLY COMPUTED FOR SPHERICAL EARTHS.  TO COMPUTE
!           THE VECTOR ROTATIONS, THE OPTIONAL ARGUMENTS 'SROT' AND 'CROT'
!           MUST BE PRESENT.  TO COMPUTE THE MAP JACOBIANS, THE
!           OPTIONAL ARGUMENTS 'XLON', 'XLAT', 'YLON', 'YLAT' MUST BE PRESENT.
!           TO COMPUTE THE GRID BOX AREAS, THE OPTIONAL ARGUMENT
!           'AREA' MUST BE PRESENT.
!
! PROGRAM HISTORY LOG:
!   96-04-10  IREDELL
!   97-10-20  IREDELL  INCLUDE MAP OPTIONS
!   09-05-13  GAYNO    ENSURE AREA ALWAYS POSITIVE
! 2015-01-21  GAYNO    MERGER OF GDSWIZ05 AND GDSWZD05.  MAKE
!                      CROT,SORT,XLON,XLAT,YLON,YLAT AND AREA
!                      OPTIONAL ARGUMENTS.  MAKE PART OF A MODULE.
!                      MOVE VECTOR ROTATION, MAP JACOBIAN AND GRID
!                      BOX AREA COMPUTATIONS TO SEPARATE SUBROUTINES.
!                      INCLUDE OPTION FOR ELLIPTICAL EARTHS.
!
! USAGE:    CALL GDSWZD05(KGDS,IOPT,NPTS,FILL,XPTS,YPTS,RLON,RLAT,NRET,
!    &                    CROT,SROT,XLON,XLAT,YLON,YLAT,AREA)
!
!   INPUT ARGUMENT LIST:
!     KGDS     - INTEGER (200) GDS PARAMETERS AS DECODED BY W3FI63
!     IOPT     - INTEGER OPTION FLAG
!                (+1 TO COMPUTE EARTH COORDS OF SELECTED GRID COORDS)
!                (-1 TO COMPUTE GRID COORDS OF SELECTED EARTH COORDS)
!     NPTS     - INTEGER MAXIMUM NUMBER OF COORDINATES
!     FILL     - REAL FILL VALUE TO SET INVALID OUTPUT DATA
!                (MUST BE IMPOSSIBLE VALUE; SUGGESTED VALUE: -9999.)
!     XPTS     - REAL (NPTS) GRID X POINT COORDINATES IF IOPT>0
!     YPTS     - REAL (NPTS) GRID Y POINT COORDINATES IF IOPT>0
!     RLON     - REAL (NPTS) EARTH LONGITUDES IN DEGREES E IF IOPT<0
!                (ACCEPTABLE RANGE: -360. TO 360.)
!     RLAT     - REAL (NPTS) EARTH LATITUDES IN DEGREES N IF IOPT<0
!                (ACCEPTABLE RANGE: -90. TO 90.)
!
!   OUTPUT ARGUMENT LIST:
!     XPTS     - REAL (NPTS) GRID X POINT COORDINATES IF IOPT<0
!     YPTS     - REAL (NPTS) GRID Y POINT COORDINATES IF IOPT<0
!     RLON     - REAL (NPTS) EARTH LONGITUDES IN DEGREES E IF IOPT>0
!     RLAT     - REAL (NPTS) EARTH LATITUDES IN DEGREES N IF IOPT>0
!     NRET     - INTEGER NUMBER OF VALID POINTS COMPUTED
!     CROT     - REAL, OPTIONAL (NPTS) CLOCKWISE VECTOR ROTATION COSINES
!     SROT     - REAL, OPTIONAL (NPTS) CLOCKWISE VECTOR ROTATION SINES
!                (UGRID=CROT*UEARTH-SROT*VEARTH;
!                 VGRID=SROT*UEARTH+CROT*VEARTH)
!     XLON     - REAL, OPTIONAL (NPTS) DX/DLON IN 1/DEGREES
!     XLAT     - REAL, OPTIONAL (NPTS) DX/DLAT IN 1/DEGREES
!     YLON     - REAL, OPTIONAL (NPTS) DY/DLON IN 1/DEGREES
!     YLAT     - REAL, OPTIONAL (NPTS) DY/DLAT IN 1/DEGREES
!     AREA     - REAL, OPTIONAL (NPTS) AREA WEIGHTS IN M**2
!                (PROPORTIONAL TO THE SQUARE OF THE MAP FACTOR)
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
 IMPLICIT NONE
!
 INTEGER,          INTENT(IN   ) :: IOPT, KGDS(200), NPTS
 INTEGER,          INTENT(  OUT) :: NRET
!
 REAL,             INTENT(IN   ) :: FILL
 REAL,             INTENT(INOUT) :: RLON(NPTS),RLAT(NPTS)
 REAL,             INTENT(INOUT) :: XPTS(NPTS),YPTS(NPTS)
 REAL, OPTIONAL,   INTENT(  OUT) :: CROT(NPTS),SROT(NPTS)
 REAL, OPTIONAL,   INTENT(  OUT) :: XLON(NPTS),XLAT(NPTS)
 REAL, OPTIONAL,   INTENT(  OUT) :: YLON(NPTS),YLAT(NPTS),AREA(NPTS)
!
 INTEGER                         :: IM, JM, IPROJ
 INTEGER                         :: ISCAN, JSCAN, ITER, N
!
 LOGICAL                         :: ELLIPTICAL, LROT, LMAP, LAREA
!
 REAL                            :: ALAT, ALAT1, ALONG, DIFF
 REAL                            :: DI, DJ, DE
 REAL                            :: DX, DY
 REAL                            :: DR, E, E_OVER_2, HI, HJ
 REAL                            :: MC
 REAL                            :: RLAT1, RLON1, RHO, T, TC
 REAL                            :: XMAX, XMIN, YMAX, YMIN
 REAL                            :: XP, YP
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 IF(PRESENT(CROT)) CROT=FILL
 IF(PRESENT(SROT)) SROT=FILL
 IF(PRESENT(XLON)) XLON=FILL
 IF(PRESENT(XLAT)) XLAT=FILL
 IF(PRESENT(YLON)) YLON=FILL
 IF(PRESENT(YLAT)) YLAT=FILL
 IF(PRESENT(AREA)) AREA=FILL
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 IF(KGDS(1).EQ.005) THEN
   ELLIPTICAL=MOD(KGDS(6)/64,2).EQ.1
   IM=KGDS(2)
   JM=KGDS(3)
   RLAT1=KGDS(4)*1.E-3
   RLON1=KGDS(5)*1.E-3
   IROT=MOD(KGDS(6)/8,2)
   ORIENT=KGDS(7)*1.E-3
   DX=KGDS(8)
   DY=KGDS(9)
   IPROJ=MOD(KGDS(10)/128,2)
   ISCAN=MOD(KGDS(11)/128,2)
   JSCAN=MOD(KGDS(11)/64,2)
   H=(-1.)**IPROJ
   HI=(-1.)**ISCAN
   HJ=(-1.)**(1-JSCAN)
   DXS=DX*HI
   DYS=DY*HJ
   IF(H.EQ.-1)ORIENT=ORIENT+180.
!
! FIND X/Y OF POLE
   IF (.NOT.ELLIPTICAL) THEN
     DE=(1.+SIN(SLATR))*RERTH
     DR=DE*COS(RLAT1/DPR)/(1+H*SIN(RLAT1/DPR))
     XP=1-H*SIN((RLON1-ORIENT)/DPR)*DR/DXS
     YP=1+COS((RLON1-ORIENT)/DPR)*DR/DYS
     DE2=DE**2
   ELSE
     E=SQRT(E2)
     E_OVER_2=E*0.5
     ALAT=H*RLAT1/DPR
     ALONG = (RLON1-ORIENT)/DPR
     T=TAN(PI4-ALAT/2.)/((1.-E*SIN(ALAT))/  &
       (1.+E*SIN(ALAT)))**(E_OVER_2)
     TC=TAN(PI4-SLATR/2.)/((1.-E*SIN(SLATR))/  &
       (1.+E*SIN(SLATR)))**(E_OVER_2)
     MC=COS(SLATR)/SQRT(1.0-E2*(SIN(SLATR)**2))
     RHO=RERTH_WGS84*MC*T/TC
     YP = 1.0 + RHO*COS(H*ALONG)/DYS
     XP = 1.0 - RHO*SIN(H*ALONG)/DXS
   ENDIF ! ELLIPTICAL
   XMIN=0
   XMAX=IM+1
   YMIN=0
   YMAX=JM+1
   NRET=0
   IF(PRESENT(CROT).AND.PRESENT(SROT))THEN
     LROT=.TRUE.
   ELSE
     LROT=.FALSE.
   ENDIF
   IF(PRESENT(XLON).AND.PRESENT(XLAT).AND.PRESENT(YLON).AND.PRESENT(YLAT))THEN
     LMAP=.TRUE.
   ELSE
     LMAP=.FALSE.
   ENDIF
   IF(PRESENT(AREA))THEN
     LAREA=.TRUE.
   ELSE
     LAREA=.FALSE.
   ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  TRANSLATE GRID COORDINATES TO EARTH COORDINATES
   IF(IOPT.EQ.0.OR.IOPT.EQ.1) THEN
     IF(.NOT.ELLIPTICAL)THEN
       DO N=1,NPTS
         IF(XPTS(N).GE.XMIN.AND.XPTS(N).LE.XMAX.AND. &
            YPTS(N).GE.YMIN.AND.YPTS(N).LE.YMAX) THEN
           DI=(XPTS(N)-XP)*DXS
           DJ=(YPTS(N)-YP)*DYS
           DR2=DI**2+DJ**2
           IF(DR2.LT.DE2*1.E-6) THEN
             RLON(N)=0.
             RLAT(N)=H*90.
           ELSE
             RLON(N)=MOD(ORIENT+H*DPR*ATAN2(DI,-DJ)+3600,360.)
             RLAT(N)=H*DPR*ASIN((DE2-DR2)/(DE2+DR2))
           ENDIF
           NRET=NRET+1
           IF(LROT) CALL GDSWZD05_VECT_ROT(RLON(N),CROT(N),SROT(N))
           IF(LMAP) CALL GDSWZD05_MAP_JACOB(RLON(N),RLAT(N), &
                                            XLON(N),XLAT(N),YLON(N),YLAT(N))
           IF(LAREA) CALL GDSWZD05_GRID_AREA(RLAT(N),AREA(N))
         ELSE
           RLON(N)=FILL
           RLAT(N)=FILL
         ENDIF
       ENDDO
     ELSE ! ELLIPTICAL
       DO N=1,NPTS
         IF(XPTS(N).GE.XMIN.AND.XPTS(N).LE.XMAX.AND.  &
            YPTS(N).GE.YMIN.AND.YPTS(N).LE.YMAX) THEN
           DI=(XPTS(N)-XP)*DXS
           DJ=(YPTS(N)-YP)*DYS
           RHO=SQRT(DI*DI+DJ*DJ)
           T=(RHO*TC)/(RERTH_WGS84*MC)
           IF(ABS(YPTS(N)-YP)<0.01)THEN
             IF(DI>0.0) ALONG=ORIENT+H*90.0
             IF(DI<=0.0) ALONG=ORIENT-H*90.0
           ELSE
             ALONG=ORIENT+H*ATAN(DI/(-DJ))*DPR
             IF(DJ>0) ALONG=ALONG+180.
           END IF
           ALAT1=PI2-2.0*ATAN(T)
           DO ITER=1,10
             ALAT = PI2 - 2.0*ATAN(T*(((1.0-E*SIN(ALAT1))/  &
                   (1.0+E*SIN(ALAT1)))**(E_OVER_2)))
             DIFF = ABS(ALAT-ALAT1)*DPR
             IF (DIFF < 0.000001) EXIT
             ALAT1=ALAT
           ENDDO
           RLAT(N)=H*ALAT*DPR
           RLON(N)=ALONG
           IF(RLON(N)<0.0) RLON(N)=RLON(N)+360.
           IF(RLON(N)>360.0) RLON(N)=RLON(N)-360.0
           NRET=NRET+1
           IF(LROT) CALL GDSWZD05_VECT_ROT(RLON(N),CROT(N),SROT(N))
         ELSE
           RLON(N)=FILL
           RLAT(N)=FILL
         ENDIF
       ENDDO
     ENDIF ! ELLIPTICAL
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  TRANSLATE EARTH COORDINATES TO GRID COORDINATES
   ELSEIF(IOPT.EQ.-1) THEN
     IF(.NOT.ELLIPTICAL)THEN
       DO N=1,NPTS
         IF(ABS(RLON(N)).LE.360.AND.ABS(RLAT(N)).LE.90.AND. &
                                       H*RLAT(N).NE.-90) THEN
           DR=DE*TAN((90-H*RLAT(N))/2/DPR)
           DR2=DR**2
           XPTS(N)=XP+H*SIN((RLON(N)-ORIENT)/DPR)*DR/DXS
           YPTS(N)=YP-COS((RLON(N)-ORIENT)/DPR)*DR/DYS
           IF(XPTS(N).GE.XMIN.AND.XPTS(N).LE.XMAX.AND. &
              YPTS(N).GE.YMIN.AND.YPTS(N).LE.YMAX) THEN
             NRET=NRET+1
             IF(LROT) CALL GDSWZD05_VECT_ROT(RLON(N),CROT(N),SROT(N))
             IF(LMAP) CALL GDSWZD05_MAP_JACOB(RLON(N),RLAT(N), &
                                              XLON(N),XLAT(N),YLON(N),YLAT(N))
             IF(LAREA) CALL GDSWZD05_GRID_AREA(RLAT(N),AREA(N))
           ELSE
             XPTS(N)=FILL
             YPTS(N)=FILL
           ENDIF
         ELSE
           XPTS(N)=FILL
           YPTS(N)=FILL
         ENDIF
       ENDDO
     ELSE  ! ELLIPTICAL CASE
       DO N=1,NPTS
         IF(ABS(RLON(N)).LE.360.AND.ABS(RLAT(N)).LE.90.AND.  &
                                        H*RLAT(N).NE.-90) THEN
           ALAT = H*RLAT(N)/DPR
           ALONG = (RLON(N)-ORIENT)/DPR
           T=TAN(PI4-ALAT*0.5)/((1.-E*SIN(ALAT))/  &
             (1.+E*SIN(ALAT)))**(E_OVER_2)
           RHO=RERTH_WGS84*MC*T/TC
           XPTS(N)= XP + RHO*SIN(H*ALONG) / DXS
           YPTS(N)= YP - RHO*COS(H*ALONG) / DYS
           IF(XPTS(N).GE.XMIN.AND.XPTS(N).LE.XMAX.AND.  &
              YPTS(N).GE.YMIN.AND.YPTS(N).LE.YMAX) THEN
             NRET=NRET+1
             IF(LROT) CALL GDSWZD05_VECT_ROT(RLON(N),CROT(N),SROT(N))
           ELSE
             XPTS(N)=FILL
             YPTS(N)=FILL
           ENDIF
         ELSE
           XPTS(N)=FILL
           YPTS(N)=FILL
         ENDIF
       ENDDO
     ENDIF
   ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  PROJECTION UNRECOGNIZED
 ELSE
   IF(IOPT.GE.0) THEN
     DO N=1,NPTS
       RLON(N)=FILL
       RLAT(N)=FILL
     ENDDO
   ENDIF
   IF(IOPT.LE.0) THEN
     DO N=1,NPTS
       XPTS(N)=FILL
       YPTS(N)=FILL
     ENDDO
   ENDIF
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 END SUBROUTINE GDSWZD05
!
 SUBROUTINE GDSWZD05_VECT_ROT(RLON, CROT, SROT)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  GDSWZD05_VECT_ROT   VECTOR ROTATION FIELDS FOR
!                                  POLAR STEREOGRAPHIC GRIDS.
!
!   PRGMMR: GAYNO     ORG: W/NMC23       DATE: 2015-01-21
!
! ABSTRACT: THIS SUBPROGRAM COMPUTES THE VECTOR ROTATION SINES AND
!           COSINES FOR A POLAR STEREOGRAPHIC AZIMUTHAL GRID.
!
! PROGRAM HISTORY LOG:
! 2015-01-21  GAYNO    INITIAL VERSION
!
! USAGE:    CALL GDSWZD05_VECT_ROT(RLON,CROT,SROT)
!
!   INPUT ARGUMENT LIST:
!     RLON     - GRID POINT LONGITUDE IN DEGREES (REAL)
!
!   OUTPUT ARGUMENT LIST:
!     CROT     - CLOCKWISE VECTOR ROTATION COSINES (REAL)
!     SROT     - CLOCKWISE VECTOR ROTATION SINES (REAL)
!                (UGRID=CROT*UEARTH-SROT*VEARTH;
!                 VGRID=SROT*UEARTH+CROT*VEARTH)
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
!
 IMPLICIT NONE

 REAL,             INTENT(IN   ) :: RLON
 REAL,             INTENT(  OUT) :: CROT, SROT

 IF(IROT.EQ.1) THEN
   CROT=H*COS((RLON-ORIENT)/DPR)
   SROT=SIN((RLON-ORIENT)/DPR)
 ELSE
   CROT=1.
   SROT=0.
 ENDIF

 END SUBROUTINE GDSWZD05_VECT_ROT
!
 SUBROUTINE GDSWZD05_MAP_JACOB(RLON,RLAT,XLON,XLAT,YLON,YLAT)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  GDSWZD05_MAP_JACOB  MAP JACOBIANS FOR
!                                  POLAR STEREOGRAPHIC GRIDS.
!
!   PRGMMR: GAYNO     ORG: W/NMC23       DATE: 2015-01-21
!
! ABSTRACT: THIS SUBPROGRAM COMPUTES THE MAP JACOBIANS FOR
!           A POLAR STEREOGRAPHIC AZIMUTHAL GRID (SPHERICAL
!           EARTH).
!
! PROGRAM HISTORY LOG:
! 2015-01-21  GAYNO    INITIAL VERSION
!
! USAGE:  CALL GDSWZD05_MAP_JACOB(RLON,RLAT,XLON,XLAT,YLON,YLAT)
!
!   INPUT ARGUMENT LIST:
!     RLON     - LONGITUDE IN DEGREES (REAL)
!     RLAT     - LATITUDE IN DEGREES (REAL)
!
!   OUTPUT ARGUMENT LIST:
!     XLON     - DX/DLON IN 1/DEGREES (REAL)
!     XLAT     - DX/DLAT IN 1/DEGREES (REAL)
!     YLON     - DY/DLON IN 1/DEGREES (REAL)
!     YLAT     - DY/DLAT IN 1/DEGREES (REAL)
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
!
 IMPLICIT NONE

 REAL,             INTENT(IN   ) :: RLON, RLAT
 REAL,             INTENT(  OUT) :: XLON, XLAT, YLON, YLAT

 REAL                            :: CLAT, DE, DR

 IF(DR2.LT.DE2*1.E-6) THEN
   DE=SQRT(DE2)
   XLON=0.
   XLAT=-SIN((RLON-ORIENT)/DPR)/DPR*DE/DXS/2
   YLON=0.
   YLAT=H*COS((RLON-ORIENT)/DPR)/DPR*DE/DYS/2
 ELSE
   DR=SQRT(DR2)
   CLAT=COS(RLAT/DPR)
   XLON=H*COS((RLON-ORIENT)/DPR)/DPR*DR/DXS
   XLAT=-SIN((RLON-ORIENT)/DPR)/DPR*DR/DXS/CLAT
   YLON=SIN((RLON-ORIENT)/DPR)/DPR*DR/DYS
   YLAT=H*COS((RLON-ORIENT)/DPR)/DPR*DR/DYS/CLAT
 ENDIF

 END SUBROUTINE GDSWZD05_MAP_JACOB
!
 SUBROUTINE GDSWZD05_GRID_AREA(RLAT, AREA)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  GDSWZD05_GRID_AREA  GRID BOX AREA FOR
!                                  POLAR STEREOGRAPHIC GRIDS
!
!   PRGMMR: GAYNO     ORG: W/NMC23       DATE: 2015-01-21
!
! ABSTRACT: THIS SUBPROGRAM COMPUTES THE GRID BOX AREA FOR
!           A POLAR STEREOGRAPHIC AZIMUTHAL GRID (SPHERICAL
!           EARTH).
!
! PROGRAM HISTORY LOG:
! 2015-01-21  GAYNO    INITIAL VERSION
!
! USAGE:  CALL GDSWZD05_GRID_AREA(RLAT,AREA)
!
!   INPUT ARGUMENT LIST:
!     RLAT     - LATITUDE OF GRID POINT IN DEGREES (REAL)
!
!   OUTPUT ARGUMENT LIST:
!     AREA     - AREA WEIGHTS IN M**2 (REAL)
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
!
 IMPLICIT NONE

 REAL,             INTENT(IN   ) :: RLAT
 REAL,             INTENT(  OUT) :: AREA

 REAL                            :: CLAT

 IF(DR2.LT.DE2*1.E-6) THEN
   AREA=RERTH**2*ABS(DXS)*ABS(DYS)*4/DE2
 ELSE
   CLAT=COS(RLAT/DPR)
   AREA=RERTH**2*CLAT**2*ABS(DXS)*ABS(DYS)/DR2
 ENDIF

 END SUBROUTINE GDSWZD05_GRID_AREA

 END MODULE GDSWZD05_MOD


!--------10--------20--------30--------40--------50--------60--------70--------80--------90--------100-------110-------120--------130
Module Constants
  implicit none
!Mathematicl constants
  real(8), parameter :: pi = 4.d0*atan(1.0d0)
  real(8), parameter :: tpi = 2.d0*pi
  real(8), parameter :: fpi = 4.d0*pi
  complex(8), parameter :: zI = (0.d0,1.d0)
!Physical constants
  real(8), parameter :: sol = 137.0d0 !speed of light
  real(8), parameter :: aB = 0.0529177d0 !nanometer
  real(8), parameter :: Hartree = 27.2116d0 !eV
  real(8), parameter :: Atomtime = 0.02419d0 !fs
  real(8), parameter :: Atomfield = 514.2d0 !V/nm
  real(8), parameter :: ch = 1240.0d0 !eV * nm
  real(8), parameter :: chbar = 197.3d0 ! eV * nm
  real(8), parameter :: halfepsc = 3.509d16 ! W/cm^2 \frac{1}{2}*\epsilon_0 * c
  real(8), parameter :: Atomfluence = halfepsc*Atomtime*1.0d-15 ! J/cm^2 ,W/cm^2 * fs = femto J/cm^2
!LDA Constants
  real(8),parameter :: gammaU=-0.1423d0,beta1U=1.0529d0
  real(8),parameter :: beta2U=0.3334d0,AU=0.0311d0,BU=-0.048d0
  real(8),parameter :: CU=0.002d0,DU=-0.0116d0

End Module Constants
!--------10--------20--------30--------40--------50--------60--------70--------80--------90--------100-------110-------120--------130


!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!                          Futility Development Group                          !
!                             All rights reserved.                             !
!                                                                              !
! Futility is a jointly-maintained, open-source project between the University !
! of Michigan and Oak Ridge National Laboratory.  The copyright and license    !
! can be found in LICENSE.txt in the head directory of this repository.        !
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!> @brief A Fortran 2003 module defining all constants and conversions for
!> different units to be used throughout the code.
!>
!> All constants used within the code will be contained in this module.
!> This module will contain Neighbor Indexing for all operations.
!> This module will also provide functionality to convert between units of
!> similar types (i.e. Kelvin to Celsius, or inches to centimeters).
!> Functionality may be added to do complex or multiple unit conversion
!> in one subroutine call. (Unsure if this will work).
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
MODULE Constants_Conversion
USE IntrType
IMPLICIT NONE
PRIVATE

PUBLIC :: K_to_C
PUBLIC :: C_to_K
PUBLIC :: F_to_C
PUBLIC :: C_to_F
PUBLIC :: F_to_K
PUBLIC :: K_to_F
PUBLIC :: tempTo_K
PUBLIC :: tempTo_C
PUBLIC :: tempTo_F
PUBLIC :: tempTo_R
PUBLIC :: convertTemp

!> Parameters for commonly used constants
REAL(SRK),PUBLIC,PARAMETER ::    ZERO=0.000000000000000_SRK !16 digits
REAL(SRK),PUBLIC,PARAMETER ::     ONE=1.000000000000000_SRK !16 digits
REAL(SRK),PUBLIC,PARAMETER ::     TWO=2.000000000000000_SRK !16 digits
REAL(SRK),PUBLIC,PARAMETER ::    HALF=0.500000000000000_SRK !16 digits
!> Useful fractions of PI
REAL(SRK),PUBLIC,PARAMETER ::   QTRPI=ATAN(ONE)
REAL(SRK),PUBLIC,PARAMETER ::  HALFPI=TWO*QTRPI
REAL(SRK),PUBLIC,PARAMETER ::      PI=TWO*HALFPI
REAL(SRK),PUBLIC,PARAMETER :: SIXTHPI=PI/6._SRK
REAL(SRK),PUBLIC,PARAMETER :: THIRDPI=TWO*SIXTHPI
REAL(SRK),PUBLIC,PARAMETER ::   TWOPI=TWO*PI
REAL(SRK),PUBLIC,PARAMETER ::  FOURPI=TWO*TWOPI
REAL(SRK),PUBLIC,PARAMETER ::     RPI=ONE/PI
REAL(SRK),PUBLIC,PARAMETER ::  RTWOPI=ONE/TWOPI
REAL(SRK),PUBLIC,PARAMETER :: RFOURPI=ONE/FOURPI

!> Convert from radians to degrees
REAL(SRK),PUBLIC,PARAMETER :: rad2degrees=180.0_SRK/PI
!> Convert from degrees to radians
REAL(SRK),PUBLIC,PARAMETER :: degrees2rad=PI/180.0_SRK

!> Avogadro's Number; source: https://physics.nist.gov/cgi-bin/cuu/Value?na
REAL(SRK),PUBLIC,PARAMETER :: NA=6.022140857E+23_SRK

! Area conversion
!> Conversion factor from barns to cm**2
REAL(SRK),PUBLIC,PARAMETER :: barn2cm=1.0E-24_SRK
!> Conversion factor from cm**2 to barns
REAL(SRK),PUBLIC,PARAMETER :: cm2barn=1.0E24_SRK

!Pressure Conversions
!> Conversion factor from MPa to psia
REAL(SRK),PUBLIC,PARAMETER :: MPa2PSIA=145.0_SRK+377.0_SRK/9990.0_SRK
!> Conversion factor from bar to MPa
REAL(SRK),PUBLIC,PARAMETER :: Bar2MPa=0.1_SRK
!> Conversion factor from MPa to bar
REAL(SRK),PUBLIC,PARAMETER :: MPa2Bar=ONE/Bar2MPa
!> Conversion factor from MPa to Pa
REAL(SRK),PUBLIC,PARAMETER :: MPa2Pa=1000000.0_SRK
!> Conversion factor from Pa to MPa
REAL(SRK),PUBLIC,PARAMETER :: Pa2MPa=ONE/MPa2Pa

!Mass conversions
!> Conversion factor from kg to g
REAL(SRK),PUBLIC,PARAMETER :: kg2g=1000.0_SRK
!> Conversion factor from g to kg
REAL(SRK),PUBLIC,PARAMETER :: g2kg=ONE/kg2g
!> Conversion factor from g to mg
REAL(SRK),PUBLIC,PARAMETER :: g2mg=1000.0_SRK
!> Conversion factor from mg to g
REAL(SRK),PUBLIC,PARAMETER :: mg2g=ONE/g2mg

!Energy conversions
!> Conversion factor from eV to J
REAL(SRK),PUBLIC,PARAMETER :: eV2J=1.602176487e-19_SRK
!> Conversion factor from J to eV
REAL(SRK),PUBLIC,PARAMETER :: J2eV=ONE/eV2J

!Time conversions
!> Conversion factor from min to s
REAL(SRK),PUBLIC,PARAMETER :: min2s=60.0_SRK
!> Conversion factor from hr to min
REAL(SRK),PUBLIC,PARAMETER :: hr2min=60.0_SRK
!> Conversion factor from day to hr
REAL(SRK),PUBLIC,PARAMETER :: day2hr=24.0_SRK
!> Conversion factor from year to day
REAL(SRK),PUBLIC,PARAMETER :: yr2day=365.25_SRK
!> Conversion factor from hr to sec
REAL(SRK),PUBLIC,PARAMETER :: hr2s=hr2min*min2s
!> Conversion factor from day to sec
REAL(SRK),PUBLIC,PARAMETER :: day2s=day2hr*hr2s
!> Conversion factor from year to sec
REAL(SRK),PUBLIC,PARAMETER :: yr2s=yr2day*day2s
!> Conversion factor from day to min
REAL(SRK),PUBLIC,PARAMETER :: day2min=day2hr*hr2min
!> Conversion factor from year to min
REAL(SRK),PUBLIC,PARAMETER :: yr2min=yr2day*day2min
!> Conversion factor from year to hr
REAL(SRK),PUBLIC,PARAMETER :: yr2hr=yr2day*day2hr
!> Conversion factor from s to min
REAL(SRK),PUBLIC,PARAMETER :: s2min=ONE/min2s
!> Conversion factor from min to hr
REAL(SRK),PUBLIC,PARAMETER :: min2hr=ONE/hr2min
!> Conversion factor from hr to day
REAL(SRK),PUBLIC,PARAMETER :: hr2day=ONE/day2hr
!> Conversion factor from day to year
REAL(SRK),PUBLIC,PARAMETER :: day2yr=ONE/yr2day
!> Conversion factor from s to hr
REAL(SRK),PUBLIC,PARAMETER :: s2hr=ONE/hr2s
!> Conversion factor from s to day
REAL(SRK),PUBLIC,PARAMETER :: s2day=ONE/day2s
!> Conversion factor from s to year
REAL(SRK),PUBLIC,PARAMETER :: s2yr=ONE/yr2s
!> Conversion factor from min to day
REAL(SRK),PUBLIC,PARAMETER :: min2day=ONE/day2min
!> Conversion factor from min to year
REAL(SRK),PUBLIC,PARAMETER :: min2yr=ONE/yr2min
!> Conversion factor from hr to year
REAL(SRK),PUBLIC,PARAMETER :: hr2yr=ONE/yr2hr

!Length conversions
!> Conversion factor from m to cm
REAL(SRK),PUBLIC,PARAMETER :: m2cm=100.0_SRK
!> Conversion factor from cm to m
REAL(SRK),PUBLIC,PARAMETER :: cm2m=ONE/m2cm
!> Conversion factor from ft to cm
REAL(SRK),PUBLIC,PARAMETER :: ft2cm=30.48_SRK
!> Conversion factor from cm to ft
REAL(SRK),PUBLIC,PARAMETER :: cm2ft=ONE/ft2cm

!Temperature conversions
!> Additive Conversion factor from Celsius to Kelvin
REAL(SRK),PUBLIC,PARAMETER :: C2K=273.15_SRK
!> Multiplicative Conversion factor from Rankine to Kelvin
REAL(SRK),PUBLIC,PARAMETER :: R2K=5.0_SRK/9.0_SRK
!> Additive Conversion factor from Fahrenheit to Rankine
REAL(SRK),PUBLIC,PARAMETER :: F2R=459.67_SRK

!> May be used for comparing real numbers relating to geometry
!> Tolerance is 0.0001 cm
REAL(SRK),PUBLIC,PARAMETER :: TOL_GEOM_cm=0.0001_SRK
!
!===============================================================================
CONTAINS
!
!-------------------------------------------------------------------------------
!> @brief converts temperature from Kelvin to Celsius
!> @param in_temp the temperature input as Kelvin
!> @return out_temp the temperature converted to Celsius
!>
ELEMENTAL FUNCTION K_to_C(in_temp) RESULT(out_temp)
  REAL(SRK),INTENT(IN) :: in_temp
  REAL(SRK) :: out_temp

  out_temp=in_temp-273.15_SRK

ENDFUNCTION K_to_C
!
!-------------------------------------------------------------------------------
!> @brief converts temperature from Celsius to Kelvin
!> @param in_temp the temperature input as Celsius
!> @return out_temp the temperature converted to Kelvin
!>
ELEMENTAL FUNCTION C_to_K(in_temp) RESULT(out_temp)
  REAL(SRK),INTENT(IN) :: in_temp
  REAL(SRK) :: out_temp

  out_temp=in_temp+273.15_SRK

ENDFUNCTION C_to_K
!
!-------------------------------------------------------------------------------
!> @brief converts temperature from Fahrenheit to Celsius
!> @param in_temp the temperature input as Fahrenheit
!> @return out_temp the temperature converted to Celsius
!>
ELEMENTAL FUNCTION F_to_C(in_temp) RESULT(out_temp)
  REAL(SRK),INTENT(IN) :: in_temp
  REAL(SRK) :: out_temp

  out_temp=(in_temp-32.0_SRK)*5.0_SRK/9.0_SRK

ENDFUNCTION F_to_C
!
!-------------------------------------------------------------------------------
!> @brief converts temperature from Celsius to Fahrenheit
!> @param in_temp the temperature input as Celsius
!> @return out_temp the temperature converted to Fahrenheit
!>
ELEMENTAL FUNCTION C_to_F(in_temp) RESULT(out_temp)
  REAL(SRK),INTENT(IN) :: in_temp
  REAL(SRK) :: out_temp

  out_temp=in_temp*9.0_SRK/5.0_SRK+32.0_SRK

ENDFUNCTION C_to_F
!
!-------------------------------------------------------------------------------
!> @brief converts temperature from Fahrenheit to Kelvin
!> @param in_temp the temperature input as Fahrenheit
!> @return out_temp the temperature converted to Kelvin
!>
ELEMENTAL FUNCTION F_to_K(in_temp) RESULT(out_temp)
  REAL(SRK),INTENT(IN) :: in_temp
  REAL(SRK) :: out_temp

  out_temp=C_to_K(F_to_C(in_temp))

ENDFUNCTION F_to_K
!
!-------------------------------------------------------------------------------
!> @brief converts temperature from Kelvin to Fahrenheit
!> @param in_temp the temperature input as Kelvin
!> @return out_temp the temperature converted to Fahrenheit
!>
ELEMENTAL FUNCTION K_to_F(in_temp) RESULT(out_temp)
  REAL(SRK),INTENT(IN) :: in_temp
  REAL(SRK) :: out_temp

  out_temp=C_to_F(K_to_C(in_temp))

ENDFUNCTION K_to_F
!
!-------------------------------------------------------------------------------
!> @brief converts temperature to Kelvin from Celsius, Rankine, or Fahrenheit,
!> if any other unit is presented in_temp is simply returned
!> @param in_temp the temperature input as the specified units
!> @param units character indicating the units of in_temp
!> @return out_temp the temperature converted to Kelvin
!>
ELEMENTAL FUNCTION tempTo_K(in_temp,units) RESULT(out_temp)
  REAL(SRK),INTENT(IN) :: in_temp
  CHARACTER(LEN=1),INTENT(IN) :: units
  REAL(SRK) :: out_temp

  SELECTCASE(units)
  CASE('C')
    out_temp = C_to_K(in_temp)
  CASE('R')
    out_temp = in_temp * R2K
  CASE('F')
    out_temp = F_to_K(in_temp)
  CASE DEFAULT
    out_temp = in_temp
  ENDSELECT

ENDFUNCTION tempTo_K
!
!-------------------------------------------------------------------------------
!> @brief converts temperature to Celsius from Kelvin, Rankine, or Fahrenheit,
!> if any other unit is presented in_temp is simply returned
!> @param in_temp the temperature input as the specified units
!> @param units character indicating the units of in_temp
!> @return out_temp the temperature converted to Celsius
!>
ELEMENTAL FUNCTION tempTo_C(in_temp,units) RESULT(out_temp)
  REAL(SRK),INTENT(IN) :: in_temp
  CHARACTER(LEN=1),INTENT(IN) :: units
  REAL(SRK) :: out_temp

  SELECTCASE(units)
  CASE('K')
    out_temp = K_to_C(in_temp)
  CASE('R')
    out_temp = in_temp * R2K - C2K
  CASE('F')
    out_temp = F_to_C(in_temp)
  CASE DEFAULT
    out_temp = in_temp
  ENDSELECT

ENDFUNCTION tempTo_C
!
!-------------------------------------------------------------------------------
!> @brief converts temperature to Fahrenheit from Celsius, Rankine, or Kelvin,
!> if any other unit is presented in_temp is simply returned
!> @param in_temp the temperature input as the specified units
!> @param units character indicating the units of in_temp
!> @return out_temp the temperature converted to Fahrenheit
!>
ELEMENTAL FUNCTION tempTo_F(in_temp,units) RESULT(out_temp)
  REAL(SRK),INTENT(IN) :: in_temp
  CHARACTER(LEN=1),INTENT(IN) :: units
  REAL(SRK) :: out_temp

  SELECTCASE(units)
  CASE('K')
    out_temp=K_to_F(in_temp)
  CASE('R')
    out_temp = in_temp - F2R
  CASE('C')
    out_temp = C_to_F(in_temp)
  CASE DEFAULT
    out_temp = in_temp
  ENDSELECT

ENDFUNCTION tempTo_F
!
!-------------------------------------------------------------------------------
!> @brief converts temperature to Rankine from Celsius, Kelvin, or Fahrenheit,
!> if any other unit is presented in_temp is simply returned
!> @param in_temp the temperature input as the specified units
!> @param units character indicating the units of in_temp
!> @return out_temp the temperature converted to Fahrenheit
!>
ELEMENTAL FUNCTION tempTo_R(in_temp,units) RESULT(out_temp)
  REAL(SRK),INTENT(IN) :: in_temp
  CHARACTER(LEN=1),INTENT(IN) :: units
  REAL(SRK) :: out_temp

  SELECTCASE(units)
  CASE('K')
    out_temp = in_temp / R2K
  CASE('F')
    out_temp = in_temp + F2R
  CASE('C')
    out_temp = C_to_K(in_temp) / R2K
  CASE DEFAULT
    out_temp = in_temp
  ENDSELECT

ENDFUNCTION tempTo_R
!
!-------------------------------------------------------------------------------
!> @brief converts temperature to a given unit from the provided unit. Celsius(C),
!> Fahrenheit(F), Kelvin(K), and Rankine(R) are the only valid units
!> @param in_temp the temperature input as the specified units
!> @param in_units character indicating the units of in_temp
!> @param out_units character indicating the units of out_temp
!> @return out_temp the temperature converted to Fahrenheit
!>
ELEMENTAL FUNCTION convertTemp(in_temp,in_units,out_units) RESULT(out_temp)
  REAL(SRK),INTENT(IN) :: in_temp
  CHARACTER(LEN=1),INTENT(IN) :: in_units
  CHARACTER(LEN=1),INTENT(IN) :: out_units
  REAL(SRK) :: out_temp

  SELECTCASE(out_units)
  CASE('K')
    out_temp = tempTo_K(in_temp,in_units)
  CASE('C')
    out_temp = tempTo_C(in_temp,in_units)
  CASE('F')
    out_temp = tempTo_F(in_temp,in_units)
  CASE('R')
    out_temp = tempTo_R(in_temp,in_units)
  ENDSELECT

ENDFUNCTION convertTemp
!
ENDMODULE Constants_Conversion


program ieee_functions
    use, intrinsic :: ieee_arithmetic
    implicit none
    real :: result, r

    call random_number(r)

    result = 1.0/min(0.0, r)
    print '(A, E10.5)', '1.0/0.0 =', result
    if (.not. ieee_is_finite(result)) then
        print '(A)', 'Infinity found'
    end if

    result = 0.0/min(0.0, r)
    print '(A, E10.5)', '1.0/0.0 =', result
    if (ieee_is_nan(result)) then
        print '(A)', 'NaN found'
    end if
end program ieee_functions


! ###############################################
! Copyright 2012-2018, University of Strathclyde
! Authors: Lawrence T. Campbell
! License: BSD-3-Clause
! ###############################################

!> @author
!> Lawrence Campbell,
!> University of Strathclyde,
!> Glasgow, UK
!> @brief
!> Module for calculating sequences used in the macroparticle generation.

module pseqs

use paratype
use ParallelInfoType
use parallelsetup
use globals
use randomGauss

implicit none

contains

!> @author
!> Lawrence Campbell,
!> University of Strathclyde,
!> Glasgow, UK
!> @brief
!> Generate random sequence with normal
!> distribution - zero mean and unit variance
!> @param[inout] com Sequence to modify (of width = 1)
!> @param[in] nparts Length of sequence sequence

subroutine genRSNorm(com, nparts)

  real(kind=wp), intent(inout) :: com(:)
  integer(kind=ip), intent(in) :: nparts

  integer(kind=ip) :: ij

  do ij = 1, nparts

    com(ij) = random_normal()

  end do

end subroutine genRSNorm

!> @author
!> Lawrence Campbell,
!> University of Strathclyde,
!> Glasgow, UK
!> @brief
!> Widen / shorten unit variance sequence
!> to given variance
!> @param[inout] com Sequence to modify (of width = 1)
!> @param[in] sig r.m.s. sigma of desired Gaussian distribution

subroutine modVar(com, sig)

  real(kind=wp), contiguous, intent(inout) :: com(:)
  real(kind=wp), intent(in) :: sig

  com = com * sig

end subroutine modVar

!> @author
!> Lawrence Campbell,
!> University of Strathclyde,
!> Glasgow, UK
!> @brief
!> Generate random sequence with normal distribution,
!> then modify to give random gaussian distribution
!> specified with input rms sigma
!> @param[inout] com Array to output sequence
!> @param[in] nparts Length of sequence
!> @param[in] sig r.m.s. sigma of desired Gaussian distribution

subroutine genGSeq(com, nparts, sigma)

  real(kind=wp), contiguous, intent(inout) :: com(:)
  real(kind=wp), intent(in) :: sigma
  integer(kind=ip), intent(in) :: nparts

  call genRSNorm(com, nparts)
  call modVar(com, sigma)

end subroutine genGSeq

!> @author
!> Lawrence Campbell,
!> University of Strathclyde,
!> Glasgow, UK
!> @brief
!> Generate random sequence distributed evenly between zero and one
!> @param[inout] com Array to output sequence
!> @param[in] nparts Length of sequence

subroutine genSeqFlat(com, nparts)

  real(kind=wp), contiguous, intent(inout) :: com(:)
  integer(kind=ip), intent(in) :: nparts

  integer(kind=ip) :: ij

  do ij = 1, nparts
    call random_number(com(ij))
  end do

end subroutine genSeqFlat

!> @author
!> Lawrence Campbell,
!> University of Strathclyde,
!> Glasgow, UK
!> @brief
!> Generate sequences for 5-D phase space for Puffin. The 5 dimensions
!> are 4 transverse (x,y,px,py) and energy.
!> @param[inout] xcom Sequence in x dimension
!> @param[inout] ycom Sequence in y dimension
!> @param[inout] pxcom Sequence in px dimension
!> @param[inout] pycom Sequence in py dimension
!> @param[inout] gcom Sequence in energy dimension
!> @param[in] sigE 6 element array of requested gaussian r.m.s. width
!> in the Puffin order (x,y,z2,px,py,gamma).

subroutine getSeqs(xcom, ycom, pxcom, pycom, gcom, zcom, sigE, iTrLoad)

  real(kind=wp), contiguous, intent(inout) :: xcom(:), ycom(:), &
                                pxcom(:), pycom(:), &
                                gcom(:), zcom(:)

  real(kind=wp), intent(in) :: sigE(:)
  integer(kind=ip), intent(in) :: iTrLoad

!  Keep these local for now...add more sequences later

  integer(kind=ip), parameter :: iRandSeq = 1_ip
  integer(kind=ip), parameter :: iHaltonSeq = 2_ip
  integer(kind=ip), parameter :: iRandLineSeq = 3_ip
  integer(kind=ip), parameter :: iHaltonLineSeq = 4_ip
  integer :: error

!  gen sequences on root process only...

  CALL init_random_seed()

  if (tProcInfo_G%qRoot) then

    if ((iTrLoad == iRandSeq) .or. (iTrLoad == iRandLineSeq) ) then

      call genGSeq(xcom, nseqparts_G, sigE(iX_CG))
      call genGSeq(ycom, nseqparts_G, sigE(iY_CG))
      call genGSeq(pxcom, nseqparts_G, sigE(iPX_CG))
      call genGSeq(pycom, nseqparts_G, sigE(iPY_CG))
      call genGSeq(gcom, nseqparts_G, sigE(iGam_CG))
      if (iTrLoad == iRandLineSeq) then
        zcom = 0.5_wp  ! For 'flat' slices
      else
        call genSeqFlat(zcom, nseqparts_G)
      end if

    else if ((iTrLoad == iHaltonSeq) .or. (iTrLoad == iHaltonLineSeq) ) then

      call genHSeq(xcom, nseqparts_G, 2_ip, sigE(iX_CG))
      call genHSeq(ycom, nseqparts_G, 3_ip, sigE(iY_CG))
      call genHSeq(pxcom, nseqparts_G, 5_ip, sigE(iPX_CG))
      call genHSeq(pycom, nseqparts_G, 11_ip, sigE(iPY_CG))
      call genHSeq(gcom, nseqparts_G, 7_ip, sigE(iGam_CG))
      if (iTrLoad == iHaltonLineSeq) then
        zcom = 0.5_wp  ! For 'flat' slices
      else
        ! will give deviations from the mean z2
        call genHSeqFLAT(zcom, nseqparts_G, 13_ip)
      end if

!      print*, xcom

    end if

  end if

!  Share sequences to all other processes

  call mpi_bcast(xcom, nseqparts_G, mpi_double_precision, 0, &
               tProcInfo_G%comm, error )

  call mpi_bcast(ycom, nseqparts_G, mpi_double_precision, 0, &
               tProcInfo_G%comm, error )

  call mpi_bcast(pxcom, nseqparts_G, mpi_double_precision, 0, &
               tProcInfo_G%comm, error )

  call mpi_bcast(pycom, nseqparts_G, mpi_double_precision, 0, &
               tProcInfo_G%comm, error )

  call mpi_bcast(gcom, nseqparts_G, mpi_double_precision, 0, &
               tProcInfo_G%comm, error )

  call mpi_bcast(zcom, nseqparts_G, mpi_double_precision, 0, &
               tProcInfo_G%comm, error )

end subroutine getSeqs

!> @author
!> Lawrence Campbell,
!> University of Strathclyde,
!> Glasgow, UK
!> @brief
!> Subroutine to generate a Halton sequence of length size nparts
!> projected over a Gaussian of specified width
!> @param[inout] seq Array to output sequence
!> @param[in] nparts Length of sequence
!> @param[in] basis Base of sequence
!> @param[in] sig r.m.s. sigma of desired Gaussian distribution

subroutine genHSeq(seq, nparts, basis, sig)

  real(kind=wp), contiguous, intent(inout) :: seq(:)
  integer(kind=ip), intent(in) :: nparts
  integer(kind=ip), intent(in) :: basis
  real(kind=wp), intent(in) :: sig

  integer(kind=ip) :: ic

  do ic = 1, nparts
    seq(ic) = halton(ic, basis) ! sequence value between 0 and 1
  end do

  call projectRSeq(seq)  ! Project sequence to Gaussian of variance = 1

  call modVar(seq, sig)  ! Alter unit variance to required variance

end subroutine genHSeq

!> @author
!> Lawrence Campbell,
!> University of Strathclyde,
!> Glasgow, UK
!> @brief
!> Subroutine to generate a Halton sequence of length size nparts
!> but not projected.
!> @param[inout] seq Array to output sequence
!> @param[in] nparts Length of sequence
!> @param[in] basis Base of sequence

subroutine genHSeqFLAT(seq, nparts, basis)

  real(kind=wp), contiguous, intent(inout) :: seq(:)
  integer(kind=ip), intent(in) :: nparts
  integer(kind=ip), intent(in) :: basis

  integer(kind=ip) :: ic

  do ic = 1, nparts
    seq(ic) = halton(ic, basis) ! sequence value between 0 and 1
  end do

end subroutine genHSeqFLAT

!> @author
!> Lawrence Campbell,
!> University of Strathclyde,
!> Glasgow, UK
!> @brief
!> Function which calculates the nth element in the bit-reversed Halton
!> sequence of specified base.
!> @param[in] ind Nth element of sequence
!> @param[in] ibase Index of sequence

function halton(ind, ibase) result(y)

  integer(kind=ip), intent(in) :: ind, ibase

  real(kind=wp) :: ft, t1
  real(kind=wp) :: y
  integer(kind=ip) :: it

  ft = 1.0_wp
  y = 0.0_wp
  it = ind

  do while (it>0)

    ft = ft / real(ibase, kind=wp)
    y = y + ft * real(mod(it, ibase), kind=wp)
    it = it / ibase

  end do

end function halton

!> @author
!> Lawrence Campbell,
!> University of Strathclyde,
!> Glasgow, UK
!> @brief
!> Subroutine to project given distribution to a Gaussian of unit variance.
!> @param[inout] seq Random/semi-random sequence to be projected.

subroutine projectRSeq(seq)

  use functions
  use error_fn

  real(kind=wp), intent(inout) :: seq(:)

  integer(kind=ip) :: is, ic1
  integer(kind=ip) :: iMeth

  integer(kind=ip), parameter :: GS = 1_ip
  integer(kind=ip), parameter :: JP = 2_ip
  integer(kind=ip), parameter :: iIntMesh = 2000_ip

  real(kind=wp), allocatable :: tseq(:), yf(:), cdf(:)

  iMeth = GS

  is = size(seq)

! can do general sequence (so no need to know inverse - will need to numerically
! calculate 'real' sequence)

  if (iMeth == GS) then

    allocate(yf(iIntMesh), cdf(iIntMesh))
    allocate(tseq(is))

    yf = linspace(-4.0_wp, 4.0_wp, iIntMesh)

    do ic1 = 1, iIntMesh
      cdf(ic1) = 0.5_wp * (1.0_wp + erf(yf(ic1) / sqrt(2.0_wp)))  ! CDF of Gaussian
    end do

    ! interpolate as MATLAB interp1(cdf, yf, seq)
!    print*, cdf
    call interps(cdf, yf, seq, tseq)

    seq = tseq

! ...or could do joint probability projection a-la Genesis...

  else if (iMeth == JP) then

!    rsq =

  end if

  deallocate(tseq)

end subroutine projectRSeq

!> @author
!> Lawrence Campbell,
!> University of Strathclyde,
!> Glasgow, UK
!> @brief
!> Interpolate values of x -> f(x) using linear interpolants. Values of x to be
!> interpolated do not have to be in order, and the grid in x does not have to
!> be equispaced.
!> @param[in] x Mesh in x
!> @param[in] func f(x) - the function to be interpolated to.
!> @param[in] smplsx The values or samples in x to be interpolated. (finding
!> f(x) at these points)
!> @param[out] smpls_interp The output interpolated values.

subroutine interps(x, func, smplsx, smpls_interp)

  real(kind=wp), intent(in) :: func(:), x(:), smplsx(:)
  real(kind=wp), intent(out):: smpls_interp(:)

  integer(kind=ip) :: nsamples, ic

  nsamples = size(smplsx)

  do ic = 1, nsamples

    smpls_interp(ic) = interp1(x, func, smplsx(ic))

  end do

end subroutine interps

!> @author
!> Lawrence Campbell,
!> University of Strathclyde,
!> Glasgow, UK
!> @brief
!> Interpolate single value of x -> f(x) using linear interpolants. The grid in
!> x does not have to be equispaced.
!> @param[in] x Mesh in x
!> @param[in] func f(x) - the function to be interpolated to.
!> @param[in] smplx The value or sample in x to be interpolated. (i.e. finding
!> f(smplx))

function interp1(x, func, smplx) result(smpl_interp)

  real(kind=wp), intent(in) :: func(:), x(:), smplx
  real(kind=wp) :: smpl_interp

  integer(kind=ip) :: is, ic, ifl, ifu
  real(kind=wp) :: dx, locx

  is = size(func)
  ic = 1_ip

  if ((smplx > x(1)) .and. (smplx < x(is))) then

    do while (smplx > x(ic))
      ic = ic + 1_ip
    end do

    ifl = ic
    ifu = ic + 1_ip

    dx = x(ifu) - x(ifl)
    locx = smplx - x(ifl)

!    smpl_interp = func(ifu) ! snap to lower
    smpl_interp = func(ifl) * (1.0_wp - locx/dx)
    smpl_interp = smpl_interp + func(ifu) * locx / dx

  else if (smplx <= x(1)) then

    smpl_interp = func(1)
!    print*, 'eh, why here? func(1) = ', func(1), 'smplx = ', smplx

  else if (smplx >= x(is)) then

    smpl_interp = func(is)
!    print*, 'eh, why here? func(1) = ', func(1), 'smplx = ', smplx

  end if

end function interp1

end module pseqs


      subroutine compute_dmdr(ctfm, rho, Nx, dmdr)
         implicit none
         integer Nx
         real*8 rho(Nx), ctfm(Nx), dmdr(Nx)
         integer i
         do i=1, Nx, 1
           dmdr(i) = rho(i)*ctfm(i)**2
         end do
         END


c     Fortran translation (Heh!) of test6 in quadpack-tests.lisp.
      program test6
      implicit none
      double precision alpha

      print *, 'Test 6, same integral as test 3'
      print *
      print *, ' integrate(cos(2^alpha*sin(x)), x, pi)'
      print *, '   = pi * J0(2^alpha)'
      print *
      print *, 'QNG'
      print 9000
      do 10 alpha = 0d0, 10d0
         call qqng(alpha)
   10 continue
      print *
      print *, 'QAGS'
      print 9000
      do 30 alpha = 0d0, 10d0
         call qqags(alpha)
   30 continue
      print *
      print *, 'QAG'
      print 9000
      do 50 alpha = 0d0, 10d0
         call qqag(alpha)
   50 continue
 9000 format('alpha   est result              est abserr             nev
     &al    ier   true answer            true abs err')
      end
      double precision function soln(alpha)
      implicit none
      double precision alpha
      double precision z
c
c     If we have Bessel J0, we should use that.
c
      soln = 0d0
      return
      end

      double precision function f(x)
      implicit none
      double precision x
      double precision alfa
      common /param/ alfa
      f = cos(2**alfa*sin(x))
      return
      end

      subroutine qqng(alpha)
      integer limit, lenw
      double precision pi
      parameter (pi = 3.141592653589793d0)
      parameter (limit = 200, lenw = 4*limit)

      double precision alpha
      integer key
      double precision alfa
      common /param/alfa

      integer iwork(limit)
      double precision work(lenw)
      double precision f, soln
      external f

      double precision result, abserr
      integer neval, ier, last

      alfa = alpha

      call dqng(f, 0d0, pi, 0d0, 1d-8, result, abserr, neval, ier)
      print 9000, alpha, result, abserr, neval, ier, soln(alpha),
     $     abs(soln(alpha) - result)
      return
 9000 format(f5.1, 2(2x, 1pe22.15), 2(2x,i5), 2x, 1pe22.15, 1x, 1pe10.3)
      end

      subroutine qqags(alpha)
      integer limit, lenw
      double precision pi
      parameter (pi = 3.141592653589793d0)
      parameter (limit = 200, lenw = 4*limit)

      double precision alpha
      integer key
      double precision alfa
      common /param/alfa

      integer iwork(limit)
      double precision work(lenw)
      double precision f, soln
      external f

      double precision result, abserr
      integer neval, ier, last

      alfa = alpha

      call dqags(f, 0d0, pi, 0d0, 1d-8, result, abserr, neval, ier,
     $     limit, lenw, last, iwork, work)
      print 9000, alpha, result, abserr, neval, ier, soln(alpha),
     $     abs(soln(alpha) - result)
      return
 9000 format(f5.1, 2(2x, 1pe22.15), 2(2x,i5), 2x, 1pe22.15, 1x, 1pe10.3)
      end

      subroutine qqag(alpha)
      integer limit, lenw
      double precision pi
      parameter (pi = 3.141592653589793d0)
      parameter (limit = 200, lenw = 4*limit)

      double precision alpha
      integer key
      double precision alfa
      common /param/alfa

      integer iwork(limit)
      double precision work(lenw)
      double precision f, soln
      external f

      double precision result, abserr
      integer neval, ier, last

      alfa = alpha

      call dqag(f, 0d0, pi, 0d0, 1d-8, 6, result, abserr, neval, ier,
     $     limit, lenw, last, iwork, work)
      print 9000, alpha, result, abserr, neval, ier, soln(alpha),
     $     abs(soln(alpha) - result)
      return
 9000 format(f5.1, 2(2x, 1pe22.15), 2(2x,i5), 2x, 1pe22.15, 1x, 1pe10.3)
      end


MODULE BALL_TREE_R64
  USE ISO_FORTRAN_ENV, ONLY: REAL64, INT64
  USE PRUNE,       ONLY: LEVEL
  USE SWAP,        ONLY: SWAP_I64
  USE FAST_SELECT, ONLY: ARGSELECT_R64
  USE FAST_SORT,   ONLY: ARGSORT
  IMPLICIT NONE

  ! Max bytes for which a doubling of memory footprint (during copy)
  !  is allowed to happen (switches to using scratch file instead).
  INTEGER(KIND=INT64) :: MAX_COPY_BYTES = 2_INT64 ** 31_INT64

CONTAINS

  ! Re-arrange elements of POINTS into a binary ball tree.
  RECURSIVE SUBROUTINE BUILD_TREE(POINTS, SQ_SUMS, RADII, ORDER,&
       ROOT, LEAF_SIZE, COMPUTED_SQ_SUMS)
    REAL(KIND=REAL64),   INTENT(INOUT), DIMENSION(:,:) :: POINTS
    REAL(KIND=REAL64),   INTENT(OUT),   DIMENSION(:) :: SQ_SUMS
    REAL(KIND=REAL64),   INTENT(OUT),   DIMENSION(:) :: RADII
    INTEGER(KIND=INT64), INTENT(INOUT), DIMENSION(:) :: ORDER
    INTEGER(KIND=INT64), INTENT(IN), OPTIONAL :: ROOT, LEAF_SIZE
    LOGICAL,             INTENT(IN), OPTIONAL :: COMPUTED_SQ_SUMS
    ! Local variables
    INTEGER(KIND=INT64) :: CENTER_IDX, MID, I, J, LS
    REAL(KIND=REAL64), DIMENSION(SIZE(POINTS,1)) :: PT
    REAL(KIND=REAL64), DIMENSION(SIZE(ORDER)) :: SQ_DISTS
    REAL(KIND=REAL64) :: MAX_SQ_DIST, SQ_DIST, SHIFT
    EXTERNAL :: DGEMM
    ! Set the leaf size to 1 by default (most possible work required,
    ! but guarantees successful use with any leaf size).
    IF (PRESENT(LEAF_SIZE)) THEN ; LS = LEAF_SIZE
    ELSE                         ; LS = 1
    END IF
    ! If no squared sums were provided, compute them.
    IF (.NOT. PRESENT(COMPUTED_SQ_SUMS) .OR. &
         .NOT. COMPUTED_SQ_SUMS) THEN
       !$OMP PARALLEL DO
       DO I = 1, SIZE(POINTS,2)
          SQ_SUMS(I) = SUM(POINTS(:,I)**2)
       END DO
       !$OMP END PARALLEL DO
    END IF
    ! Set the index of the 'root' of the tree.
    IF (PRESENT(ROOT)) THEN ; CENTER_IDX = ROOT
    ELSE
       ! 1) Compute distances between first point (random) and all others.
       ! 2) Pick the furthest point (on conv hull) from first as the center node.
       J = ORDER(1)
       PT(:) = POINTS(:,J)
       SQ_DISTS(1) = 0.0_REAL64
       !$OMP PARALLEL DO
       ROOT_TO_ALL : DO I = 2, SIZE(ORDER)
          SQ_DISTS(I) = SQ_SUMS(J) + SQ_SUMS(ORDER(I)) - &
               2 * DOT_PRODUCT(POINTS(:,ORDER(I)), PT(:))
       END DO ROOT_TO_ALL
       !$OMP END PARALLEL DO
       CENTER_IDX = MAXLOC(SQ_DISTS(:),1)
       ! Now CENTER_IDX is the selected center for this node in tree.
    END IF

    ! Move the "center" to the first position.
    CALL SWAP_I64(ORDER(1), ORDER(CENTER_IDX))
    ! Measure squared distance beween "center" node and all other points.
    J = ORDER(1)
    PT(:) = POINTS(:,J)
    SQ_DISTS(1) = 0.0_REAL64

    !$OMP PARALLEL DO
    CENTER_TO_ALL : DO I = 2, SIZE(ORDER)
       SQ_DISTS(I) = SQ_SUMS(J) + SQ_SUMS(ORDER(I)) - &
            2 * DOT_PRODUCT(POINTS(:,ORDER(I)), PT(:))
    END DO CENTER_TO_ALL
    !$OMP END PARALLEL DO

    ! Base case for recursion, once we have few enough points, exit.
    IF (SIZE(ORDER) .LE. LS) THEN
       RADII(ORDER(1)) = SQRT(MAXVAL(SQ_DISTS))
       IF (SIZE(ORDER) .GT. 1) RADII(ORDER(2:)) = 0.0_REAL64
       RETURN
    ELSE IF (SIZE(ORDER) .EQ. 2) THEN
       ! If the leaf size is 1 and there are only 2 elements, store
       ! the radius and exit (since there are no further steps.
       RADII(ORDER(1)) = SQRT(SQ_DISTS(2))
       RADII(ORDER(2)) = 0.0_REAL64
       RETURN
    END IF

    ! Rearrange "SQ_DISTS" about the median value.
    ! Compute the last index that will belong "inside" this node.
    MID = (SIZE(ORDER) + 2) / 2
    CALL ARGSELECT_R64(SQ_DISTS(2:), ORDER(2:), MID - 1)
    ! Now ORDER has been rearranged such that the median distance
    ! element of POINTS is at the median location.
    ! Identify the furthest point (must be in second half of list).
    I = MID + MAXLOC(SQ_DISTS(MID+1:),1)
    ! Store the "radius" of this ball, the furthest point.
    RADII(ORDER(1)) = SQRT(SQ_DISTS(I))
    ! Move the median point (furthest "interior") to the front (inner root).
    CALL SWAP_I64(ORDER(2), ORDER(MID))
    ! Move the furthest point into the spot after the median (outer root).
    CALL SWAP_I64(ORDER(MID+1), ORDER(I))

    !$OMP PARALLEL NUM_THREADS(2)
    !$OMP SECTIONS
    !$OMP SECTION
    ! Recurisively create this tree.
    !   build a tree with the root being the furthest from this center
    !   for the remaining "interior" points of this center node.
    CALL BUILD_TREE(POINTS, SQ_SUMS, RADII, ORDER(2:MID), 1_INT64, LS, .TRUE.)
    !$OMP SECTION
    !   build a tree with the root being the furthest from this center
    !   for the remaining "exterior" points of this center node.
    !   Only perform this operation if there are >0 points available.
    IF (MID < SIZE(ORDER)) &
         CALL BUILD_TREE(POINTS, SQ_SUMS, RADII, &
         ORDER(MID+1:), 1_INT64, LS, .TRUE.)
    !$OMP END SECTIONS
    !$OMP END PARALLEL
  END SUBROUTINE BUILD_TREE

  ! Compute the K nearest elements of TREE to each point in POINTS.
  SUBROUTINE NEAREST(POINTS, K, TREE, SQ_SUMS, RADII, ORDER, &
       LEAF_SIZE, INDICES, DISTS, TO_SEARCH)
    REAL(KIND=REAL64), INTENT(IN), DIMENSION(:,:) :: POINTS, TREE
    REAL(KIND=REAL64), INTENT(IN), DIMENSION(:)   :: SQ_SUMS
    REAL(KIND=REAL64), INTENT(IN), DIMENSION(:)   :: RADII
    INTEGER(KIND=INT64), INTENT(IN), DIMENSION(:) :: ORDER
    INTEGER(KIND=INT64), INTENT(IN)               :: K, LEAF_SIZE
    INTEGER(KIND=INT64), INTENT(OUT), DIMENSION(K,SIZE(POINTS,2)) :: INDICES
    REAL(KIND=REAL64),   INTENT(OUT), DIMENSION(K,SIZE(POINTS,2)) :: DISTS
    INTEGER(KIND=INT64), INTENT(IN),  OPTIONAL    :: TO_SEARCH
    ! Local variables.
    INTEGER(KIND=INT64) :: I, B, BUDGET
    INTEGER(KIND=INT64), DIMENSION(K+LEAF_SIZE+2) :: INDS_BUFFER
    REAL(KIND=REAL64),   DIMENSION(K+LEAF_SIZE+2) :: DISTS_BUFFER
    IF (PRESENT(TO_SEARCH)) THEN ; BUDGET = MAX(K, TO_SEARCH)
    ELSE ; BUDGET = SIZE(ORDER) ; END IF
    ! For each point in this set, use the recursive branching
    ! algorithm to identify the nearest elements of TREE.
    !$OMP PARALLEL DO PRIVATE(INDS_BUFFER, DISTS_BUFFER, B)
    DO I = 1, SIZE(POINTS,2)
       B = BUDGET
       CALL PT_NEAREST(POINTS(:,I), K, TREE, SQ_SUMS, RADII, ORDER, &
            LEAF_SIZE, INDS_BUFFER, DISTS_BUFFER, B)
       ! Sort the first K elements of the temporary arry for return.
       INDICES(:,I) = INDS_BUFFER(:K)
       DISTS(:,I) = DISTS_BUFFER(:K)
    END DO
    !$OMP END PARALLEL DO
  END SUBROUTINE NEAREST

  ! Compute the K nearest elements of TREE to each point in POINTS.
  RECURSIVE SUBROUTINE PT_NEAREST(POINT, K, TREE, SQ_SUMS, RADII, &
       ORDER, LEAF_SIZE, INDICES, DISTS, CHECKS, FOUND, PT_SS)
    REAL(KIND=REAL64), INTENT(IN), DIMENSION(:)   :: POINT
    REAL(KIND=REAL64), INTENT(IN), DIMENSION(:,:) :: TREE
    REAL(KIND=REAL64), INTENT(IN), DIMENSION(:)   :: SQ_SUMS
    REAL(KIND=REAL64), INTENT(IN), DIMENSION(:)   :: RADII
    INTEGER(KIND=INT64), INTENT(IN), DIMENSION(:) :: ORDER
    INTEGER(KIND=INT64), INTENT(IN)               :: K, LEAF_SIZE
    INTEGER(KIND=INT64), INTENT(OUT), DIMENSION(:) :: INDICES
    REAL(KIND=REAL64),   INTENT(OUT), DIMENSION(:) :: DISTS
    INTEGER(KIND=INT64), INTENT(INOUT), OPTIONAL   :: CHECKS
    INTEGER(KIND=INT64), INTENT(INOUT), OPTIONAL   :: FOUND
    REAL(KIND=REAL64),   INTENT(IN),    OPTIONAL   :: PT_SS
    ! Local variables
    INTEGER(KIND=INT64) :: F, I, I1, I2, MID, ALLOWED_CHECKS
    REAL(KIND=REAL64)   :: D, D1, D2
    REAL(KIND=REAL64)   :: PS
    ! Initialize FOUND for first call, if FOUND is present then
    ! this must not be first and all are present.
    INITIALIZE : IF (PRESENT(FOUND)) THEN
       ALLOWED_CHECKS = CHECKS
       IF (ALLOWED_CHECKS .LE. 0) RETURN
       F = FOUND
       PS = PT_SS
    ELSE
       ! Initialize the remaining checks to search.
       IF (PRESENT(CHECKS)) THEN ; ALLOWED_CHECKS = CHECKS - 1
       ELSE ; ALLOWED_CHECKS = SIZE(ORDER) - 1 ; END IF
       ! Start at index 0 (added onto current index). Compute squared sum.
       PS = SUM(POINT(:)**2)
       ! Measure distance to root.
       INDICES(1) = ORDER(1)
       DISTS(1) = SQRT(PS + SQ_SUMS(ORDER(1)) - &
            2*DOT_PRODUCT(POINT(:), TREE(:,ORDER(1))))
       ! Set the "points found" to be 1.
       F = 1
    END IF INITIALIZE
    ! If this is NOT a leaf node, then recurse.
    BRANCH_OR_LEAF : IF (SIZE(ORDER) .GT. LEAF_SIZE) THEN
       ALLOWED_CHECKS = ALLOWED_CHECKS - 1
       ! Measure distance to inner child.
       I1 = ORDER(2)
       D1 = SQRT(PS + SQ_SUMS(I1) - &
            2*DOT_PRODUCT(POINT(:),TREE(:,I1)))
       ! Store this distance calculation and index.
       F = F + 1
       INDICES(F) = I1
       DISTS(F) = D1
       ! Measure distance to outer child the same as above, after
       ! checking to see if there *is* an outer child.
       MID = (SIZE(ORDER) + 2) / 2
       IF (MID+1 > SIZE(ORDER)) THEN
          I2 = 0
          D2 = HUGE(D2)
       ELSE
          I2 = ORDER(MID+1)
          IF (I2 .NE. I1) THEN
             ALLOWED_CHECKS = ALLOWED_CHECKS - 1
             D2 = SQRT(PS + SQ_SUMS(I2) - &
                  2*DOT_PRODUCT(POINT(:),TREE(:,I2)))
             ! Store this distance calculation and index.
             F = F + 1
             INDICES(F) = I2
             DISTS(F) = D2
          ELSE ; D2 = HUGE(D2)
          END IF
       END IF
       ! Re-organize the list of closest points, pushing them to first K spots.
       CALL ARGSELECT_R64(DISTS(:F), INDICES(:F), MIN(K,F))
       F = MIN(K,F)
       ! Store the maximum distance.
       D = MAXVAL(DISTS(:F),1)
       ! Determine which child to search (depth-first search) based
       ! on which child region the point lands in from the root.
       INNER_CHILD_CLOSER : IF (D1 .LE. D2) THEN
          ! Search the inner child if it could contain a nearer point.
          SEARCH_INNER1 : IF ((F .LT. K) .OR. (D .GT. D1 - RADII(I1))) THEN
             CALL PT_NEAREST(POINT, K, TREE, SQ_SUMS, RADII, ORDER(2:MID), &
                  LEAF_SIZE, INDICES, DISTS, ALLOWED_CHECKS, F, PS)
          END IF SEARCH_INNER1
          ! Search the outer child if it could contain a nearer point.
          SEARCH_OUTER1 : IF (((F .LT. K) .OR. (D .GT. D2 - RADII(I2))) &
               .AND. (I2 .NE. I1) .AND. (I2 .GT. 0)) THEN
             CALL PT_NEAREST(POINT, K, TREE, SQ_SUMS, RADII, ORDER(MID+1:), &
                  LEAF_SIZE, INDICES, DISTS, ALLOWED_CHECKS, F, PS)
          END IF SEARCH_OUTER1
       ELSE
          ! Search the outer child if it could contain a nearer point.
          SEARCH_OUTER2 : IF (((F .LT. K) .OR. (D .GT. D2 - RADII(I2))) &
               .AND. (I2 .NE. I1) .AND. (I2 .GT. 0)) THEN
             CALL PT_NEAREST(POINT, K, TREE, SQ_SUMS, RADII, ORDER(MID+1:), &
                  LEAF_SIZE, INDICES, DISTS, ALLOWED_CHECKS, F, PS)
          END IF SEARCH_OUTER2
          ! Search the inner child if it could contain a nearer point.
          SEARCH_INNER2 : IF ((F .LT. K) .OR. (D .GT. D1 - RADII(I1))) THEN
             CALL PT_NEAREST(POINT, K, TREE, SQ_SUMS, RADII, ORDER(2:MID), &
                  LEAF_SIZE, INDICES, DISTS, ALLOWED_CHECKS, F, PS)
          END IF SEARCH_INNER2
       END IF INNER_CHILD_CLOSER
    ! Since this is a leaf node, we measure distance to all children.
    ELSE
       DIST_TO_CHILDREN : DO I = 2, SIZE(ORDER)
          IF (ALLOWED_CHECKS .LE. 0) EXIT DIST_TO_CHILDREN
          ALLOWED_CHECKS = ALLOWED_CHECKS - 1
          ! Measure distance to all children of this node.
          D = SQRT(PS + SQ_SUMS(ORDER(I)) - &
               2*DOT_PRODUCT(POINT(:),TREE(:,ORDER(I))))
          ! Store this distance.
          F = F + 1
          DISTS(F) = D
          INDICES(F) = ORDER(I)
       END DO DIST_TO_CHILDREN
       ! Reduce the kept points to only those that are closest.
       CALL ARGSELECT_R64(DISTS(:F), INDICES(:F), MIN(K,F))
       F = MIN(K, F)
    END IF BRANCH_OR_LEAF

    ! Handle closing operations..
    SORT_K : IF (PRESENT(FOUND)) THEN
       ! This is not the root, we need to pass the updated value of
       ! FOUND back up the recrusion stack.
       FOUND = F
       CHECKS = ALLOWED_CHECKS
    ELSE
       ! This is the root, initial caller. Sort the distances for return.
       CALL ARGSELECT_R64(DISTS(:F), INDICES(:F), K)
       CALL ARGSORT(DISTS(:K), INDICES(:K))
    END IF SORT_K
  END SUBROUTINE PT_NEAREST

  ! Compute the K nearest elements of TREE to each point in POINTS.
  SUBROUTINE APPROX_NEAREST(POINTS, K, TREE, SQ_SUMS, RADII, ORDER, &
       LEAF_SIZE, INDICES, DISTS, LOOK_AHEAD, RANDOMIZED)
    REAL(KIND=REAL64), INTENT(IN), DIMENSION(:,:) :: POINTS, TREE
    REAL(KIND=REAL64), INTENT(IN), DIMENSION(:)   :: SQ_SUMS
    REAL(KIND=REAL64), INTENT(IN), DIMENSION(:)   :: RADII
    INTEGER(KIND=INT64), INTENT(IN), DIMENSION(:) :: ORDER
    INTEGER(KIND=INT64), INTENT(IN)               :: K, LEAF_SIZE
    INTEGER(KIND=INT64), INTENT(OUT), DIMENSION(K,SIZE(POINTS,2)) :: INDICES
    REAL(KIND=REAL64),   INTENT(OUT), DIMENSION(K,SIZE(POINTS,2)) :: DISTS
    INTEGER(KIND=INT64), INTENT(IN),  OPTIONAL    :: LOOK_AHEAD
    LOGICAL, INTENT(IN), OPTIONAL :: RANDOMIZED
    ! Local variables.
    LOGICAL :: RANDOM_TRAVERSAL
    INTEGER(KIND=INT64) :: I, B, LH
    INTEGER(KIND=INT64), DIMENSION(:), ALLOCATABLE :: INDS_BUFFER
    REAL(KIND=REAL64),   DIMENSION(:), ALLOCATABLE :: DISTS_BUFFER
    IF (PRESENT(LOOK_AHEAD)) THEN ; LH = LOOK_AHEAD
    ELSE ; LH = MIN(5, CEILING(LOG(REAL(SIZE(ORDER))) / LOG(2.0))) ; END IF
    IF (PRESENT(RANDOMIZED)) THEN ; RANDOM_TRAVERSAL = RANDOMIZED
    ELSE ; RANDOM_TRAVERSAL = .FALSE. ; END IF
    ! Allocate the buffers for holding the nearest indices and distances.
    ALLOCATE( INDS_BUFFER(1:K+2**LH), DISTS_BUFFER(1:K+2**LH) )
    ! For each point in this set, use the recursive branching
    ! algorithm to identify the nearest elements of TREE.
    !$OMP PARALLEL DO PRIVATE(INDS_BUFFER, DISTS_BUFFER, B)
    DO I = 1, SIZE(POINTS,2)
       CALL PT_APPROX_NEAREST(POINTS(:,I), K, TREE, SQ_SUMS, RADII, &
            ORDER, LEAF_SIZE, INDS_BUFFER, DISTS_BUFFER, LH, &
            RANDOMIZED=RANDOM_TRAVERSAL)
       ! Sort the first K elements of the temporary arry for return.
       INDICES(:,I) = INDS_BUFFER(:K)
       DISTS(:,I) = DISTS_BUFFER(:K)
    END DO
    !$OMP END PARALLEL DO
  END SUBROUTINE APPROX_NEAREST

  ! Compute the K nearest elements of TREE to each point in POINTS
  ! using the "look ahead" method for determining tree traversal.
  RECURSIVE SUBROUTINE PT_APPROX_NEAREST(POINT, K, TREE, SQ_SUMS, &
       RADII, ORDER, LEAF_SIZE, INDICES, DISTS, LOOK_AHEAD, FOUND, &
       PT_SS, RANDOMIZED)
    REAL(KIND=REAL64), INTENT(IN), DIMENSION(:)   :: POINT
    REAL(KIND=REAL64), INTENT(IN), DIMENSION(:,:) :: TREE
    REAL(KIND=REAL64), INTENT(IN), DIMENSION(:)   :: SQ_SUMS
    REAL(KIND=REAL64), INTENT(IN), DIMENSION(:)   :: RADII
    INTEGER(KIND=INT64), INTENT(IN), DIMENSION(:) :: ORDER
    INTEGER(KIND=INT64), INTENT(IN)               :: K, LEAF_SIZE, LOOK_AHEAD
    INTEGER(KIND=INT64), INTENT(OUT), DIMENSION(:) :: INDICES
    REAL(KIND=REAL64),   INTENT(OUT), DIMENSION(:) :: DISTS
    INTEGER(KIND=INT64), INTENT(INOUT), OPTIONAL   :: FOUND
    REAL(KIND=REAL64),   INTENT(IN),    OPTIONAL   :: PT_SS
    LOGICAL, INTENT(IN), OPTIONAL :: RANDOMIZED
    ! Local variables
    INTEGER(KIND=INT64) :: F, I, I1, I2, MID, LMID
    REAL(KIND=REAL64)   :: D, D1, D2
    REAL(KIND=REAL64)   :: PS
    LOGICAL :: RANDOM_TRAVERSAL
    ! Storage space for the inner and outer children indices / distances.
    INTEGER(KIND=INT64), DIMENSION(1:2**LOOK_AHEAD) :: LEVEL_INDS
    REAL(KIND=REAL64), DIMENSION(1:2**LOOK_AHEAD) :: LEVEL_DISTS
    ! Initialize randomization.
    IF (PRESENT(RANDOMIZED)) THEN
       RANDOM_TRAVERSAL = RANDOMIZED
    ELSE
       RANDOM_TRAVERSAL = .FALSE.
    END IF
    ! Initialize FOUND for first call, if FOUND is present then
    ! this must not be first and all are present.
    INITIALIZE : IF (PRESENT(FOUND)) THEN
       F = FOUND
       PS = PT_SS
    ELSE
       ! Start at index 0 (added onto current index). Compute squared sum.
       PS = SUM(POINT(:)**2)
       ! Measure distance to root.
       INDICES(1) = ORDER(1)
       DISTS(1) = SQRT(PS + SQ_SUMS(ORDER(1)) - &
            2*DOT_PRODUCT(POINT(:), TREE(:,ORDER(1))))
       ! Set the "points found" to be 1.
       F = 1
    END IF INITIALIZE
    ! If there are enough layers beneath this one, then look ahead.
    KEEP_LOOKING : IF (SIZE(ORDER) .GE. 2**LOOK_AHEAD) THEN
       ! If this is NOT a leaf node, then recurse.
       BRANCH_OR_LEAF : IF (SIZE(ORDER) .GT. 2*LEAF_SIZE+1) THEN
          ! Compute the indices of the inner and outer children.
          MID = (SIZE(ORDER) + 2) / 2
          LMID = 2 ** (LOOK_AHEAD - 1)
          I1 = 0_INT64
          CALL LEVEL(MID-1, LOOK_AHEAD-1, LEVEL_INDS(:LMID), I1, 2_INT64)
          I2 = 0_INT64
          CALL LEVEL(SIZE(ORDER)-MID, LOOK_AHEAD-1, LEVEL_INDS(LMID+1:), I2, MID+1)
          ! Compute distance to the LOOK_AHEAD next level.
          ! Traverse down the branch that looks better.
          !
          ! Measure distance to all inner children.
          DO I = 1, I1
             LEVEL_DISTS(I) = SQRT(PS + SQ_SUMS(ORDER(LEVEL_INDS(I))) - &
                  2*DOT_PRODUCT(POINT(:),TREE(:,ORDER(LEVEL_INDS(I)))))
             ! Store this measured distance.
             F = F + 1
             INDICES(F) = ORDER(LEVEL_INDS(I))
             DISTS(F) = LEVEL_DISTS(I)
          END DO
          ! Measure distance to all outer children.
          DO I = LMID+1, LMID+I2
             LEVEL_DISTS(I) = SQRT(PS + SQ_SUMS(ORDER(LEVEL_INDS(I))) - &
                  2*DOT_PRODUCT(POINT(:),TREE(:,ORDER(LEVEL_INDS(I)))))
             ! Store this measured distance.
             F = F + 1
             INDICES(F) = ORDER(LEVEL_INDS(I))
             DISTS(F) = LEVEL_DISTS(I)
          END DO
          ! Reduce the kept points to only those that are closest.
          CALL ARGSELECT_R64(DISTS(:F), INDICES(:F), MIN(K,F))
          F = MIN(K, F)
          ! Compute the probability that the inner (left) is less than the outer (right).
          CALL PROBABILITY_LESS_THAN(LEVEL_DISTS(1:I1), LEVEL_DISTS(LMID+1:LMID+I2), D1)
          ! Compute the probability that the outer (right) is less than the inner (left).
          CALL PROBABILITY_LESS_THAN(LEVEL_DISTS(LMID+1:LMID+I2), LEVEL_DISTS(1:I1), D2)
          ! Compute the probability of traversing for randomized search.
          IF (RANDOM_TRAVERSAL) THEN
             ! Normalize the probability that D1 is less.
             D1 = D1 / (D1 + D2)
             ! Generate a random number to decide which path to traverse.
             CALL RANDOM_NUMBER(D)
             ! Determine whether or not D1 is less than D2 based on randomness.
             IF (D1 .LE. D) THEN
                D1 = 2.0_REAL64
             ELSE
                D1 = -1.0_REAL64
             END IF
          END IF
          ! Traverse inner (left).
          IF (D1 .GE. D2) THEN
             CALL PT_APPROX_NEAREST(POINT, K, TREE, SQ_SUMS, RADII, ORDER(2:MID), &
                  LEAF_SIZE, INDICES, DISTS, LOOK_AHEAD, F, PS, RANDOM_TRAVERSAL)
          ! Traverse outer (right).
          ELSE
             CALL PT_APPROX_NEAREST(POINT, K, TREE, SQ_SUMS, RADII, ORDER(MID+1:), &
                  LEAF_SIZE, INDICES, DISTS, LOOK_AHEAD, F, PS, RANDOM_TRAVERSAL)
          END IF
       ELSE
          ! This is a leaf, distances need to be measured to all the
          ! children of each child node.
          DIST_TO_CHILDREN : DO I = 2, SIZE(ORDER)
             ! Measure distance to all children of this node.
             D = SQRT(PS + SQ_SUMS(ORDER(I)) - &
                  2*DOT_PRODUCT(POINT(:),TREE(:,ORDER(I))))
             ! Store this distance.
             F = F + 1
             DISTS(F) = D
             INDICES(F) = ORDER(I)
          END DO DIST_TO_CHILDREN
          ! Reduce the kept points to only those that are closest.
          CALL ARGSELECT_R64(DISTS(:F), INDICES(:F), MIN(K,F))
          F = MIN(K, F)
       END IF BRANCH_OR_LEAF
    ELSE
       ! There are no further levels to measure distance to, exit.
       RETURN
    END IF KEEP_LOOKING

    ! Handle closing operations..
    SORT_K : IF (PRESENT(FOUND)) THEN
       ! This is not the root, we need to pass the updated value of
       ! FOUND back up the recrusion stack.
       FOUND = F
    ELSE
       ! This is the root, initial caller. Sort the distances for return.
       CALL ARGSELECT_R64(DISTS(:F), INDICES(:F), K)
       CALL ARGSORT(DISTS(:K), INDICES(:K))
    END IF SORT_K
  END SUBROUTINE PT_APPROX_NEAREST

  ! Given two lists of numbers, compute the probability that a random
  !  number selected from the first list is less than a random number
  !  selected from the second list.
  SUBROUTINE PROBABILITY_LESS_THAN(L1, L2, P)
    REAL(KIND=REAL64), INTENT(INOUT), DIMENSION(:) :: L1, L2
    REAL(KIND=REAL64), INTENT(OUT) :: P
    ! Local variables.
    INTEGER(KIND=INT64), DIMENSION(SIZE(L2)) :: INDS
    INTEGER(KIND=INT64) :: I, J, COUNT
    ! Sort the second list.
    CALL ARGSORT(L2(:), INDS(:))
    ! Sum the probabilities that each element in L1 is less than a
    !  a random element for L2, then divide by the size of L1.
    COUNT = 0
    DO I = 1, SIZE(L1)
       CALL FIRST_GREATER_OR_EQUAL(L2, L1(I), J)
       COUNT = COUNT + (SIZE(L2) - J + 1)
    END DO
    P = REAL(COUNT, KIND=REAL64) / REAL(SIZE(L2)*SIZE(L1), KIND=REAL64)

  CONTAINS
    ! Identify the index of the first element in a list that is greater
    !  than or equal to a given value.
    SUBROUTINE FIRST_GREATER_OR_EQUAL(LIST, VAL, INDEX)
      REAL(KIND=REAL64), INTENT(IN), DIMENSION(:) :: LIST
      REAL(KIND=REAL64), INTENT(IN) :: VAL
      INTEGER(KIND=INT64), INTENT(OUT) :: INDEX
      ! Local variables.
      INTEGER(KIND=INT64) :: FRONT, BACK
      ! Check for special case where every value in the list is greater.
      IF (LIST(1) .GE. VAL) THEN
         INDEX = 1
         RETURN
      END IF
      ! Check for special case where every value in the list is less.
      IF (LIST(SIZE(LIST)) .LT. VAL) THEN
         INDEX = SIZE(LIST)+1
         RETURN
      END if
      ! Perform a binary search to find the first index of an element
      ! in the list that is strictly less than the given value.
      FRONT = 1
      BACK = SIZE(L2)
      binary_search : DO WHILE (FRONT .LT. BACK)
         INDEX = (FRONT + BACK) / 2
         ! Check loop termination condition.
         IF ((INDEX .EQ. FRONT) .OR. (INDEX .EQ. BACK)) THEN
            IF (LIST(FRONT) .GE. VAL) THEN
               INDEX = FRONT
            ELSE
               INDEX = BACK
            END IF
            RETURN
         ! Shrink front and back towards each other.
         ELSE
            IF (LIST(INDEX) .LT. VAL) THEN
               FRONT = INDEX
            ELSE
               BACK = INDEX
            END IF
         END IF
      END DO binary_search
    END SUBROUTINE FIRST_GREATER_OR_EQUAL

  END SUBROUTINE PROBABILITY_LESS_THAN

  ! Re-organize a built tree so that it is more usefully packed in memory.
  SUBROUTINE FIX_ORDER(POINTS, SQ_SUMS, RADII, ORDER, COPY)
    REAL(KIND=REAL64),   INTENT(INOUT), DIMENSION(:,:) :: POINTS
    REAL(KIND=REAL64),   INTENT(OUT),   DIMENSION(:)   :: SQ_SUMS
    REAL(KIND=REAL64),   INTENT(OUT),   DIMENSION(:)   :: RADII
    INTEGER(KIND=INT64), INTENT(INOUT), DIMENSION(:)   :: ORDER
    LOGICAL, INTENT(IN), OPTIONAL :: COPY
    LOGICAL :: SHOULD_COPY
    INTEGER(KIND=INT64) :: I
    ! Default to copy (in memory) if there is less than 1 GB of data.
    IF (PRESENT(COPY)) THEN ; SHOULD_COPY = COPY
    ELSE ; SHOULD_COPY = SIZEOF(POINTS) .LE. MAX_COPY_BYTES
    END IF
    ! Reorder all of the data. Use a scratch file for large data sets.
    IF (SHOULD_COPY) THEN
       POINTS(:,:) = POINTS(:,ORDER)
    ELSE
       ! Open scratch file for writing all of the points in order.
       OPEN(UNIT=1, STATUS='SCRATCH', ACTION='READWRITE', FORM='UNFORMATTED', ACCESS='STREAM')
       ! Write all points to a scratch file in the correct order.
       DO I = 1, SIZE(ORDER)
          WRITE(UNIT=1) POINTS(:,ORDER(I))
       END DO
       ! Read all points from file (they are now ordered correctly).
       READ(UNIT=1,POS=1) POINTS(:,:)
       ! Close scratch file.
       CLOSE(UNIT=1)
    END IF
    ! Always copy the square sums and the radii in memory (shouldn't be bad).
    SQ_SUMS(:) = SQ_SUMS(ORDER)
    RADII(:) = RADII(ORDER)
    ! Reset the order because now it is the expected format.
    FORALL (I=1:SIZE(ORDER)) ORDER(I) = I
  END SUBROUTINE FIX_ORDER

END MODULE BALL_TREE_R64

!2021-06-06 12:10:09
!
          !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
          ! PRINT *, ''                                                !
          ! PRINT *, 'LOOK_AHEAD         ', LOOK_AHEAD                 !
          ! PRINT *, 'LMID:              ', LMID                       !
          ! PRINT *, 'LEVEL_INDS(:)      ', LEVEL_INDS(:)              !
          ! PRINT *, 'LEVEL_INDS(:LMID)  ', LEVEL_INDS(:I1)            !
          ! PRINT *, 'LEVEL_INDS(LMID+1:)', LEVEL_INDS(LMID+1:LMID+I2) !
          !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!


subroutine apply_linearized_pde_operator(t, q, p, output)

! For the PDE q_t = g(q), calculates g'[q](p), i.e. the linearization
! of g, about q, applied to perturbation p
!
! Args:
!   t: Time at which the operator is evaluated.
!   q: Base function of the linearization.
!   p: Perturbation to which the linearized operator is applied.
!   output: g'[q](p), calculated here.

    implicit none

    integer :: mx, mbc, meqn
    double precision :: dx, x_lower
    common /claw_config/ mx, mbc, x_lower, dx, meqn

    double precision, intent(in) :: t
    double precision, dimension(1-mbc:mx+mbc, meqn), intent(in) :: q, p
    double precision, dimension(1-mbc:mx+mbc, meqn), intent(out) :: output

    call apply_pde_operator(t, p, output)

end subroutine apply_linearized_pde_operator


! { dg-do compile }
! { dg-options "-O3 -fno-automatic" }

      FUNCTION WWERF(Z)

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMPLEX*16 WWERF
      COMPLEX*16 Z,ZH,R(37),S,T,V,W

      PARAMETER (Z1 = 1, HF = Z1/2, Z10 = 10)
      PARAMETER (C1 = 74/Z10, C2 = 83/Z10, C3 = Z10/32, C4 = 16/Z10)
      PARAMETER (C = 1.12837 91670 95512 57D0, P = (2*C4)**33)

      DOUBLE PRECISION GREAL,GIMAG,XARG,YARG
      COMPLEX*16 ZARG,GCONJG,GCMPLX
      GREAL( ZARG)=DREAL( ZARG)
      GIMAG( ZARG)=DIMAG( ZARG)
      GCONJG(ZARG)=DCONJG(ZARG)
      GCMPLX(XARG,YARG)=DCMPLX(XARG,YARG)

      X=Z
      Y=GIMAG(Z)
      XA=ABS(X)
      YA=ABS(Y)
      IF(YA .LT. C1 .AND. XA .LT. C2) THEN
       ZH=GCMPLX(YA+C4,XA)
       R(37)=0
       DO 1 N = 36,1,-1
       T=ZH+N*GCONJG(R(N+1))
    1  R(N)=HF*T/(GREAL(T)**2+GIMAG(T)**2)
       XL=P
       S=0
       DO 2 N = 33,1,-1
       XL=C3*XL
    2  S=R(N)*(S+XL)
       V=C*S
      ELSE
       ZH=GCMPLX(YA,XA)
       R(1)=0
       DO 3 N = 9,1,-1
       T=ZH+N*GCONJG(R(1))
    3  R(1)=HF*T/(GREAL(T)**2+GIMAG(T)**2)
       V=C*R(1)
      END IF
      IF(YA .EQ. 0) V=GCMPLX(EXP(-XA**2),GIMAG(V))
      IF(Y .LT. 0) THEN
       V=2*EXP(-GCMPLX(XA,YA)**2)-V
       IF(X .GT. 0) V=GCONJG(V)
      ELSE
       IF(X .LT. 0) V=GCONJG(V)
      END IF

      WWERF=V

      RETURN
      END


!-----------------------------------------------------------------------
      program test
      implicit none
      include 'ceedf.h'

      integer ceed,err,i,j
      integer b
      real*8 collograd1d(16), collograd1d2(36)

      character arg*32

      call getarg(1,arg)

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

!     Already collocated, GetCollocatedGrad will return grad1d
      call ceedbasiscreatetensorh1lagrange(ceed,1,1,4,4,ceed_gauss_lobatto,b,&
     & err)
      call ceedbasisgetcollocatedgrad(b,collograd1d,err)
      do i=1,16
        if (abs(collograd1d(i))<1.0D-14) then
          collograd1d(i) = 0
        endif
      enddo
      do i=0,3
        write(*,'(A,I1,A,F12.8,F12.8,F12.8,F12.8,F12.8,F12.8)')&
     &   'collograd[',i,']:',(collograd1d(j+4*i),j=1,4)
      call flush(6)
      enddo
      call ceedbasisdestroy(b,err)

!     Q = P, not already collocated
      call ceedbasiscreatetensorh1lagrange(ceed,1,1,4,4,ceed_gauss,b,err)
      call ceedbasisgetcollocatedgrad(b,collograd1d,err)
      do i=1,16
        if (abs(collograd1d(i))<1.0D-14) then
! LCOV_EXCL_START
          collograd1d(i) = 0
! LCOV_EXCL_STOP
        endif
      enddo
      do i=0,3
        write(*,'(A,I1,A,F12.8,F12.8,F12.8,F12.8,F12.8,F12.8)')&
     &   'collograd[',i,']:',(collograd1d(j+4*i),j=1,4)
      call flush(6)
      enddo
      call ceedbasisdestroy(b,err)

!     Q = P + 2, not already collocated
      call ceedbasiscreatetensorh1lagrange(ceed,1,1,4,6,ceed_gauss,b,err)
      call ceedbasisgetcollocatedgrad(b,collograd1d2,err)
      do i=1,36
        if (abs(collograd1d2(i))<1.0D-14) then
! LCOV_EXCL_START
          collograd1d2(i) = 0
! LCOV_EXCL_STOP
        endif
      enddo
      do i=0,5
        write(*,'(A,I1,A,F12.8,F12.8,F12.8,F12.8,F12.8,F12.8)')&
     &   'collograd[',i,']:',(collograd1d2(j+6*i),j=1,6)
      call flush(6)
      enddo
      call ceedbasisdestroy(b,err)

      call ceeddestroy(ceed,err)

      end
!-----------------------------------------------------------------------