!******************************************************************************
!*
!*                    VARIOUS MATHEMATICAL DISTRIBUTIONS
!*
!******************************************************************************

  !==========================================================================
  ! 1) AUTHOR: F. Galliano
  !
  ! 2) HISTORY:
  !    - Created 09/2007
  !    - Updated 11/2012
  !    - 04/2016: remove ERF and ERFC (now intrinsic in F08).
  !
  ! 3) DESCRIPTION: implements various commonly used mathematical functions,
  !                 distributions, and operations to manipulate them.
  !==========================================================================

MODULE special_functions

  USE utilities, ONLY:
  IMPLICIT NONE
  PRIVATE

  PUBLIC :: factorial_small, factorial, lngamma, igamma, igammac, ibeta
  PUBLIC :: expm1

  INTERFACE expm1
    MODULE PROCEDURE expm1_scl, expm1_1D
  END INTERFACE expm1

  INTERFACE lngamma
    MODULE PROCEDURE lngamma_scl, lngamma_1D
  END INTERFACE lngamma

  INTERFACE igamma
    MODULE PROCEDURE igamma_scl, igamma_1D
  END INTERFACE igamma

  INTERFACE igammac
    MODULE PROCEDURE igammac_scl, igammac_1D
  END INTERFACE igammac

  INTERFACE factorial
    MODULE PROCEDURE factorial_scl, factorial_1D
  END INTERFACE factorial

  INTERFACE betacf
    MODULE PROCEDURE betacf_scl, betacf_1D
  END INTERFACE betacf

  INTERFACE ibeta
    MODULE PROCEDURE ibeta_scl, ibeta_1D
  END INTERFACE ibeta

