!******************************************************************************
!*
!*                 VARIOUS DISTRIBUTIONS OF RANDOM VARIABLES
!*
!******************************************************************************

  !==========================================================================
  ! 1) AUTHOR: F. Galliano
  !
  ! 2) HISTORY:
  !    - Created 10/2007
  !    - 03/2015: add multivariate distributions
  !    - 03/2015: add GENERATE_NEWSEED
  !    - 04/2016: add the skew-normal generator
  !
  ! 3) DESCRIPTION: provides random generators of various well-known
  !                 probability distributions.
  !==========================================================================

MODULE random

  USE utilities, ONLY: DP
  USE arrays, ONLY:
  USE inout, ONLY:
  USE linear_system, ONLY:
  USE interpolation, ONLY:
  USE adaptative_grid, ONLY:
  PRIVATE

  PUBLIC :: rand_exp, rand_norm, rand_skewnorm, rand_splitnorm, rand_student
  PUBLIC :: rand_poisson, rand_general, rand_multinorm, rand_multistudent
  PUBLIC :: generate_newseed

  INTERFACE rand_exp
    MODULE PROCEDURE rand_exp_v, rand_exp_s
  END INTERFACE rand_exp

  INTERFACE rand_norm
    MODULE PROCEDURE rand_norm_m, rand_norm_v, rand_norm_s
  END INTERFACE rand_norm

  INTERFACE rand_skewnorm
    MODULE PROCEDURE rand_skewnorm_m, rand_skewnorm_v, rand_skewnorm_s
  END INTERFACE rand_skewnorm

  INTERFACE rand_splitnorm
    MODULE PROCEDURE rand_splitnorm_m, rand_splitnorm_v, rand_splitnorm_s
  END INTERFACE rand_splitnorm

  INTERFACE rand_student
    MODULE PROCEDURE rand_student_m, rand_student_v, rand_student_s
  END INTERFACE rand_student

  INTERFACE rand_multinorm
    MODULE PROCEDURE rand_multinorm_v, rand_multinorm_s
  END INTERFACE rand_multinorm

  INTERFACE rand_multistudent
    MODULE PROCEDURE rand_multistudent_v, rand_multistudent_s
  END INTERFACE rand_multistudent

  INTERFACE rand_general
    MODULE PROCEDURE rand_general_vec, rand_general_scl
  END INTERFACE rand_general

