! Compute pi using OpenMP
! First, the pseudorandom number generator
        real function lcgrandom()
          integer*8, parameter :: MULTIPLIER = 1366
          integer*8, parameter :: ADDEND = 150889
          integer*8, parameter :: PMOD = 714025
          integer*8, save :: random_last = 0

          integer*8 :: random_next = 0
          random_next = mod((MULTIPLIER * random_last + ADDEND), PMOD)
          random_last = random_next
          lcgrandom = (1.0*random_next)/PMOD
          return
        end

! Now, we compute pi
        program darts
          implicit none
          integer*8 :: num_trials = 1000000, i = 0, Ncirc = 0
          real :: pi = 0.0, x = 0.0, y = 0.0, r = 1.0
          real :: r2 = 0.0
          real :: lcgrandom
          r2 = r*r

!$OMP parallel private(x,y) reduction(+:Ncirc)
!$OMP do
          do i = 1, num_trials
!$OMP critical (randoms)
            x = lcgrandom()
            y = lcgrandom()
!$OMP end critical (randoms)
            if ((x*x + y*y) .le. r2) then
              Ncirc = Ncirc+1
            end if
          end do
!$OMP end parallel

          pi = 4.0*((1.0*Ncirc)/(1.0*num_trials))
          print*, '     '
          print*, '     Computing pi using OpenMP:         '
          print*, '     For ', num_trials, ' trials, pi = ', pi
          print*, '     '

        end


C
C	$Id: css2c.f,v 1.4 2008-07-27 03:10:07 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE CSS2C (N,RLAT,RLON, X,Y,Z)
      INTEGER N
      REAL RLAT(N), RLON(N), X(N), Y(N), Z(N)
C
C   This subroutine transforms spherical coordinates into
C Cartesian coordinates on the unit sphere.
C
C On input:
C
C       N = Number of nodes (points on the unit sphere)
C           whose coordinates are to be transformed.
C
C       RLAT = Array of length N containing latitudinal
C              coordinates of the nodes in degrees.
C
C       RLON = Array of length N containing longitudinal
C              coordinates of the nodes in degrees.
C
C The above parameters are not altered by this routine.
C
C       X,Y,Z = Arrays of length at least N.
C
C On output:
C
C       X,Y,Z = Cartesian coordinates in the range -1 to 1.
C               X(I)**2 + Y(I)**2 + Z(I)**2 = 1 for I = 1
C               to N.
C
C Modules required by CSS2C:  None
C
C Intrinsic functions called by CSS2C:  SIN, COS
C
C***********************************************************
C
      PARAMETER (D2R=0.017453293, R2D=57.295778)
      INTEGER I, NN
      REAL COSPHI, PHI, THETA
C
C Local parameters:
C
C COSPHI = cos(PHI)
C I =      DO-loop index
C NN =     Local copy of N
C PHI =    Latitude
C THETA =  Longitude
C
      NN = N
      DO 1 I = 1,NN
        RLATD = D2R*RLAT(I)
        RLOND = D2R*RLON(I)
        PHI = RLATD
        THETA = RLOND
        COSPHI = COS(PHI)
        X(I) = COSPHI*COS(THETA)
        Y(I) = COSPHI*SIN(THETA)
        Z(I) = SIN(PHI)
    1   CONTINUE
      RETURN
      END


! test_bobyqa.f90 --
!
!     Test problem for BOBYQA, the objective function being the sum of
!     the reciprocals of all pairwise distances between the points P_I,
!     I=1,2,...,M in two dimensions, where M=N/2 and where the components
!     of P_I are X(2*I-1) and X(2*I). Thus each vector X of N variables
!     defines the M points P_I. The initial X gives equally spaced points
!     on a circle. Four different choices of the pairs (N,NPT) are tried,
!     namely (10,16), (10,21), (20,26) and (20,41). Convergence to a local
!     minimum that is not global occurs in both the N=10 cases. The details
!     of the results are highly sensitive to computer rounding errors. The
!     choice IPRINT=2 provides the current X and optimal F so far whenever
!     RHO is reduced. The bound constraints of the problem require every
!     component of X to be in the interval [-1,1].
!
module bobyqa_functions
    use bobyqa_minimisation, only: wp
    implicit none

contains
subroutine calfun (x,f)
    real(kind=wp), dimension(:) :: x
    real(kind=wp)               :: f

    integer                     :: i, j, n
    real(kind=wp)               :: temp

    n = size(x)
    f = 0.0d0
    do i = 4,n,2
        do j=2,i-2,2
            temp = (x(i-1)-x(j-1))**2+(x(i)-x(j))**2
            temp = max( temp, 1.0d-6 )
            f    = f + 1.0d0 / sqrt(temp)
        enddo
    enddo
end subroutine calfun
end module bobyqa_functions

program test_bobyqa
    use bobyqa_minimisation
    use bobyqa_functions

    implicit none
    real(kind=wp), dimension(100) :: x, xl, xu
    real(kind=wp)                 :: twopi, bdl, bdu, rhobeg, rhoend, temp
    integer                       :: iprint, maxfun
    integer                       :: m, n, j, jcase, npt

    twopi  =  8.0d0 * atan(1.0d0)
    bdl    = -1.0d0
    bdu    =  1.0d0
    iprint =  2
    maxfun =  500000
    rhobeg =  1.0d-1
    rhoend =  1.0d-6

    m = 5
    do while ( m <= 10 )
        n  = 2 * m
        xl = bdl
        xu = bdu

        do jcase = 1,2
            npt = n + 6
            if ( jcase == 2 ) npt = 2 * n + 1
            print 30, m,n,npt
   30       format (//5x,'2d output with m =',i4,',  n =',i4, &
                         '  and  npt =',i4)
            do j = 1,m
                temp = real(j,wp) * twopi / real(m,wp)
                x(2*j-1) = cos(temp)
                x(2*j)   = sin(temp)
            enddo

            call bobyqa( npt, x(1:n), xl(1:n), xu(1:n), rhobeg, rhoend, iprint, maxfun, calfun)
        enddo
        m = 2 * m
    enddo
end program


  SUBROUTINE REALFT (DATA, N, ISIGN)