CONTAINS

  !==========================================================================
  ! EXP(X) - 1 = EXPM1(x)
  !
  !   Numerically accurate development of exp(x)-1 around 0, using the
  ! expansion of Abramowitz & Stegun (4.2.45). It is suposed to be accurate
  ! at 2.E-10.
  !==========================================================================

  PURE FUNCTION expm1_1D (x)

    USE utilities, ONLY: DP
    IMPLICIT NONE
    REAL(DP), DIMENSION(:), INTENT(IN) :: x
    REAL(DP), DIMENSION(SIZE(x)) :: expm1_1D

    INTEGER, PARAMETER :: Ncoef = 7
    REAL(DP), PARAMETER :: xmax = 0.6931472_DP ! ln(2)
    REAL(DP), DIMENSION(Ncoef), PARAMETER :: &
      coef = [ 0.9999999995_DP, 0.4999999206_DP, 0.1666653019_DP, &
               0.0416573475_DP, 0.0083013598_DP, 0.0013298820_DP, &
               0.0001413161_DP ]

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

    WHERE (ABS(x(:)) > xmax)
      expm1_1D(:) = EXP(x(:)) - 1._DP
    ELSEWHERE
      expm1_1D(:) = coef(7)*x(:)**7
      expm1_1D(:) = coef(6)*x(:)**6 + expm1_1D(:)
      expm1_1D(:) = coef(5)*x(:)**5 + expm1_1D(:)
      expm1_1D(:) = coef(4)*x(:)**4 + expm1_1D(:)
      expm1_1D(:) = coef(3)*x(:)**3 + expm1_1D(:)
      expm1_1D(:) = coef(2)*x(:)**2 + expm1_1D(:)
      expm1_1D(:) = coef(1)*x(:)**1 + expm1_1D(:)
    END WHERE

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

  END FUNCTION expm1_1D

  PURE FUNCTION expm1_scl (x)

    USE utilities, ONLY: DP
    IMPLICIT NONE
    REAL(DP), INTENT(IN) :: x
    REAL(DP) :: expm1_scl

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

    expm1_scl = MAXVAL(EXPM1_1D([x]))

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

  END FUNCTION expm1_scl

  !==========================================================================
  ! n! = FACTORIAL_SMALL(n)
  !
  !   Determines the factorial of a small integer as an integer.
  !==========================================================================

  RECURSIVE FUNCTION factorial_small (n) RESULT(fact)

    IMPLICIT NONE
    INTEGER, INTENT(IN) :: n
    INTEGER :: fact

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

    def: IF (n <= 1) THEN
      fact = 1
    ELSE
      fact = n*FACTORIAL_SMALL(n-1)
    END IF def

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

  END FUNCTION factorial_small

  !==========================================================================
  ! n! = FACTORIAL(n)
  !
  !   Determines the factorial of an integer.
  !==========================================================================

  FUNCTION factorial_scl (n)

    USE utilities, ONLY: DP, cumprod, arth
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: n
    REAL(DP) :: factorial_scl

    INTEGER, PARAMETER :: nmax = 32

    INTEGER, SAVE :: ntop = 0
    REAL(DP), DIMENSION(nmax), SAVE :: a

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

    IF (n < ntop) THEN
      factorial_scl = a(n+1)
    ELSE IF (n < nmax) THEN
      ntop = nmax
      a(1) = 1._DP
      a(2:nmax) = CUMPROD(ARTH(1._DP,1._DP,nmax-1))
      factorial_scl = a(n+1)
    ELSE
      factorial_scl = EXP(LNGAMMA(n+1._DP))
    END IF

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

  END FUNCTION factorial_scl

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

  FUNCTION factorial_1D (n)

    USE utilities, ONLY: DP, cumprod, arth
    IMPLICIT NONE
    INTEGER, DIMENSION(:), INTENT(IN) :: n
    REAL(DP), DIMENSION(SIZE(n)) :: factorial_1D

    INTEGER, PARAMETER :: nmax = 32

    LOGICAL, DIMENSION(SIZE(n)) :: mask
    INTEGER, SAVE :: ntop = 0
    REAL(DP), DIMENSION(nmax), SAVE :: a

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

    IF (ntop == 0) THEN
      ntop = nmax
      a(1) = 1._DP
      a(2:nmax) = CUMPROD(ARTH(1._DP,1._DP,nmax-1))
    END IF
    mask = (n >= nmax)
    factorial_1D = UNPACK(EXP(LNGAMMA(PACK(n,mask)+1.0_DP)),mask,0._DP)
    WHERE (.NOT. mask) factorial_1D = a(n+1)

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

  END FUNCTION factorial_1D

  !==========================================================================
  ! y = LN(GAMMA(x))
  !
  !   Log of gamma function for x > 0.
  !==========================================================================

  ELEMENTAL FUNCTION lngamma_scl (xx)

    USE utilities, ONLY: DP, arth
    IMPLICIT NONE
    REAL(DP), INTENT(IN) :: xx
    REAL(DP) :: lngamma_scl

    REAL(DP), PARAMETER :: stp = 2.5066282746310005_DP
    REAL(DP), DIMENSION(6), PARAMETER :: &
      coef = (/ 76.18009172947146_DP,     -86.50532032941677_DP, &
                24.01409824083091_DP,     -1.231739572450155_DP, &
                0.1208650973866179E-2_DP, -0.5395239384953E-5_DP /)

    REAL(DP) :: tmp, x

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

    x = xx
    tmp = x + 5.5_DP
    tmp = (x+0.5_DP)*LOG(tmp) - tmp
    lngamma_scl = tmp + LOG(stp*(1.000000000190015_DP &
                              +SUM(coef(:)/ARTH(x+1.0_DP,1.0_DP,SIZE(coef))))/x)

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

  END FUNCTION lngamma_scl

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

  PURE FUNCTION lngamma_1D (xx)

    USE utilities, ONLY: DP
    IMPLICIT NONE
    REAL(DP), DIMENSION(:), INTENT(IN) :: xx
    REAL(DP), DIMENSION(SIZE(xx)) :: lngamma_1D

    REAL(DP), PARAMETER :: stp = 2.5066282746310005_DP
    REAL(DP), DIMENSION(6), PARAMETER :: &
      coef = (/ 76.18009172947146_DP,     -86.50532032941677_DP, &
                24.01409824083091_DP,     -1.231739572450155_DP, &
                0.1208650973866179E-2_DP, -0.5395239384953E-5_DP /)

    INTEGER :: i
    REAL(DP), DIMENSION(SIZE(xx)) :: ser, tmp, x, y

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

    x = xx
    tmp = x + 5.5_DP
    tmp = (x+0.5_DP)*LOG(tmp) - tmp
    ser = 1.000000000190015_DP
    y = x
    DO i=1,SIZE(coef)
      y = y + 1.0_DP
      ser = ser + coef(i)/y
    END DO
    lngamma_1D = tmp + LOG(stp*ser/x)

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

  END FUNCTION lngamma_1D

  !==========================================================================
  ! IGAMMA(x) = 1/Gamma(a) * int(EXP(-t)*t^(a-1),{t=[0,x]}), a>0
  !
  !   Incomplete gamma function. We must have x >= 0 and a > 0. The preliminary
  ! functions GSER et GCF returns the two forms of the incomplete gamma function
  ! P(a,x) and Q(a,x) = 1 - P(a,x), with different numerical methods, depending
  ! on the parameter values.
  !==========================================================================

  ELEMENTAL FUNCTION gser_scl (a,x)

    USE utilities, ONLY: DP, epsDP
    IMPLICIT NONE

    REAL(DP), INTENT(IN) :: a, x
    REAL(DP) :: gser_scl

    INTEGER, PARAMETER :: itmax = 100

    INTEGER :: n
    REAL(DP) :: ap, del, summ

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

    IF (x == 0._DP) THEN
      gser_scl = 0._DP
      RETURN
    END IF
    ap = a
    summ = 1._DP / a
    del = summ
    DO n=1,itmax
      ap = ap + 1._DP
      del = del * x / ap
      summ = summ + del
      IF (ABS(del) < ABS(summ)*epsDP) EXIT
    END DO
    gser_scl = summ * EXP( -x + a*LOG(x) - LNGAMMA(a) )

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

  END FUNCTION gser_scl

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

  PURE FUNCTION gser_1D(a,x)

    USE utilities, ONLY: DP, epsDP
    IMPLICIT NONE

    REAL(DP), DIMENSION(:), INTENT(IN) :: a, x
    REAL(DP), DIMENSION(SIZE(a)) :: gser_1D

    INTEGER, PARAMETER :: itmax = 100

    INTEGER :: i, N
    REAL(DP), DIMENSION(SIZE(a)) :: ap, del, summ
    LOGICAL, DIMENSION(SIZE(a)) :: converged, zero

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

    N = SIZE(x(:))
    zero(:) = ( x(:) == 0._DP )
    WHERE (zero) gser_1D(:) = 0._DP
    ap(:) = a(:)
    summ(:) = 1._DP / a(:)
    del(:) = summ(:)
    converged(:) = zero(:)
    DO i=1,itmax
      WHERE (.NOT. converged(:))
        ap(:) = ap(:) + 1._DP
        del(:) = del(:) * x(:) / ap(:)
        summ(:) = summ(:) + del(:)
        converged(:) = (ABS(del(:)) < ABS(summ(:))*epsDP)
      END WHERE
      IF (ALL(converged(:))) EXIT
    END DO
    WHERE (.NOT. zero(:)) &
      gser_1D(:) = summ(:) * EXP( -x(:) + a(:)*LOG(x(:)) - LNGAMMA(a(:)) )

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

  END FUNCTION gser_1D

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

  ELEMENTAL FUNCTION gcf_scl(a,x)

    USE utilities, ONLY: DP, epsDP, tinyDP
    IMPLICIT NONE

    REAL(DP), INTENT(IN) :: a, x
    REAL(DP) :: gcf_scl

    INTEGER, PARAMETER :: itmax = 100
    REAL(DP), PARAMETER :: fpmin = tinyDP / epsDP

    INTEGER :: i
    REAL(DP) :: an, b, c, d, del, h

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

    IF (x == 0._DP) THEN
      gcf_scl = 1._DP
      RETURN
    ENDIF
    b = x + 1._DP - a
    c = 1._DP / fpmin
    d = 1._DP / b
    h = d
    DO i=1,itmax
      an = -i * (i-a)
      b = b + 2._DP
      d = an*d + b
      IF (ABS(d) < fpmin) d = fpmin
      c = b + an/c
      IF (ABS(c) < fpmin) c = fpmin
      d = 1._DP / d
      del = d * c
      h = h * del
      IF (ABS(del-1._DP) <= epsDP) EXIT
    END DO
    gcf_scl = EXP( -x + a*LOG(x) - LNGAMMA(a) ) * h

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

  END FUNCTION gcf_scl

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

  PURE FUNCTION gcf_1D(a,x)

    USE utilities, ONLY: DP, epsDP, tinyDP
    IMPLICIT NONE

    REAL(DP), DIMENSION(:), INTENT(IN) :: a, x
    REAL(DP), DIMENSION(SIZE(a)) :: gcf_1D

    INTEGER, PARAMETER :: itmax = 100
    REAL(DP), PARAMETER :: fpmin = tinyDP / epsDP

    INTEGER :: i, N
    REAL(DP), DIMENSION(SIZE(a)) :: an, b, c, d, del, h
    LOGICAL, DIMENSION(SIZE(a)) :: converged, zero

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

    N = SIZE(x(:))
    zero(:) = ( x(:) == 0._DP )
    WHERE (zero(:))
      gcf_1D(:) = 1._DP
    ELSEWHERE
      b(:) = x(:) + 1._DP - a(:)
      c(:) = 1._DP / fpmin
      d(:) = 1._DP / b(:)
      h(:) = d(:)
    END WHERE
    converged(:) = zero(:)
    DO i=1,itmax
      WHERE (.NOT. converged(:))
        an(:) = -i * (i-a(:))
        b(:) = b(:) + 2._DP
        d(:) = an(:)*d(:) + b(:)
        d(:) = MERGE( fpmin, d(:), ABS(d(:))<fpmin )
        c(:) = b(:) + an(:)/c(:)
        c(:) = MERGE( fpmin, c(:), ABS(c(:))<fpmin )
        d(:) = 1._DP / d(:)
        del(:) = d(:) * c(:)
        h(:) = h(:) * del(:)
        converged(:) = (ABS(del(:)-1._DP)<=epsDP)
      END WHERE
      IF (ALL(converged(:))) EXIT
    END DO
    WHERE (.NOT. zero(:)) &
      gcf_1D(:) = EXP( -x(:) + a(:)*LOG(x(:)) - LNGAMMA(a(:)) ) * h(:)

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

  END FUNCTION gcf_1D

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

  ELEMENTAL FUNCTION igamma_scl (a,x)

    USE utilities, ONLY: DP
    IMPLICIT NONE

    REAL(DP), INTENT(IN) :: a, x
    REAL(DP) :: igamma_scl

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

    IF ( x < a+1._DP ) THEN
      igamma_scl = GSER_SCL(a,x)
    ELSE
      igamma_scl = 1._DP - GCF_SCL(a,x)
    END IF

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

  END FUNCTION igamma_scl

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

  PURE FUNCTION igamma_1D (a,x)

    USE utilities, ONLY: DP
    IMPLICIT NONE

    REAL(DP), DIMENSION(:), INTENT(IN) :: a, x
    REAL(DP), DIMENSION(SIZE(x)) :: igamma_1D

    INTEGER :: N
    LOGICAL, DIMENSION(SIZE(x)) :: mask

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

    N = SIZE(x(:))
    mask(:) = ( x(:) < a(:)+1._DP )
    igamma_1D(:) = MERGE( GSER_1D(a(:),MERGE(x(:),0._DP,mask)), &
                          1._DP-GCF_1D(a(:),MERGE(x(:),0._DP,.NOT. mask(:))), &
                          mask(:) )

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

  END FUNCTION igamma_1D

  !==========================================================================
  ! IGAMMAC(x) = 1/Gamma(a) * int(EXP(-t)*t^(a-1),{t=[x,infty]}), a>0
  !
  !   Complementary incomplete gamma function, Q(a,x) = 1 - P(a,x). We must
  ! have x >= 0 and a > 0.
  !==========================================================================

  ELEMENTAL FUNCTION igammac_scl (a,x)

    USE utilities, ONLY: DP
    IMPLICIT NONE

    REAL(DP), INTENT(IN) :: a, x
    REAL(DP) :: igammac_scl

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

    IF ( x < a+1._DP) THEN
      igammac_scl = 1._DP - GSER_SCL(a,x)
    ELSE
      igammac_scl = GCF_SCL(a,x)
    END IF

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

  END FUNCTION igammac_scl

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

  PURE FUNCTION igammac_1D(a,x)

    USE utilities, ONLY: DP
    IMPLICIT NONE

    REAL(DP), DIMENSION(:), INTENT(IN) :: a, x
    REAL(DP), DIMENSION(SIZE(a)) :: igammac_1D
    LOGICAL, DIMENSION(SIZE(x)) :: mask
    INTEGER :: N

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

    N = SIZE(x(:))
    mask(:) = ( x(:) < a(:)+1._DP )
    igammac_1D = MERGE( 1._DP - GSER_1D(a(:),MERGE(x(:),0._DP,mask(:))), &
                        GCF_1D(a(:),MERGE(x(:),0._DP,.NOT. mask(:))), &
                        mask(:) )

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

  END FUNCTION igammac_1D

  !==========================================================================
  ! y[N] = BETACF(a[N],b[N],x[N])
  !
  !   Evaluates continued fraction for incomplete beta function by modified
  ! Lenz's method.
  !==========================================================================

  ELEMENTAL FUNCTION betacf_scl (a,b,x)

    USE utilities, ONLY: DP, tinyDP, epsDP
    IMPLICIT NONE

    REAL(DP), INTENT(IN) :: a, b, x
    REAL(DP) :: betacf_scl

    INTEGER, PARAMETER :: maxit = 100
    REAL(DP), PARAMETER :: fpmin = tinyDP/epsDP

    INTEGER :: m, m2
    REAL(DP) :: aa, c, d, del, h, qab, qam, qap

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

    qab = a + b
    qap = a + 1._DP
    qam = a - 1._DP
    c = 1._DP
    d = 1._DP - qab*x/qap
    IF (ABS(d) < fpmin) d = fpmin
    d = 1._DP/d
    h = d
    DO m=1,maxit
      m2 = 2*m
      aa = m * (b-m) * x / ((qam+m2)*(a+m2))
      d = 1._DP + aa*d
      IF (ABS(d) < fpmin) d = fpmin
      c = 1._DP + aa/c
      IF (ABS(c) < fpmin) c = fpmin
      d = 1._DP/d
      h = h*d*c
      aa = - (a+m) * (qab+m) * x / ((a+m2)*(qap+m2))
      d = 1._DP + aa*d
      IF (ABS(d) < fpmin) d = fpmin
      c = 1._DP + aa/c
      IF (ABS(c) < fpmin) c = fpmin
      d = 1._DP / d
      del = d*c
      h = h*del
      IF (ABS(del-1._DP) <= epsDP) EXIT
    END DO

    betacf_scl = h

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

  END FUNCTION betacf_scl

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

  PURE FUNCTION betacf_1D (a,b,x)

    USE utilities, ONLY: DP, tinyDP, epsDP
    IMPLICIT NONE

    REAL(DP), DIMENSION(:), INTENT(IN) :: a, b, x
    REAL(DP), DIMENSION(SIZE(x)) :: betacf_1D

    INTEGER, PARAMETER :: maxit = 100
    REAL(DP), PARAMETER :: fpmin = tinyDP/epsDP

    INTEGER :: m
    INTEGER, DIMENSION(SIZE(x)) :: m2
    REAL(DP), DIMENSION(SIZE(x)) :: aa, c, d, del, h, qab, qam, qap
    LOGICAL, DIMENSION(SIZE(x)) :: converged

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

    m = SIZE(x)
    qab = a + b
    qap = a + 1._DP
    qam = a - 1._DP
    c = 1._DP
    d = 1._DP - qab*x/qap
    WHERE (ABS(d) < fpmin) d = fpmin
    d = 1._DP/d
    h = d
    converged = .FALSE.
    DO m=1,maxit
      WHERE (.NOT. converged)
        m2 = 2*m
        aa = m * (b-m) * x / ((qam+m2)*(a+m2))
        d = 1._DP + aa*d
        d = MERGE(fpmin,d,ABS(d)<fpmin)
        c = 1._DP + aa/c
        c = MERGE(fpmin,c,ABS(c)<fpmin)
        d = 1._DP/d
        h = h*d*c
        aa = - (a+m) * (qab+m) * x / ((a+m2)*(qap+m2))
        d = 1._DP + aa*d
        d = MERGE(fpmin,d,ABS(d)<fpmin)
        c = 1._DP + aa/c
        c = MERGE(fpmin,c,ABS(c)<fpmin)
        d = 1._DP/d
        del = d*c
        h = h*del
        converged = (ABS(del-1._DP) <= epsDP)
      END WHERE
      IF (ALL(converged)) EXIT
    END DO

    betacf_1D = h

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

  END FUNCTION betacf_1D

  !==========================================================================
  ! y[N] = IBETA(a[N],b[N],x[N])
  !
  !   Incomplete beta function.
  !==========================================================================

  ELEMENTAL FUNCTION ibeta_scl (a,b,x)

    USE utilities, ONLY: DP
    IMPLICIT NONE

    REAL(DP), INTENT(IN) :: a, b, x
    REAL(DP) :: ibeta_scl
    REAL(DP) :: bt

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

    IF (x == 0._DP .OR. x == 1._DP) THEN
      bt = 0._DP
    ELSE
      bt = EXP( LNGAMMA(a+b) - LNGAMMA(a) - LNGAMMA(b) &
              + a*LOG(x) + b*LOG(1._DP-x) )
    END IF
    IF (x < (a+1._DP)/(a+b+2._DP)) THEN
      ibeta_scl = bt * BETACF(a,b,x) / a
    ELSE
      ibeta_scl = 1._DP - bt * BETACF(b,a,1._DP-x) / b
    END IF

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

  END FUNCTION ibeta_scl

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

  PURE FUNCTION ibeta_1D (a,b,x)

    USE utilities, ONLY: DP
    IMPLICIT NONE

    REAL(DP), DIMENSION(:), INTENT(IN) :: a, b, x
    REAL(DP), DIMENSION(SIZE(a)) :: ibeta_1D

    INTEGER :: ndum
    REAL(DP), DIMENSION(SIZE(a)) :: bt
    LOGICAL, DIMENSION(SIZE(a)) :: mask

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

    ndum = SIZE(x)
    WHERE (x == 0._DP .OR. x == 1._DP)
      bt = 0._DP
    ELSEWHERE
      bt = EXP( LNGAMMA(a+b) - LNGAMMA(a) - LNGAMMA(b) &
              + a*LOG(x) + b*LOG(1._DP-x) )
    END WHERE
    mask = (x < (a+1._DP)/(a+b+2._DP))
    ibeta_1D = bt * BETACF(MERGE(a,b,mask),MERGE(b,a,mask), &
                            MERGE(x,1._DP-x,mask)) / MERGE(a,b,mask)
    WHERE (.NOT. mask) ibeta_1D = 1._DP - ibeta_1D

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

  END FUNCTION ibeta_1D