CONTAINS

  !==========================================================================
  ! CALL GENERATE_NEWSEED(fileIN,fileOUT)
  !
  !   IF FILEIN and/or FILEOUT are set, then the sequence of integers
  ! constituing the seed is read/written. To ensure the seed is different at
  ! each run, we initialize it with date and time.
  !==========================================================================

  SUBROUTINE generate_newseed (fileIN,fileOUT)

    USE utilities, ONLY: verbatim, trimlr
    USE inout, ONLY: lenpath, ascext
    IMPLICIT NONE
    CHARACTER(*), INTENT(IN), OPTIONAL :: fileIN
    CHARACTER(lenpath), INTENT(OUT), OPTIONAL :: fileOUT

    INTEGER, PARAMETER :: unitIN = 1, unitOUT = 2

    INTEGER :: i, Nseed
    INTEGER, DIMENSION(8) :: values
    INTEGER, DIMENSION(:), ALLOCATABLE :: seed

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

    ! Get the new seed
    genseed: IF (PRESENT(fileIN)) THEN
      OPEN(unitIN,FILE=fileIN,ACTION="READ")
        READ(unitIN,"(I20)") Nseed
        ALLOCATE (seed(Nseed))
        DO i=1,Nseed
          READ(unitIN,"(I20)") seed(i)
        END DO
      CLOSE(unitIN)
      IF (verbatim) PRINT*, " - File "//TRIMLR(fileIN)//" has been written."
    ELSE
      CALL RANDOM_SEED(SIZE=Nseed)
      ALLOCATE (seed(Nseed))
      CALL RANDOM_SEED(GET=seed)
      CALL DATE_AND_TIME(VALUES=values)
      seed(:) = seed(:)*SUM(values)
    END IF genseed

    ! Writes the seed to a file
    IF (PRESENT(fileOUT)) THEN
      OPEN(unitOUT,FILE=fileOUT,STATUS="REPLACE",ACTION="WRITE")
        WRITE(unitOUT,"(I20)") Nseed
        DO i=1,Nseed
           WRITE(unitOUT,"(I20)") seed(i)
        END DO
      CLOSE(unitOUT)
    END IF

    ! Initialize the random sequence
    CALL RANDOM_SEED(PUT=seed)
    DEALLOCATE (seed)

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

  END SUBROUTINE generate_newseed

  !==========================================================================
  ! x = RAND_EXP (N,tau)
  !
  !   Returns an array[N] of random variables following an exponential law
  ! with a timescale of TAU. Taken from http://users.bigpond.net.au/amiller/ .
  !==========================================================================

  FUNCTION rand_exp_v (N,tau)

    USE utilities, ONLY: DP
    IMPLICIT NONE

    INTEGER, INTENT(IN) :: N
    REAL(DP), INTENT(IN), OPTIONAL :: tau
    REAL(DP), DIMENSION(N) :: rand_exp_v

    INTEGER :: i
    REAL(DP), DIMENSION(N) :: r

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

    varN: DO i=1,N
      randgen: DO
        CALL RANDOM_NUMBER (r(i))
        IF (r(i) > 0._DP) EXIT
      END DO randgen
    END DO varN

    ! p(t) = EXP(-t/tau)
    rand_exp_v(:) = - LOG(r(:))
    IF (PRESENT(tau)) rand_exp_v(:) = rand_exp_v(:) * tau

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

  END FUNCTION rand_exp_v

  ! Interface shell
  FUNCTION rand_exp_s(tau)
    USE utilities, ONLY: DP
    IMPLICIT NONE
    REAL(DP), INTENT(IN), OPTIONAL :: tau
    REAL(DP) :: rand_exp_s
    rand_exp_s = MAXVAL(RAND_EXP_V(1,tau))
  END FUNCTION rand_exp_s

  !==========================================================================
  ! x = RAND_NORM (N,M,center,sigma)
  !
  !   Returns an array[N] of random variables following a normal distribution
  ! of mean CENTER and standard deviation SIGMA. Taken from
  ! http://people.sc.fsu.edu/~jburkardt/f_src/normal/normal.f90, tested and
  ! vectorized.
  !==========================================================================

  FUNCTION rand_norm_m (N,M,center,sigma)

    USE utilities, ONLY: DP
    USE constants, ONLY: pi
    USE arrays, ONLY: reallocate
    IMPLICIT NONE

    INTEGER, INTENT(IN) :: N, M
    REAL(DP), INTENT(IN), OPTIONAL :: center, sigma
    REAL(DP), DIMENSION(N,M) :: rand_norm_m

    REAL(DP), DIMENSION(N,M) :: r1, r2, x

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

    CALL RANDOM_NUMBER(r1(:,:))
    CALL RANDOM_NUMBER(r2(:,:))
    x(:,:) = SQRT( - 2._DP * LOG(r1(:,:)) ) * COS( 2._DP * pi * r2(:,:) )
    rand_norm_m(:,:) = x(:,:)
    IF (PRESENT(sigma)) rand_norm_m(:,:) = rand_norm_m(:,:) * sigma
    IF (PRESENT(center)) rand_norm_m(:,:) = rand_norm_m(:,:) + center

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

  END FUNCTION rand_norm_m

  ! Interface shells
  FUNCTION rand_norm_v (N,center,sigma)
    USE utilities, ONLY: DP
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: N
    REAL(DP), INTENT(IN), OPTIONAL :: center, sigma
    REAL(DP), DIMENSION(N) :: rand_norm_v
    rand_norm_v(:) = RESHAPE(RAND_NORM_M(N,1,CENTER=center,SIGMA=sigma),[N])
  END FUNCTION rand_norm_v
  FUNCTION rand_norm_s (center,sigma)
    USE utilities, ONLY: DP
    IMPLICIT NONE
    REAL(DP), INTENT(IN), OPTIONAL :: center, sigma
    REAL(DP) :: rand_norm_s
    rand_norm_s = MAXVAL(RAND_NORM_M(1,1,CENTER=center,SIGMA=sigma))
  END FUNCTION rand_norm_s

  !==========================================================================
  ! x = RAND_SKEWNORM (N,M,ksi,omega,alpha)
  !
  !   Returns an array[N] of random variables following a skew-normal
  ! distribution of position parameter KSI, scale parameter OMEGA, and shape
  ! parameter ALPHA. Extracted from the MATLAB library.
  !==========================================================================

  FUNCTION rand_skewnorm_m (N,M,ksi,omega,alpha)

    USE utilities, ONLY: DP
    USE arrays, ONLY: reallocate
    IMPLICIT NONE

    INTEGER, INTENT(IN) :: N, M
    REAL(DP), INTENT(IN), OPTIONAL :: ksi, omega, alpha
    REAL(DP), DIMENSION(N,M) :: rand_skewnorm_m

    REAL(DP), DIMENSION(N,M) :: r1, r2, x
    REAL(DP) :: delta, ksi0, omega0, alpha0

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

    IF (PRESENT(ksi)) THEN ; ksi0 = ksi ; ELSE ; ksi0 = 0._DP ; END IF
    IF (PRESENT(omega)) THEN ; omega0 = omega ; ELSE ; omega0 = 1._DP ; END IF
    IF (PRESENT(alpha)) THEN ; alpha0 = alpha ; ELSE ; alpha0 = 0._DP ; END IF
    r1(:,:) = RAND_NORM_M(N,M)
    r2(:,:) = RAND_NORM_M(N,M)
    delta = alpha0 / SQRT(1+alpha0**2)
    x(:,:) = delta * r1(:,:) + SQRT(1-delta**2)*r2(:,:)
    rand_skewnorm_m(:,:) = SIGN(1._DP,r1(:,:))*x(:,:)*omega0 + ksi0

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

  END FUNCTION rand_skewnorm_m

  ! Interface shells
  FUNCTION rand_skewnorm_v (N,ksi,omega,alpha)
    USE utilities, ONLY: DP
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: N
    REAL(DP), INTENT(IN), OPTIONAL :: ksi, omega, alpha
    REAL(DP), DIMENSION(N) :: rand_skewnorm_v
    rand_skewnorm_v(:) &
      = RESHAPE(RAND_SKEWNORM_M(N,1,KSI=ksi,OMEGA=omega,ALPHA=alpha),[N])
  END FUNCTION rand_skewnorm_v
  FUNCTION rand_skewnorm_s (ksi,omega,alpha)
    USE utilities, ONLY: DP
    IMPLICIT NONE
    REAL(DP), INTENT(IN), OPTIONAL :: ksi, omega, alpha
    REAL(DP) :: rand_skewnorm_s
    rand_skewnorm_s &
      = MAXVAL(RAND_SKEWNORM_M(1,1,KSI=ksi,OMEGA=omega,ALPHA=alpha))
  END FUNCTION rand_skewnorm_s

  !==========================================================================
  ! x = RAND_SPLITNORM (N,M,mu,lambda,tau)
  !
  !   Returns an array[N] of random variables following a split-normal
  ! distribution of position parameter MU, scale parameter LAMBDA, and shape
  ! parameter TAU.
  !==========================================================================

  FUNCTION rand_splitnorm_m (N,M,mu,lambda,tau)

    USE utilities, ONLY: DP
    USE arrays, ONLY: reallocate
    IMPLICIT NONE

    INTEGER, INTENT(IN) :: N, M
    REAL(DP), INTENT(IN), OPTIONAL :: mu, lambda, tau
    REAL(DP), DIMENSION(N,M) :: rand_splitnorm_m

    REAL(DP), DIMENSION(N,M) :: r1, r2
    REAL(DP) :: mu0, lambda0, tau0

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

    IF (PRESENT(mu)) THEN ; mu0 = mu ; ELSE ; mu0 = 0._DP ; END IF
      IF (PRESENT(lambda)) THEN ; lambda0 = lambda
                           ELSE ; lambda0 = 1._DP ; END IF
    IF (PRESENT(tau)) THEN ; tau0 = tau ; ELSE ; tau0 = 0._DP ; END IF
    r1(:,:) = RAND_NORM_M(N,M)
    CALL RANDOM_NUMBER(r2(:,:))
    WHERE (r2(:,:) < 1._DP/(1._DP+tau))
      rand_splitnorm_m(:,:) = - ABS(r1(:,:)) * lambda + mu
    ELSEWHERE
      rand_splitnorm_m(:,:) = ABS(r1(:,:)) * lambda * tau + mu
    END WHERE

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

  END FUNCTION rand_splitnorm_m

  ! Interface shells
  FUNCTION rand_splitnorm_v (N,mu,lambda,tau)
    USE utilities, ONLY: DP
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: N
    REAL(DP), INTENT(IN), OPTIONAL :: mu, lambda, tau
    REAL(DP), DIMENSION(N) :: rand_splitnorm_v
    rand_splitnorm_v(:) &
      = RESHAPE(RAND_SPLITNORM_M(N,1,MU=mu,LAMBDA=lambda,TAU=tau),[N])
  END FUNCTION rand_splitnorm_v
  FUNCTION rand_splitnorm_s (mu,lambda,tau)
    USE utilities, ONLY: DP
    IMPLICIT NONE
    REAL(DP), INTENT(IN), OPTIONAL :: mu, lambda, tau
    REAL(DP) :: rand_splitnorm_s
    rand_splitnorm_s = MAXVAL(RAND_SPLITNORM_M(1,1,MU=mu,LAMBDA=lambda,TAU=tau))
  END FUNCTION rand_splitnorm_s

  !==========================================================================
  ! x = RAND_MULTINORM(N,covar[M,M],mu)
  !
  !   Returns an array[M,N] of random variables following a multivariate normal
  ! distribution with covariance matrix COVAR.
  !==========================================================================

  FUNCTION rand_multinorm_v (N,covar,mu)

    USE utilities, ONLY: DP, strike
    USE linear_system, ONLY: cholesky_decomp
    IMPLICIT NONE

    INTEGER, INTENT(IN) :: N
    REAL(DP), DIMENSION(:,:), INTENT(IN) :: covar
    REAL(DP), DIMENSION(:), INTENT(IN), OPTIONAL :: mu
    REAL(DP), DIMENSION(SIZE(covar,1),N) :: rand_multinorm_v

    INTEGER :: i, M
    REAL(DP), DIMENSION(SIZE(covar,1),N) :: theta
    REAL(DP), DIMENSION(SIZE(covar,1),SIZE(covar,2)) :: L

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

    ! Covariance size
    M = SIZE(covar(:,:),1)
    IF (SIZE(covar(:,:),2) /= M) &
      CALL STRIKE("RAN_MULTINORM","wrong size for COVAR")

    ! Draw independent normal variables
    theta(:,:) = RAND_NORM(M,N)

    ! Perform Cholesky decompsition
    L(:,:) = CHOLESKY_DECOMP(covar(:,:))
    rand_multinorm_v(:,:) = MATMUL(L(:,:),theta(:,:))
    IF (PRESENT(mu)) THEN
      FORALL (i=1:N) rand_multinorm_v(:,i) = rand_multinorm_v(:,i) + mu(:)
    END IF

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

  END FUNCTION rand_multinorm_v

  ! Interface shell
  FUNCTION rand_multinorm_s (covar,mu)
    USE utilities, ONLY: DP
    IMPLICIT NONE
    REAL(DP), DIMENSION(:,:), INTENT(IN) :: covar
    REAL(DP), DIMENSION(:), INTENT(IN), OPTIONAL :: mu
    REAL(DP), DIMENSION(SIZE(covar,1)) :: rand_multinorm_s
    rand_multinorm_s(:) = RESHAPE(RAND_MULTINORM_V(1,covar,mu),[SIZE(covar,1)])
  END FUNCTION rand_multinorm_s

  !==========================================================================
  ! x = RAND_STUDENT (N,M,Df,center,sigma)
  !
  !   Returns an array[N] of random variables following a Student's t
  ! distribution of mean CENTER and standard deviation SIGMA, with Df degrees
  ! of freedom. Taken from http://www.netlib.org/random/.
  !==========================================================================

  ! Scalar function for a reduced random variable
  !----------------------------------------------
  FUNCTION rand_student_m(N,M,Df,center,sigma)

    USE utilities, ONLY: DP, strike, NaN
    IMPLICIT NONE

    INTEGER, INTENT(IN) :: N, M, Df
    REAL(DP), INTENT(IN), OPTIONAL :: center, sigma
    REAL(DP), DIMENSION(N,M) :: rand_student_m

    REAL(DP), PARAMETER :: zero = 0.0_DP, quart = 0.25_DP, half = 0.5_DP
    REAL(DP), PARAMETER :: one = 1.0_DP, two = 2.0_DP, three = 3.0_DP
    REAL(DP), PARAMETER :: four = 4.0_DP, five = 5.0_DP, sixteen = 16.0_DP

    INTEGER :: mm, i, j
    REAL(DP), SAVE :: s, c, a, f, g
    REAL(DP) :: r, x, v

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

    IF (Df < 1) THEN
      rand_student_m(:,:) = NaN()
      RETURN
    END IF

    mm = 0
    DO i=1,N
      DO j=1,M
        IF (Df /= mm) THEN ! Initialization, if necessary
          s = Df
          c = - quart * (s + one)
          a = four / (one + one/s)**c
          f = sixteen / a
          IF (Df > 1) THEN
            g = s - one
            g = ((s + one)/g)**c * SQRT((s+s)/g)
          ELSE
            g = one
          END IF
          mm = Df
        END IF

        DO
          CALL RANDOM_NUMBER(r)
          IF (r <= zero) CYCLE
          CALL RANDOM_NUMBER(v)
          x = (two*v - one)*g/r
          v = x*x
          IF (v > five - a*r) THEN
            IF (Df >= 1 .AND. r*(v + three) > f) CYCLE
            IF (r > (one + v/s)**c) CYCLE
          END IF
          EXIT
        END DO
        rand_student_m(i,j) = x
      END DO
    END DO

    IF (PRESENT(sigma)) rand_student_m(:,:) = rand_student_m(:,:) * sigma
    IF (PRESENT(center)) rand_student_m(:,:) = rand_student_m(:,:) + center

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

  END FUNCTION rand_student_m

  ! Interface shell
  FUNCTION rand_student_v(N,Df,center,sigma)
    USE utilities, ONLY: DP
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: N, Df
    REAL(DP), INTENT(IN), OPTIONAL :: center, sigma
    REAL(DP), DIMENSION(N) :: rand_student_v
    rand_student_v(:) &
      = RESHAPE(RAND_STUDENT_M(N,1,Df,CENTER=center,SIGMA=sigma),[N])
  END FUNCTION rand_student_v
  FUNCTION rand_student_s(Df,center,sigma)
    USE utilities, ONLY: DP
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: Df
    REAL(DP), INTENT(IN), OPTIONAL :: center, sigma
    REAL(DP) :: rand_student_s
    rand_student_s = MAXVAL(RAND_STUDENT_M(1,1,Df,CENTER=center,SIGMA=sigma))
  END FUNCTION rand_student_s

  !==========================================================================
  ! x = RAND_MULTISTUDENT (N,Df,covar[M,M],mu)
  !
  !   Returns an array[M,N] of random variables following a multivariate t
  ! distribution with covariance matrix COVAR.
  !==========================================================================

  FUNCTION rand_multistudent_v (N,Df,covar,mu)

    USE utilities, ONLY: DP, strike
    USE linear_system, ONLY: cholesky_decomp
    IMPLICIT NONE

    INTEGER, INTENT(IN) :: N, Df
    REAL(DP), DIMENSION(:,:), INTENT(IN) :: covar
    REAL(DP), DIMENSION(:), INTENT(IN), OPTIONAL :: mu
    REAL(DP), DIMENSION(SIZE(covar,1),N) :: rand_multistudent_v

    INTEGER :: i, M
    REAL(DP), DIMENSION(SIZE(covar,1),N) :: theta
    REAL(DP), DIMENSION(SIZE(covar,1),SIZE(covar,2)) :: L

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

    ! Covariance size
    M = SIZE(covar(:,:),1)
    IF (SIZE(covar(:,:),2) /= M) &
      CALL STRIKE("RAN_MULTISTUDENT","wrong size for COVAR")

    ! Draw independent normal variables
    theta(:,:) = RAND_STUDENT(M,N,Df)

    ! Perform Cholesky decompsition
    L(:,:) = CHOLESKY_DECOMP(covar(:,:))
    rand_multistudent_v(:,:) = MATMUL(L(:,:),theta(:,:))
    IF (PRESENT(mu)) THEN
      FORALL (i=1:N) rand_multistudent_v(:,i) = rand_multistudent_v(:,i) + mu(:)
    END IF

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

  END FUNCTION rand_multistudent_v

  ! Interface shell
  FUNCTION rand_multistudent_s (Df,covar,mu)
    USE utilities, ONLY: DP
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: Df
    REAL(DP), DIMENSION(:,:), INTENT(IN) :: covar
    REAL(DP), DIMENSION(:), INTENT(IN), OPTIONAL :: mu
    REAL(DP), DIMENSION(SIZE(covar,1)) :: rand_multistudent_s
    rand_multistudent_s(:) = RESHAPE(RAND_MULTISTUDENT_V(1,Df,covar,mu), &
                                     [SIZE(covar,1)])
  END FUNCTION rand_multistudent_s

  !==========================================================================
  ! x = GEN_POISSON (mu,first)
  !
  !   Returns a random poissonian deviate of average MU. FIRST for initiating
  ! the serie. Taken from http://users.bigpond.net.au/amiller/.
  !==========================================================================

  FUNCTION gen_poisson (mu,first) RESULT(ival)

    USE utilities, ONLY: DP
    IMPLICIT NONE

    REAL(DP), INTENT(IN) :: mu
    LOGICAL, INTENT(IN) :: first
    INTEGER :: ival

    REAL(DP), PARAMETER :: a0 = -0.5_DP, a1 = 0.3333333_DP, a2 = -0.2500068_DP
    REAL(DP), PARAMETER :: a3 = 0.2000118_DP, a4 = -0.1661269_DP
    REAL(DP), PARAMETER :: a5 = 0.1421878_DP, a6 = -0.1384794_DP
    REAL(DP), PARAMETER :: a7 = 0.1250060_DP
    REAL(DP), DIMENSION(10), PARAMETER :: &
      fact(10) = [ 1._DP, 1._DP, 2._DP, 6._DP, 24._DP, 120._DP, 720._DP, &
                   5040._DP, 40320._DP, 362880._DP ]

    INTEGER :: j, k, kflag
    INTEGER, SAVE :: l, m
    REAL(DP) :: b1, b2, c, c0, c1, c2, c3, del, difmuk, e, fk, fx, fy, g
    REAL(DP) :: omega, px, py, t, u, v, x, xx
    REAL(DP), SAVE :: s, d, p, q, p0
    LOGICAL, SAVE :: full_init
    REAL(DP), SAVE :: pp(35)

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

    fk = 0._DP
    difmuk = 0._DP
    ival = 0

    valofmu: IF (mu > 10.0) THEN
    ! CASE  A. (Recalculation OF S, D, L if MU has changed)
    !--------

      IF (first) THEN
        s = SQRT(mu)
        d = 6._DP*mu*mu
        ! The Poisson probabilities Pk exceed the discrete normal
        ! probabilities Fk whenever K >= M(MU). L=IFIX(MU-1.1484)
        ! is an upper bound to M(MU) for all MU >= 10 .
        l = INT(mu - 1.1484_DP)
        full_init = .False.
      END IF

      ! STEP N. Normal sample - random_normal() for standard normal deviate
      g = mu + s*MAXVAL(rand_norm(1))
      IF (g > 0.0) THEN
        ival = INT(g)
        ! STEP I. Immediate acceptance if IVAL is large enough
        IF (ival>=l) RETURN
        ! STEP S. Squeeze acceptance - Sample U
        fk = ival
        difmuk = mu - fk
        CALL RANDOM_NUMBER(u)
        IF (d*u >= difmuk*difmuk*difmuk) RETURN
      END IF

      ! STEP P. Preparations for steps Q and H.
      !         (Recpitulations of parameters if necessary)
      !         .3989423=(2*PI)**(-.5)  .416667E-1=1./24.  .1428571=1./7.
      !         The quantities B1, B2, C3, C2, C1, C0 are for the Hermite
      !         Aproximations to the discrete normal probabilities Fk.
      !         C=.1069/MU guarantees majorization by the 'Hat'-function.
      IF (.NOT. full_init) THEN
        omega = 0.3989423_DP / s
        b1 = 0.4166667E-1/mu
        b2 = 0.3*b1*b1
        c3 = 0.1428571*b1*b2
        c2 = b2 - 15.*c3
        c1 = b1 - 6.*b2 + 45.*c3
        c0 = 1. - b1 + 3.*b2 - 15.*c3
        c = 0.1069/mu
        full_init = .True.
      ELSE
        omega = 0._DP
        c3 = 0._DP
        c2 = 0._DP
        c1 = 0._DP
        c0 = 0._DP
        c = 0._DP
      END IF

      IF (g < 0.0) GOTO 50

      ! 'Subroutine' F is called (KFLAG=0 for correct return)
      kflag = 0
      GOTO 70

      ! STEP Q. Quotient acceptance (rare case)
      40 IF (fy-u*fy <= py*EXP(px-fx)) RETURN

      ! STEP E. Exponential sample - rand_exp() for standard exponential
      !         Deviate E and sample T from the Laplace 'Hat'
      !         (If T <= -.6744 then Pk < Fk for all MU >= 10.)
      50 e = MAXVAL(rand_exp(1))
      CALL RANDOM_NUMBER(u)
      u = u + u - 1.
      t = 1.8 + SIGN(e, u)
      IF (t <= (-.6744)) GOTO 50
      ival = INT(mu + s*t)
      fk = ival
      difmuk = mu - fk

      ! 'Subroutine' F is called (KFLAG=1 for correct return)
      kflag = 1
      GOTO 70

      ! STEP H. Hat acceptance (E is repeated on rejection)
      60 IF (c*ABS(u) > py*EXP(px+e) - fy*EXP(fx+e)) GOTO 50
      RETURN

      ! STEP F. 'Subroutine' F. Calculation of Px, Py, Fx, Fy.
      !         Case IVAL < 10 uses factorials from table fact
      70 IF (ival>=10) GOTO 80
      px = -mu
      py = mu**ival/fact(ival+1)
      GOTO 110

      ! Case IVAL >= 10 uses polynomial aproximation
      ! A0-A7 for accuracy when advisable
      ! .8333333E-1=1./12.  .3989423=(2*PI)**(-.5)
      80 del = .8333333E-1/fk
      del = del - 4.8*del*del*del
      v = difmuk/fk
      IF (ABS(v)>0.25) THEN
        px = fk*LOG(1. + 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 = .3989423/SQRT(fk)
      110 x = (0.5 - difmuk)/s
      xx = x*x
      fx = -0.5*xx
      fy = omega * (((c3*xx + c2)*xx + c1)*xx + c0)
      IF (kflag <= 0) GOTO 40
      GOTO 60

    ELSE
    ! CASE B. mu < 10
    !-------
    ! Start new table and calculate P0 if necessary

      IF (first) THEN
        m = MAX(1,INT(mu))
        l = 0
        p = EXP(-mu)
        q = p
        p0 = p
      END IF

      ! STEP U. Uniform sample for inversion method
      DO
        CALL RANDOM_NUMBER(u)
        ival = 0
        IF (u <= p0) RETURN

        ! STEP T. Table comparison until the end PP(L) of the
        !         PP-Table of cumulative Poisson probabilities
        !         (0.458=PP(9) for MU=10)
        IF (l == 0) GOTO 150
        j = 1
        IF (u > 0.458) j = MIN(l, m)
        DO k=j,l
          IF (u <= pp(k)) GOTO 180
        END DO
        IF (l == 35) CYCLE

        ! STEP C. Creation of new Poisson probabilities P
        !         and their cumulatives Q=PP(K)
        150 l = l + 1
        DO k=l,35
          p = p*mu / k
          q = q + p
          pp(k) = q
          IF (u <= q) GOTO 170
        END DO
        l = 35
      END DO

      170 l = k
      180 ival = k
      RETURN

    END IF valofmu

    RETURN

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

  END FUNCTION gen_poisson

  !==========================================================================
  ! x = RAND_POISSON (N,tau,first)
  !
  !   Returns an array[N] of random poissonian variables with a timescale of
  ! TAU. Taken from http://users.bigpond.net.au/amiller/ .
  !==========================================================================

  FUNCTION rand_poisson (N,tau,first)

    USE utilities, ONLY: DP
    IMPLICIT NONE

    INTEGER, INTENT(IN) :: N
    REAL(DP), INTENT(IN) :: tau
    INTEGER, DIMENSION(N) :: rand_poisson
    LOGICAL, INTENT(IN), OPTIONAL :: first

    INTEGER :: i
    LOGICAL :: prem

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

    IF (PRESENT(first)) THEN ; prem = first ; ELSE ; prem = .True. ; END IF

    rand_poisson(1) = GEN_POISSON(1._DP/tau,FIRST=prem)
    rand_poisson(2:N) = (/(GEN_POISSON(1._DP/tau,FIRST=.False.),i=2,N)/)

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

  END FUNCTION rand_poisson

  !==========================================================================
  !  x[N] = RAND_GENERAL(N,func,limits,xlog,ylog,limited,accmax)
  !
  !  Draw random sample from a user defined distribution.
  !==========================================================================

  FUNCTION rand_general_vec (N,func,limits,xlog,ylog,lnfunc,verbose,limited, &
                             accuracy,Nmax,Nsamp,xgrid,pgrid,Fgrid,proper)

    USE utilities, ONLY: DP
    USE arrays, ONLY: ramp, uniq_sorted
    USE interpolation, ONLY: interp_lin_sorted
    USE adaptative_grid, ONLY: gridadapt1D
    IMPLICIT NONE

    INTEGER, INTENT(IN) :: N
    INTERFACE
      FUNCTION func (x)
        USE utilities, ONLY: DP
        IMPLICIT NONE
        REAL(DP), DIMENSION(:), INTENT(IN) :: x
        REAL(DP), DIMENSION(SIZE(x)) :: func
      END FUNCTION func
    END INTERFACE
    REAL(DP), DIMENSION(2), INTENT(IN) :: limits
    LOGICAL, INTENT(IN), OPTIONAL :: xlog, ylog, lnfunc, verbose
    LOGICAL, DIMENSION(2), INTENT(IN), OPTIONAL :: limited
    REAL(DP), INTENT(IN), OPTIONAL :: accuracy
    INTEGER, INTENT(IN), OPTIONAL :: Nmax
    INTEGER, INTENT(OUT), OPTIONAL :: Nsamp
    REAL(DP), INTENT(OUT), DIMENSION(:), ALLOCATABLE, OPTIONAL :: xgrid, pgrid
    REAL(DP), INTENT(OUT), DIMENSION(:), ALLOCATABLE, OPTIONAL :: Fgrid
    LOGICAL, INTENT(OUT), DIMENSION(N), OPTIONAL :: proper
    REAL(DP), DIMENSION(N) :: rand_general_vec

    INTEGER, PARAMETER :: Ncoarse = 10
    REAL(DP), PARAMETER :: accmax0 = 1.E-3_DP

    INTEGER :: Nfine, Ncdf
    REAL(DP) :: acc, xinf0, xsup1, accmax
    REAL(DP), DIMENSION(Ncoarse) :: xcoarse
    REAL(DP), DIMENSION(N) :: rand
    REAL(DP), DIMENSION(2) :: lim
    REAL(DP), DIMENSION(:), ALLOCATABLE :: xfine, yfine, prim, xuniq, Funiq
    LOGICAL :: xl, yl, lnfn, verb
    LOGICAL, DIMENSION(2) :: adjxlim
    LOGICAL, DIMENSION(N) :: prop
    LOGICAL, DIMENSION(:), ALLOCATABLE :: keepinf, keepsup, keep

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

    ! Log axes
    xl = .False.
    IF (PRESENT(xlog)) xl = xlog
    yl = .False.
    IF (PRESENT(ylog)) yl = ylog

    ! User defined function
    lnfn = .False.
    IF (PRESENT(lnfunc)) lnfn = lnfunc

    ! Limited or not
    adjxlim(:) = .False.
    IF (PRESENT(limited)) adjxlim(:) = ( .NOT. limited(:) )

    ! Random drawing
    IF (PRESENT(accuracy)) THEN ; accmax = accuracy
                           ELSE ; accmax = accmax0 ; END IF
    CALL RANDOM_NUMBER(rand(:))
    acc = MIN( accmax*ABS(MINVAL(rand(:))), accmax*ABS(1._DP-MAXVAL(rand(:))) )

    ! Coarse grid
    xcoarse(:) = RAMP(Ncoarse,limits(1),limits(2),XLOG=xl)

    ! Adpatative grid
    IF (PRESENT(verbose)) THEN ; verb = verbose ; ELSE ; verb = .False. ; END IF
    CALL GRIDADAPT1D(xcoarse,xfine,yfine,func,acc,NMAX=Nmax,INTEG=.True., &
                     PRIMITIVE=prim,XLOG=xl,YLOG=yl,VERBOSE=verb,LNFUNC=lnfn, &
                     RESCALE=.True.,SLIM=.False.,ADJUSTXLIM=adjxlim(:))
    Nfine = SIZE(xfine(:))
    IF (PRESENT(Nsamp)) Nsamp = Nfine
    prim(:) = prim(:) / prim(Nfine)

    ! Ensure the most compact support: if there are several CDF=0, take the
    ! largest x, if there are several CDF=1 take the smaller x.
    ALLOCATE (keepinf(Nfine),keepsup(Nfine),keep(Nfine))
    keepinf(:) = UNIQ_SORTED(prim(:),LAST=.True.)
    keepsup(:) = UNIQ_SORTED(prim(:),FIRST=.True.)
    keep(:) = MERGE(keepinf(:),keepsup(:),prim(:) < 0.5_DP)

    ! Remove values outside of support
    xinf0 = MAXVAL(PACK(xfine(:),prim(:) == 0._DP))
    xsup1 = MINVAL(PACK(xfine(:),prim(:) == 1._DP))
    keep(:) = MERGE(keep(:),.False.,xfine(:) >= xinf0)
    keep(:) = MERGE(keep(:),.False.,xfine(:) <= xsup1)

    ! Pack the CDF
    Ncdf = COUNT(keep)
    ALLOCATE (Funiq(Ncdf),xuniq(Ncdf))
    Funiq(:) = PACK(prim(:),keep(:))
    xuniq(:) = PACK(xfine(:),keep(:))

    ! Interpolate the values (y->x)
    rand_general_vec(:) = INTERP_LIN_SORTED(xuniq(:),Funiq(:),rand(:),YLOG=xl)

    ! Make sure the value does not get out of the range
    lim(1) = MAX( xuniq(1), INTERP_LIN_SORTED(xuniq(:),Funiq(:),0._DP) )
    lim(2) = MIN( xuniq(Ncdf), INTERP_LIN_SORTED(xuniq(:),Funiq(:),1._DP) )
    prop(:) = .True.
    WHERE (rand_general_vec(:) < lim(1))
      rand_general_vec(:) = lim(1)
      prop(:) = .False.
    END WHERE
    WHERE (rand_general_vec(:) > lim(2))
      rand_general_vec(:) = lim(2)
      prop(:) = .False.
    END WHERE
    IF (PRESENT(proper)) proper(:) = prop(:)

    ! For debugging
    IF (PRESENT(xgrid)) THEN
      ALLOCATE (xgrid(Ncdf))
      xgrid(:) = xuniq(:)
    END IF
    IF (PRESENT(pgrid)) THEN
      ALLOCATE (pgrid(Ncdf))
      pgrid(:) = PACK(yfine(:),keep(:))
    END IF
    IF (PRESENT(Fgrid)) THEN
      ALLOCATE (Fgrid(Ncdf))
      Fgrid(:) = Funiq(:)
    END IF

    ! Clean memory space
    DEALLOCATE (xfine,yfine,prim,xuniq,Funiq,keepinf,keepsup,keep)

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

  END FUNCTION rand_general_vec

  ! Interface shell
  FUNCTION rand_general_scl (func,limits,xlog,ylog,lnfunc,verbose,limited, &
                             accuracy,Nmax,Nsamp,xgrid,pgrid,Fgrid,proper)
    USE utilities, ONLY: DP
    IMPLICIT NONE
    INTERFACE
      FUNCTION func (x)
        USE utilities, ONLY: DP
        IMPLICIT NONE
        REAL(DP), DIMENSION(:), INTENT(IN) :: x
        REAL(DP), DIMENSION(SIZE(x)) :: func
      END FUNCTION func
    END INTERFACE
    REAL(DP), DIMENSION(2), INTENT(IN) :: limits
    LOGICAL, INTENT(IN), OPTIONAL :: xlog, ylog, lnfunc, verbose
    LOGICAL, DIMENSION(2), INTENT(IN), OPTIONAL :: limited
    REAL(DP), INTENT(IN), OPTIONAL :: accuracy
    INTEGER, INTENT(IN), OPTIONAL :: Nmax
    INTEGER, INTENT(OUT), OPTIONAL :: Nsamp
    REAL(DP), DIMENSION(:), ALLOCATABLE, INTENT(OUT), OPTIONAL :: xgrid, pgrid
    REAL(DP), DIMENSION(:), ALLOCATABLE, INTENT(OUT), OPTIONAL :: Fgrid
    LOGICAL, INTENT(OUT), OPTIONAL :: proper
    REAL(DP) :: rand_general_scl
    LOGICAL, DIMENSION(1) :: prop
    rand_general_scl = MINVAL(RAND_GENERAL_VEC(1,func,limits,XLOG=xlog, &
                                               YLOG=ylog,VERBOSE=verbose, &
                                               LNFUNC=lnfunc,LIMITED=limited, &
                                               ACCURACY=accuracy,NMAX=Nmax, &
                                               NSAMP=Nsamp,XGRID=xgrid, &
                                               PGRID=pgrid,FGRID=Fgrid, &
                                               PROPER=prop))
    IF (PRESENT(proper)) proper = prop(1)
  END FUNCTION rand_general_scl

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

END MODULE random


program minval_maxval_mask

implicit none (type, external)

integer :: A(5) = [0, 5, 1, 2, 3]
integer :: L

logical :: mask(size(A))

if(maxval(A, dim=1) /= 5) error stop "maxval sanity"
if(minval(A, dim=1) /= 0) error stop "minval sanity"

if(maxval(A, dim=1, mask=[.true., .false., .true., .true., .true.]) /= 3) error stop "maxval mask sanity"
if(minval(A, dim=1, mask=[.false., .true., .true., .true., .true.]) /= 1) error stop "minval mask sanity"

mask = .false.
if (maxval(A, dim=1, mask=mask) /= -huge(0)-1) error stop "maxval mask = .false."
if (minval(A, dim=1, mask=mask) /= huge(0)) error stop "minval mask = .false."

print *, "OK: minval_maxval_mask"

end program

! if (maxval(A, dim=1, mask=mask) /= huge(0)) error stop "maxval mask = .false."


	!>@author
	!>Paul Connolly, The University of Manchester
	!>@brief
	!>code to find position in an array
	!>param[in] xarr: array of xs
	!>param[inout] x: value where position wanted
	!>@return find_pos: integer pointing to the position in the array
	function find_pos(xarr,x)
	    use numerics_type
        implicit none
        real(wp), dimension(:), intent(in) :: xarr
        real(wp), intent(in) :: x
        integer(i4b) :: find_pos
        integer(i4b) :: n,ilow,imid,iupp
        logical(lgt) :: ascnd
        n=size(xarr)
        ascnd = (xarr(n) >= xarr(1))
        ilow=0
        iupp=n+1
        do
            if (iupp-ilow <= 1) exit
            imid=(iupp+ilow)/2 ! just bisects array until it finds position
            if (ascnd .eqv. (x >= xarr(imid))) then
                ilow=imid
            else
                iupp=imid
            end if
        end do
        if (x == xarr(1)) then
            find_pos=1
        else if (x == xarr(n)) then
            find_pos=n-1
        else
            find_pos=ilow
        end if
	end function find_pos


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c
c ... file slapec.f
c
c     this file includes documentation and code for
c     subroutine slapec          i
c
c ... files which must be loaded with slapec.f
c
c     sphcom.f, hrfft.f, shaec.f, shsec.f
c
c
c
c     subroutine slapec(nlat,nlon,isym,nt,slap,ids,jds,a,b,mdab,ndab,
c    +                  wshsec,lshsec,work,lwork,ierror)
c
c
C*PL*ERROR* Comment line too long
c     given the scalar spherical harmonic coefficients a and b, precomputed
C*PL*ERROR* Comment line too long
c     by subroutine shaec for a scalar field sf, subroutine slapec computes
c     the laplacian of sf in the scalar array slap.  slap(i,j) is the
c     laplacian of sf at the colatitude
c
c         theta(i) = (i-1)*pi/(nlat-1)
c
c     and east longitude
c
c         lambda(j) = (j-1)*2*pi/nlon
c
c     on the sphere.  i.e.
c
c         slap(i,j) =
c
c                  2                2
C*PL*ERROR* Comment line too long
c         [1/sint*d (sf(i,j)/dlambda + d(sint*d(sf(i,j))/dtheta)/dtheta]/sint
c
c
c     where sint = sin(theta(i)).  the scalar laplacian in slap has the
C*PL*ERROR* Comment line too long
c     same symmetry or absence of symmetry about the equator as the scalar
c     field sf.  the input parameters isym,nt,mdab,ndab must have the
C*PL*ERROR* Comment line too long
c     same values used by shaec to compute a and b for sf. the associated
c     legendre functions are recomputed rather than stored as they are
c     in subroutine slapes.

c
c     input parameters
c
c     nlat   the number of colatitudes on the full sphere including the
c            poles. for example, nlat = 37 for a five degree grid.
c            nlat determines the grid increment in colatitude as
c            pi/(nlat-1).  if nlat is odd the equator is located at
c            grid point i=(nlat+1)/2. if nlat is even the equator is
c            located half way between points i=nlat/2 and i=nlat/2+1.
c            nlat must be at least 3. note: on the half sphere, the
c            number of grid points in the colatitudinal direction is
c            nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct longitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than zero. the axisymmetric case corresponds to nlon=1.
c            the efficiency of the computation is improved when nlon
c            is a product of small prime numbers.
c
C*PL*ERROR* Comment line too long
c     isym   this parameter should have the same value input to subroutine
C*PL*ERROR* Comment line too long
c            shaec to compute the coefficients a and b for the scalar field
c            sf.  isym is set as follows:
c
c            = 0  no symmetries exist in sf about the equator. scalar
C*PL*ERROR* Comment line too long
c                 synthesis is used to compute slap on the entire sphere.
c                 i.e., in the array slap(i,j) for i=1,...,nlat and
c                 j=1,...,nlon.
c
c           = 1  sf and slap are antisymmetric about the equator. the
c                synthesis used to compute slap is performed on the
c                northern hemisphere only.  if nlat is odd, slap(i,j) is
c                computed for i=1,...,(nlat+1)/2 and j=1,...,nlon.  if
c                nlat is even, slap(i,j) is computed for i=1,...,nlat/2
c                and j=1,...,nlon.
c
c
c           = 2  sf and slap are symmetric about the equator. the
c                synthesis used to compute slap is performed on the
c                northern hemisphere only.  if nlat is odd, slap(i,j) is
c                computed for i=1,...,(nlat+1)/2 and j=1,...,nlon.  if
c                nlat is even, slap(i,j) is computed for i=1,...,nlat/2
c                and j=1,...,nlon.
c
c
c     nt     the number of analyses.  in the program that calls slapec
c            the arrays slap,a, and b can be three dimensional in which
c            case multiple synthesis will be performed.  the third index
c            is the synthesis index which assumes the values k=1,...,nt.
c            for a single analysis set nt=1. the description of the
c            remaining parameters is simplified by assuming that nt=1
c            or that all the arrays are two dimensional.
c
c   ids      the first dimension of the array slap as it appears in the
c            program that calls slapec.  if isym = 0 then ids must be at
c            least nlat.  if isym > 0 and nlat is even then ids must be
c            at least nlat/2. if isym > 0 and nlat is odd then ids must
c            be at least (nlat+1)/2.
c
c   jds      the second dimension of the array slap as it appears in the
c            program that calls slapec. jds must be at least nlon.
c
c
c   a,b      two or three dimensional arrays (see input parameter nt)
c            that contain scalar spherical harmonic coefficients
c            of the scalar field sf as computed by subroutine shaec.
c     ***    a,b must be computed by shaec prior to calling slapec.
c
c
c    mdab    the first dimension of the arrays a and b as it appears
c            in the program that calls slapec.  mdab must be at
c            least min0(nlat,(nlon+2)/2) if nlon is even or at least
c            min0(nlat,(nlon+1)/2) if nlon is odd.
c
c    ndab    the second dimension of the arrays a and b as it appears
c            in the program that calls slapec. ndbc must be at least
c            least nlat.
c
c            mdab,ndab should have the same values input to shaec to
c            compute the coefficients a and b.
c
c
c    wshsec  an array which must be initialized by subroutine shseci
c            before calling slapec.  once initialized, wshsec
c            can be used repeatedly by slapec as long as nlat and nlon
c            remain unchanged.  wshsec must not be altered between calls
c            of slapec.
c
c    lshsec  the dimension of the array wshsec as it appears in the
c            program that calls slapec.  let
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lshsec must be greater than or equal to
c
c               2*nlat*l2+3*((l1-2)*(nlat+nlat-l1-1))/2+nlon+15
c
c
c     work   a work array that does not have to be saved.
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls slapec. define
c
c               l2 = nlat/2                    if nlat is even or
c               l2 = (nlat+1)/2                if nlat is odd
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            if isym = 0 let
c
c               lwkmin = nlat*(2*nt*nlon+max0(6*l2,nlon)+2*nt*l1+1.
c
c            if isym > 0 let
c
C*PL*ERROR* Comment line too long
c               lwkmin = l2*(2*nt*nlon+max0(6*nlat,nlon))+nlat*(2*nt*l1+1)
c
c
c     then lwork must be greater than or equal to lwkmin (see ierror=10)
c
c     **************************************************************
c
c     output parameters
c
c
C*PL*ERROR* Comment line too long
c    slap    a two or three dimensional arrays (see input parameter nt) that
C*PL*ERROR* Comment line too long
c            contain the scalar laplacian of the scalar field sf.  slap(i,j)
c            is the scalar laplacian at the colatitude
c
c                 theta(i) = (i-1)*pi/(nlat-1)
c
c            and longitude
c
c                 lambda(j) = (j-1)*2*pi/nlon
c
c            for i=1,...,nlat and j=1,...,nlon.
c
c
C*PL*ERROR* Comment line too long
c  ierror    a parameter which flags errors in input parameters as follows:
c
c            = 0  no errors detected
c
c            = 1  error in the specification of nlat
c
c            = 2  error in the specification of nlon
c
c            = 3  error in the specification of ityp
c
c            = 4  error in the specification of nt
c
c            = 5  error in the specification of ids
c
c            = 6  error in the specification of jds
c
c            = 7  error in the specification of mdbc
c
c            = 8  error in the specification of ndbc
c
c            = 9  error in the specification of lshsec
c
c            = 10 error in the specification of lwork
c
c
c **********************************************************************
c
c     end of documentation for slapec
c
c **********************************************************************
c
c
      SUBROUTINE DSLAPEC(NLAT,NLON,ISYM,NT,SLAP,IDS,JDS,A,B,MDAB,NDAB,
     +                  WSHSEC,LSHSEC,WORK,LWORK,IERROR)
      DOUBLE PRECISION SLAP
      DOUBLE PRECISION A
      DOUBLE PRECISION B
      DOUBLE PRECISION WSHSEC
      DOUBLE PRECISION WORK
      DIMENSION SLAP(IDS,JDS,NT),A(MDAB,NDAB,NT),B(MDAB,NDAB,NT)
      DIMENSION WSHSEC(LSHSEC),WORK(LWORK)
c
c     check input parameters
c
      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.4) RETURN
      IERROR = 3
      IF (ISYM.LT.0 .OR. ISYM.GT.2) RETURN
      IERROR = 4
      IF (NT.LT.0) RETURN
      IERROR = 5
      IMID = (NLAT+1)/2
      IF ((ISYM.EQ.0.AND.IDS.LT.NLAT) .OR.
     +    (ISYM.GT.0.AND.IDS.LT.IMID)) RETURN
      IERROR = 6
      IF (JDS.LT.NLON) RETURN
      IERROR = 7
      MMAX = MIN0(NLAT,NLON/2+1)
      IF (MDAB.LT.MMAX) RETURN
      IERROR = 8
      IF (NDAB.LT.NLAT) RETURN
      IERROR = 9
c
c     set and verify saved work space length
c
c
      L1 = MIN0(NLAT, (NLON+2)/2)
      L2 = (NLAT+1)/2
      LWMIN = 2*NLAT*L2 + 3* ((L1-2)* (NLAT+NLAT-L1-1))/2 + NLON + 15
      IF (LSHSEC.LT.LWMIN) RETURN
      IERROR = 10
c
c     set and verify unsaved work space length
c
      LS = NLAT
      IF (ISYM.GT.0) LS = IMID
      NLN = NT*LS*NLON
      MN = MMAX*NLAT*NT
c     lwmin = nln+ls*nlon+2*mn+nlat
c     if (lwork .lt. lwmin) return
      L2 = (NLAT+1)/2
      L1 = MIN0(NLAT,NLON/2+1)
      IF (ISYM.EQ.0) THEN
          LWKMIN = NLAT* (2*NT*NLON+MAX0(6*L2,NLON)+2*NT*L1+1)
      ELSE
          LWKMIN = L2* (2*NT*NLON+MAX0(6*NLAT,NLON)) + NLAT* (2*NT*L1+1)
      END IF
      IF (LWORK.LT.LWKMIN) RETURN

      IERROR = 0
c
c     set work space pointers
c
      IA = 1
      IB = IA + MN
      IFN = IB + MN
      IWK = IFN + NLAT
      LWK = LWORK - 2*MN - NLAT
      CALL DSLAPEC1(NLAT,NLON,ISYM,NT,SLAP,IDS,JDS,A,B,MDAB,NDAB,
     +             WORK(IA),WORK(IB),MMAX,WORK(IFN),WSHSEC,LSHSEC,
     +             WORK(IWK),LWK,IERROR)
      RETURN
      END

      SUBROUTINE DSLAPEC1(NLAT,NLON,ISYM,NT,SLAP,IDS,JDS,A,B,MDAB,NDAB,
     +                   ALAP,BLAP,MMAX,FNN,WSHSEC,LSHSEC,WK,LWK,IERROR)
      DOUBLE PRECISION SLAP
      DOUBLE PRECISION A
      DOUBLE PRECISION B
      DOUBLE PRECISION ALAP
      DOUBLE PRECISION BLAP
      DOUBLE PRECISION FNN
      DOUBLE PRECISION WSHSEC
      DOUBLE PRECISION WK
      DOUBLE PRECISION FN
      DIMENSION SLAP(IDS,JDS,NT),A(MDAB,NDAB,NT),B(MDAB,NDAB,NT)
      DIMENSION ALAP(MMAX,NLAT,NT),BLAP(MMAX,NLAT,NT),FNN(NLAT)
      DIMENSION WSHSEC(LSHSEC),WK(LWK)
c
c     set coefficient multiplyers
c
      DO 1 N = 2,NLAT
          FN = DBLE(N-1)
          FNN(N) = FN* (FN+1.D0)
    1 CONTINUE
c
c     compute scalar laplacian coefficients for each vector field
c
      DO 2 K = 1,NT
          DO 3 N = 1,NLAT
              DO 4 M = 1,MMAX
                  ALAP(M,N,K) = 0.0D0
                  BLAP(M,N,K) = 0.0D0
    4         CONTINUE
    3     CONTINUE
c
c     compute m=0 coefficients
c
          DO 5 N = 2,NLAT
              ALAP(1,N,K) = -FNN(N)*A(1,N,K)
              BLAP(1,N,K) = -FNN(N)*B(1,N,K)
    5     CONTINUE
c
c     compute m>0 coefficients
c
          DO 6 M = 2,MMAX
              DO 7 N = M,NLAT
                  ALAP(M,N,K) = -FNN(N)*A(M,N,K)
                  BLAP(M,N,K) = -FNN(N)*B(M,N,K)
    7         CONTINUE
    6     CONTINUE
    2 CONTINUE
c
c     synthesize alap,blap into slap
c
      CALL DSHSEC(NLAT,NLON,ISYM,NT,SLAP,IDS,JDS,ALAP,BLAP,MMAX,NLAT,
     +           WSHSEC,LSHSEC,WK,LWK,IERROR)
      RETURN
      END


subroutine GLQGridCoord(latglq, longlq, lmax, nlat, nlong)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	Given a maximum spherical harmonic degree lmax, this routine
!	will determine the latitude and longitude coordinates associated with
!	grids that are used in the Gauss-Legendre quadratue spherical harmonic
!	expansion routines. The coordinates are output in DEGREES.
!
!	Calling Parameters
!		IN
!			lmax		Maximum spherical harmonic degree of the expansion.
!		OUT
!			latglq		Array of latitude points used in Gauss-Legendre grids, in degrees.
!			longlq		Array of longitude points used in Gauss-Legendre grids, in degrees.
!			nlat, nlong	Number of latidude and longitude points.
!
!	Dependencies:		NGLQSH, PreGLQ
!
!	Written by Mark Wieczorek, 2004
!	Completely rewritten June 6, 2006.
!
!	Copyright (c) 2005-2006 Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	use SHTOOLS, only: NGLQSH, PreGLQ

	implicit none
	integer, intent(in) ::	lmax
	integer, intent(out) ::	nlat, nlong
	real*8, intent(out) ::	latglq(:), longlq(:)
	real*8 ::		pi, upper, lower, zero(lmax+1), w(lmax+1)
	integer ::		i

	if (size(latglq) < lmax+1) then
		print*, "Error --- GLQGridCoord"
		print*, "LATGLQ must be dimensioned as (LMAX+1) where LMAX is ", lmax
		print*, "Input array is dimensioned as ", size(latglq)
		stop
	elseif (size(longlq) < 2*lmax+1) then
		print*, "Error --- GLQGridCoord"
		print*, "LONGLQ must be dimensioned as (2*LMAX+1) where LMAX is ", lmax
		print*, "Input array is dimensioned as ", size(longlq)
		stop
	endif

	pi = acos(-1.0d0)

	nlat = NGLQSH(lmax)
	nlong = 2*lmax +1

	upper = 1.0d0
	lower = -1.0d0

	call PreGLQ(lower, upper, nlat, zero, w)	! Determine Gauss Points and Weights.

	do i=1, nlong
		longlq(i) = 360.0d0*(i-1)/nlong
	enddo

	do i=1, nlat
		latglq(i) = asin(zero(i))*180.0d0/pi
	enddo

end subroutine GLQGridCoord


	FUNCTION PR_ZALT  ( altm, pres )
C************************************************************************
C* PR_ZALT								*
C*									*
C* This function computes station elevation from altimeter and station	*
C* pressure. It is also used to estimate height at various pressure	*
C* levels from the altimeter in millibars.  The PC library computes	*
C* ZMSL, Z000, Z950, Z850, Z800 by calling this function with PRES	*
C* equal to PMSL, 1000, 950, 850 and 800 respectively.  The following	*
C* equation is used:							*
C*									*
C*    ZALT  =  [ To * ( 1 - ( ( PRES/ALTM ) ** expo ) ] / GAMMA		*
C*									*
C*          GAMMA  = GAMUSD / 1000					*
C*             To  =  US Std. Atmos. sea level temp in Kelvin		*
C*                 =  TMCK + 15						*
C*           expo  =  ( GAMMA * RDGAS ) / GRAVTY			*
C*									*
C* REAL PR_ZALT  ( ALTM, PRES )						*
C*									*
C* Input parameters:							*
C*	ALTM		REAL	 	Altimeter in millibars		*
C*	PRES		REAL	 	Pressure in millibars		*
C*									*
C* Output parameters:							*
C*	PR_ZALT		REAL	 	Height in meters		*
C**									*
C* Log:									*
C* I. Graffman/RDS	11/84	original source				*
C* I. Graffman/RDS	12/87	GEMPAK4					*
C* G. Huffman/GSC	 8/88	Documentation; check ALTM, PRES .le. 0	*
C* T. Lee/GSC		12/99	Used TMCK				*
C************************************************************************
        INCLUDE  	'GEMPRM.PRM'
        INCLUDE  	'ERMISS.FNC'
C------------------------------------------------------------------------
C*	Check for bad data.
C
	IF  ( ERMISS ( altm ) .or. ERMISS ( pres )
     +       .or. ( altm .le. 0. ) .or. ( pres .le. 0. ) )  THEN
	    PR_ZALT = RMISSD
	    RETURN
	END IF
C
C*	Set constants.
C
	to    = TMCK + 15.
	gamma = GAMUSD / 1000.
C
C*	Calculate the exponent and pressure ratio.
C
	expo =  ( gamma * RDGAS ) / GRAVTY
	prat = pres / altm
C
C*	Calculate.
C
	PR_ZALT = ( to * ( 1. - prat ** expo ) ) / gamma
C*
	RETURN
	END


	FUNCTION PR_RHDP  ( tmpc, relh )
C************************************************************************
C* PR_RHDP								*
C*									*
C* This function computes DWPC from TMPC and RELH.  The following	*
C* equation is used:							*
C*									*
C*           DWPC = 243.5 * LN (6.112) - 243.5 * LN (VAPR) /		*
C*                  ( LN (VAPR) - LN (6.112) - 17.67 )			*
C*									*
C*                VAPR = VAPS * RELH					*
C*                VAPS = saturation vapor pressure			*
C*                     = PR_VAPR ( TMPC )				*
C*									*
C* Note: If DWPC is less than -190 degrees C, it is treated as		*
C* missing data.							*
C*									*
C* REAL PR_RHDP  ( TMPC, RELH )						*
C*									*
C* Input parameters:							*
C*	TMPC		REAL		Temperature in Celsius		*
C*	RELH		REAL		Relative humidity in percent	*
C*									*
C* Output parameters:							*
C*	PR_RHDP		REAL		Dewpoint in Celsius		*
C**									*
C* Log:									*
C* I. Graffman/RDS	7/86						*
C* I. Graffman/RDS	12/87	GEMPAK4					*
C* M. desJardins/GSFC	3/88	Fixed log of 0 problem			*
C* G. Huffman/GSC	7/88	Documentation; refixed log of 0		*
C************************************************************************
        INCLUDE   'GEMPRM.PRM'
        INCLUDE   'ERMISS.FNC'
C------------------------------------------------------------------------
C*	Missing values.
C
	IF  ( ERMISS ( tmpc ) .or. ERMISS ( relh ) )  THEN
	    PR_RHDP = RMISSD
	  ELSE
C
C*	    Calculate saturation vapor pressure; test for existence.
C
	    vaps = PR_VAPR ( tmpc )
	    IF  ( ERMISS ( vaps ) )  THEN
		PR_RHDP = RMISSD
		RETURN
	    END IF
C
C*	    Calculate vapor pressure.
C
	    vapr = relh * vaps / 100.
C
C*	    Calculate dewpoint.  The VAPR test prevents LOG blowups.
C
	    IF  ( vapr .lt. 1.E-30 )  THEN
	        PR_RHDP = RMISSD
	      ELSE
	        PR_RHDP = 243.5 * ( LOG (6.112) - LOG (vapr) ) /
     *                 (LOG (vapr) - LOG (6.112) - 17.67)
	    END IF
	END IF
C*
	RETURN
	END


C$Procedure      VLCOM ( Vector linear combination, 3 dimensions )

      SUBROUTINE VLCOM ( A, V1, B, V2, SUM )

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

      DOUBLE PRECISION   A
      DOUBLE PRECISION   V1  ( 3 )
      DOUBLE PRECISION   B
      DOUBLE PRECISION   V2  ( 3 )
      DOUBLE PRECISION   SUM ( 3 )

C$ Brief_I/O
C
C      VARIABLE  I/O  DESCRIPTION
C      --------  ---  --------------------------------------------------
C      A          I   Coefficient of V1
C      V1         I   Vector in 3-space
C      B          I   Coefficient of V2
C      V2         I   Vector in 3-space
C      SUM        O   Linear Vector Combination A*V1 + B*V2
C
C$ Detailed_Input
C
C      A     This double precision variable multiplies V1.
C      V1    This is an arbitrary, double precision 3-dimensional
C            vector.
C      B     This double precision variable multiplies V2.
C      V2    This is an arbitrary, double precision 3-dimensional
C            vector.
C
C$ Detailed_Output
C
C      SUM   is an arbitrary, double precision 3-dimensional vector
C            which contains the linear combination A*V1 + B*V2.
C
C$ Parameters
C
C      None.
C
C$ Particulars
C
C      For each index from 1 to 3, this routine implements in FORTRAN
C      code the expression:
C
C      SUM(I) = A*V1(I) + B*V2(I)
C
C      No error checking is performed to guard against numeric overflow.
C
C$ Examples
C
C      To generate a sequence of points on an ellipse with major
C      and minor axis vectors MAJOR and MINOR, one could use the
C      following code fragment
C
C            STEP = TWOPI()/ N
C            ANG  = 0.0D0
C
C            DO I = 0,N
C
C               CALL VLCOM ( DCOS(ANG),MAJOR,  DSIN(ANG),MINOR,  POINT )
C
C               do something with the ellipse point just constructed
C
C               ANG = ANG + STEP
C
C            END DO
C
C      As a second example, suppose that U and V are orthonormal vectors
C      that form a basis of a plane. Moreover suppose that we wish to
C      project a vector X onto this plane, we could use the following
C      call inserts this projection into PROJ.
C
C            CALL VLCOM ( VDOT(X,V),V,   VDOT(X,U),U,    PROJ )
C
C
C$ Restrictions
C
C      No error checking is performed to guard against numeric overflow
C      or underflow.  The user is responsible for insuring that the
C      input values are reasonable.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C      None
C
C$ Author_and_Institution
C
C      W.L. Taber      (JPL)
C
C$ Literature_References
C
C      None
C
C$ Version
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WLT)
C
C-&

C$ Index_Entries
C
C     linear combination of two 3-dimensional vectors
C
C-&

C$ Revisions
C
C-     Beta Version 1.0.1, 1-Feb-1989 (WLT)
C
C      Example section of header upgraded.
C
C-&

      SUM(1) = A*V1(1) + B*V2(1)
      SUM(2) = A*V1(2) + B*V2(2)
      SUM(3) = A*V1(3) + B*V2(3)

      RETURN
      END


	SUBROUTINE AXISPTS(XMIN,XMAX,BOT,TOP,NTIC)
C
C								scale axis
	X = ALOG10(XMAX-XMIN)
	IF (X.GE.0.0) THEN				! span between tic-marks
	    DIV = 10.0**INT(X)
	ELSE
	    DIV = 10.0**INT(X-1.0)
	END IF
	IF (XMIN.GE.0.0) THEN				! lower limit of graph
	    BOT = DIV*INT(XMIN/DIV)
	ELSE
	    BOT = DIV*INT((XMIN/DIV)-1.0)
	END IF
	NTIC = 1+(XMAX-BOT)/DIV				! # of tic-marks
	TOP = BOT+NTIC*DIV				! upper limit of graph
C
	IF (NTIC.LE.3) THEN				! adjust # of tic-marks
	    NTIC = 5*NTIC
	    DIV = DIV/5.0
	END IF
	IF (NTIC.LE.7) THEN
	    NTIC = 2*NTIC
	    DIV = DIV/2.0
	END IF
	DO WHILE (XMIN .GE. BOT+0.999999*DIV)
	    BOT = BOT+DIV
	    NTIC = NTIC-1
	END DO
	DO WHILE (XMAX .LE. TOP-0.999999*DIV)
	    TOP = TOP-DIV
	    NTIC = NTIC-1
	END DO
	RETURN
	END


    MODULE random_negative_binomial_mod
! .. Implicit None Statement ..
      IMPLICIT NONE
! ..
    CONTAINS

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

      FUNCTION random_negative_binomial(n,p)
! .. Use Statements ..
        USE random_standard_gamma_mod
        USE random_poisson_mod
! ..
! .. Implicit None Statement ..
        IMPLICIT NONE
! ..
! .. Function Return Value ..
        INTEGER :: random_negative_binomial
! ..
! .. Scalar Arguments ..
        REAL, INTENT (IN) :: p
        INTEGER, INTENT (IN) :: n
! ..
! .. Local Scalars ..
        REAL :: a, r, y
! ..
! .. Intrinsic Functions ..
        INTRINSIC REAL
! ..
! .. Executable Statements ..

!**********************************************************************
!     INTEGER FUNCTION IGNNBN( N, P )
!                GENerate Negative BiNomial random deviate
!                              Function
!     Generates a single random deviate from a negative binomial
!     distribution.
!                              Arguments
!     N  --> Required number of events.
!                              INTEGER N
!     JJV                      (N > 0)
!     P  --> The probability of an event during a Bernoulli trial.
!                              REAL P
!     JJV                      (0.0 < P < 1.0)
!                              Method
!     Algorithm from page 480 of
!     Devroye, Luc
!     Non-Uniform Random Variate Generation.  Springer-Verlag,
!     New York, 1986.
!**********************************************************************
!     JJV changed to call SGAMMA directly
!     REAL random_gamma
!      EXTERNAL random_gamma,random_poisson
!     Check Arguments
!     JJV changed argumnet checker to abort if N <= 0
        IF (n<=0) STOP 'N <= 0 in IGNNBN'
        IF (p<=0.0) STOP 'P <= 0.0 in IGNNBN'
        IF (p>=1.0) STOP 'P >= 1.0 in IGNNBN'

!     Generate Y, a random gamma (n,(1-p)/p) variable
!     JJV Note: the above parametrization is consistent with Devroye,
!     JJV       but gamma (p/(1-p),n) is the equivalent in our code
        r = REAL(n)
        a = p/(1.0-p)
!      y = random_gamma(a,r)
        y = random_standard_gamma(r)/a

!     Generate a random Poisson(y) variable
        random_negative_binomial = random_poisson(y)
        RETURN

      END FUNCTION random_negative_binomial

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

    END MODULE random_negative_binomial_mod


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c     file alf.f contains subroutines alfk,lfim,lfim1,lfin,lfin1,lfpt
c     for computing normalized associated legendre polynomials
c
c subroutine alfk (n,m,cp)
c
c dimension of           real cp(n/2 + 1)
c arguments
c
c purpose                routine alfk computes single precision fourier
c                        coefficients in the trigonometric series
c                        representation of the normalized associated
c                        legendre function pbar(n,m,theta) for use by
c                        routines lfp and lfpt in calculating single
c                        precision pbar(n,m,theta).
c
c                        first define the normalized associated
c                        legendre functions
c
c                        pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m)
c                        /(2*factorial(n+m)))*sin(theta)**m/(2**n*
c                        factorial(n)) times the (n+m)th derivative of
c                        (x**2-1)**n with respect to x=cos(theta)
c
c                        where theta is colatitude.
c
c                        then subroutine alfk computes the coefficients
c                        cp(k) in the following trigonometric
c                        expansion of pbar(m,n,theta).
c
c                        1) for n even and m even, pbar(m,n,theta) =
c                           .5*cp(1) plus the sum from k=1 to k=n/2
c                           of cp(k+1)*cos(2*k*th)
c
c                        2) for n even and m odd, pbar(m,n,theta) =
c                           the sum from k=1 to k=n/2 of
c                           cp(k)*sin(2*k*th)
c
c                        3) for n odd and m even, pbar(m,n,theta) =
c                           the sum from k=1 to k=(n+1)/2 of
c                           cp(k)*cos((2*k-1)*th)
c
c                        4) for n odd and m odd,  pbar(m,n,theta) =
c                           the sum from k=1 to k=(n+1)/2 of
c                           cp(k)*sin((2*k-1)*th)
c
c
c usage                  call alfk(n,m,cp)
c
c arguments
c
c on input               n
c                          nonnegative integer specifying the degree of
c                          pbar(n,m,theta)
c
c                        m
c                          is the order of pbar(n,m,theta). m can be
c                          any integer however cp is computed such that
c                          pbar(n,m,theta) = 0 if abs(m) is greater
c                          than n and pbar(n,m,theta) = (-1)**m*
c                          pbar(n,-m,theta) for negative m.
c
c on output              cp
c                          single precision array of length (n/2)+1
c                          which contains the fourier coefficients in
c                          the trigonometric series representation of
c                          pbar(n,m,theta)
c
c
c special conditions     none
c
c precision              single
c
c algorithm              the highest order coefficient is determined in
c                        closed form and the remainig coefficients are
c                        determined as the solution of a backward
c                        recurrence relation.
c
c accuracy               comparison between routines alfk and double
c                        precision dalfk on the cray1 indicates
c                        greater accuracy for smaller values
c                        of input parameter n.  agreement to 14
c                        places was obtained for n=10 and to 13
c                        places for n=100.
c
      subroutine alfk (n,m,cp)
      dimension       cp(n/2+1)
      parameter (sc10=1024.)
      parameter (sc20=sc10*sc10)
      parameter (sc40=sc20*sc20)