!
! Numerical recipes FFT of a real function routine.
!
! Calculates the Fourier transform of a set of n real-valued data points.
! Replaces this data by the positive frequency half of its complex Fourier
! transform.  The real valued first and last components of the complex transform are
! returned as data(1) and data(2).  n must be a power of 2.  For isign=-1 the
! inverse transform is returned and must be multiplied by 2/n.
!
      REAL(8) WR, WI, WPR, WPI, WTEMP, THETA
      REAL(4) DATA ( * )
      THETA = 3.141592653589793D0 / DBLE (N / 2)
      C1 = 0.5
      IF (ISIGN.EQ.1) THEN
         C2 = - 0.5
         CALL FOUR1 (DATA, N / 2, + 1)
      ELSE
         C2 = 0.5
         THETA = - THETA
      ENDIF
      WPR = - 2.0D0 * DSIN (0.5D0 * THETA) **2
      WPI = DSIN (THETA)
      WR = 1.0D0 + WPR
      WI = WPI
      N2P3 = N + 3
      DO 11 I = 2, N / 4
         I1 = 2 * I - 1
         I2 = I1 + 1
         I3 = N2P3 - I2
         I4 = I3 + 1
         WRS = SNGL (WR)
         WIS = SNGL (WI)
         H1R = C1 * (DATA (I1) + DATA (I3) )
         H1I = C1 * (DATA (I2) - DATA (I4) )
         H2R = - C2 * (DATA (I2) + DATA (I4) )
         H2I = C2 * (DATA (I1) - DATA (I3) )
         DATA (I1) = H1R + WRS * H2R - WIS * H2I
         DATA (I2) = H1I + WRS * H2I + WIS * H2R
         DATA (I3) = H1R - WRS * H2R + WIS * H2I
         DATA (I4) = - H1I + WRS * H2I + WIS * H2R
         WTEMP = WR
         WR = WR * WPR - WI * WPI + WR
         WI = WI * WPR + WTEMP * WPI + WI
11    END DO
      IF (ISIGN.EQ.1) THEN
        H1R = DATA (1)
        DATA (1) = H1R + DATA (2)
        DATA (2) = H1R - DATA (2)
      ELSE
        H1R = DATA (1)
        DATA (1) = C1 * (H1R + DATA (2) )
        DATA (2) = C1 * (H1R - DATA (2) )
        CALL FOUR1 (DATA, N / 2, - 1)
      ENDIF
      RETURN
      END SUBROUTINE REALFT


program tarefac
    implicit real(8) (a-h,o-z)

    dt = 0.001d0
    tmax = 120d0

    g = 9.8d0
    a_l = 9.8d0
    gama = 0.5d0
    Omega = 2d0/3d0

    write(*,*) 'Entre com o valor de F0:'
    read(*,*) F0

    open(10, file='saida-c-10407962.dat')

    theta_i1 = 0.2d0
    omega_i1 = 0d0
    theta_i2 = theta_i1 + 0.001d0
    omega_i2 = omega_i1
    i = 0
    n = 0
    a_lyapunov = 0d0

    do while ( i*dt.le.tmax )

        dw_i1 = dw(g, a_l, theta_i1, gama, omega_i1, F0, Omega, dt*i)
        call oscilacao(theta_i1, omega_i1, dw_i1, dt)

        dw_i2 = dw(g, a_l, theta_i2, gama, omega_i2, F0, Omega, dt*i)
        call oscilacao(theta_i2, omega_i2, dw_i2, dt)

        deltaTheta = abs(theta_i2-theta_i1)
        a_lyapunov_i = log(deltaTheta)/(i*dt)

        if (((i*dt).gt.(tmax/2)).and.(abs(a_lyapunov_i).lt.9d300)) then
            a_lyapunov = a_lyapunov + a_lyapunov_i
            n = n + 1
        end if

        write(10, *) i*dt, deltaTheta

        i = i+1
    end do

    close(10)

    print *, F0, a_lyapunov/n

contains
    function dw(g, a_l, theta, gama, dTheta, F0, Omega, t)
        implicit real(8) (a-h,o-z)
        dw = -(g/a_l)*sin(theta) -gama*dTheta +F0*sin(Omega*t)
        return
    end function

    subroutine oscilacao(theta_i, omega_i, dw_i, dt)
        implicit real(8) (a-h,o-z)
        parameter (pi = 4d0*atan(1d0))
        omega_i = omega_i +dw_i*dt
        theta_i = theta_i +omega_i*dt

        do while (abs(theta_i).ge.pi)
            sinal = theta_i/abs(theta_i)
            theta_i = theta_i -sinal*2*pi
        end do
        return
    end subroutine

end program tarefac


c
c     =================================================
      double precision function psi(x,y)
c     =================================================
c
c     # stream function

      implicit double precision (a-h,o-z)
      common /compsi/ pi

      psi = ((dsin(pi*x))**2 * (dsin(pi*y))**2) / pi
c
      return
      end


  subroutine LineSegIntersection(p,p2,q,q2,pRatio,qRatio,rPtc,bIntersect)
    !-- source http://www.codeproject.com/Tips/862988/Find-the-Intersection-Point-of-Two-Line-Segments
    use mod_parameters
    implicit none
    real*8 , intent(in)::p(2),p2(2),q(2),q2(2) !-input lines p-p2, q-q2
    real*8 , intent(out)::rPtc(2),pRatio,qRatio !- output intersection point
    integer ,intent(out)::bIntersect !- =0 for no intersection
    integer i
    real*8 r(2),s(2),qp(2),rxs,qpxr,qpxs,CorssProduct2d

    bIntersect=0
    r=p2-p
    s=q2-q
    qp=q-p
    rxs=CorssProduct2d(r,s)
    qpxr=CorssProduct2d(qp,r)
    !- If r x s = 0 and (q - p) x r = 0, then the two lines are collinear.
    if ((abs(rxs) < TolZero16) .and. (abs(qpxr) <TolZero16 )) then
      return
    endif
    !- If r x s = 0 and (q - p) x r != 0, then the two lines are parallel and non-intersecting.
    if ((abs(rxs) < TolZero16) .and. (qpxr /=TolZero16 )) then
      return
    endif

    qpxs=CorssProduct2d(qp,s)
    !- pRatio = (q - p) x s / (r x s)
    pRatio = qpxs/rxs

    !- qRatio = (q - p) x r / (r x s)
    qRatio = qpxr/rxs

    !- If r x s != 0 and 0 <= t <= 1 and 0 <= u <= 1
    !- the two line segments meet at the point p + t r = q + u s.
    if ((0 <= pRatio .and. pRatio <= 1) .and. (0 <= qRatio .and. qRatio <= 1)) then
        !- We can calculate the intersection point using either t or u.
        rPtc = p + pRatio*r
        !-An intersection was found.
        bIntersect=1
    endif

    !- Otherwise, the two line segments are not parallel but do not intersect.
  end subroutine LineSegIntersection