END MODULE special_functions


FUNCTION determinant(jac)RESULT(det)
!
! This function returns the determinant of a 1x1, 2x2 or 3x3
! Jacobian matrix.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::jac(:,:)
 REAL(iwp)::det
 INTEGER::it
 it=UBOUND(jac,1)
 SELECT CASE(it)
 CASE(1)
   det=1.0_iwp
 CASE(2)
   det=jac(1,1)*jac(2,2)-jac(1,2)*jac(2,1)
 CASE(3)
   det=jac(1,1)*(jac(2,2)*jac(3,3)-jac(3,2)*jac(2,3))
   det=det-jac(1,2)*(jac(2,1)*jac(3,3)-jac(3,1)*jac(2,3))
   det=det+jac(1,3)*(jac(2,1)*jac(3,2)-jac(3,1)*jac(2,2))
 CASE DEFAULT
   WRITE(*,*)' wrong dimension for Jacobian matrix'
 END SELECT
RETURN
END FUNCTION determinant


c
c
c ... file rgrd1.f
c
c     this file contains documentation for subroutine rgrd1 followed by
c     fortran code for rgrd1 and additional subroutines.
c
c ... author
c
c     John C. Adams (NCAR 1999)
c
c ... subroutine rgrd1(nx,x,p,mx,xx,q,intpol,w,lw,iw,liw,ier)
c
c ... purpose
c
c     subroutine rgrd1 interpolates the values p(i) on the grid x(i)
c     for i=1,...,nx onto q(ii) on the grid xx(ii),ii=1,...,mx.
c
c ... language
c
c     coded in portable FORTRAN90 and FORTRAN77
c
c ... test program
c
c     file trgrd1.f on regridpack includes a test program for subroutine rgrd1
c
c ... method
c
c     Linear interpolation (intpol=1)
c
c       Given ii in the integer interval [1,mx], let i be the
c       largest integer in the integer interval [1,nx-1] such
c       that x(i) is less than or equal to xx(ii).  Then q(ii)
c       at xx(ii) is linearly interpolated from p(i),p(i+1) at
c       x(i),x(i+1).
c
c     Cubic interpolation (intpol=3)
c
c       Given ii in the integer interval [1,mx], let i be the
c       largest integer in the integer interval [2,nx-2] such
c       that x(i) is less than or equal to xx(ii).  Then q(ii)
c       at xx(ii) is cubically interpolated from p(i-1),p(i),
c       p(i+1),p(i+2) at x(i-1),x(i),x(i+1),x(i+2).
c
c ... required files
c
c     none
c
c ... requirements
c
c     x must be a strictly increasing grid and xx must be an increasing
c     grid (see ier = 4).  in addition the interval
c
c          [xx(1),xx(mx)]
c
c     must lie within the interval
c
c          [x(1),x(nx)].
c
c     extrapolation is not allowed (see ier=3).  if these intervals
c     are identical and the x and xx grids are UNIFORM then subroutine
c     rgrd1u (see file rgrd1u.f) should be used in place of rgrd1.
c
c ... required files
c
c     none
c
c ... efficiency
c
c     inner most loops in regridpack software vectorize.
c
c
c *** input arguments
c
c
c ... nx
c
c     the integer dimension of the grid vector x and the dimension of p.
c     nx > 1 if intpol = 1 or nx > 3 if intpol = 3 is required.
c
c ... x
c
c     a real nx vector of strictly increasing values which defines the x
c     grid on which p is given.
c
c
c ... p
c
c     a real nx vector of values given on the x grid
c
c ... mx
c
c     the integer dimension of the grid vector xx and the dimension of q.
c     mx > 0 is required.
c
c ... xx
c
c     a real mx vector of increasing values which defines the
c     grid on which q is defined.  xx(1) < x(1) or xx(mx) > x(nx)
c     is not allowed (see ier = 3)
c
c ... intpol
c
c     an integer which sets linear or cubic
c     interpolation as follows:
c
c        intpol = 1 sets linear interpolation
c        intpol = 3 sets cubic interpolation
c
c     values other than 1 or 3 in intpol are not allowed (ier = 6).
c
c ... w
c
c     a real work space of length at least lw which must be provided in the
c     routine calling rgrd1
c
c
c ... lw
c
c     the integer length of the real work space w.  let
c
c          lwmin =   mx            if intpol(1) = 1
c          lwmin = 4*mx            if intpol(1) = 3
c
c     then lw must be greater than or equal to lwmin
c
c ... iw
c
c     an integer work space of length at least liw which must be provided in the
c     routine calling rgrd1
c
c ... liw
c
c     tne length of the integer work space iw. liw must be greater than or equal to mx.
c
c
c *** output arguments
c
c
c ... q
c
c     a real mx vector of values on the xx grid which are
c     interpolated from p on the x grid
c
c ... ier
c
c     an integer error flag set as follows:
c
c     ier = 0 if no errors in input arguments are detected
c
c     ier = 1 if  mx < 1
c
c     ier = 2 if nx < 2 when intpol=1 or nx < 4 when intpol=3
c
c     ier = 3 if xx(1) < x(1) or x(nx) < xx(mx)
c
c *** to avoid this flag when end points are intended to be the
c     same but may differ slightly due to roundoff error, they
c     should be set exactly in the calling routine (e.g., if both
c     grids have the same x boundaries then xx(1)=x(1) and xx(mx)=x(nx)
c     should be set before calling rgrd1)
c
c     ier = 4 if the x grid is not strictly monotonically increasing
c             or if the xx grid is not montonically increasing.  more
c             precisely if:
c
c             x(i+1) <= x(i) for some i such that 1 <= i < nx (or)
c
c             xx(ii+1) < xx(ii) for some ii such that 1 <= ii < mx
c
c     ier = 5 if lw or liw is too small (insufficient work space)
c
c     ier = 6 if intpol is not equal to 1 or 3
c
c ************************************************************************
c
c     end of rgrd1 documentation, fortran code follows:
c
c ************************************************************************
c
      subroutine rgrd1(nx,x,p,mx,xx,q,intpol,w,lw,iw,liw,ier)
c     dimension x(nx),p(nx),xx(mx),q(mx),w(lw)
      implicit none
      real x(*),p(*),xx(*),q(*),w(*)
      integer iw(*)
      integer nx,mx,ier,intpol,lw,liw,i,ii,i1,i2,i3,i4
c
c     check arguments for errors
c
      ier = 1
c
c     check xx grid resolution
c
      if (mx .lt. 1) return
c
c     check intpol
c
      ier = 6
      if (intpol.ne.1 .and. intpol.ne.3) return
c
c     check x grid resolution
c
      ier = 2
      if (intpol.eq.1 .and. nx.lt.2) return
      if (intpol.eq.3 .and. nx.lt.4) return
c
c     check xx grid contained in x grid
c
      ier = 3
      if (xx(1).lt.x(1) .or. xx(mx).gt.x(nx)) return
c
c     check montonicity of grids
c
      do i=2,nx
	if (x(i-1).ge.x(i)) then
	  ier = 4
	  return
	end if
      end do
      do ii=2,mx
	if (xx(ii-1).gt.xx(ii)) then
	  ier = 4
	  return
	end if
      end do
c
c     check minimum work space lengths
c
      if (intpol.eq.1) then
	if (lw .lt. mx) return
      else
	if (lw .lt. 4*mx) return
      end if
      if (liw .lt. mx) return
c
c     arguments o.k.
c
      ier = 0

      if (intpol.eq.1) then
c
c     linear interpolation in x
c
      i1 = 1
      i2 = i1+mx
      call linmx(nx,x,mx,xx,iw,w)
      call lint1(nx,p,mx,q,iw,w)
      return
      else