c
      cp(1) = 0.
      ma = iabs(m)
      if(ma .gt. n) return
      if(n-1) 2,3,5
    2 cp(1) = sqrt(2.)
      return
    3 if(ma .ne. 0) go to 4
      cp(1) = sqrt(1.5)
      return
    4 cp(1) = sqrt(.75)
      if(m .eq. -1) cp(1) = -cp(1)
      return
    5 if(mod(n+ma,2) .ne. 0) go to 10
      nmms2 = (n-ma)/2
      fnum = n+ma+1
      fnmh = n-ma+1
      pm1 = 1.
      go to 15
   10 nmms2 = (n-ma-1)/2
      fnum = n+ma+2
      fnmh = n-ma+2
      pm1 = -1.
 15   t1 = 1./sc20
      nex = 20
      fden = 2.
      if(nmms2 .lt. 1) go to 20
      do 18 i=1,nmms2
      t1 = fnum*t1/fden
      if(t1 .gt. sc20) then
      t1 = t1/sc40
      nex = nex+40
      end if
      fnum = fnum+2.
      fden = fden+2.
   18 continue
   20 t1 = t1/2.**(n-1-nex)
      if(mod(ma/2,2) .ne. 0) t1 = -t1
      t2 = 1.
      if(ma .eq. 0) go to 26
      do 25 i=1,ma
      t2 = fnmh*t2/(fnmh+pm1)
      fnmh = fnmh+2.
   25 continue
   26 cp2 = t1*sqrt((n+.5)*t2)
      fnnp1 = n*(n+1)
      fnmsq = fnnp1-2.*ma*ma
      l = (n+1)/2
      if(mod(n,2) .eq. 0 .and. mod(ma,2) .eq. 0) l = l+1
      cp(l) = cp2
      if(m .ge. 0) go to 29
      if(mod(ma,2) .ne. 0) cp(l) = -cp(l)
   29 if(l .le. 1) return
      fk = n
      a1 = (fk-2.)*(fk-1.)-fnnp1
      b1 = 2.*(fk*fk-fnmsq)
      cp(l-1) = b1*cp(l)/a1
   30 l = l-1
      if(l .le. 1) return
      fk = fk-2.
      a1 = (fk-2.)*(fk-1.)-fnnp1
      b1 = -2.*(fk*fk-fnmsq)
      c1 = (fk+1.)*(fk+2.)-fnnp1
      cp(l-1) = -(b1*cp(l)+c1*cp(l+1))/a1
      go to 30
      end