!##############################################################################
!##############################################################################
  function CorssProduct2d(v1,v2)result(v1xv2)
    implicit none
    real*8 , intent(in)::v1(2),v2(2) !-input lines p-p2, q-q2
    real*8 ::v1xv2 !- output intersection point
    v1xv2=v1(1)*v2(2)-v1(2)*v2(1) != v1x*v2y-v1y*v2x

  end function CorssProduct2d
  !##############################################################################
  !##############################################################################
    subroutine GetLineStartEndPts(rPt,Vnx,Vny,rDelta,p1,p2)
      implicit none
      real*8 , intent(in)::Vnx,Vny,rDelta,rPt(2) !- input line direction
      real*8 , intent(out)::p1(2),p2(2) !-output points
      real*8 ::v1xv2 !- output intersection point
      p1(1)=rPt(1)-rDelta*Vnx
      p1(2)=rPt(2)-rDelta*Vny

      p2(1)=rPt(1)+rDelta*Vnx
      p2(2)=rPt(2)+rDelta*Vny

    end subroutine GetLineStartEndPts
    !##############################################################################
    !##############################################################################
    function CalcPolygonArea(xs,ys,nPts)result(rArea)
        implicit none
        integer , intent(in):: nPts
        real*8 , intent(in)::xs(nPts),ys(nPts) !-input lines p-p2, q-q2
        real*8 ::rArea !- output area
!!!        real*8 ::v1(2),v2(2),CorssProduct2d !- output area
        integer i

        rArea=0.0
!!!        do i=2,nPts
!!!            v1(1)=xs(i+1)-xs(i)
!!!            v1(2)=ys(i+1)-ys(i)
!!!
!!!            v2(1)=xs(i)-xs(i-1)
!!!            v2(2)=ys(i)-ys(i-1)
!!!            rArea=rArea+abs(CorssProduct2d(v1,v2))
!!!        end do
!!!        v1(1)=xs(1)-xs(4)
!!!        v1(2)=ys(1)-ys(4)
!!!
!!!        v2(1)=xs(4)-xs(3)
!!!        v2(2)=ys(4)-ys(3)
!!!        rArea=rArea+abs(CorssProduct2d(v1,v2))
        do i=1,nPts-1
            !- (x2-x1)(y2+y1)
            rArea=rArea+(xs(i+1)-xs(i))*(ys(i+1)+ys(i))
        end do
        rArea=rArea+(xs(1)-xs(nPts))*(ys(1)+ys(nPts))

        rArea=0.5*abs(rArea)

    end function CalcPolygonArea
    !##############################################################################
    !##############################################################################
    subroutine GetPtOnLine(rP1,rP2,DistRatio,rPtc)
        implicit none
        real*8 , intent(in)::rP1(2),rP2(2),DistRatio !- input line direction
        real*8 , intent(out)::rPtc(2) !-output points
        real*8 ::v21(2) !- output intersection point

        v21=rP2-rP1
        rPtc=rP1+DistRatio*v21

    end subroutine GetPtOnLine
    !##############################################################################
    !##############################################################################


C$Procedure      VPROJG ( Vector projection, general dimension )

      SUBROUTINE VPROJG ( A, B, NDIM, P )

C$ Abstract
C
C     VPROJG finds the projection of the one vector onto another
C     vector.  All vectors are of arbitrary dimension.
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

      INTEGER            NDIM
      DOUBLE PRECISION   A ( NDIM )
      DOUBLE PRECISION   B ( NDIM )
      DOUBLE PRECISION   P ( NDIM )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     A          I   The vector to be projected.