c
c     cubic interpolation in x
c
      i1 = 1
      i2 = i1+mx
      i3 = i2+mx
      i4 = i3+mx
      call cubnmx(nx,x,mx,xx,iw,w(i1),w(i2),w(i3),w(i4))
      call cubt1(nx,p,mx,q,iw,w(i1),w(i2),w(i3),w(i4))
      return
      end if
      end

      subroutine lint1(nx,p,mx,q,ix,dx)
c     dimension p(nx),q(mx),ix(mx),dx(mx)
      implicit none
      integer mx,ix(mx),nx,ii,i
      real p(nx),q(mx),dx(mx)
c
c     linearly interpolate p on x onto q on xx
c
      do ii=1,mx
	i = ix(ii)
	q(ii) = p(i)+dx(ii)*(p(i+1)-p(i))
      end do
      return
      end

      subroutine cubt1(nx,p,mx,q,ix,dxm,dx,dxp,dxpp)
      implicit none
      integer mx,ix(mx),nx,i,ii
      real p(nx),q(mx),dxm(mx),dx(mx),dxp(mx),dxpp(mx)
c
c     cubically interpolate p on x to q on xx
c
      do ii=1,mx
	i = ix(ii)
	q(ii) = dxm(ii)*p(i-1)+dx(ii)*p(i)+dxp(ii)*p(i+1)+dxpp(ii)*p(i+2)
      end do
      return
      end

      subroutine linmx(nx,x,mx,xx,ix,dx)
c
c     set x grid pointers for xx grid and interpolation scale terms
c
      implicit none
      real x(*),xx(*),dx(*)
      integer ix(*),isrt,ii,i,nx,mx
      isrt = 1
      do ii=1,mx
c
c     find x(i) s.t. x(i) < xx(ii) <= x(i+1)
c
	do i=isrt,nx-1
	  if (x(i+1) .ge. xx(ii)) then
	    isrt = i
	    ix(ii) = i
	    go to 3
	  end if
	end do
    3   continue
      end do
c
c     set linear scale term
c
      do ii=1,mx
	i = ix(ii)
	dx(ii) = (xx(ii)-x(i))/(x(i+1)-x(i))
      end do
      return
      end

      subroutine cubnmx(nx,x,mx,xx,ix,dxm,dx,dxp,dxpp)
      implicit none
      real x(*),xx(*),dxm(*),dx(*),dxp(*),dxpp(*)
      integer ix(*),mx,nx,i,ii,isrt

      isrt = 1
      do ii=1,mx
c
c     set i in [2,nx-2] closest s.t.
c     x(i-1),x(i),x(i+1),x(i+2) can interpolate xx(ii)
c
	do i=isrt,nx-1
	  if (x(i+1) .ge. xx(ii)) then
	    ix(ii) = min0(nx-2,max0(2,i))
	    isrt = ix(ii)
	    go to 3
	  end if
	end do
    3   continue
      end do
c
c     set cubic scale terms
c
      do ii=1,mx
	i = ix(ii)
	dxm(ii) = (xx(ii)-x(i))*(xx(ii)-x(i+1))*(xx(ii)-x(i+2))/
     +          ((x(i-1)-x(i))*(x(i-1)-x(i+1))*(x(i-1)-x(i+2)))
	dx(ii) = (xx(ii)-x(i-1))*(xx(ii)-x(i+1))*(xx(ii)-x(i+2))/
     +          ((x(i)-x(i-1))*(x(i)-x(i+1))*(x(i)-x(i+2)))
	dxp(ii) = (xx(ii)-x(i-1))*(xx(ii)-x(i))*(xx(ii)-x(i+2))/
     +          ((x(i+1)-x(i-1))*(x(i+1)-x(i))*(x(i+1)-x(i+2)))
	dxpp(ii) = (xx(ii)-x(i-1))*(xx(ii)-x(i))*(xx(ii)-x(i+1))/
     +          ((x(i+2)-x(i-1))*(x(i+2)-x(i))*(x(i+2)-x(i+1)))
      end do
      return
      end


module aloha_constants
    ! Code working precision
    integer, parameter :: wp = kind(1.0D0)
    ! 10 decimals numbers and a dynamic of 10^60
!     integer, parameter :: wp = selected_real_kind(10,60)
    ! mathematical constants
    real(kind=wp), parameter :: pi = 3.14159265358979323846264338327950288419716939937510
    complex, parameter       :: ImU = (0.0,1.0) 	! Imaginary Unit
    ! physics constants
    real(kind=wp), parameter :: cl = 299792458.0     ! Vacuum light velocity
    real(kind=wp), parameter :: mu0= 4.0*pi*1.E-7    ! Vacuum permeability
    real(kind=wp), parameter :: Eps0=8.854187E-12    ! Vacuum permittivity
    real(kind=wp), parameter :: Z0 = mu0*cl          ! Vacuum impedance
    real(kind=wp), parameter :: Y0 = 1.0/Z0          ! Vacuum inductance
    ! Electron properties
    real(kind=wp), parameter :: me = 9.10938215E-31  ! Electron mass
    real(kind=wp), parameter :: qe = 1.602176487E-19 ! Electron Electric charge (modulus)
    ! misc.
    real, parameter          :: pc = 1.*1.E-3

end module aloha_constants


	FUNCTION PR_TMPK  ( pres, thta )
C************************************************************************
C* PR_TMPK				                                *
C*									*
C* This function computes TMPK from PRES and THTA.  The Poisson		*
C* equation is used:							*
C*									*
C*             TMPK = THTA * ( PRES / 1000 ) ** RKAPPA			*
C*									*
C* REAL PR_TMPK  ( PRES, THTA )						*
C*									*
C* Input parameters:							*
C*	PRES		REAL		Pressure in millibars		*
C*	THTA		REAL    	Potential temperature in K	*
C*									*
C* Output parameters:							*
C*	PR_TMPK		REAL		Temperature in Kelvin		*
C**									*
C* Log:									*
C* T. Roegner/CSC	6/80	Original source code			*
C* M. Goodman/RDS	3/84	Modified prologue and KAPPA		*
C* I. Graffman/RDS	12/87	GEMPAK4					*
C* G. Huffman/GSC	8/88	Documentation; check PRES .lt. 0	*
C************************************************************************
        INCLUDE         'GEMPRM.PRM'
        INCLUDE         'ERMISS.FNC'
C------------------------------------------------------------------------
	IF  ( ERMISS ( pres ) .or. ERMISS ( thta )
     *       .or. ( pres .lt. 0. ) )  THEN
	    PR_TMPK = RMISSD
	  ELSE
C
C*	    The Poisson equation.
C
	    PR_TMPK = thta * ( pres / 1000. ) ** RKAPPA
	END IF
C*
	RETURN
	END


c     program DRDUCOMP
c>> 1994-10-19 DRDUCOMP Krogh  Changes to use M77CON
c>> 1994-08-04 DRDUCOMP CLL New subroutine: DUSETN
c>> 1992-02-17 CLL
c>> 1990-12-13 CLL Added demo of DUREV.
c>> 1987-12-09 DRDUCOMP Lawson  Initial Code.
c     Demo driver for the DUCOMP package, including DUREV.
c     The DUCOMP package computes partial derivatives.
c     DUREV does series reversion involving 1st and 2nd partial
c     derivatives of N functions of N variables.
c     ------------------------------------------------------------------
c--D replaces "?": DR?UCOMP, ?UCOMP, ?UREV, ?USETN, ?USET, ?UATN2
c--   &         ?UPRO, ?USUM, ?USQRT, ?UQUO, ?UATAN, ?UCOS, ?USIN, ?COPY
c     ------------------------------------------------------------------
      integer I, LDIM, NMAX
      parameter(NMAX = 3, LDIM = ((NMAX+2)*(NMAX+1))/2)
      integer IWORK(NMAX)
      double precision X(LDIM), Y(LDIM), Z(LDIM)
      double precision R(LDIM), PHI(LDIM), THETA(LDIM)
      double precision SSQ(LDIM), S(LDIM), TEMP(LDIM)
      double precision X2(LDIM), Y2(LDIM), Z2(LDIM)
      double precision XSQ(LDIM), YSQ(LDIM), ZSQ(LDIM)
      double precision XVAL, YVAL, ZVAL, RSQ(LDIM), ZBYS(LDIM)
      double precision SP(LDIM), CP(LDIM), ST(LDIM), CT(LDIM)
      double precision WORK(NMAX,NMAX,3), RCOND
      double precision UT(LDIM,NMAX), TU(LDIM,NMAX)
      double precision X1(LDIM), X3(LDIM), T1(LDIM), T2(LDIM), T3(LDIM)
      parameter(XVAL = 0.1D0, YVAL = 0.2D0, ZVAL = 0.3D0)
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c                                   Set N, M1, and M2.
      call DUSETN(NMAX, 0, 2)
c                                   Initialize independent variables.
      call DUSET(XVAL,1,X)
      call DUSET(YVAL,2,Y)
      call DUSET(ZVAL,3,Z)
      print'(1x,a)',
     * 'DRDUCOMP..  Demo driver for the DUCOMP package.',
     * 'This demo first transforms (x,y,z) to (r,theta,phi),',
     * 'and then transforms back, including computation of',
     * '1st and 2nd partial derivatives.'
      write(*,'(1x/8x,10a)') '  VALUE','     D1','     D2','     D3',
     *   '    D11','    D21','    D22','    D31','    D32','    D33'
      write(*,'(1x/(1x,a,10f7.3))')
     *  '    X =',X,'    Y =',  Y,'    Z =',Z
c
c                                Transform from (x,y,z) to (r,theta,phi)
      call DUATN2(Y, X, PHI)
      call DUPRO(X, X, XSQ)
      call DUPRO(Y, Y, YSQ)
      call DUPRO(Z, Z, ZSQ)
      call DUSUM(XSQ, YSQ, SSQ)
      call DUSUM(SSQ, ZSQ, RSQ)
      call DUSQRT(RSQ, R)
      call DUSQRT(SSQ, S)
      call DUQUO(Z, S, ZBYS)
      call DUATAN(ZBYS, THETA)
      write(*,'(1x/(1x,a,10f7.3))')
     *  '    R =',R,'  PHI =',PHI,'THETA =',THETA