c subroutine lfim (init,theta,l,n,nm,pb,id,wlfim)
c
c dimension of           theta(l),  pb(id,nm+1),  wlfim(4*l*(nm+1))
c arguments
c
c purpose                given n and l, routine lfim calculates
c                        the normalized associated legendre functions
c                        pbar(n,m,theta) for m=0,...,n and theta(i)
c                        for i=1,...,l where
c
c                        pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m)
c                        /(2*factorial(n+m)))*sin(theta)**m/(2**n*
c                        factorial(n)) times the (n+m)th derivative of
c                        (x**2-1)**n with respect to x=cos(theta)
c
c usage                  call lfim (init,theta,l,n,nm,pb,id,wlfim)
c
c arguments
c on input               init
c                        = 0
c                            initialization only - using parameters
c                            l, nm and array theta, subroutine lfim
c                            initializes array wlfim for subsequent
c                            use in the computation of the associated
c                            legendre functions pb. initialization
c                            does not have to be repeated unless
c                            l, nm, or array theta are changed.
c                        = 1
c                            subroutine lfim uses the array wlfim that
c                            was computed with init = 0 to compute pb.
c
c                        theta
c                          an array that contains the colatitudes
c                          at which the associated legendre functions
c                          will be computed. the colatitudes must be
c                          specified in radians.
c
c                        l
c                          the length of the theta array. lfim is
c                          vectorized with vector length l.
c
c                        n
c                          nonnegative integer, less than nm, specifying
c                          degree of pbar(n,m,theta). subroutine lfim
c                          must be called starting with n=0. n must be
c                          incremented by one in subsequent calls and
c                          must not exceed nm.
c
c                        nm
c                          the maximum value of n and m
c
c                        id
c                          the first dimension of the two dimensional
c                          array pb as it appears in the program that
c                          calls lfim. (see output parameter pb)
c
c                        wlfim
c                          an array with length 4*l*(nm+1) which
c                          must be initialized by calling lfim
c                          with init=0 (see parameter init)  it
c                          must not be altered between calls to
c                          lfim.
c
c
c on output              pb
c                          a two dimensional array with first
c                          dimension id in the program that calls
c                          lfim. the second dimension of pb must
c                          be at least nm+1. starting with n=0
c                          lfim is called repeatedly with n being
c                          increased by one between calls. on each
c                          call, subroutine lfim computes
c                          = pbar(m,n,theta(i)) for m=0,...,n and
c                          i=1,...l.
c
c                        wlfim
c                          array containing values which must not
c                          be altered unless l, nm or the array theta
c                          are changed in which case lfim must be
c                          called with init=0 to reinitialize the
c                          wlfim array.
c
c special conditions     n must be increased by one between calls
c                        of lfim in which n is not zero.
c
c precision              single
c
c
c algorithm              routine lfim calculates pbar(n,m,theta) using
c                        a four term recurrence relation. (unpublished
c                        notes by paul n. swarztrauber)
c
      subroutine lfim (init,theta,l,n,nm,pb,id,wlfim)
      dimension       pb(1)        ,wlfim(1)