C     B          I   The vector onto which A is to be projected.
C     NDIM       I   Dimension of A, B, and P.
C     P          O   The projection of A onto B.
C
C$ Detailed_Input
C
C     A     is a double precision vector of arbitrary dimension.  This
C           vector is to be projected onto the vector B.
C
C     B     is a double precision vector of arbitrary dimension.  This
C           vector is the vector which receives the projection.
C
C     NDIM  is the dimension of A, B and P.
C
C$ Detailed_Output
C
C     P     is a double precision vector of arbitrary dimension
C           containing the projection of A onto B. (P is necessarily
C           parallel to B.)
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     The projection of a vector A onto a vector B is, by definition,
C     that component of A which is parallel to B.  To find this
C     component it is enough to find the scalar ratio of the length of
C     B to the projection of A onto B, and then use this number to
C     scale the length of B.  This ratio is given by
C
C         RATIO = (A DOT B) / (B DOT B)
C
C     where DOT denotes the general vector dot product. This routine
C     does not attempt to divide by zero in the event that B is the
C     zero vector.
C
C$ Examples
C
C     The following table gives sample inputs and results from calling
C     VPROJG.
C
C        A                  B                NDIM       P
C        -----------------------------------------------------------
C        (6, 6, 6, 6)      ( 2, 0, 0, 0)     4          (6, 0, 0, 0)
C        (6, 6, 6, 0)      (-3, 0, 0, 0)     4          (6, 0, 0, 0)
C        (6, 6, 0, 0)      ( 0, 7, 0, 0)     4          (0, 6, 0, 0)
C        (6, 0, 0, 0)      ( 0, 0, 9, 0)     4          (0, 0, 0, 0)
C
C$ Restrictions
C
C     No error detection or recovery schemes are incorporated into this
C     subroutine except to insure that no attempt is made to divide by
C     zero.  Thus, the user is required to make sure that the vectors
C     A and B are such that no floating point overflow will occur when
C     the dot products are calculated.
C
C$ Literature_References
C
C     Any reasonable calculus text (for example Thomas)
C
C$ Author_and_Institution
C
C     N.J. Bachman    (JPL)
C     H.A. Neilan     (JPL)
C     W.L. Taber      (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.3, 23-APR-2010 (NJB)
C
C        Header correction: assertions that the output
C        can overwrite the input have been removed.
C
C-    SPICELIB Version 1.0.2, 22-AUG-2001 (EDW)
C
C        Corrected ENDIF to END IF.
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     n-dimensional vector projection
C
C-&

C$ Revisions
C
C-     Beta Version 1.1.0, 17-FEB-1989 (HAN) (NJB)
C
C         Contents of the Exceptions section was changed
C         to "error free" to reflect the decision that the
C         module will never participate in error handling.
C
C         The declaration of the unused variable I was removed.
C-&

      DOUBLE PRECISION VDOTG
C
      DOUBLE PRECISION ADOTB
      DOUBLE PRECISION BDOTB
      DOUBLE PRECISION SCALE
C
      ADOTB  = VDOTG (A,B,NDIM)
      BDOTB  = VDOTG (B,B,NDIM)
C
      IF ( BDOTB .EQ. 0.D0 ) THEN
         SCALE = 0.D0
      ELSE
         SCALE = ADOTB/BDOTB
      END IF
C
      CALL VSCLG (SCALE, B, NDIM, P)
C
      RETURN
      END


!WARNING : this code is slightly overbuilt for the actual problem
! but is a handy illustration of types etc

MODULE numerical_rootfinder

  !Implicit none should be in all modules and the main program.

  IMPLICIT NONE

  ! We probably do need Dbl to get these right. This is the
  ! most portable way to get it at the moment
  INTEGER, PARAMETER :: dbl = SELECTED_REAL_KIND(15, 307)

  ! Type to hold polynomial info
  ! I have made mine work for any order
  ! I assume coefficients go largest power to smallest
  TYPE polynomial_wrapper
    ! Since this holds order+1, but it useful to have as the size of coeffs
    INTEGER :: order_plus
    REAL(KIND=dbl), DIMENSION(:), ALLOCATABLE :: coeffs
  END TYPE

  CONTAINS

  SUBROUTINE define_poly(poly, coeffs, err)

    TYPE(polynomial_wrapper), INTENT(INOUT) :: poly
    REAL(KIND=dbl), DIMENSION(:), INTENT(IN) :: coeffs
    ! I make this optional because maybe I have already checked validity of coeffs
    LOGICAL, OPTIONAL :: err
    LOGICAL :: err_in

    err_in = .FALSE.

    poly%order_plus = SIZE(coeffs)

    ! 0th order poly has no roots, and I arbitrarily limit to max 8
    IF(poly%order_plus < 1 .OR. poly%order_plus > 8) THEN
      PRINT*, "Polynomial order should be between 1 and 8"
      err_in = .TRUE.
    ELSE
      ! In case we're re-defining
      IF(ALLOCATED(poly%coeffs)) DEALLOCATE(poly%coeffs)
      ALLOCATE(poly%coeffs(poly%order_plus))
      poly%coeffs = coeffs
    END IF

    ! Put value in before returning
    IF(PRESENT(err)) err = err_in

  END SUBROUTINE

  ! f is a terrible function name in general, but it matches the equation I am coding
  FUNCTION f(poly, x)
    TYPE(polynomial_wrapper) :: poly
    REAL(KIND=dbl) :: f, x, x_term
    INTEGER :: i

    f = 0.0
    x_term = 1.0

    ! I go backwards so I can accumulate the x powers
    DO i = poly%order_plus, 1,  -1
      f = f + x_term * poly%coeffs(i)
      x_term = x_term * x
    END DO

  END FUNCTION f

  FUNCTION f_prime(poly, x)
    TYPE(polynomial_wrapper) :: poly
    REAL(KIND=dbl) :: f_prime, x, x_term
    INTEGER :: i

    f_prime = 0.0
    x_term = 1.0

    ! I go backwards so I can accumulate the x powers
    DO i = poly%order_plus-1, 1,  -1
      f_prime = f_prime + x_term * poly%coeffs(i) * REAL(poly%order_plus-i)
      x_term = x_term * x
    END DO

  END FUNCTION f_prime

  FUNCTION root_near(poly, guess)
    ! Find a root of a function near a given guess
    ! We can return any valid root

    ! The polynomial
    TYPE(polynomial_wrapper) :: poly
    ! Initial guess for the root
    REAL(KIND=dbl), INTENT(IN) :: guess

    REAL(KIND=dbl):: change
    REAL(KIND=dbl) :: root_near
    REAL(KIND=dbl), PARAMETER :: threshold = 0.001_dbl
    INTEGER, PARAMETER :: max_iter = 50
    INTEGER :: i

    ! See numerical_root for discussion of termination condition

    root_near = guess
    ! Start with a number for change that definitely
    ! does not trip the fractional change limit
    change = guess * 100.0
    DO i = 1, max_iter
      !I chose to print the progress in this
      PRINT*, "Iteration", i, "Fractional change", change, "Guess", root_near
      ! I am using a fractional change limit
      IF(ABS(change/root_near) .LT. threshold) EXIT

      ! I am being a bit "clever" to minimise my temporaries here
      ! by storing the change before applying it
      ! I could also store the old and new values, or other
      ! approaches
      change = f(poly,root_near)/f_prime(poly,root_near)
      root_near = root_near - change
    END DO

    ! If we hit max_iter, we probably don't have a root
    ! This is a dumb way to create a NaN - we should really
    ! use the IEEE module, but I am keeping this simple
    IF(i >= max_iter) root_near = 0.0*1.0/(root_near-root_near)

  END FUNCTION root_near

END MODULE numerical_rootfinder

PROGRAM main

  USE numerical_rootfinder

  IMPLICIT NONE

  ! Select some bounds for finding
  REAL(KIND=dbl) :: guess = 0.555555555_dbl
  REAL(KIND=dbl) :: res
  TYPE(polynomial_wrapper) :: poly

  CALL define_poly(poly, (/1.0_dbl, -0.31428571428_dbl, &
      -0.21549295774_dbl, 0.20845070422_dbl/))

  ! Calculate and print the answer
  ! The Fortran standard lets compilers do something unhelpful
  ! if you PRINT the result of a function which has a print in,
  ! so I generally always capture a result, then print it
  res = root_near(poly, guess)

  PRINT*, "Root is ", res

END PROGRAM


      PROGRAM sphfinrot
C----
C Given a point (ilon,ilat), a pole of rotation (plon,plat), and a
C finite angle of rotation, in degrees, calculate the new point
C (olon,olat).
C
C Based on results found at:
C inside.mines.edu/~gmurray/ArbitraryAxisRotation
C----

      IMPLICIT none
      REAL*8 olon,olat,ilon,ilat,plon,plat,angle
      REAL*8 ix,iy,iz,px,py,pz,ox,oy,oz
      CHARACTER*30 ifile,ofile
      INTEGER user

      call gcmdln(ifile,ofile,user)

      if (user.eq.1) then
          print *,'Enter lon_init lat_init pole_lon pole_lat angle:'
          read *,ilon,ilat,plon,plat,angle
          call rotate(olon,olat,ilon,ilat,plon,plat,angle)
          write (*,9999), olon,olat
      else
          open (unit=11,file=ifile,status='old')
          open (unit=12,file=ofile,status='unknown')
  101     read (11,*,end=102) ilon,ilat,plon,plat,angle
              call rotate(olon,olat,ilon,ilat,plon,plat,angle)
              write (12,9999) olon,olat
              goto 101
  102     continue
      endif

 9999 format(2F14.6)

      END

C----------------------------------------------------------------------c

      SUBROUTINE rotate(olon,olat,ilon,ilat,plon,plat,angle)
      IMPLICIT NONE
      REAL*8 olon,olat,ilon,ilat,plon,plat,angle
      REAL*8 ix,iy,iz,px,py,pz,ox,oy,oz
      REAL*8 pi,d2r,r2d
      PARAMETER (pi=4.0d0*datan(1.0d0),d2r=pi/1.8d2,r2d=1.8d2/pi)

      call lonlat2xyz(ix,iy,iz,ilon,ilat)
      call lonlat2xyz(px,py,pz,plon,plat)

      ox = px*(px*ix+py*iy+pz*iz)*(1.0d0-dcos(angle*d2r))
     1         + ix*dcos(angle*d2r)
     2         + (-pz*iy+py*iz)*dsin(angle*d2r)
      oy = py*(px*ix+py*iy+pz*iz)*(1.0d0-dcos(angle*d2r))
     1         + iy*dcos(angle*d2r)
     2         + ( pz*ix-px*iz)*dsin(angle*d2r)
      oz = pz*(px*ix+py*iy+pz*iz)*(1.0d0-dcos(angle*d2r))
     1         + iz*dcos(angle*d2r)
     2         + (-py*ix+px*iy)*dsin(angle*d2r)

      olon = datan2(oy,ox)*r2d
      olat = dasin(oz)*r2d

      RETURN
      END

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

      SUBROUTINE lonlat2xyz(x,y,z,lon,lat)

      IMPLICIT none
      REAL*8 pi,d2r
      PARAMETER (pi=4.0d0*datan(1.0d0),d2r=pi/1.8d2)
      REAL*8 lon,lat,x,y,z

      x = dcos(lon*d2r)*dcos(lat*d2r)
      y = dsin(lon*d2r)*dcos(lat*d2r)
      z = dsin(lat*d2r)

      RETURN
      END

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

      SUBROUTINE gcmdln(ifile,ofile,user)

      IMPLICIT NONE
      CHARACTER*30 ifile,ofile,tag
      INTEGER i,narg,user

      user = 0
      ifile = 'sphfinrot.in'
      ofile = 'sphfinrot.out'

      narg = iargc()
      if (narg.eq.0) call usage()

      i = 0
 9998 i = i + 1
      if (i.gt.narg) goto 9999
          call getarg(i,tag)
          if (tag(1:2).eq.'-f') then
              i = i + 1
              call getarg(i,ifile)
          elseif (tag(1:2).eq.'-o') then
              i = i + 1
              call getarg(i,ofile)
          elseif (tag(1:2).eq.'-d') then
              write(*,*) 'Running with default file names'
          elseif (tag(1:2).eq.'-u') then
              user = 1
          elseif (tag(1:2).eq.'-h'.or.tag(1:2).eq.'-?') then
              call usage()
          endif
          goto 9998
 9999 continue

      RETURN
      END

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

      SUBROUTINE usage()
      IMPLICIT none

      write(*,*)
     1 'Usage: sphfinrot -f [IFILE] -o [OFILE] -d -u -h/-?'
      write(*,*)
     1 '  -f [IFILE] (Default sphfinrot.in) name of input file'
      write(*,*)
     1 '  -o [OFILE] (Default sphfinrot.out) name of output file'
      write(*,*)
     1 '  -d         Run with default file names'
      write (*,*)
     1 '  -u         Prompt user to enter information through standard'
      write (*,*)
     1 '                 input for single calculation'
      write (*,*)
     1 '  -h/-?      Online help (this screen)'
      write (*,*) ''
      write (*,*)
     1 '  sphfinrot makes a counter-clockwise finite rotation of a',
     2     ' point around a pole'
      write (*,*) ''
      write (*,*)
     1 '    Input file'
      write (*,*)
     1 '        lon_init lat_init pole_lon pole_lat angle'
      write (*,*)
     1 '         :  :'
      write(*,*) ''
      write (*,*)
     1 '    Output file'
      write (*,*)
     1 '        lon_final lat_final'
      write (*,*)
     1 '         :  :'
      write (*,*) ''

      STOP
      END


	Program Eigenvalue

!c gfortran eigen.f90 -I/use/include -L/usr/lib -llapack -lblas
!c Confirm needed libraries are installed in your device

!c I myself Byron Encinas claim no authorship over this example of code.

!c finding the eigenvalues of a complex matrix using LAPACK
	Implicit none
!c declarations, notice double precision
	complex*16 A(3,3), b(3), DUMMY(1,1), WORK(6)
	integer i, ok
!c define matrix A
	A(1,1)=(3.1, 0)
	A(1,2)=(1.3, 0)
	A(1,3)=(-5.7, 0)
	A(2,1)=(1.0, 0)
	A(2,2)=(-6.9, 0)
	A(2,3)=(5.8, 0)
	A(3,1)=(3.4, 0)
	A(3,2)=(7.2, 0)
	A(3,3)=(-8.8, 0)
!c
!c find the solution using the LAPACK routine ZGEEV
	call ZGEEV('N', 'N', 3, A, 3, b, DUMMY, 1, DUMMY, 1, WORK, 6, WORK, ok)
!c
!c parameters in the order as they appear in the function call
!c    no left eigenvectors, no right eigenvectors, order of input matrix A,
!c    input matrix A, leading dimension of A, array for eigenvalues,
!c    array for left eigenvalue, leading dimension of DUMMY,
!c    array for right eigenvalues, leading dimension of DUMMY,
!c    workspace array dim>=2*order of A, dimension of WORK
!c    workspace array dim=2*order of A, return value
!c
!c output of eigenvalues
	if (ok .eq. 0) then
	   do i=1, 3
	      write(*,*) b(i)
	   enddo
	else
	   write (*,*) "An error occurred"
	endif
	end


PROGRAM linear_reg
IMPLICIT NONE
  REAL :: x, y, x_sum = 0, y_sum = 0, xy_sum = 0, x2_sum = 0, x_mean, y_mean, m, b
  INTEGER :: num_records = 0, status
  CHARACTER(80) :: msg
  OPEN(UNIT=1, FILE='coords.dat', STATUS='OLD', ACTION='READ', IOSTAT=status, IOMSG=msg)

  DO
    READ(1, *, IOSTAT=status) x, y
    IF (status .ne. 0) THEN
      EXIT
    ELSE
      x_sum = x_sum + x
      y_sum = y_sum + y
      xy_sum = xy_sum + (x * y)
      x2_sum = x2_sum + (x**2)
      num_records = num_records + 1
    END IF
  END DO

  x_mean = x_sum / REAL(num_records)
  y_mean = y_sum / REAL(num_records)
  m = (xy_sum - x_sum * y_mean) / (x2_sum - x_sum * x_mean)
  b = y_mean - m * x_mean
  WRITE(*, '(A,F9.7,A,F9.7)') "y = ",m, "x + ",b

END PROGRAM linear_reg


c gmm01f
c  THIS FILE IS PART OF THE ORIGINAL GMM01F DISTRIBUTION
      SUBROUTINE orientcd(BETAMI,BETAMX,THETMI,THETMX,PHIMIN,PHIMAX,
     &                  MXBETA,MXTHET,MXPHI,NBETA,NTHETA,NPHI,
     &                  BETA,THETA,PHI)
C Arguments:
      INTEGER MXBETA,MXTHET,MXPHI,NBETA,NTHETA,NPHI
      double precision BETAMI,BETAMX,THETMI,THETMX,PHIMIN,PHIMAX
      double precision BETA(MXBETA),THETA(MXTHET),PHI(MXPHI)
C Local variables:
      INTEGER J
      double precision DELTA
C***********************************************************************
C Given: BETAMI=minimum value of beta (radians)
C        BETAMX=maximum value of beta (radians)
C        THETMI=minimum value of theta (radians)
C        THETMX=maximum value of theta (radians)
C        PHIMIN=minimum value of phi (radians)
C        PHIMAX=maximum value of phi (radians)
C        MXBETA,MXTHET,MXPHI=dimensions of the arrays BETA,THETA,PHI
C        NBETA=number of values of beta
C        NTHETA=number of values of theta
C        NPHI=number of values of PHI
C Returns: BETA(1-NBETA)=beta values (radians)
C          THETA(1-NTHETA)=theta values (radians)
C          PHI(1-NPHI)=phi values (radians)
C Purpose: to generate a sequence of desired target orientations
C Present version assumes:
C        beta to be uniformly distributed between BETAMI and BETAMX
C        cos(theta) to be uniformly distributed between cos(THETMI) and
C                   cos(THETMX)
C        phi to be uniformly distributed between PHIMIN and PHIMAX
C        If NPHI=1, first angle is THETMI, last angle is THETMX
C        If NPHI>1, then angles are midpoints of intervals of equal
C            range in theta subdividing range from THETMI to THETMX
C***********************************************************************
      BETA(1)=BETAMI
      IF(NBETA.GT.1)THEN
         DELTA=(BETAMX-BETAMI)/DBLE(NBETA-1)
         DO 1000 J=2,NBETA
           BETA(J)=BETA(1)+DELTA*DBLE(J-1)
 1000    CONTINUE
      ENDIF
      IF(NPHI.EQ.1.AND.NTHETA.GT.1)THEN
         DELTA=(DCOS(THETMX)-DCOS(THETMI))/DBLE(NTHETA-1)
         THETA(1)=THETMI
      ELSE
         DELTA=(DCOS(THETMX)-DCOS(THETMI))/DBLE(NTHETA)
         THETA(1)=DACOS(DCOS(THETMI)+0.5d0*DELTA)
      ENDIF
      IF(NTHETA.GT.1)THEN
         DO 2000 J=2,NTHETA
            THETA(J)=DACOS(DCOS(THETA(1))+DELTA*DBLE(J-1))
 2000    CONTINUE
      ENDIF
c      DELTA=(PHIMAX-PHIMIN)/DBLE(NPHI)
c      PHI(1)=PHIMIN+0.5D0*DELTA
      PHI(1)=PHIMIN
      IF(NPHI.GT.1)THEN
         DELTA=(PHIMAX-PHIMIN)/DBLE(NPHI-1)
         DO 3000 J=2,NPHI
            PHI(J)=PHI(1)+DELTA*DBLE(J-1)
 3000    CONTINUE
      ENDIF
      RETURN
      END


PROGRAM stats
IMPLICIT NONE
  INTEGER, PARAMETER :: MAX_SIZE = 32
  INTEGER, DIMENSION(MAX_SIZE) :: numbers
  INTEGER :: arr_size, smallest, start, swap, status, index = 1, diff = 0
  REAL :: median, mean, std_dev, x_sum = 0.0, diff2_sum = 0.0
  CHARACTER(LEN = 85) :: msg

  OPEN(UNIT=1, FILE='numbers.txt', STATUS='OLD', ACTION='READ', IOSTAT=status, IOMSG=msg)

  ! Read data from file and load it into numbers array. Calculate mean and
  ! std_dev in the process
  DO
    READ(1,*,IOSTAT=status) numbers(index)
    x_sum = x_sum + numbers(index)
    IF (status .ne. 0) THEN
      ! Get upper bound of array
      arr_size = index - 1
      EXIT
    END IF
    index = index + 1
  END DO

  mean = x_sum / arr_size
  WRITE(*, *) "Mean: ", mean

  DO index = 1, arr_size
    diff = numbers(index) - mean
    diff2_sum = diff2_sum + diff**2
  END DO

  std_dev = SQRT(diff2_sum/(arr_size - 1))
  WRITE(*, *) "Standard Deviation: ", std_dev

  ! Find smallest and swap it with the value stored in start
  outer: DO start = 1, arr_size
    smallest = start
    find_smallest: DO index = start, arr_size
      IF (numbers(index) < numbers(smallest)) THEN
        smallest = index
      END IF
    END DO find_smallest
    IF (start .ne. smallest) THEN
      swap = numbers(start)
      numbers(start) = numbers(smallest)
      numbers(smallest) = swap
    END IF
  END DO outer

  ! Calculate the median and print it
  IF (MODULO(arr_size,2) .ne. 0) THEN
    median = REAL(numbers(index/2))
    WRITE(*, *) "Median: ", INT(median)
  ELSE
    median = REAL(numbers(index/2) + numbers(index/2 + 1)) / 2.0
    WRITE(*, *) "Near median: ", numbers(index/2), numbers(index/2 + 1)
    WRITE(*, *) "Median: ", median
  END IF

  CLOSE(1)

END PROGRAM stats


PROGRAM test_chi_squared
IMPLICIT NONE
INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(15, 60)
INTEGER             :: ndf
REAL (dp)           :: chi2

INTERFACE
  FUNCTION chi_squared(ndf, chi2) RESULT(prob)
    IMPLICIT NONE
    INTEGER, PARAMETER     :: dp = SELECTED_REAL_KIND(15, 60)
    INTEGER, INTENT(IN)    :: ndf
    REAL (dp), INTENT(IN)  :: chi2
    REAL (dp)              :: prob
  END FUNCTION chi_squared
END INTERFACE

DO
  WRITE(*, *) 'Enter no. of degrees of freedom: '
  READ(*, *) ndf
  WRITE(*, *) 'Enter chi-squared value: '
  READ(*, *) chi2
  WRITE(*, *) 'Chi-squared probability = ', chi_squared(ndf, chi2)
END DO
STOP

END PROGRAM test_chi_squared

FUNCTION chi_squared(ndf, chi2) RESULT(prob)
! Calculate the chi-squared distribution function
! ndf  = number of degrees of freedom
! chi2 = chi-squared value
! prob = probability of a chi-squared value <= chi2 (i.e. the left-hand
!        tail area)

IMPLICIT NONE
INTEGER, PARAMETER     :: dp = SELECTED_REAL_KIND(15, 60)
INTEGER, INTENT(IN)    :: ndf
REAL (dp), INTENT(IN)  :: chi2
REAL (dp)              :: prob

INTERFACE
  FUNCTION gammad(x, p) RESULT(gamma_prob)
    IMPLICIT NONE
    INTEGER, PARAMETER     :: dp = SELECTED_REAL_KIND(15, 60)
    REAL (dp), INTENT(IN)  :: x, p
    REAL (dp)              :: gamma_prob
  END FUNCTION gammad
END INTERFACE

! Local variables
REAL (dp)  :: half = 0.5d0, x, p

x = half * chi2
p = half * REAL(ndf)
prob = gammad(x, p)
RETURN

END FUNCTION chi_squared

FUNCTION gammad(x, p) RESULT(fn_val)

!   ALGORITHM AS239  APPL. STATIST. (1988) VOL. 37, NO. 3

!   Computation of the Incomplete Gamma Integral

!   Auxiliary functions required: lngamma = logarithm of the gamma
!   function, and ALNORM = algorithm AS66

! ELF90-compatible version by Alan Miller
! amiller@bigpond.net.au
! Latest revision - 28 October 2000

! N.B. Argument IFAULT has been removed

IMPLICIT NONE
INTEGER, PARAMETER     :: dp = SELECTED_REAL_KIND(12, 60)
REAL (dp), INTENT(IN)  :: x, p
REAL (dp)              :: fn_val

INTERFACE
  FUNCTION alnorm( x, upper ) RESULT( fn_val )
    IMPLICIT NONE
    INTEGER, PARAMETER    :: dp = SELECTED_REAL_KIND(15, 100)
    REAL(dp), INTENT(IN)  :: x
    LOGICAL, INTENT(IN)   :: upper
    REAL(DP)              :: fn_val
  END FUNCTION alnorm

  FUNCTION lngamma(z) RESULT(lanczos)
    IMPLICIT NONE
    INTEGER, PARAMETER    :: dp = SELECTED_REAL_KIND(15, 60)
    REAL(dp), INTENT(IN)  :: z
    REAL(dp)              :: lanczos
  END FUNCTION lngamma
END INTERFACE

! Local variables
REAL (dp)             :: pn1, pn2, pn3, pn4, pn5, pn6, arg, c, rn, a, b, an
REAL (dp), PARAMETER  :: zero = 0.0_dp, one = 1.0_dp, two = 2.0_dp, &
                         oflo = 1.d+37, three = 3.0_dp, nine = 9.0_dp, &
                         tol = 1.d-14, xbig = 1.d+8, plimit = 1000.0_dp, &
                         elimit = -88.0_dp
! EXTERNAL lngamma, alnorm

fn_val = zero

!      Check that we have valid values for X and P

IF (p <= zero .OR. x < zero) THEN
  WRITE(*, *) 'AS239: Either p <= 0 or x < 0'
  RETURN
END IF
IF (x == zero) RETURN

!      Use a normal approximation if P > PLIMIT

IF (p > plimit) THEN
  pn1 = three * SQRT(p) * ((x / p) ** (one / three) + one /(nine * p) - one)
  fn_val = alnorm(pn1, .false.)
  RETURN
END IF

!      If X is extremely large compared to P then set fn_val = 1

IF (x > xbig) THEN
  fn_val = one
  RETURN
END IF

IF (x <= one .OR. x < p) THEN

!      Use Pearson's series expansion.
!      (Note that P is not large enough to force overflow in lngamma).
!      No need to test IFAULT on exit since P > 0.

  arg = p * LOG(x) - x - lngamma(p + one)
  c = one
  fn_val = one
  a = p
  DO
    a = a + one
    c = c * x / a
    fn_val = fn_val + c
    IF (c <= tol) EXIT
  END DO
  arg = arg + LOG(fn_val)
  fn_val = zero
  IF (arg >= elimit) fn_val = EXP(arg)

ELSE

!      Use a continued fraction expansion

  arg = p * LOG(x) - x - lngamma(p)
  a = one - p
  b = a + x + one
  c = zero
  pn1 = one
  pn2 = x
  pn3 = x + one
  pn4 = x * b
  fn_val = pn3 / pn4
  DO
    a = a + one
    b = b + two
    c = c + one
    an = a * c
    pn5 = b * pn3 - an * pn1
    pn6 = b * pn4 - an * pn2
    IF (ABS(pn6) > zero) THEN
      rn = pn5 / pn6
      IF (ABS(fn_val - rn) <= MIN(tol, tol * rn)) EXIT
      fn_val = rn
    END IF

    pn1 = pn3
    pn2 = pn4
    pn3 = pn5
    pn4 = pn6
    IF (ABS(pn5) >= oflo) THEN

!      Re-scale terms in continued fraction if terms are large

      pn1 = pn1 / oflo
      pn2 = pn2 / oflo
      pn3 = pn3 / oflo
      pn4 = pn4 / oflo
    END IF
  END DO

  arg = arg + LOG(fn_val)
  fn_val = one
  IF (arg >= elimit) fn_val = one - EXP(arg)
END IF

RETURN
END FUNCTION gammad

!  Algorithm AS66 Applied Statistics (1973) vol.22, no.3

!  Evaluates the tail area of the standardised normal curve
!  from x to infinity if upper is .true. or
!  from minus infinity to x if upper is .false.

! ELF90-compatible version by Alan Miller
! Latest revision - 29 November 2001

FUNCTION alnorm( x, upper ) RESULT( fn_val )
   IMPLICIT NONE
   INTEGER, PARAMETER    :: dp = SELECTED_REAL_KIND(15, 100)
   REAL(dp), INTENT(IN)  :: x
   LOGICAL, INTENT(IN)   :: upper
   REAL(dp)              :: fn_val

   !  Local variables
   REAL(dp), PARAMETER   ::  zero=0.0_dp, one=1.0_dp, half=0.5_dp, con=1.28_dp
   REAL(dp)              ::  z, y
   LOGICAL               ::  up

   !  Machine dependent constants
   REAL(dp), PARAMETER  :: ltone = 7.0_dp, utzero = 18.66_dp
   REAL(dp), PARAMETER  :: p = 0.398942280444_dp, q = 0.39990348504_dp,   &
                           r = 0.398942280385_dp, a1 = 5.75885480458_dp,  &
                           a2 = 2.62433121679_dp, a3 = 5.92885724438_dp,  &
                           b1 = -29.8213557807_dp, b2 = 48.6959930692_dp, &
                           c1 = -3.8052D-8, c2 = 3.98064794D-4,           &
                           c3 = -0.151679116635_dp, c4 = 4.8385912808_dp, &
                           c5 = 0.742380924027_dp, c6 = 3.99019417011_dp, &
                           d1 = 1.00000615302_dp, d2 = 1.98615381364_dp,  &
                           d3 = 5.29330324926_dp, d4 = -15.1508972451_dp, &
                           d5 = 30.789933034_dp

   up = upper
   z = x
   IF( z < zero ) THEN
      up = .NOT. up
      z = -z
   END IF
   IF( z <= ltone  .OR.  (up  .AND.  z <= utzero) ) THEN
      y = half*z*z
      IF( z > con ) THEN
         fn_val = r*EXP( -y )/(z+c1+d1/(z+c2+d2/(z+c3+d3/(z+c4+d4/(z+c5+d5/(z+c6))))))
      ELSE
         fn_val = half - z*(p-q*y/(y+a1+b1/(y+a2+b2/(y+a3))))
      END IF
   ELSE
      fn_val = zero
   END IF

   IF( .NOT. up ) fn_val = one - fn_val
   RETURN
END FUNCTION alnorm

FUNCTION lngamma(z) RESULT(lanczos)

!  Uses Lanczos-type approximation to ln(gamma) for z > 0.
!  Reference:
!       Lanczos, C. 'A precision approximation of the gamma
!               function', J. SIAM Numer. Anal., B, 1, 86-96, 1964.
!  Accuracy: About 14 significant digits except for small regions
!            in the vicinity of 1 and 2.

!  Programmer: Alan Miller
!              1 Creswick Street, Brighton, Vic. 3187, Australia
!  Latest revision - 14 October 1996

IMPLICIT NONE
INTEGER, PARAMETER    :: dp = SELECTED_REAL_KIND(15, 60)
REAL(dp), INTENT(IN)  :: z
REAL(dp)              :: lanczos

! Local variables

REAL(dp)  :: a(9) = (/ 0.9999999999995183D0, 676.5203681218835D0, &
                       -1259.139216722289D0, 771.3234287757674D0, &
                       -176.6150291498386D0, 12.50734324009056D0, &
                       -0.1385710331296526D0, 0.9934937113930748D-05, &
                        0.1659470187408462D-06 /), zero = 0.D0,   &
             one = 1.d0, lnsqrt2pi = 0.9189385332046727D0, &
             half = 0.5d0, sixpt5 = 6.5d0, seven = 7.d0, tmp
INTEGER   :: j

IF (z <= zero) THEN
  WRITE(*, *) 'Error: zero or -ve argument for lngamma'
  RETURN
END IF

lanczos = zero
tmp = z + seven
DO j = 9, 2, -1
  lanczos = lanczos + a(j)/tmp
  tmp = tmp - one
END DO
lanczos = lanczos + a(1)
lanczos = LOG(lanczos) + lnsqrt2pi - (z + sixpt5) + (z - half)*LOG(z + sixpt5)
RETURN

END FUNCTION lngamma