c
c                           Transform back from (r,theta,phi) to (x,y,z)
      call DUCOS(PHI, CP)
      call DUCOS(THETA, CT)
      call DUPRO(CP, CT, TEMP)
      call DUPRO(TEMP, R, X2)
      call DUSIN(PHI, SP)
      call DUPRO(SP, CT, TEMP)
      call DUPRO(TEMP, R, Y2)
      call DUSIN(THETA, ST)
      call DUPRO(ST, R, Z2)
      write(*,'(1x/(1x,a,10f7.3))')
     *  '    X =',X2,'    Y =',  Y2,'    Z =',Z2
c
c                          Set data to call DUREV.
c
      call DCOPY(LDIM, R,1, UT(1,1),1)
      call DCOPY(LDIM, PHI,1, UT(1,2),1)
      call DCOPY(LDIM, THETA,1, UT(1,3),1)
      TU(1,1) = X(1)
      TU(1,2) = Y(1)
      TU(1,3) = Z(1)
      call DUREV( UT, TU, LDIM, RCOND, IWORK, WORK)

      write(*,'(a)') ' ',
     * ' To demo DUREV we store (R, PHI, THETA) including',
     * ' the first and second derivatives w.r.t. (X,Y,Z) into UT(),',
     * ' and set TU() = (X, Y, Z).',
     * ' Then compute (TU1,TU2,TU3) using DUREV.',
     * ' For comparison compute (T1,T2,T3) using the known functional',
     * ' definition of (X, Y, Z) as a function of (R, PHI, THETA).'

      write(*,'(1x/(1x,a,10f7.3))')
     *  '  TU1 =',(TU(I,1),I=1,LDIM),
     *  '  TU2 =',(TU(I,2),I=1,LDIM),
     *  '  TU3 =',(TU(I,3),I=1,LDIM)
c
c              For comparison set X1, X2, X3, and transform them to
c              T1, T2, T3.  These are the same operations as
c              transforming from (r,theta,phi) to (x,y,z).
c
      call DUSET(R(1),1,X1)
      call DUSET(PHI(1),2,X2)
      call DUSET(THETA(1),3,X3)
c
      call DUCOS(X2, CP)
      call DUCOS(X3, CT)
      call DUPRO(CP, CT, TEMP)
      call DUPRO(TEMP, X1, T1)
      call DUSIN(X2, SP)
      call DUPRO(SP, CT, TEMP)
      call DUPRO(TEMP, X1, T2)
      call DUSIN(X3, ST)
      call DUPRO(ST, X1, T3)
      write(*,'(1x/(1x,a,10f7.3))')
     *  '   T1 =',T1,'   T2 =',  T2,'   T3 =',T3
      end


Module root_finder

  Implicit None

  Contains

  Subroutine lapack_root_finder(coefficients, real_part_root, img_part_root)

    ! Find roots of a polynomial using a companion matrix.

    ! Warning: The polynomial degree is different from the coefficient array size.
    !          Ex.:
    !               The polynomial: a + x + x^2 = 0, has a coefficient array of
    !               size 3, but its degree is 2.

    ! Parameters:
    !             coefficients: Real*8, Dimension(:)
    !                           Stores the coefficients of a polynomial.
    ! Returns:
    !             real_part_root: Real*8, Allocatable, Dimension(:)
    !                             The real part of a root.
    !             img_part_root:  Real*8, Allocatable, Dimension(:)
    !                             The imaginary part of a root.

    Implicit None

    Real*8, Allocatable, Dimension(:), intent(out) :: real_part_root, img_part_root
    Real*8, Dimension (:), intent(in) :: coefficients

    Integer*4, Parameter :: Nb = 64
    Integer*4 :: LWORK

    Integer*4 LDA, Info

    Real*8 Dummy(1,1)
    Real*8, Allocatable, Dimension (:,:) :: Companion_matrix
    Real*8, Allocatable, Dimension (:) :: WORK

    Integer*4 j
    Integer*4 pol_degree
    Real*8 normalization

    pol_degree = size(coefficients) - 1

    Allocate(real_part_root(pol_degree), img_part_root(pol_degree))

    LWORK = (2 + Nb) * 3 * (pol_degree + 1)

    LDA = pol_degree

    Allocate(Companion_matrix(LDA, pol_degree), WORK(LWORK))

    Companion_matrix = 0.0d0

    Do j = 2, pol_degree

       Companion_matrix(j - 1, j) = 1.0d0

    end do

    normalization = coefficients(pol_degree + 1)

    if( normalization == 0.0d0 )then
      print*,'Normalization is zero, this will cause infinity coefficients.'
      stop
    end if

    Do j = 1, pol_degree

      Companion_matrix(pol_degree, j) = ( -1.0d0 * coefficients(j) ) / normalization

    end do

    ! First the program find the best array size to work with.
    Call DGEEV('No left vectors', 'No right vectors', pol_degree, &
               Companion_matrix, LDA, real_part_root, &
               img_part_root, Dummy, 1, Dummy, 1, WORK, -1, Info)

    LWORK = min(int(LWORK), int(WORK(1)));

    Deallocate(WORK)

    Allocate(WORK(LWORK))

    ! Now it diagonalize the matrice.
    Call DGEEV('No left vectors', 'No right vectors', pol_degree, &
               Companion_matrix, LDA, real_part_root, &
               img_part_root, Dummy, 1, Dummy, 1, WORK, LWORK, Info)

    if( Info /= 0 )then
     print*,' '
     write(*,*)'INFO:', Info, LWORK
     write(*,*)'The algorithm had some problems finding the roots.'
     print*,' '
    end if

  End Subroutine lapack_root_finder

  Subroutine save_roots_arq(real_part_root, img_part_root, arq_name)

    ! Save in a file all the roots found.

    ! The first column will be the real part of the root and the second the
    ! imaginary part.

    ! Parameters:
    !             arq_name:       Character(len=*)
    !                             Name of the file where the roots will be recorded.

    ! Returns:
    !             real_part_root: Real*8
    !                             The real part of a root.
    !             img_part_root:  Real*8
    !                             The imaginary part of a root.

    Real*8, Dimension (:), intent(in) :: real_part_root, img_part_root
    Character(len=*), intent(in) :: arq_name

    Integer*4 j

    Open(Unit = 100, file = arq_name)

    write(100,'("#",6X,"Real Part",15X,"Imaginary Part")')

    if(size(real_part_root) /= size(img_part_root))then
      print*, 'Different sizes:'
      print*, 'real_part_root', size(real_part_root)
      print*, 'img_part_root', size(img_part_root)
      stop
    end if

    Do j = 1, size(real_part_root)

      If(img_part_root(j) .eq. 0.0d0)then

        write(100,*) real_part_root(j), 0.0d0            ! Write real roots.

      else

        write(100,*) real_part_root(j), img_part_root(j) ! Write imaginary roots.

      end if
    end do

    close(100)

  End Subroutine save_roots_arq

End Module root_finder

Module utils

  Implicit None

  Contains

  Subroutine number_of_rows_in_file(arq_name, rows_number)

    ! Return the number of rows of a file.

    ! Parameters:
    !             arq_name:    Character(len=*)
    !                          Name of the file to be checked.
    ! Returns:
    !             rows_number: Integer*4
    !                          Number of rows in the file.

    Implicit None

    Character(len=*), intent(in) :: arq_name
    Integer*4, intent(out) :: rows_number

    Integer*4 end_of_file, err

    Open(100, file=Trim(arq_name), status='old', iostat=err)

    Call open_file_error(arq_name, err, 'number_of_rows_in_file')

    rows_number = 0

    Do

      Read(100, *, IOSTAT = end_of_file)

      if( IS_IOSTAT_END(end_of_file) ) exit

      rows_number = rows_number + 1

    end do

    Close(100)

  End Subroutine number_of_rows_in_file

  Subroutine open_file_error(arq_name, err, sub_name)

    ! Check if a file was open, if not print an error menssage and stop
    ! the program.

      ! Parameters:
      !             arq_name:  Character(len=*)
      !                        Name of the file to be checked.
      !
      !             err:       Integer*4
      !                        Error number identification.
      !
      !             sub_name:  Character(len=*)
      !                        Subroutine name.
      !
      ! Returns:
      !            Returns Returns nothing.

    Implicit None

    Integer*4, intent(in) :: err
    Character(len=*), intent(in) :: arq_name, sub_name

    if (err /= 0) then
      print*,'File (', Trim(arq_name), ') does not exist.'
      print*,'Subroutine name: ', sub_name
      print*,'Erro number:', err
      stop
    end if

  End Subroutine open_file_error

End Module utils

Program Main

  Implicit None

  Call system('mkdir roots')

  !=====================================!
  ! Find the roots a simple polynomial. !
  !=====================================!
  Call simple_polynomial

  !==============================================!
  ! Find the roots of a high degree polynomial,  !
  ! reading the polynomial coefficients from a   !
  ! file.                                        !
  !==============================================!
  Call high_degree_polynomial

End Program Main

Subroutine simple_polynomial

  Use root_finder
  Implicit None

  Real*8, Allocatable, Dimension (:) :: coefficients                    ! Polynomial coefficients.
  Real*8, Allocatable, Dimension (:) :: img_part_root, real_part_root   ! Imaginary and real part of the roots.
  Integer*4 pol_degree                                                  ! Polynomial degree.

  Character*60 arq_name   ! File name where roots values will be saved.

  !==========================================================!
  !   We will use the polynomial 4 - x^2 = 0 as an example   !
  !==========================================================!

  pol_degree = 2        ! Polynomial degree

  Allocate(coefficients(pol_degree + 1)) ! The +1 is to count the constant term c. (c + x + x^2)

  coefficients(1) = 4    ! Constant (c)
  coefficients(2) = 0    ! First term (x^1)
  coefficients(3) = -1   ! Second term (x^2)

  ! Lapack root finder subroutine.
  Call lapack_root_finder(coefficients, real_part_root, img_part_root)

  ! File name where roots will be stored.
  arq_name = 'roots/simple_roots.dat'

  ! Save root in a file.
  Call save_roots_arq(real_part_root, img_part_root, arq_name)

  print*, ''
  print*, 'Solving: 4 - x^2 = 0'
  print*, 'Roots:', real_part_root(1), img_part_root(1)
  print*, 'Roots:', real_part_root(2), img_part_root(2)
  print*, ''