c
c     total length of wlfim is 4*l*(nm+1)
c
      lnx = l*(nm+1)
      iw1 = lnx+1
      iw2 = iw1+lnx
      iw3 = iw2+lnx
      call lfim1(init,theta,l,n,nm,id,pb,wlfim,wlfim(iw1),
     1                wlfim(iw2),wlfim(iw3),wlfim(iw2))
      return
      end
      subroutine lfim1(init,theta,l,n,nm,id,p3,phz,ph1,p1,p2,cp)
      dimension       p1(l,1)    ,p2(l,1)    ,p3(id,1)   ,phz(l,1)   ,
     1                ph1(l,1)   ,cp(1)      ,theta(1)
      nmp1 = nm+1
      if(init .ne. 0) go to 5
      ssqrt2 = 1./sqrt(2.)
      do 10 i=1,l
      phz(i,1) = ssqrt2
   10 continue
      do 15 np1=2,nmp1
      nh = np1-1
      call alfk(nh,0,cp)
      do 16 i=1,l
      call lfpt(nh,0,theta(i),cp,phz(i,np1))
   16 continue
      call alfk(nh,1,cp)
      do 17 i=1,l
      call lfpt(nh,1,theta(i),cp,ph1(i,np1))
   17 continue
   15 continue
      return
    5 if(n .gt. 2) go to 60
      if(n-1)25,30,35
   25 do 45 i=1,l
      p3(i,1)=phz(i,1)
   45 continue
      return
   30 do 50 i=1,l
      p3(i,1) = phz(i,2)
      p3(i,2) = ph1(i,2)
   50 continue
      return
   35 sq5s6 = sqrt(5./6.)
      sq1s6 = sqrt(1./6.)
      do 55 i=1,l
      p3(i,1) = phz(i,3)
      p3(i,2) = ph1(i,3)
      p3(i,3) = sq5s6*phz(i,1)-sq1s6*p3(i,1)
      p1(i,1) = phz(i,2)
      p1(i,2) = ph1(i,2)
      p2(i,1) = phz(i,3)
      p2(i,2) = ph1(i,3)
      p2(i,3) = p3(i,3)
   55 continue
      return
   60 nm1 = n-1
      np1 = n+1
      fn = float(n)
      tn = fn+fn
      cn = (tn+1.)/(tn-3.)
      do 65 i=1,l
      p3(i,1) = phz(i,np1)
      p3(i,2) = ph1(i,np1)
   65 continue
      if(nm1 .lt. 3) go to 71
      do 70 mp1=3,nm1
      m = mp1-1
      fm = float(m)
      fnpm = fn+fm
      fnmm = fn-fm
      temp = fnpm*(fnpm-1.)
      cc = sqrt(cn*(fnpm-3.)*(fnpm-2.)/temp)
      dd = sqrt(cn*fnmm*(fnmm-1.)/temp)
      ee = sqrt((fnmm+1.)*(fnmm+2.)/temp)
      do 70 i=1,l
      p3(i,mp1) = cc*p1(i,mp1-2)+dd*p1(i,mp1)-ee*p3(i,mp1-2)
   70 continue
   71 fnpm = fn+fn-1.
      temp = fnpm*(fnpm-1.)
      cc = sqrt(cn*(fnpm-3.)*(fnpm-2.)/temp)
      ee = sqrt(6./temp)
      do 75 i=1,l
      p3(i,n) = cc*p1(i,n-2)-ee*p3(i,n-2)
   75 continue
      fnpm = fn+fn
      temp = fnpm*(fnpm-1.)
      cc = sqrt(cn*(fnpm-3.)*(fnpm-2.)/temp)
      ee = sqrt(2./temp)
      do 80 i=1,l
      p3(i,n+1) = cc*p1(i,n-1)-ee*p3(i,n-1)
   80 continue
      do 90 mp1=1,np1
      do 90 i=1,l
      p1(i,mp1) = p2(i,mp1)
      p2(i,mp1) = p3(i,mp1)
   90 continue
      return
      end