End Subroutine simple_polynomial

Subroutine high_degree_polynomial

  Use root_finder
  Use utils
  Implicit None

  Real*8, Allocatable, Dimension (:) :: coefficients                    ! Polynomial coefficients.
  Real*8, Allocatable, Dimension (:) :: img_part_root, real_part_root   ! Imaginary and real part of the roots.
  Integer*4 rows_number, i, err

  Character(len=60) arq_name

  ! The name of the file name where the coefficients are stored.
  arq_name = 'HD_coefficients/HD_coefficients.dat'

  ! Get the number of rows in the file.
  Call number_of_rows_in_file(arq_name, rows_number)

  Allocate(coefficients(rows_number))

  Open(100, file=arq_name)
  Call open_file_error(arq_name, err, 'high_degree_polynomial')

  ! Read the file to get the coefficients.
  Do i = 1, rows_number
    read(100, *) coefficients(i)
  end do

  print*, ''
  print*, 'Solving a high degree polynomial.'

  ! Lapack root finder subroutine.
  Call lapack_root_finder(coefficients, real_part_root, img_part_root)

  arq_name = 'roots/HD_polynomial_roots.dat'

  ! Save root in a file.
  Call save_roots_arq(real_part_root, img_part_root, arq_name)

  print*,''
  print*,'Done.'
  print*,''

  print*,'See the roots in file: ', Trim(arq_name)
  print*, ''

End Subroutine high_degree_polynomial


!	elemental
!
!Pure procedures are procedures declared with the PURE keyword and which
!satisfy certain constraints that ensure they have no side
!effects. They can be used in specification expressions and
!within FORALL constructs and statements.

!Elemental procedures can be written in Fortran 95 using the ELEMENTAL
!keyword. Elemental procedures are automatically ``pure''.

!Example:

	PURE REAL FUNCTION pure_func(x,y) ! pure okay
		IMPLICIT NONE
		REAL, INTENT(IN) ::  x, y
		pure_func = x*x + y*y + 2*x*y + ASIN(MIN(x/y,y/x))
	END FUNCTION pure_func

	PURE REAL FUNCTION F(x,y) ! pure broken returns 'PURE REAL FU'
		IMPLICIT NONE
		REAL, INTENT(IN) ::  x, y
		F = x*x + y*y + 2*x*y + ASIN(MIN(x/y,y/x))
	END FUNCTION F

	ELEMENTAL REAL FUNCTION elem_maxabs(a,b) ! elemental broke
		IMPLICIT NONE
		REAL,INTENT(IN) :: a,b
		elem_maxabs = MAX(ABS(a),ABS(b))
	END

	PURE REAL FUNCTION pure_maxabs2(a,b) ! pure okay
		IMPLICIT NONE
		REAL,INTENT(IN) :: a,b
		pure_maxabs2 = MAX(ABS(a),ABS(b))
	END


      program gaussian_elimination
        integer :: i
        integer :: row, pivot_row
        real :: val, max_val, scaling_factor
        real, dimension(3, 3) :: A
        real, dimension(4, 3) :: Ay
        real, dimension(3) :: y
        real, dimension(4) :: tmp_row

        ! A(:, 1) = (/ 1,  3,  1 /)
        ! A(:, 2) = (/ 1,  1, -1 /)
        ! A(:, 3) = (/ 3, 11,  5 /)

        ! A(:, 1) = (/ 3, 1, 1 /)
        ! A(:, 2) = (/ 1, 2, 5 /)
        ! A(:, 3) = (/ 2, 5, -1 /)
        ! y = (/ 6, -4, 27 /)

        A(:, 1) = (/ 0, 2, 1 /)
        A(:, 2) = (/ 1, -2, -3 /)
        A(:, 3) = (/ -1, 1, 2 /)
        y = (/ -8, 0, 3 /)

        print "(a)", "A:"
        print "(3f5.0)", A
        print *

        print "(a)", "y:"
        print "(3f5.0)", y
        print *

        ! Augment
        Ay(1:3, :) = A
        Ay(4, :) = y

        print "(a)", "Ay: "
        print "(4f6.1)", Ay
        print *

        ! todo MxN matrices
        ! todo put inside function
        ! todo underdetermined systems (might require row, col pivots)

        print "(a, /)", "Convert to Upper Triangular"

        ! Convert to upper triangular form
        do row = 1, 3  ! while?
          ! Locate pivot via argmax . abs
          max_val = 0
          do i = row, 3
            val = abs(Ay(row, i))
            if (val > max_val) then
              max_val = val
              pivot_row = i
            endif
          enddo

          ! Swap rows
          tmp_row = Ay(:, row)
          Ay(:, row) = Ay(:, pivot_row)
          Ay(:, pivot_row) = tmp_row

          ! TODO assert first element is non-zero... otherwise, just skip?
          ! TODO optimizations like (row:, row)

          ! Normalize row
          scaling_factor = Ay(row, row)
          Ay(:, row) = Ay(:, row) / scaling_factor

          do i = row + 1, 3
            scaling_factor = Ay(row, i)
            Ay(:, i) = Ay(:, i) - scaling_factor * Ay(:, row)
          enddo

          print "(4f6.1)", Ay
          print *
        enddo

        print "(a, /)", "Substitution"

        do i = 3, 1, -1
          do j = i + 1, 3
            ! TODO a lot of redundant computation
            scaling_factor = Ay(j, i)
            Ay(:, i) = Ay(:, i) - scaling_factor * Ay(:, j)
          enddo

          print "(4f6.1)", Ay
          print *
        enddo

        print "(a)", "Answer:"
        print "(3f6.1)", Ay(4, :)
        print *

        print "(a)", "Expected answer:"
        print "(3f6.1)", (/ -4., -5., 2. /)
        print *
      end program gaussian_elimination

! todo check that endif works in Fortran 77
! todo check that enddo works in Fortran 77


	FUNCTION PR_TLCL  ( tmpc, dwpc )
C************************************************************************
C* PR_TLCL 								*
C*									*
C* This function computes temperature at the Lifted Condensation	*
C* Level for a parcel of air given TMPC and  DWPC.  The following 	*
C* equation is used:							*
C*									*
C*  TLCL = [ 1 / ( 1 / (DWPK-56) + ALOG (TMPK/DWPK) / 800 ) ] + 56	*
C*									*
C* Bolton.								*
C*									*
C* REAL PR_TLCL  ( TMPC, DWPC )						*
C*									*
C* Input parameters:							*
C*	TMPC		REAL    	Temperature in Celsius		*
C*	DWPC		REAL		Dewpoint in Celsius		*
C*									*
C* Output parameters:							*
C*	PR_TLCL		REAL    	LCL temperature in Kelvin	*
C**									*
C* Log:									*
C* M. Goodman/RDS	8/84	Original source				*
C* I. Graffman/RDS	12/87	GEMPAK4					*
C* G. Huffman/GSC	8/88	Modified documentation, made -273 real  *
C* G. Krueger/EAI        4/96   Replaced C->K constant with TMCK	*
C* T. Lee/GSC		 8/97	Rearranged equation			*
C************************************************************************
        INCLUDE   'GEMPRM.PRM'
        INCLUDE   'ERMISS.FNC'
C------------------------------------------------------------------------
C*      Check for missing or out-of-bounds values.
C
	IF  ( ( ERMISS ( tmpc ) ) .or. ( ERMISS ( dwpc ) ) .or.
     +        ( tmpc .lt. -TMCK ) .or. ( dwpc .lt. -TMCK ) )  THEN
	    PR_TLCL = RMISSD
	  ELSE
	    tmpk = PR_TMCK ( tmpc )
	    dwpk = PR_TMCK ( dwpc )
	    PR_TLCL = ( 800. * ( dwpk - 56. ) / ( 800. + ( dwpk - 56. )*
     +			ALOG ( tmpk / dwpk ) ) ) + 56.
	END IF
C*
	RETURN
	END


! Subroutine SOLZEN

! This software is part of the GLOW model.  Use is governed by the Open Source
! Academic Research License Agreement contained in the file glowlicense.txt.
! For more information see the file glow.txt.

! Stan Solomon, 1988.
! Temporary Y2K fix-up, SCS, 2005.
! Refactored to f90, SCC, 2016.

! Returns Solar Zenith Angle SZA in degrees for specified date in form yyddd or yyyyddd,
! universal time in seconds, geographic latitude and longitude in degrees.

subroutine solzen (idate, ut, glat, glong, sza)

  implicit none

  integer,intent(in) :: idate
  real,intent(in) :: ut, glat, glong
  real,intent(out) :: sza

  real,parameter :: pi=3.1415926536
  real :: rlat, rlong, sdec, srasn, gst, rh, cossza

  rlat = glat * pi/180.
  rlong = glong * pi/180.
  call suncor (idate, ut, sdec, srasn, gst)
  rh = srasn - (gst+rlong)
  cossza = sin(sdec)*sin(rlat) + cos(sdec)*cos(rlat)*cos(rh)
  sza = acos(cossza) * 180./pi
  return

end subroutine solzen

! Subroutine SUNCOR returns the declination SDEC and right ascension
! SRASN of the sun in GEI coordinates, radians, for a given date IDATE
! in yyddd or yyyyddd format, universal time UT in seconds, and Greenwich sidereal
! time GST in radians.  Reference:  C.T. Russell, Geophysical Coordinate Transforms.

subroutine suncor (idate, ut, sdec, srasn, gst)

  implicit none

  integer,intent(in) :: idate
  real,intent(in) :: ut
  real,intent(out) :: sdec, srasn, gst

  real,parameter :: pi=3.1415926536
  real :: fday, dj, t, vl, g, slong, obliq, slp, sind, cosd
  integer :: iyr, iday

  fday=ut/86400.
  iyr=idate/1000
  iday=idate-iyr*1000

! Temporary Y2K fix-up:
! Should work with either yyddd or yyyyddd format from 1950 to 2050.
! Note deteriorating accuracy after ~2050 anyway.
! Won't work after 2100 due to lack of a leap year.

  if (iyr >= 1900) iyr=iyr-1900
  if (iyr < 50) iyr=iyr+100

  dj=365*iyr+(iyr-1)/4+iday+fday-0.5
  t=dj/36525.
  vl=amod(279.696678+.9856473354*dj,360.)
  gst=amod(279.696678+.9856473354*dj+360.*fday+180.,360.) * pi/180.
  g=amod(358.475845+.985600267*dj,360.) * pi/180.
  slong=vl+(1.91946-.004789*t)*sin(g)+.020094*sin(2.*g)
  obliq=(23.45229-0.0130125*t) *pi/180.
  slp=(slong-.005686) * pi/180.
  sind=sin(obliq)*sin(slp)
  cosd=sqrt(1.-sind**2)
  sdec=atan(sind/cosd)
  srasn=pi-atan2(1./tan(obliq)*sind/cosd,-cos(slp)/cosd)

  return

end subroutine suncor


      PROGRAM xtwofft
C     driver for routine twofft
      INTEGER N,N2
      REAL PER,PI
      PARAMETER(N=32,N2=2*N,PER=8.0,PI=3.14159)
      INTEGER i,isign
      REAL data1(N),data2(N),fft1(N2),fft2(N2),x
      do 11 i=1,N
        x=2.0*PI*i/PER
        data1(i)=nint(cos(x))
        data2(i)=nint(sin(x))
11    continue
      call twofft(data1,data2,fft1,fft2,N)
      write(*,*) 'Fourier transform of first function:'
      call prntft(fft1,N2)
      write(*,*) 'Fourier transform of second function:'
      call prntft(fft2,N2)
C     invert transform
      isign=-1
      call four1(fft1,N,isign)
      write(*,*) 'Inverted transform = first function:'
      call prntft(fft1,N2)
      call four1(fft2,N,isign)
      write(*,*) 'Inverted transform = second function:'
      call prntft(fft2,N2)
      END
      SUBROUTINE prntft(data,n2)
      INTEGER i,n2,nn2,m
      REAL data(n2)
      write(*,'(1x,t7,a,t13,a,t24,a,t35,a,t47,a)')
     *     'n','Real(n)','Imag.(n)','Real(N-n)','Imag.(N-n)'
      write(*,'(1x,i6,4f12.6)') 0,data(1),data(2),data(1),data(2)
      do 11 i=3,(n2/2)+1,2
        m=(i-1)/2
        nn2=n2+2-i
        write(*,'(1x,i6,4f12.6)') m,data(i),data(i+1),
     *       data(nn2),data(nn2+1)