c subroutine lfin (init,theta,l,m,nm,pb,id,wlfin)
c
c dimension of           theta(l),  pb(id,nm+1),  wlfin(4*l*(nm+1))
c arguments
c
c purpose                given m and l, routine lfin calculates
c                        the normalized associated legendre functions
c                        pbar(n,m,theta) for n=m,...,nm and theta(i)
c                        for i=1,...,l where
c
c                        pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m)
c                        /(2*factorial(n+m)))*sin(theta)**m/(2**n*
c                        factorial(n)) times the (n+m)th derivative of
c                        (x**2-1)**n with respect to x=cos(theta)
c
c usage                  call lfin (init,theta,l,m,nm,pb,id,wlfin)
c
c arguments
c on input               init
c                        = 0
c                            initialization only - using parameters
c                            l, nm and the array theta, subroutine lfin
c                            initializes the array wlfin for subsequent
c                            use in the computation of the associated
c                            legendre functions pb. initialization does
c                            not have to be repeated unless l, nm or
c                            the array theta are changed.
c                        = 1
c                            subroutine lfin uses the array wlfin that
c                            was computed with init = 0 to compute pb
c
c                        theta
c                          an array that contains the colatitudes
c                          at which the associated legendre functions
c                          will be computed. the colatitudes must be
c                          specified in radians.
c
c                        l
c                          the length of the theta array. lfin is
c                          vectorized with vector length l.
c
c                        m
c                          nonnegative integer, less than nm, specifying
c                          degree of pbar(n,m,theta). subroutine lfin
c                          must be called starting with n=0. n must be
c                          incremented by one in subsequent calls and
c                          must not exceed nm.
c
c                        nm
c                          the maximum value of n and m
c
c                        id
c                          the first dimension of the two dimensional
c                          array pb as it appears in the program that
c                          calls lfin. (see output parameter pb)
c
c                        wlfin
c                          an array with length 4*l*(nm+1) which
c                          must be initialized by calling lfin
c                          with init=0 (see parameter init)  it
c                          must not be altered between calls to
c                          lfin.
c
c
c on output              pb
c                          a two dimensional array with first
c                          dimension id in the program that calls
c                          lfin. the second dimension of pb must
c                          be at least nm+1. starting with m=0
c                          lfin is called repeatedly with m being
c                          increased by one between calls. on each
c                          call, subroutine lfin computes pb(i,n+1)
c                          = pbar(m,n,theta(i)) for n=m,...,nm and
c                          i=1,...l.
c
c                        wlfin
c                          array containing values which must not
c                          be altered unless l, nm or the array theta
c                          are changed in which case lfin must be
c                          called with init=0 to reinitialize the
c                          wlfin array.
c
c special conditions     m must be increased by one between calls
c                        of lfin in which m is not zero.
c
c precision              single
c
c algorithm              routine lfin calculates pbar(n,m,theta) using
c                        a four term recurrence relation. (unpublished
c                        notes by paul n. swarztrauber)
c
      subroutine lfin (init,theta,l,m,nm,pb,id,wlfin)
      dimension       pb(1)        ,wlfin(1)