11    continue
      write(*,'(/1x,a)') ' press RETURN to continue ...'
      read(*,*)
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xtwofft.for


      SUBROUTINE MC01QD( DA, DB, A, B, RQ, IWARN, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute, for two given real polynomials A(x) and B(x), the
C     quotient polynomial Q(x) and the remainder polynomial R(x) of
C     A(x) divided by B(x).
C
C     The polynomials Q(x) and R(x) satisfy the relationship
C
C        A(x) = B(x) * Q(x) + R(x),
C
C     where the degree of R(x) is less than the degree of B(x).
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     DA      (input) INTEGER
C             The degree of the numerator polynomial A(x).  DA >= -1.
C
C     DB      (input/output) INTEGER
C             On entry, the degree of the denominator polynomial B(x).
C             DB >= 0.
C             On exit, if B(DB+1) = 0.0 on entry, then DB contains the
C             index of the highest power of x for which B(DB+1) <> 0.0.
C
C     A       (input) DOUBLE PRECISION array, dimension (DA+1)
C             This array must contain the coefficients of the
C             numerator polynomial A(x) in increasing powers of x
C             unless DA = -1 on entry, in which case A(x) is taken
C             to be the zero polynomial.
C
C     B       (input) DOUBLE PRECISION array, dimension (DB+1)
C             This array must contain the coefficients of the
C             denominator polynomial B(x) in increasing powers of x.
C
C     RQ      (output) DOUBLE PRECISION array, dimension (DA+1)
C             If DA < DB on exit, then this array contains the
C             coefficients of the remainder polynomial R(x) in
C             increasing powers of x; Q(x) is the zero polynomial.
C             Otherwise, the leading DB elements of this array contain
C             the coefficients of R(x) in increasing powers of x, and
C             the next (DA-DB+1) elements contain the coefficients of
C             Q(x) in increasing powers of x.
C
C     Warning Indicator
C
C     IWARN   INTEGER
C             = 0:  no warning;
C             = k:  if the degree of the denominator polynomial B(x) has
C                   been reduced to (DB - k) because B(DB+1-j) = 0.0 on
C                   entry for j = 0, 1, ..., k-1 and B(DB+1-k) <> 0.0.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  if on entry, DB >= 0 and B(i) = 0.0, where
C                   i = 1, 2, ..., DB+1.
C
C     METHOD
C
C     Given real polynomials
C                                                  DA
C        A(x) = a(1) + a(2) * x + ... + a(DA+1) * x
C
C     and
C                                                  DB
C        B(x) = b(1) + b(2) * x + ... + b(DB+1) * x
C
C     where b(DB+1) is non-zero, the routine computes the coeffcients of
C     the quotient polynomial
C                                                     DA-DB
C        Q(x) = q(1) + q(2) * x + ... + q(DA-DB+1) * x
C
C     and the remainder polynomial
C                                                DB-1
C        R(x) = r(1) + r(2) * x + ... + r(DB) * x
C
C     such that A(x) = B(x) * Q(x) + R(x).
C
C     The algorithm used is synthetic division of polynomials (see [1]),
C     which involves the following steps:
C
C        (a) compute q(k+1) = a(DB+k+1) / b(DB+1)
C
C     and
C
C        (b) set a(j) = a(j) - q(k+1) * b(j-k) for j = k+1, ..., DB+k.
C
C     Steps (a) and (b) are performed for k = DA-DB, DA-DB-1, ..., 0 and
C     the algorithm terminates with r(i) = a(i) for i = 1, 2, ..., DB.
C
C     REFERENCES
C
C     [1] Knuth, D.E.
C         The Art of Computer Programming, (Vol. 2, Seminumerical
C         Algorithms).
C         Addison-Wesley, Reading, Massachusetts (2nd Edition), 1981.
C
C     NUMERICAL ASPECTS
C
C     None.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997.
C     Supersedes Release 2.0 routine MC01ED by A.J. Geurts.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Elementary polynomial operations, polynomial operations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO
      PARAMETER         ( ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      INTEGER           DA, DB, INFO, IWARN
C     .. Array Arguments ..
      DOUBLE PRECISION  A(*), B(*), RQ(*)
C     .. Local Scalars ..
      INTEGER           N
      DOUBLE PRECISION  Q
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DCOPY, XERBLA
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      IWARN = 0
      INFO = 0
      IF( DA.LT.-1 ) THEN
         INFO = -1
      ELSE IF( DB.LT.0 ) THEN
         INFO = -2
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MC01QD', -INFO )
         RETURN
      END IF
C
C     WHILE ( DB >= 0 and B(DB+1) = 0 ) DO
   20 IF ( DB.GE.0 ) THEN
         IF ( B(DB+1).EQ.ZERO ) THEN
            DB = DB - 1
            IWARN = IWARN + 1
            GO TO 20
         END IF
      END IF
C     END WHILE 20
      IF ( DB.EQ.-1 ) THEN
         INFO = 1
         RETURN
      END IF
C
C     B(x) is non-zero.
C
      IF ( DA.GE.0 ) THEN
         N = DA
         CALL DCOPY( N+1, A, 1, RQ, 1 )
C        WHILE ( N >= DB ) DO
   40    IF ( N.GE.DB ) THEN
            IF ( RQ(N+1).NE.ZERO ) THEN
               Q = RQ(N+1)/B(DB+1)
               CALL DAXPY( DB, -Q, B, 1, RQ(N-DB+1), 1 )
               RQ(N+1) = Q
            END IF
            N = N - 1
            GO TO 40
         END IF
C        END WHILE 40
      END IF
C
      RETURN
C *** Last line of MC01QD ***
      END


!--------------------------------------------------
!..Homework 1 Bonus
!..Team 31
!..AE305 - Numerical Methods
!
! This program uses RK2 method and Trapezoid method
! to calculate ground roll distance of an aircraft
!--------------------------------------------------
Module data
   implicit none
   real,parameter:: WParea=29.24, takeoffweight=88250, TmaxSL=16256, nrofengines=2, friccoeff=0.02, grav=9.81
   real,parameter :: CL=1.792 ! CL is assumed constant
   real,parameter :: CD=0.2150 ! as CL is assumed constant, CD also became constant
!  Density obtained from the standart atmosphere table.
   real,parameter :: airdensitySL=1.225, airdensity1000m=1.112, airdensity2000m=1.007

   real :: rho, thrust ! These variables will be set when altitude is selected

    contains
      Function Liftf(vel) ! Calculate Lift
       real :: vel, Liftf
       Liftf = CL*(1./2)*rho*(vel**2)*WParea
       return
       End Function Liftf

      Function Dragf(vel) ! Calculate Drag
       real :: vel, Dragf
       Dragf = CD*(1./2)*rho*(vel**2)*WParea
       return
       End Function Dragf

      Function Thrustf(dens) ! Calculate Thrust
       real :: dens, Thrustf
       Thrustf = TmaxSL*(dens/airdensitySL)
       return
       End Function Thrustf

       Function ODE(vel) ! Slope function for velocity
          real:: vel
          real :: ODE
          ODE  = (thrust-Dragf(vel)-friccoeff*(takeoffweight-Liftf(vel)))*(grav/takeoffweight)
          return
        End
 End module

 PROGRAM HOMEWORK1_BONUS
    use data

    implicit none

    real :: stepsize, k1, k2, oldvelocity, velocity, velocityx, lift, time
    real :: integration = 0   ! Integration will be accumulated in this variable
    real, parameter:: a1 =1./4 , a2=3./4, p1=2./3 ! a1 and a2 are weights for RK2 Method
    integer :: selectedaltitude ! Altitude input is stored in this variable

 !  Initial values
    time=0.
    velocity=0.
    oldvelocity = 0.
    lift=0.

 !  Select altitude
    write(*,'(/,a)')'Select one of the available altitudes:'
    write(*,'(a)')' [1] 0 m (Sea Level)'
    write(*,'(a)')' [2] 1000 m '
    write(*,'(a)')' [3] 2000 m '
    write(*,'(a)',advance='no')'Input :> '
    read(*,*) selectedaltitude

 !  Set proper variables for selected altitude
    Select case(selectedaltitude)
       case(1)
          write(*,*) 'Selected Sea Level'
          ! Set density and thrust for sea level
          rho = airdensitySL
          thrust = TmaxSL*nrofengines
       case(2)
          write(*,*) 'Selected 1000 m'
          ! Set density and thrust for 1000 m
          rho = airdensity1000m
          thrust = Thrustf(rho)*nrofengines
       case(3)
          ! Set density and thrust 2000 m
          write(*,*) 'Selected 2000 m'
          rho = airdensity2000m
          thrust = Thrustf(rho)*nrofengines
       case default
          ! Validation check
          write(*,*) 'Unidentified input, stopping program...'
          stop
    end Select

 !  Select time step
    write(*,'(/,(a))',advance='no')'Enter Time Step :> '
    read(*,*) stepsize

 !  Use RK2 Method to find velocity and trapezoidal integration method to find distance
       do while ( lift .lt. takeoffweight )                      ! Check if lift off occured
          oldvelocity = velocity;                                ! Current velocity is stored to be used in integration
          time = time + stepsize                                 ! New time is defined
          k1 = ODE(velocity)                                     ! k1 is calculated which is slope at previous velocity
          velocityx = velocity + k1*p1*stepsize                  ! velocityx is calculated
          k2 = ODE(velocityx)                                    ! k2 is calculated which is slope at velocityx
          velocity = velocity + ( a1*k1 + a2*k2 )* stepsize      ! New velocity is defined
          integration = integration + (1./2)*(oldvelocity + velocity)*stepsize  ! Integral is calculated for every interval
          lift = Liftf(velocity)                                 ! Calculate the lift to check if lift off occured
       enddo

       write(*,'(a,f12.3)') 'Minimum distance: ', integration    ! Write result to terminal

 !..Close the output file
    close(1)

    stop
 END PROGRAM HOMEWORK1_BONUS


!--------------------------------------------------
!..Homework 2
!..Team 31
!..AE305 - Numerical Methods
!
!..This program calculates the chamber pressure,
!..burn rate and specific impulse for given rocket
!..using RK4 method with constant time step and
!..outputs results to a file.
!--------------------------------------------------
Module rocket_params_vars
  Implicit none
  integer, parameter :: no_eqs = 2
  real*8, parameter :: p_a = 101325.d0, &
                     rho_p = 1140.d0, &
                         n = 0.305d0, &
                         a = 0.0000555d0, &
                       r_0 = 0.05d0, &
                       r_f = 0.15d0, &
                         L = 1.25d0, &
                       T_c = 2810.d0, &
                     R_cst = 365.d0, &
                      gama = 1.25d0, &
                      grav = 9.81d0, &
                        pi = 4.*atan(1.d0)
  real*8 :: p_c, p_c_dot, &
          r, r_dot, &
          p_c_old, r_old, &
          A_star

  contains

  Function m_n_dot(p_c_)
    ! calculate m_n dot to use in ODE
    real*8 :: m_n_dot, p_c_
    m_n_dot = p_c_*A_star*sqrt(gama/(R_cst*T_c))*((gama+1)/2)**(-(gama+1)/(2*(gama-1)))
    return
  End Function m_n_dot

  Function rho_c(p_c_)
    ! calculate rho_c to use in ODE
    real*8 :: rho_c, p_c_
    rho_c = p_c_/(R_cst*T_c)
    return
  End Function rho_c

  Function f_cor(rad)
   ! perimeter factor
   Implicit none
    real*8 :: f_cor, eta, rad
     eta = (r_f-rad)/(r_f-r_0)
     f_cor = 1.d0
     if( eta < 0 )then
         f_cor = 0
     else if (eta <= 0.15)then
         f_cor = 1-exp(-7*eta)
     end if
   return
  End Function f_cor

  Function I_sp(p_c_)
    ! specific impulse
    Implicit none
    real*8 :: I_sp, p_c_
    ! Here, absolute of value inside square root is taken because
    ! there is really small error caused by numerical computing makes
    ! value inside of the square root negative for some intervals
    ! which results in runtime error. This negative value is so small
    ! that its practically zero. Therefore, absolute can be used without
    ! effecting accuracy of result. Using abs solved the runtime error.
      I_sp = (1/grav)*sqrt(abs(((2*gama*R_cst*T_c)/(gama-1))*(1-((p_a/p_c_)**((gama-1)/gama)))))
    return
  End function I_sp

  Function ODEs( p_c_ ) result ( k )
    Implicit none
    real*8 :: p_c_
    real*8, dimension( no_eqs ) :: k
    r_dot = a*p_c**n
    k( 1 ) =  r_dot
    k( 2 ) =  R_cst*T_c*(((f_cor(r)*2* a * p_c ** n)/r)*(rho_p-rho_c(p_c_))-m_n_dot(p_c_)/(pi*L*r**2))
    return
  End function

  Subroutine RK4( t, del_t )
    Implicit none
    integer, parameter :: no_stages = 4
    real*8 :: t, del_t
    real*8, dimension( no_eqs )  ::  k( no_stages, no_eqs ), phi(no_eqs)
    p_c_old = p_c
    r_old = r
    k(1, : ) = ODEs( p_c ) !Slopes at the beginning of the interval are calculated

  !Slopes at p_1=0.5 fraction of the interval are calculated
    p_c = p_c_old + 0.5d0 * del_t * k(1, 2)
    r = r_old + 0.5d0 * del_t * k(1, 1)
    k(2, : ) = ODEs( p_c )

  !Slopes at p_2=0.5 fraction of the interval are calculated
    p_c = p_c_old + 0.5d0 * del_t * k(2, 2)
    r = r_old + 0.5d0 * del_t * k(2, 1)
    k(3, : ) = ODEs( p_c )

  !Slopes at p_3=1.0 fraction of the interval are calculated
    p_c = p_c_old + del_t * k(3, 2)
    r = r_old + del_t * k(3, 1)
    k(4, : ) = ODEs( p_c )

    phi(:) = (1.0/6)* (k(1, : )+2*k(2, : )+2*k(3, : )+k(4, : )) !weighted slopes are calculated
    p_c = p_c_old + phi(2) * del_t ! p_c is updated
    r = r_old + phi(1) * del_t ! r is updated

    t = t + del_t ! time is updated
  return
  End subroutine

End module

Program Rocket_Perf
  Use rocket_params_vars
  Implicit none
  character*40 :: fname
  real*8 ::  dt, time, isp
  integer :: nstep = 0
  real*8 :: th_radius

  write(*,'(a)') 'Enter throat radius in centimeters :'
  write(*,'(a)',advance='no') ':>'
  read*, th_radius

  A_star = pi * (th_radius/100)**2

  print*,'enter time step size, dt [s] : '
  read*, dt

!.. initial params
  p_c =  p_a    ! chamber pressure
  r = r_0      ! chamber radius
  isp = I_sp(p_c)

  write(*,'(a)',advance='no')' Enter the output file name [rocket.dat]:>'
  read(*,'(a)') fname
  if( fname .eq. ' ') fname = 'rocket.dat'
  open(1 ,file=fname, form='formatted')

  write(1,*)' "t [s]" "p_c [MPa]" "I_sp[s]" "r_dot[m/s]"'

  time = 0.d0
  nstep = 0

  do while( p_c >= p_a )
    nstep = nstep + 1

    ! update solution and time
    call RK4(time, dt)

    ! calculate isp
    isp = I_sp(p_c)

    ! print on screen and store soln
    if( nstep == 1 .or. mod(nstep,5)==0) &
      write(1,'(8(4x,e12.6))') time, p_c*1.d-6 ,isp, r_dot
      write(*,'(8(a,e9.3))')' t = ',time,' s,   p_c = ', p_c*1d-6,' MPa, I_sp = ', isp, ' s r_dot = ',r_dot,' m/s'

  enddo

  ! Print the interval number for bonus part
  write(*,*) 'Number of time intervals needed = ', nstep

  close(1)

  stop
End


! Mikayla Webber
! 4670 Numerical Analysis
! Homework Two Redo

! From Notes on Bisection Method:
! f needs to be continuous
! 1. Start with a, b so that f(a), f(b) have opposite signs
! 2. Find the middle M = (a+b)/2 and calculate f(M)
! 3. If f(a) and f(M) have opposite signs
! set b = M
! else set a = M
! end if
! Loop back to #2

module secret

end module secret

program WebberHomework2Question2
use secret							! uses secret module
implicit none

double precision :: a
double precision :: b
double precision :: f
double precision :: m
double precision :: mid
double precision :: tolerance

integer :: i
integer :: findSign 						! I didn't realize "sign" was a
								! reserved word
a = -5.0d0
b = 5.0d0
tolerance = 1.0d0-10

do i = 1, 100
	m = mid(a, b)						! find the middle and calculate f(M)

	if (((b - a) / 2) < tolerance) then 			! if m is less than tolerance then
		print*, "Middle = ", m				! prints the middle
		stop
	else if (f(m) == 0) then				! else if f(m) equals zero then
		print*, "Middle = ", m				! prints the middle
		stop
	else 							! if neither case is true
		print*, "f(a, b) = (", a, ",", b, ") and m = ", m
	end if

	if ((findSign(f(a)) * findSign(f(m))) < 0) then		! if f(a) && f(M) have opposite signs
		b = m						! it sets b to M
	else
		a = m						! else it sets a to b
	end if
end do

stop
end program WebberHomework2Question2

double precision function f(x)					! main function for the problem
implicit none

double precision :: x

f = ((-32.17d0 / (2.0d0 * x ** 2.0d0)) * ((dsinh(x) - dsin(x)) - 1.7d0))

return
end

double precision function mid(a,b)				! function to find midpoint
implicit none

double precision :: a
double precision :: b

mid = ((a + (b - a)) / 2.0d0)					! midpoint formula

return
end

double precision function findSign(x)				! function to determine if negative
implicit none							! or positive

double precision :: x

if (x < 0.0d0) then 						! if less than zero sign is -1
	findSign = -1.0d0
else if (x == 0.0d0) then					! else if x is zero sign is 0
	findSign = 0.0d0
else								! if x is greater than zero sign is 1
	findSign = 1.0d0
end if

return
end