c
c     total length of wlfin is 4*l*(nm+1)
c
      lnx = l*(nm+1)
      iw1 = lnx+1
      iw2 = iw1+lnx
      iw3 = iw2+lnx
      call lfin1(init,theta,l,m,nm,id,pb,wlfin,wlfin(iw1),
     1                wlfin(iw2),wlfin(iw3),wlfin(iw2))
      return
      end
      subroutine lfin1(init,theta,l,m,nm,id,p3,phz,ph1,p1,p2,cp)
      dimension       p1(l,1)    ,p2(l,1)    ,p3(id,1)   ,phz(l,1)   ,
     1                ph1(l,1)   ,cp(1)      ,theta(1)
      nmp1 = nm+1
      if(init .ne. 0) go to 5
      ssqrt2 = 1./sqrt(2.)
      do 10 i=1,l
      phz(i,1) = ssqrt2
   10 continue
      do 15 np1=2,nmp1
      nh = np1-1
      call alfk(nh,0,cp)
      do 16 i=1,l
      call lfpt(nh,0,theta(i),cp,phz(i,np1))
   16 continue
      call alfk(nh,1,cp)
      do 17 i=1,l
      call lfpt(nh,1,theta(i),cp,ph1(i,np1))
   17 continue
   15 continue
      return
    5 mp1 = m+1
      fm = float(m)
      tm = fm+fm
      if(m-1)25,30,35
   25 do 45 np1=1,nmp1
      do 45 i=1,l
      p3(i,np1) = phz(i,np1)
      p1(i,np1) = phz(i,np1)
   45 continue
      return
   30 do 50 np1=2,nmp1
      do 50 i=1,l
      p3(i,np1) = ph1(i,np1)
      p2(i,np1) = ph1(i,np1)
   50 continue
      return
   35 temp = tm*(tm-1.)
      cc = sqrt((tm+1.)*(tm-2.)/temp)
      ee = sqrt(2./temp)
      do 85 i=1,l
      p3(i,m+1) = cc*p1(i,m-1)-ee*p1(i,m+1)
   85 continue
      if(m .eq. nm) return
      temp = tm*(tm+1.)
      cc = sqrt((tm+3.)*(tm-2.)/temp)
      ee = sqrt(6./temp)
      do 70 i=1,l
      p3(i,m+2) = cc*p1(i,m)-ee*p1(i,m+2)
   70 continue
      mp3 = m+3
      if(nmp1 .lt. mp3) go to 80
      do 75 np1=mp3,nmp1
      n = np1-1
      fn = float(n)
      tn = fn+fn
      cn = (tn+1.)/(tn-3.)
      fnpm = fn+fm
      fnmm = fn-fm
      temp = fnpm*(fnpm-1.)
      cc = sqrt(cn*(fnpm-3.)*(fnpm-2.)/temp)
      dd = sqrt(cn*fnmm*(fnmm-1.)/temp)
      ee = sqrt((fnmm+1.)*(fnmm+2.)/temp)
      do 75 i=1,l
      p3(i,np1) = cc*p1(i,np1-2)+dd*p3(i,np1-2)-ee*p1(i,np1)
   75 continue
   80 do 90 np1=m,nmp1
      do 90 i=1,l
      p1(i,np1) = p2(i,np1)
      p2(i,np1) = p3(i,np1)
   90 continue
      return
      end
c subroutine lfpt (n,m,theta,cp,pb)
c
c dimension of
c arguments
c                        cp((n/2)+1)
c
c purpose                routine lfpt uses coefficients computed by
c                        routine alfk to compute the single precision
c                        normalized associated legendre function pbar(n,
c                        m,theta) at colatitude theta.
c
c usage                  call lfpt(n,m,theta,cp,pb)
c
c arguments
c
c on input               n
c                          nonnegative integer specifying the degree of
c                          pbar(n,m,theta)
c                        m
c                          is the order of pbar(n,m,theta). m can be
c                          any integer however pbar(n,m,theta) = 0
c                          if abs(m) is greater than n and
c                          pbar(n,m,theta) = (-1)**m*pbar(n,-m,theta)
c                          for negative m.
c
c                        theta
c                          single precision colatitude in radians
c
c                        cp
c                          single precision array of length (n/2)+1
c                          containing coefficients computed by routine
c                          alfk
c
c on output              pb
c                          single precision variable containing
c                          pbar(n,m,theta)
c
c special conditions     calls to routine lfpt must be preceded by an
c                        appropriate call to routine alfk.
c
c precision              single
c
c algorithm              the trigonometric series formula used by
c                        routine lfpt to calculate pbar(n,m,th) at
c                        colatitude th depends on m and n as follows:
c
c                           1) for n even and m even, the formula is
c                              .5*cp(1) plus the sum from k=1 to k=n/2
c                              of cp(k)*cos(2*k*th)
c                           2) for n even and m odd. the formula is
c                              the sum from k=1 to k=n/2 of
c                              cp(k)*sin(2*k*th)
c                           3) for n odd and m even, the formula is
c                              the sum from k=1 to k=(n+1)/2 of
c                              cp(k)*cos((2*k-1)*th)
c                           4) for n odd and m odd, the formula is
c                              the sum from k=1 to k=(n+1)/2 of
c                              cp(k)*sin((2*k-1)*th)
c
c accuracy               comparison between routines lfpt and double
c                        precision dlfpt on the cray1 indicates greater
c                        accuracy for greater values on input parameter
c                        n.  agreement to 13 places was obtained for
c                        n=10 and to 12 places for n=100.
c
c timing                 time per call to routine lfpt is dependent on
c                        the input parameter n.
c
      subroutine lfpt (n,m,theta,cp,pb)
      dimension       cp(1)
c
      pb = 0.
      ma = iabs(m)
      if(ma .gt. n) return
      if (n)  10, 10, 30
   10 if (ma)  20, 20, 30
   20 pb= sqrt(.5)
      go to 140
   30 np1 = n+1
      nmod = mod(n,2)
      mmod = mod(ma,2)
      if (nmod)  40, 40, 90
   40 if (mmod)  50, 50, 70
   50 kdo = n/2+1
      cdt = cos(theta+theta)
      sdt = sin(theta+theta)
      ct = 1.
      st = 0.
      sum = .5*cp(1)
      do  60 kp1=2,kdo
         cth = cdt*ct-sdt*st
         st = sdt*ct+cdt*st
         ct = cth
         sum = sum+cp(kp1)*ct
   60 continue
      pb= sum
      go to 140
   70 kdo = n/2
      cdt = cos(theta+theta)
      sdt = sin(theta+theta)
      ct = 1.
      st = 0.
      sum = 0.
      do  80 k=1,kdo
         cth = cdt*ct-sdt*st
         st = sdt*ct+cdt*st
         ct = cth
         sum = sum+cp(k)*st
   80 continue
      pb= sum
      go to 140
   90 kdo = (n+1)/2
      if (mmod) 100,100,120
  100 cdt = cos(theta+theta)
      sdt = sin(theta+theta)
      ct = cos(theta)
      st = -sin(theta)
      sum = 0.
      do 110 k=1,kdo
         cth = cdt*ct-sdt*st
         st = sdt*ct+cdt*st
         ct = cth
         sum = sum+cp(k)*ct
  110 continue
      pb= sum
      go to 140
  120 cdt = cos(theta+theta)
      sdt = sin(theta+theta)
      ct = cos(theta)
      st = -sin(theta)
      sum = 0.
      do 130 k=1,kdo
         cth = cdt*ct-sdt*st
         st = sdt*ct+cdt*st
         ct = cth
         sum = sum+cp(k)*st
  130 continue
      pb= sum
  140 return
      end


	FUNCTION PR_DWPT  ( rmix, pres )
C************************************************************************
C* PR_DWPT								*
C* 									*
C* This function computes DWPT from MIXR and PRES.  The following	*
C* equation is used:							*
C*									*
C*   DWPT = ALOG (E / 6.112) * 243.5 / ( 17.67 - ALOG (E / 6.112) )	*
C*									*
C*        E = vapor pressure						*
C*          = e / ( 1.001 + ( (PRES - 100.) / 900. ) * .0034 ) 		*
C*        e = ( PRES * MIXR ) / ( .62197 + MIXR ) 			*
C*									*
C* Bolton.								*
C*									*
C* This function also computes TMPC from MIXS and PRES.			*
C*									*
C* REAL PR_DWPT  ( RMIX, PRES )						*
C*									*
C* Input parameters:							*
C*	RMIX		REAL		Mixing ratio in g/kg		*
C*	PRES   		REAL    	Pressure in millibars		*
C*									*
C* Output parameters:							*
C*	PR_DWPT		REAL		Dewpoint in Celsius		*
C**									*
C* Log:									*
C* P. Kocin/914		1980	Original source code			*
C* M. Goodman/RDS  	8/84	Cleaned code				*
C* G.Huffman/GSC	7/88	Constant .62197, p .le. 0		*
C* J. Nielsen/SUNYA	8/90	Assume mixing ratio is in g/kg		*
C* T. Piper/GSC		11/98	Updated prolog				*
C************************************************************************
        INCLUDE   'GEMPRM.PRM'
        INCLUDE   'ERMISS.FNC'
C------------------------------------------------------------------------
	IF  ( ERMISS ( rmix ) .or. ( rmix .le. 0. ) .or.
     +	      ERMISS ( pres ) .or. ( pres .le. 0. ) )  THEN
	    PR_DWPT = RMISSD
	  ELSE
C
C*	    Convert G/KG to G/G.
C
	    ratio = rmix / 1000.
C
C*	    Calculate vapor pressure from mixing ratio and pressure.
C
	    e = (pres * ratio) / (.62197 + ratio)
C
C*	    Correct vapor pressure.
C
	    e = e / (1.001 + ((pres - 100.) / 900.) * .0034)
C
C*	    Calculate dewpoint.
C
	    PR_DWPT = ALOG (e/6.112) * 243.5 / (17.67 - ALOG(e/6.112))
	END IF
C*
	RETURN
	END


subroutine computef(neq, t, y, f)
  implicit none
  integer :: neq
  double precision :: f(neq), d
  double precision, intent(in) :: t, y(neq)
  ! This subroutine computes the RHS of the differential equation:
  !  dy
  !  -- = f(t, y)
  !  dt
  ! where y is the array of unknowns, indexed from one to neq and f is the array of right sides.

  !y(0) = 0
  f(1) = (t * dexp(3.0d0 * t) - 2.0d0 * y(1))

  return
end


SUBROUTINE WEIGHT(PTS, PT, WTS)
  USE ISO_FORTRAN_ENV, ONLY: REAL64
  ! Inputs and outputs
  REAL(KIND=REAL64), INTENT(IN), DIMENSION(:,:) :: PTS
  REAL(KIND=REAL64), INTENT(IN), DIMENSION(SIZE(PTS,1)) :: PT
  REAL(KIND=REAL64), INTENT(OUT), DIMENSION(SIZE(PTS,2)) :: WTS
  ! Local variables
  REAL(KIND=REAL64), DIMENSION(SIZE(WTS)) :: DISTS
  REAL(KIND=REAL64) :: MAX_DIST, MIN_DIST, EPS
  INTEGER :: I
  !$omp parallel do
  DO I = 1, SIZE(PTS, 2)
     DISTS(I) = NORM2(PTS(:,I) - PT(:))
  END DO
  ! Compute the epsilon (for checking "zero" values).
  EPS = SQRT(EPSILON(WTS(1)))
  ! Compute the maximum and minimum distance to points.
  MIN_DIST = MINVAL(DISTS)
  MAX_DIST = MAXVAL(DISTS)
  ! Make sure that the maximum distance is positive.
  IF (MAX_DIST .LT. EPS) THEN
     ! Set all weights to be equal.
     WTS(:) = 1._REAL64
  ELSE IF (MIN_DIST .LT. EPS) THEN
     ! Share the weights equally across those close values.
     WTS(:) = 0._REAL64
     WHERE (DISTS .LT. EPS) WTS = 1._REAL64
  ELSE
     ! Compute the weights based on inverse distances.
     WTS(:) = 1._REAL64 / DISTS(:)**2
  END IF
  ! Convexify the weights.
  WTS = WTS / SUM(WTS)
END SUBROUTINE WEIGHT


recursive subroutine factorial(i,f)
  implicit none
  integer f,i,j
  intent(in) i
  intent(out) f
  if (i.le.0) then
    stop 'argument must be > 0'
  else if (i.eq.1) then
    f=i
  else
    call factorial(i-1,j)
    f=i*j
  end if
end subroutine factorial