subroutine abs_smooth(x, delta_x, y)
    ! absolute value function with small quadratic in the valley
    ! so that it is C1 continuous

    implicit none
    integer, parameter :: dp = kind(0.d0)

    ! in
    real(dp), intent(in) :: x, delta_x

    ! out
    real(dp), intent(out) :: y

    if (x >= delta_x) then
        y = x
    elseif (x <= -delta_x) then
        y = -x
    else
        y = x**2/(2.0_dp*delta_x) + delta_x/2.0_dp
    end if

end subroutine abs_smooth

subroutine setup(n, xpt, ypt, p0, p1, p2, p3, delta_x)
    ! setup the Akima spline function

    implicit none

    integer, parameter :: dp = kind(0.d0)
    real(dp), parameter :: eps = 1d-30

    ! in
    integer, intent(in) :: n
    real(dp), dimension(n), intent(in) :: xpt, ypt  ! given points
    real(dp), intent(in) :: delta_x
    !f2py real(dp), intent(in) :: delta_x = 0.1

    ! out
    real(dp), dimension(n-1), intent(out) :: p0, p1, p2, p3  ! spline coefficients

    ! local
    integer :: i
    real(dp), dimension(-1:n+1) :: m
    real(dp), dimension(n) :: t
    real(dp) :: m1, m2, m3, m4, w1, w2
    real(dp) :: t1, t2, dx

    ! compute segment slopes
    do i = 1, n-1
        m(i) = (ypt(i+1) - ypt(i)) / (xpt(i+1) - xpt(i))
    end do

    ! estimation for end points
    m(0) = 2.0_dp*m(1) - m(2)
    m(-1) = 2.0_dp*m(0) - m(1)
    m(n) = 2.0_dp*m(n-1) - m(n-2)
    m(n+1) = 2.0_dp*m(n) - m(n-1)

    ! slope at points
    do i = 1, n
        m1 = m(i-2)
        m2 = m(i-1)
        m3 = m(i)
        m4 = m(i+1)
!         w1 = abs(m4 - m3)
!         w2 = abs(m2 - m1)
        call abs_smooth(m4 - m3, delta_x, w1)
        call abs_smooth(m2 - m1, delta_x, w2)
        if ( w1 < eps .and. w2 < eps ) then
            t(i) = 0.5_dp*(m2 + m3)  ! special case to avoid divide by zero
        else
            t(i) = (w1*m2 + w2*m3) / (w1 + w2)
        end if
    end do

    ! polynomial cofficients
    do i = 1, n-1
        dx = xpt(i+1) - xpt(i)
        t1 = t(i)
        t2 = t(i+1)
        p0(i) = ypt(i)
        p1(i) = t1
        p2(i) = (3.0_dp*m(i) - 2.0_dp*t1 - t2)/dx
        p3(i) = (t1 + t2 - 2.0_dp*m(i))/dx**2
    end do

end subroutine setup

subroutine interp(npt, n, x, xpt, p0, p1, p2, p3, &
    dp0dxpt, dp1dxpt, dp2dxpt, dp3dxpt,&
    dp0dypt, dp1dypt, dp2dypt, dp3dypt,&
    y, dydx, dydxpt, dydypt)
    ! evaluate the Akima spline and its derivatives

    implicit none
    integer, parameter :: dp = kind(0.d0)

    ! in
    integer, intent(in) :: npt
    real(dp), dimension(npt), intent(in) :: xpt  ! given x points
    real(dp), dimension(npt-1), intent(in) :: p0, p1, p2, p3  ! spline coefficients
    integer, intent(in) :: n
    real(dp), dimension(n), intent(in) :: x  ! x values to evalute at
    real(dp), dimension(npt-1, npt), intent(in) :: dp0dxpt, dp1dxpt, dp2dxpt, dp3dxpt
    real(dp), dimension(npt-1, npt), intent(in) :: dp0dypt, dp1dypt, dp2dypt, dp3dypt

    ! out
    real(dp), dimension(n), intent(out) :: y  ! interpolate y values
    real(dp), dimension(n), intent(out) :: dydx  ! derivative of y w.r.t. x
    real(dp), dimension(n, npt), intent(out) :: dydxpt, dydypt  ! derivative of y w.r.t. xpt and ypt

    ! local
    integer :: i, j, k
    real(dp) :: dx

     ! interpolate at each point
    do i = 1, n

        ! find location in array (use end segments if out of bounds)
        if (x(i) < xpt(1)) then
            j = 1

        else
            ! linear search for now
            do j = npt-1, 1, -1
                if ( x(i) >= xpt(j)) then
                    exit
                end if
            end do
        end if

        ! evaluate polynomial (and derivative)
        dx = (x(i) - xpt(j))
        y(i) = p0(j) + p1(j)*dx + p2(j)*dx**2 + p3(j)*dx**3
        dydx(i) = p1(j) + 2.0_dp*p2(j)*dx + 3.0_dp*p3(j)*dx**2

        do k = 1, npt
            dydxpt(i, k) = dp0dxpt(j, k) + dp1dxpt(j, k)*dx + dp2dxpt(j, k)*dx**2 + dp3dxpt(j, k)*dx**3
            if (k == j) then
                dydxpt(i, k) = dydxpt(i, k) - dydx(i)
            end if
            dydypt(i, k) = dp0dypt(j, k) + dp1dypt(j, k)*dx + dp2dypt(j, k)*dx**2 + dp3dypt(j, k)*dx**3
        end do

    end do

end subroutine interp

!        Generated by TAPENADE     (INRIA, Tropics team)
!  Tapenade 3.9 (r5096) - 24 Feb 2014 16:54
!
!  Differentiation of setup in forward (tangent) mode:
!   variations   of useful results: p0 p1 p2 p3
!   with respect to varying inputs: xpt ypt
!   RW status of diff variables: xpt:in p0:out p1:out p2:out p3:out
!                ypt:in

SUBROUTINE SETUP_DV(n, xpt, xptd, ypt, yptd, p0, p0d, p1, p1d, p2, p2d, &
& p3, p3d, delta_x, nbdirs)
!   USE DIFFSIZES
!  Hint: nbdirsmax should be the maximum number of differentiation directions
  IMPLICIT NONE
  INTEGER, PARAMETER :: dp=KIND(0.d0)
  REAL(dp), PARAMETER :: eps=1d-30
! in
  INTEGER, INTENT(IN) :: n
  INTEGER, intent(in) :: nbdirs
! given points
  REAL(dp), DIMENSION(n), INTENT(IN) :: xpt, ypt
  REAL(dp), DIMENSION(nbdirs, n), INTENT(IN) :: xptd, yptd
  REAL(dp), INTENT(IN) :: delta_x
!f2py real(dp), intent(in) :: delta_x = 0.1
! out
! spline coefficients
  REAL(dp), DIMENSION(n - 1), INTENT(OUT) :: p0, p1, p2, p3
  REAL(dp), DIMENSION(nbdirs, n-1), INTENT(OUT) :: p0d, p1d, p2d, p3d
! local
  INTEGER :: i
  REAL(dp), DIMENSION(-1:n + 1) :: m
  REAL(dp), DIMENSION(nbdirs, -1:n+1) :: md
  REAL(dp), DIMENSION(n) :: t
  REAL(dp), DIMENSION(nbdirs, n) :: td
  REAL(dp) :: m1, m2, m3, m4, w1, w2
  REAL(dp), DIMENSION(nbdirs) :: m1d, m2d, m3d, m4d, w1d, w2d
  REAL(dp) :: t1, t2, dx
  REAL(dp), DIMENSION(nbdirs) :: t1d, t2d, dxd
  INTRINSIC KIND
  REAL(dp) :: arg1
  REAL(dp), DIMENSION(nbdirs) :: arg1d
  INTEGER :: nd
  DO nd=1,nbdirs
    md(nd, :) = 0.0_dp
  END DO
! compute segment slopes
  DO i=1,n-1
    DO nd=1,nbdirs
      md(nd, i) = ((yptd(nd, i+1)-yptd(nd, i))*(xpt(i+1)-xpt(i))-(ypt(i+&
&       1)-ypt(i))*(xptd(nd, i+1)-xptd(nd, i)))/(xpt(i+1)-xpt(i))**2
    END DO
    m(i) = (ypt(i+1)-ypt(i))/(xpt(i+1)-xpt(i))
  END DO
  DO nd=1,nbdirs
! estimation for end points
    md(nd, 0) = 2.0_dp*md(nd, 1) - md(nd, 2)
    md(nd, -1) = 2.0_dp*md(nd, 0) - md(nd, 1)
    md(nd, n) = 2.0_dp*md(nd, n-1) - md(nd, n-2)
    md(nd, n+1) = 2.0_dp*md(nd, n) - md(nd, n-1)
  END DO
  m(0) = 2.0_dp*m(1) - m(2)
  m(-1) = 2.0_dp*m(0) - m(1)
  m(n) = 2.0_dp*m(n-1) - m(n-2)
  m(n+1) = 2.0_dp*m(n) - m(n-1)
  DO nd=1,nbdirs
    td(nd, :) = 0.0_dp
  END DO
! slope at points
  DO i=1,n
    DO nd=1,nbdirs
      m1d(nd) = md(nd, i-2)
      m2d(nd) = md(nd, i-1)
      m3d(nd) = md(nd, i)
      m4d(nd) = md(nd, i+1)
!         w1 = abs(m4 - m3)
!         w2 = abs(m2 - m1)
      arg1d(nd) = m4d(nd) - m3d(nd)
    END DO
    m1 = m(i-2)
    m2 = m(i-1)
    m3 = m(i)
    m4 = m(i+1)
    arg1 = m4 - m3
    CALL ABS_SMOOTH_DV(arg1, arg1d, delta_x, w1, w1d, nbdirs)
    DO nd=1,nbdirs
      arg1d(nd) = m2d(nd) - m1d(nd)
    END DO
    arg1 = m2 - m1
    CALL ABS_SMOOTH_DV(arg1, arg1d, delta_x, w2, w2d, nbdirs)
    IF (w1 .LT. eps .AND. w2 .LT. eps) THEN
      DO nd=1,nbdirs
! special case to avoid divide by zero
        td(nd, i) = 0.5_dp*(m2d(nd)+m3d(nd))
      END DO
      t(i) = 0.5_dp*(m2+m3)
    ELSE
      DO nd=1,nbdirs
        td(nd, i) = ((w1d(nd)*m2+w1*m2d(nd)+w2d(nd)*m3+w2*m3d(nd))*(w1+&
&         w2)-(w1*m2+w2*m3)*(w1d(nd)+w2d(nd)))/(w1+w2)**2
      END DO
      t(i) = (w1*m2+w2*m3)/(w1+w2)
    END IF
  END DO
  DO nd=1,nbdirs
    p0d(nd, :) = 0.0_dp
    p1d(nd, :) = 0.0_dp
    p2d(nd, :) = 0.0_dp
    p3d(nd, :) = 0.0_dp
  END DO
! polynomial cofficients
  DO i=1,n-1
    dx = xpt(i+1) - xpt(i)
    t1 = t(i)
    t2 = t(i+1)
    DO nd=1,nbdirs
      dxd(nd) = xptd(nd, i+1) - xptd(nd, i)
      t1d(nd) = td(nd, i)
      t2d(nd) = td(nd, i+1)
      p0d(nd, i) = yptd(nd, i)
      p1d(nd, i) = t1d(nd)
      p2d(nd, i) = ((3.0_dp*md(nd, i)-2.0_dp*t1d(nd)-t2d(nd))*dx-(3.0_dp&
&       *m(i)-2.0_dp*t1-t2)*dxd(nd))/dx**2
      p3d(nd, i) = ((t1d(nd)+t2d(nd)-2.0_dp*md(nd, i))*dx**2-(t1+t2-&
&       2.0_dp*m(i))*2*dx*dxd(nd))/(dx**2)**2
    END DO
    p0(i) = ypt(i)
    p1(i) = t1
    p2(i) = (3.0_dp*m(i)-2.0_dp*t1-t2)/dx
    p3(i) = (t1+t2-2.0_dp*m(i))/dx**2
  END DO
END SUBROUTINE SETUP_DV

!  Differentiation of abs_smooth in forward (tangent) mode:
!   variations   of useful results: y
!   with respect to varying inputs: x

SUBROUTINE ABS_SMOOTH_DV(x, xd, delta_x, y, yd, nbdirs)
!   USE DIFFSIZES
!  Hint: nbdirsmax should be the maximum number of differentiation directions
  IMPLICIT NONE
  INTEGER, PARAMETER :: dp=KIND(0.d0)
! in
  REAL(dp), INTENT(IN) :: x, delta_x
  REAL(dp), DIMENSION(nbdirs), INTENT(IN) :: xd
  INTEGER, intent(in) :: nbdirs
! out
  REAL(dp), INTENT(OUT) :: y
  REAL(dp), DIMENSION(nbdirs), INTENT(OUT) :: yd
  INTRINSIC KIND
  INTEGER :: nd
  IF (x .GE. delta_x) THEN
    DO nd=1,nbdirs
      yd(nd) = xd(nd)
    END DO
    y = x
  ELSE IF (x .LE. -delta_x) THEN
    DO nd=1,nbdirs
      yd(nd) = -xd(nd)
    END DO
    y = -x
  ELSE
    DO nd=1,nbdirs
      yd(nd) = 2.0_dp*x*xd(nd)/(2.0_dp*delta_x)
    END DO
    y = x**2/(2.0_dp*delta_x) + delta_x/2.0_dp
  END IF
END SUBROUTINE ABS_SMOOTH_DV


subroutine deter(a,det,nsize)

!-----------------------------------------------------------------------
!
! This routine calculates the determinant DETER of a matrix a
!
!
!-----------------------------------------------------------------------
  use      typre
  implicit none
  integer(ip), intent(in)  :: nsize
  real(rp),    intent(in)  :: a(nsize,nsize)
  real(rp),    intent(out) :: det
  integer(ip)              :: isize,jsize
  real(rp)                 :: denom,t1,t2,t3,t4

  select case (nsize)

  case(1)
     det=a(1,1)

  case(2)
     det=a(1,1)*a(2,2)-a(2,1)*a(1,2)

  case(3)
     t1  = a(2,2)*a(3,3) - a(3,2)*a(2,3)
     t2  =-a(2,1)*a(3,3) + a(3,1)*a(2,3)
     t3  = a(2,1)*a(3,2) - a(3,1)*a(2,2)
     det= a(1,1)*t1 + a(1,2)*t2 + a(1,3)*t3

  case(4)
     t1= a(2,2)*a(3,3)*a(4,4) + a(2,3)*a(3,4)*a(4,2)&
          + a(2,4)*a(3,2)*a(4,3) - a(2,3)*a(3,2)*a(4,4)&
          - a(2,2)*a(3,4)*a(4,3) - a(2,4)*a(3,3)*a(4,2)
     t2=-a(2,1)*a(3,3)*a(4,4) - a(2,3)*a(3,4)*a(4,1)&
          - a(2,4)*a(3,1)*a(4,3) + a(2,4)*a(3,3)*a(4,1)&
          + a(2,3)*a(3,1)*a(4,4) + a(2,1)*a(3,4)*a(4,3)
     t3=+a(2,1)*a(3,2)*a(4,4) + a(2,2)*a(3,4)*a(4,1)&
          + a(2,4)*a(3,1)*a(4,2) - a(2,4)*a(3,2)*a(4,1)&
          - a(2,2)*a(3,1)*a(4,4) - a(2,1)*a(3,4)*a(4,2)
     t4=-a(2,1)*a(3,2)*a(4,3) - a(2,2)*a(3,3)*a(4,1)&
          - a(2,3)*a(3,1)*a(4,2) + a(2,3)*a(3,2)*a(4,1)&
          + a(2,2)*a(3,1)*a(4,3) + a(2,1)*a(3,3)*a(4,2)
     det= a(1,1)*t1 + a(1,2)*t2 + a(1,3)*t3 + a(1,4)*t4

  end select

end subroutine deter


SUBROUTINE tides_solid1 (rmoon, rsun, GMearth, Re, GMmoon, GMsun, dCnm, dSnm)

! ----------------------------------------------------------------------
! SUBROUTINE: tides_solid1.f90
! ----------------------------------------------------------------------
! Purpose:
! Solid Earth Tides (frequency independent)
!  Solid Earth Tides (Step 1) based on the IERS Conventions 2010.
!  tides_solid1 implements the Step1 that refers to the computation of the
!  frequency independent corrections to the geopotential's  spherical harmonic
!  coefficients.
! ----------------------------------------------------------------------
! Input arguments
! - GMearth : Earth gravity constant  (m^3/sec^2)
! - Re      : Earth radius  (meters)
! - GMmoon  : Moon gravity constant  (m^3/sec^2)
! - rmoon   : Moon body-fixed geocentric position vector (meters)
! - GMsun   : Sun gravity constant  (m^3/sec^2)
! - rsun    : Sun body-fixed geocentric position vector (meters)
!
! Output arguments:
! - dCnm    : Cnm corrections matrix
! - dSnm    : Snm corrections matrix
! ----------------------------------------------------------------------
! Remark:
!  Computed dCnm and dSnm are formed into lower triangular matrices.
!  Coefficient dCnm corresponds to the matrix element dCnm(n+1,m+1).
! ----------------------------------------------------------------------
! Dr. Thomas Papanikolaou, Geoscience Australia          6 November 2015
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      !USE mdl_legendre
      USE m_legendre
      USE mdl_planets
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_q), INTENT(IN), DIMENSION(3) :: rmoon, rsun
      REAL (KIND = prec_q), INTENT(IN) :: GMearth, Re, GMmoon, GMsun
! OUT
      REAL (KIND = prec_q), INTENT(OUT), DIMENSION(5,5) :: dCnm, dSnm
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_q), DIMENSION(:,:), ALLOCATABLE :: Pnm_norm
      REAL (KIND = prec_q) :: phi_sun,lamda_sun,lsun , phi_moon,lamda_moon,lmoon
      REAL (KIND = prec_q) :: dCnm_moon,dCnm_sun,dSnm_moon,dSnm_sun
      REAL (KIND = prec_q), DIMENSION(4,4) :: knm, Pnm_norm_moon, Pnm_norm_sun
      REAL (KIND = prec_q), DIMENSION(3,3) :: knm_plus
      INTEGER (KIND = prec_int8) :: n, m, Nmax
      INTEGER (KIND = prec_int2) :: DeAllocateStatus
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Love numbers (Knm): Table 6.3
! ----------------------------------------------------------------------
! Elastic Earth
knm(2+1,0+1) = 0.29525D0
knm(2+1,1+1) = 0.29470D0
knm(2+1,2+1) = 0.29801D0
knm(3+1,0+1) = 0.093D0
knm(3+1,1+1) = 0.093D0
knm(3+1,2+1) = 0.093D0
knm(3+1,3+1) = 0.094D0
! Knm(+) matrix
knm_plus(2+1,0+1) = -0.00087D0
knm_plus(2+1,1+1) = -0.00079D0
knm_plus(2+1,2+1) = -0.00057D0
! ----------------------------------------------------------------------
! Anelastic Earth
!knm(2+1,0+1) = 0.30190D0
!knm(2+1,1+1) = 0.29830D0
!knm(2+1,2+1) = 0.30102D0
!! Knm(+) matrix
!knm_plus(2+1,0+1) = -0.00089D0
!knm_plus(2+1,1+1) = -0.00080D0
!knm_plus(2+1,2+1) = -0.00057D0
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Earth
!GMearth = GM_gfm
!Re = Earth_radius
! ----------------------------------------------------------------------
! GM constants
! Spherical coordinates (radians)
! Normalized associated Legendre functions
! Moon
      !GMmoon = GMconst(10)
      CALL coord_r2sph (rmoon , phi_moon,lamda_moon,lmoon)
	  Nmax = 3
      CALL legendre (phi_moon, Nmax, Pnm_norm)
      Pnm_norm_moon = Pnm_norm
      DEALLOCATE (Pnm_norm, STAT = DeAllocateStatus)
! Sun
      !GMsun = GMconst(11)
      CALL coord_r2sph (rsun , phi_sun,lamda_sun,lsun)
	  Nmax = 3
      CALL legendre (phi_sun, Nmax, Pnm_norm)
      Pnm_norm_sun = Pnm_norm
      DEALLOCATE (Pnm_norm, STAT = DeAllocateStatus)
! ----------------------------------------------------------------------

dCnm      = 0.0D0
dCnm      = 0.0D0
dCnm_moon = 0.0D0
dSnm_moon = 0.0D0
dCnm_sun  = 0.0D0
dSnm_sun  = 0.0D0

! ----------------------------------------------------------------------
! Computation of dCnm and dSnm terms for degree and order 3
DO n = 2 , 3
    DO m = 0 , n
        ! dCnm term
        dCnm_moon = (GMmoon / GMearth) * (Re / lmoon)**(n+1D0) * Pnm_norm_moon(n+1,m+1) * cos(m*lamda_moon)
        dCnm_sun  = (GMsun / GMearth) * (Re / lsun)**(n+1D0) * Pnm_norm_sun(n+1,m+1) * cos(m*lamda_sun)
        dCnm(n+1,m+1) = ( knm(n+1,m+1) / (2D0 * n + 1D0) ) * (dCnm_moon + dCnm_sun)
        ! dSnm term
        dSnm_moon = (GMmoon / GMearth) * (Re / lmoon)**(n+1D0) * Pnm_norm_moon(n+1,m+1) * sin(m*lamda_moon)
        dSnm_sun  = (GMsun / GMearth) * (Re / lsun)**(n+1D0) * Pnm_norm_sun(n+1,m+1) * sin(m*lamda_sun)
        dSnm(n+1,m+1) = ( knm(n+1,m+1) / (2D0*n + 1D0) ) * (dSnm_moon + dSnm_sun)
    END DO
END DO
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Computation of dCnm and dSnm terms for degree n=4 and order m=0,1,2
DO m = 0 , 2
    ! dCnm terms
    dCnm_moon = (GMmoon / GMearth) * (Re / lmoon)**3 * Pnm_norm_moon(2+1,m+1) * cos(m*lamda_moon)
    dCnm_sun  = (GMsun / GMearth) * (Re / lsun)**3 * Pnm_norm_sun(2+1,m+1) * cos(m*lamda_sun)
    dCnm(4+1,m+1) = ( knm_plus(2+1,m+1) / 5D0 ) * (dCnm_moon + dCnm_sun)

    ! dSnm terms
    dSnm_moon = (GMmoon / GMearth) * (Re / lmoon)**3 * Pnm_norm_moon(2+1,m+1) * sin(m*lamda_moon)
    dSnm_sun  = (GMsun / GMearth) * (Re / lsun)**3 * Pnm_norm_sun(2+1,m+1) * sin(m*lamda_sun)
    dSnm(4+1,m+1) = ( knm_plus(2+1,m+1) / 5D0 ) * (dSnm_moon + dSnm_sun)
END DO
! ----------------------------------------------------------------------

END


PURE FUNCTION func_mean(arr, dof) RESULT(ans)
    ! NOTE: See https://numpy.org/doc/stable/reference/generated/numpy.mean.html

    USE ISO_FORTRAN_ENV

    IMPLICIT NONE

    ! Declare inputs/outputs ...
    INTEGER(kind = INT64), INTENT(in), OPTIONAL                                 :: dof
    REAL(kind = REAL64)                                                         :: ans
    REAL(kind = REAL64), DIMENSION(:), INTENT(in)                               :: arr

    ! Declare internal variables ...
    INTEGER(kind = INT64)                                                       :: n

    ! Find size of array ...
    n = SIZE(arr, kind = INT64)

    ! Calculate the mean ...
    IF(PRESENT(dof))THEN
        ans = SUM(arr) / REAL(n - dof, kind = REAL64)
    ELSE
        ans = SUM(arr) / REAL(n, kind = REAL64)
    END IF
END FUNCTION func_mean


!##############################################################################
! MODULE globals
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
module globals

    implicit none
    real*8, parameter :: w = 1d0
    real*8, parameter :: R = 1d0
    real*8, parameter :: beta = 1d0
    real*8, parameter :: gamma = 0.5d0
    real*8, parameter :: egam = 1d0 - 1d0/gamma

    real*8 :: a(3), c(3)

contains

    ! utility function of the household
    function utility(x)

        implicit none
        real*8, intent(in) :: x(:)
        real*8 :: utility

        ! savings
        a(1) = 0d0
        a(2:3) = x

        ! consumption (insure consumption > 0)
        c(1) = w - a(2)
        c(2) = R*a(2) + w - a(3)
        c(3) = R*a(3)
        c = max(c, 1d-10)

        ! utility function
        utility = -(c(1)**egam + beta*c(2)**egam + beta**2*c(3)**egam)/egam

    end function

end module


program P14563
    implicit none
    integer :: T, S, D, i
    integer, dimension(1000) :: N
    read *, T
    read *, (N(i), i = 1, T)
    do i = 1, T
        if (N(i) > 1) then
            S = 1
        else
            S = 0
        end if
        D = 2
        do while (D <= sqrt(real(N(i))))
            if (mod(N(i), D) == 0) then
                S = S + D
                if (N(i) / D /= D) then
                    S = S + N(i) / D
                end if
            end if
            D = D + 1
        end do
        if (S > N(i)) then
            write (*, '(A)') 'Abundant'
        else if (S < N(i)) then
            write (*, '(A)') 'Deficient'
        else
            write (*, '(A)') 'Perfect'
        end if
    end do
end program P14563


C$Procedure  SPHSD ( Spherical surface distance )

      DOUBLE PRECISION FUNCTION SPHSD (  RADIUS,  LONG1,  LAT1,
     .                                            LONG2,  LAT2  )

C$ Abstract
C
C     Return the distance between two points on a sphere, measured
C     along the shortest great circle arc connecting them.
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     GEOMETRY
C
C$ Declarations

      DOUBLE PRECISION      RADIUS
      DOUBLE PRECISION      LONG1
      DOUBLE PRECISION      LAT1
      DOUBLE PRECISION      LONG2
      DOUBLE PRECISION      LAT2

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     RADIUS     I   Radius of sphere.
C     LONG1,
C     LAT1       I   Longitude and latitude of first point in radians.
C     LONG2,
C     LAT2       I   Longitude and latitude of second point in radians.
C
C     The function returns the distance between the two input points,
C     measured along the shortest great circle arc connecting them.
C
C$ Detailed_Input
C
C     RADIUS         Radius of the sphere on which the points are
C                    located.
C
C     LONG1,
C     LAT1           Longitude and latitude of the first point.  The
C                    units are radians.
C
C     LONG2,
C     LAT2           Longitude and latitude of the second point. The
C                    units are radians.
C
C$ Detailed_Output
C
C     The function returns the distance between the two input points,
C     measured along the shortest great circle arc connecting them.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)  If RADIUS is negative, the error SPICE(INPUTOUTOFRANGE)
C         is signalled.  SPHSD is set to zero.  RADIUS may be zero;
C         this case is not treated as an exception.
C
C     2)  Latitudes out of the range [-pi/2, pi/2] are NOT treated
C         as errors, although they are not valid in the latitudinal
C         coordinate system and so may be considered to be exceptional
C         inputs.  All latitude values are used in the same way in the
C         computation, regardless of whether or not they are in range.
C         See the code for the equation used.
C
C     3)  Longitudes out of the range (-pi, pi] are NOT treated
C         as errors, although they are not valid in the latitudinal
C         coordinate system and so may be considered to be exceptional
C         inputs.  All longitude values are used in the same way in the
C         computation, regardless of whether or not they are in range.
C         See the code for the equation used.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     You may need to consider whether a spherical model is adequate
C     for your application; some bodies may be more accurately modelled
C     by an oblate or prolate spheroid, or by a triaxial ellipsoid.
C
C$ Examples
C
C     1)  To find the distance along a sphere of radius 1000 km between
C         the points at
C
C            longitude = 1.570796326794897D0  (pi/2) radians,
C            latitude  = 7.853981633974483D-1 (pi/4) radians
C
C         and
C
C            longitude = 0.0D0 radians,
C            latitude  = 7.853981633974483D-1 (pi/4) radians,
C
C         we could make the function call:
C
C            DIST = SPHSD ( 1.0D3,
C         .                 1.570796326794897D0, 7.853981633974483D-1,
C         .                 0.D0,                7.853981633974483D-1  )
C
C         The value of DIST should be
C
C            1.047197551196598D3,
C
C         which is (very, very close to) 1000 * pi/3.
C
C         The exact numbers used in this example were obtained using
C         VAX Fortran 77 on a VAX 11/780; different compilers and
C         systems may yield different results.
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     H.A. Neilan     (JPL)
C     N.J. Bachman    (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.1.0, 17-MAY-1994 (HAN)
C
C       If the value of the function RETURN is TRUE upon execution of
C       this module, this function is assigned a default value of
C       either 0, 0.0D0, .FALSE., or blank depending on the type of
C       the function.
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, 01-NOV-1990 (NJB)
C
C-&

C$ Index_Entries
C
C     spherical surface distance
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      BRCKTD

      LOGICAL               RETURN

C
C     Local variables
C
      DOUBLE PRECISION      SL1SL2
      DOUBLE PRECISION      COSANG

C
C     Check RETURN but do not check in unless an error is detected.
C
      IF ( RETURN() ) THEN
         SPHSD = 0.0D0
         RETURN
      END IF

C
C     Make sure that RADIUS is ok; check in only if it isn't.
C
      IF ( RADIUS .LT. 0 ) THEN

         SPHSD = 0.D0

         CALL CHKIN  ( 'SPHSD'                  )
         CALL SETMSG ( 'Radius was #.'          )
         CALL ERRDP  ( '#', RADIUS              )
         CALL SIGERR ( 'SPICE(VALUEOUTOFRANGE)' )
         CALL CHKOUT ( 'SPHSD'                  )
         RETURN

      END IF

C
C     The usual equation for the distance between points, measured
C     along a great circle, is:
C
C                  -1
C       DIST  =  COS (   ( COS(LONG1-LONG2) * COS(LAT1) * COS(LAT2) )
C                      + (                    SIN(LAT1) * SIN(LAT2) )  )
C
C              * RADIUS
C
C     To arrive at this equation, we find the cartesian coordinates of
C     the input surface points and take the dot product of the two
C     points.
C
C     To save a trig function reference, however, we implement this
C     calculation slightly differently.
C

C
C     COSANG is the cosine of the angle between the two position
C     vectors.  We bracket COSANG 'tween -1 and 1 to make sure
C     round-off error doesn't take it out of the domain of arc
C     cosine...
C
      SL1SL2  =       SIN ( LAT1 ) * SIN ( LAT2 )

      COSANG  =       COS ( LONG1 - LONG2 )
     .           * (  COS ( LAT1  - LAT2  )  -  SL1SL2  )
     .           +    SL1SL2

      SPHSD   =       RADIUS * ACOS (  BRCKTD ( COSANG, -1.D0, 1.D0 )  )

      RETURN
      END


!SUBROUTINE BottomWhalin(FineGrid,y0)
!GD: modif
SUBROUTINE BottomWhalin(FineGrid,y0,GhostGridX,GhostGridY)
!
! Define bottom and bottom gradients for whalin's test (3D)
! By Allan P. Engsig-Karup.
!
USE Precision
USE Constants
USE DataTypes
IMPLICIT NONE
TYPE (Level_def) :: FineGrid
REAL(KIND=long) :: y0, SIGMA, y, x, SIGMAy, SIGMAyy, SIGMAx, SIGMAxx
INTEGER :: Nx, Ny, i, j, GhostGridX, GhostGridY
!Nx = FineGrid%Nx
!Ny = FineGrid%Ny
!GD: modif
Nx = FineGrid%Nx+2*GhostGridX
Ny = FineGrid%Ny+2*GhostGridY

IF (FineGrid%Nx>FineGrid%Ny) THEN
  DO j = 1, Ny
	y = FineGrid%y(1,j) ! FIXME: x-index
	IF (y<y0) y = y0
	SIGMA   = SQRT(6.096_long*y-y*y)
	SIGMAy  = -0.04_long*(6.096_long-two*y)*half/SIGMA
	SIGMAyy = 0.04_long*6.096_long**2/(four*SIGMA**3)
	DO i = 1 , Nx
		x = FineGrid%x(i,1) ! FIXME: y-index
		IF (x<=10.67-SIGMA) THEN
			FineGrid%h(i,j)   = 0.4572_long
			FineGrid%hx(i,j)  = zero
			FineGrid%hy(i,j)  = zero
			FineGrid%hxx(i,j) = zero
			FineGrid%hyy(i,j) = zero
		ELSE IF (x>=18.29-SIGMA) THEN
			FineGrid%h(i,j)   = 0.1524_long
			FineGrid%hx(i,j)  = zero
			FineGrid%hy(i,j)  = zero
			FineGrid%hxx(i,j) = zero
			FineGrid%hyy(i,j) = zero
		ELSE ! 10.67 - SIGMA < x < 18.29 - SIGMA
			FineGrid%h(i,j)   = 0.4572_long + 0.04_long*(10.67_long-SIGMA-x)
			FineGrid%hx(i,j)  = -0.04_long
			FineGrid%hy(i,j)  = SIGMAy
			FineGrid%hxx(i,j) = zero
			FineGrid%hyy(i,j) = SIGMAyy
		ENDIF
	END DO
  END DO
ELSE
  DO i = 1, Nx
	x = FineGrid%x(i,1) ! FIXME: y-index
	IF (x<y0) x = y0
	SIGMA   = SQRT(6.096_long*x-x*x)
	SIGMAx  = -0.04_long*(6.096_long-two*x)*half/SIGMA
	SIGMAxx = 0.04_long*6.096_long**2/(four*SIGMA**3)
	DO j = 1 , Ny
		y = FineGrid%y(1,j) ! FIXME: x-index
		IF (y<=10.67_long-SIGMA) THEN
			FineGrid%h(i,j)   = 0.4572_long
			FineGrid%hx(i,j)  = zero
			FineGrid%hy(i,j)  = zero
			FineGrid%hxx(i,j) = zero
			FineGrid%hyy(i,j) = zero
		ELSE IF (y>=18.29_long-SIGMA) THEN
			FineGrid%h(i,j)   = 0.1524_long
			FineGrid%hx(i,j)  = zero
			FineGrid%hy(i,j)  = zero
			FineGrid%hxx(i,j) = zero
			FineGrid%hyy(i,j) = zero
		ELSE ! 10.67 - SIGMA < y < 18.29 - SIGMA
			FineGrid%h(i,j)   = 0.4572_long + 0.04_long*(10.67_long-SIGMA-y)
			FineGrid%hy(i,j)  = -0.04_long
			FineGrid%hx(i,j)  = SIGMAx
			FineGrid%hyy(i,j) = zero
			FineGrid%hxx(i,j) = SIGMAxx
		ENDIF
	END DO
  END DO
ENDIF
END SUBROUTINE BottomWhalin


	DOUBLE PRECISION FUNCTION BESSJ0(X)
	DOUBLE PRECISION X
	DOUBLE PRECISION Y, Z, AX, XX
	DOUBLE PRECISION P1,P2,P3,P4,P5
	DOUBLE PRECISION Q1,Q2,Q3,Q4,Q5
	DOUBLE PRECISION R1,R2,R3,R4,R5,R6
	DOUBLE PRECISION S1,S2,S3,S4,S5,S6

	DATA P1 /1.D0/
	DATA P2 /-.1098628627D-2/
	DATA P3 /.2734510407D-4/
	DATA P4 /-.2073370639D-5/
	DATA P5 /.2093887211D-6/

	DATA Q1 /-.1562499995D-1/
	DATA Q2 /.1430488765D-3/
	DATA Q3 /-.6911147651D-5/
	DATA Q4 /.7621095161D-6/
	DATA Q5 /-.934945152D-7/

	DATA R1 /57568490574.D0/
	DATA R2 /-13362590354.D0/
	DATA R3 /651619640.7D0/
	DATA R4 /-11214424.18D0/
	DATA R5 /77392.33017D0/
	DATA R6 /-184.9052456D0/

	DATA S1 /57568490411.D0/
	DATA S2 /1029532985.D0/
	DATA S3 /9494680.718D0/
	DATA S4 /59272.64853D0/
	DATA S5 /267.8532712D0/
	DATA S6 /1.D0/

	IF(ABS(X).LT.8.)THEN
		Y = X**2
		BESSJ0 = (R1+Y*(R2+Y*(R3+Y*(R4+Y*(R5+Y*R6)))))
     *			/ (S1+Y*(S2+Y*(S3+Y*(S4+Y*(S5+Y*S6)))))
	ELSE
		AX = ABS(X)
		Z = 8./AX
		Y = Z**2
		XX = AX-.785398164
		BESSJ0 = SQRT (.636619772/AX) *
     *			(COS(XX) * (P1+Y*(P2+Y*(P3+Y*(P4+Y*P5)))) -
     *			Z * SIN(XX) * (Q1+Y*(Q2+Y*(Q3+Y*(Q4+Y*Q5)))))
	ENDIF
	RETURN
	END


      SUBROUTINE DFRMG (FIRST,NA,NB,NC,L,M,N,A,B,C,FREQ,AINVB,G,H,IPVT,
     +                  ZC,ZR,EVRE,EVIM,IERR,INFO,RCOND)
      INTEGER NA,NB,NC,L,M,N,IPVT(N),IERR,INFO
      DOUBLE PRECISION A(NA,N),B(NB,M),C(NC,N),ZR(N),EVRE(N),EVIM(N),
     +                 RCOND
      DOUBLE COMPLEX FREQ,AINVB(NB,M),G(NC,M),H(NA,N),ZC(N)
      LOGICAL FIRST
C
C     *** PURPOSE:
C
C     DFRMG TAKES REAL MATRICES A (N X N), B (N X M), AND C (L X N)
C     AND FORMS THE COMPLEX FREQUENCY RESPONSE MATRIX
C           G(FREQ) := C * (((FREQ * I) - A)-INVERSE) * B
C     WHERE  I = (N X N) IDENTITY MATRIX AND  FREQ  IS A COMPLEX
C     SCALAR PARAMETER TAKING VALUES ALONG THE IMAGINARY AXIS FOR
C     CONTINUOUS-TIME SYSTEMS AND ON THE UNIT CIRCLE FOR DISCRETE-
C     TIME SYSTEMS.
C
C     ON ENTRY:
C
C        FIRST    LOGICAL
C                 SET = .TRUE.  FOR THE FIRST CALL OF DFRMG WHEREUPON
C                 IT IS SET TO .FALSE. FOR ALL SUBSEQUENT CALLS; MAY BE
C                 SET = .FALSE.  INITIALLY IF A IS ALREADY IN UPPER
C                 HESSENBERG FORM AND NEITHER BALANCING NOR EIGENVALUES
C                 OF A ARE DESIRED.
C
C        NA       INTEGER
C                 THE LEADING OR ROW DIMENSION OF THE REAL ARRAY A
C                 (AND THE COMPLEX ARRAY H) AS DECLARED IN THE MAIN
C                 CALLING PROGRAM.
C
C        NB       INTEGER
C                 THE LEADING OR ROW DIMENSION OF THE REAL ARRAY B
C                 (AND THE COMPLEX ARRAY AINVB) AS DECLARED IN THE MAIN
C                 CALLING PROGRAM.
C
C        NC       INTEGER
C                 THE LEADING OR ROW DIMENSION OF THE REAL ARRAY C
C                 (AND THE COMPLEX ARRAY G) AS DECLARED IN THE MAIN
C                 CALLING PROGRAM.
C
C        L        INTEGER
C                 THE NUMBER OF ROWS OF C (THE NUMBER OF OUTPUTS).
C
C        M        INTEGER
C                 THE NUMBER OF COLUMNS OF B (THE NUMBER OF INPUTS).
C
C        N        INTEGER
C                 THE ORDER OF THE MATRIX A (THE NUMBER OF STATES);
C                 ALSO = NUMBER OF COLUMNS OF C = NUMBER OF ROWS OF B.
C
C        A        DOUBLE PRECISION(NA,N)
C                 A REAL N X N MATRIX (THE SYSTEM MATRIX); NOT NEEDED AS
C                 INPUT IF FIRST .EQ. .FALSE.
C
C        B        DOUBLE PRECISION(NB,M)
C                 A REAL N X M MATRIX (THE INPUT MATRIX); NOT NEEDED AS
C                 INPUT IF FIRST .EQ. .FALSE.
C
C        C        DOUBLE PRECISION(NC,N)
C                 A REAL L X N MATRIX (THE OUTPUT MATRIX); NOT NEEDED AS
C                 INPUT IF FIRST .EQ. .FALSE.
C
C        FREQ     DOUBLE COMPLEX
C                 A COMPLEX SCALAR (THE FREQUENCY PARAMETER).
C
C        IERR     INTEGER
C               --FIRST = .FALSE. : -IERR IS IGNORED.
C               --FIRST = .TRUE.  : -IF IERR .GE. 0, A WILL BE BALANCED
C                                    AND THE EIGENVALUES OF A WILL BE
C                                    COMPUTED (RECOMMENDED OPTION).
C                                   -IF IERR .LT. 0, A WILL NOT BE BAL-
C                                    ANCED AND THE EIGENVALUES OF A WILL
C                                    NOT BE COMPUTED.
C
C        INFO     INTEGER
C               --IF INFO .LT. 0, THE CONDITION OF (FREQ*I - A) WITH
C                 RESPECT TO INVERSION WILL BE ESTIMATED (RECOMMENDED
C                 OPTION).
C               --IF INFO .GE. 0, THE CONDITION OF (FREQ*I - A) WITH
C                 RESPECT TO INVERSION WILL NOT BE ESTIMATED.
C
C     ON RETURN:
C
C        G        DOUBLE COMPLEX(NC,M)
C                 THE FREQUENCY RESPONSE MATRIX G(FREQ).
C
C        A,B,C    A IS IN UPPER HESSENBERG FORM WHILE B AND C HAVE BEEN
C                 SUITABLY TRANSFORMED; IF  FIRST .EQ. .FALSE.  THESE
C                 ARRAYS ARE NOT FURTHER MODIFIED.
C
C        EVRE,    DOUBLE PRECISION(N),DOUBLE PRECISION(N)
C         EVIM    THE REAL AND IMAGINARY PARTS, RESPECTIVELY, OF THE
C                 EIGENVALUES OF THE MATRIX A IF DFRMG WAS INITIALLY
C                 CALLED WITH  FIRST = .TRUE. .AND. IERR .GE. 0.
C
C        IERR     IF (FIRST = .TRUE. .AND. IERR .GE. 0 ON INPUT) THEN
C                 IERR IS OUTPUT AS THE IERR PARAMETER OF THE EISPACK
C                 SUBROUTINE HQR (HQR DOCUMENTATION MAY BE CONSULTED FOR
C                 DETAILS); NORMAL RETURN IS 0.
C
C        INFO   --IGNORE IF INFO .LT. 0 ON INPUT.
C               --IF INFO .GE. 0 ON INPUT, THIS IS OUTPUT AS THE INFO
C                 PARAMETER OF SUBROUTINE ZHEFA (ZHEFA MAY BE CONSULTED
C                 FOR DETAILS); NORMAL RETURN IS 0.
C
C        RCOND    REAL
C               --IGNORE IF INFO .GE. 0 ON INPUT.
C               --IF INFO .LT. 0 ON INPUT, THIS IS OUTPUT AS THE RCOND
C                 PARAMETER OF SUBROUTINE ZHECO (ZHECO MAY BE CONSULTED
C                 FOR DETAILS); NORMAL RETURN IS WHEN
C                      (1.0 + RCOND) .GT. 1.0.
C
C        AINVB    DOUBLE COMPLEX(NB,M)
C                 SCRATCH ARRAY USED FOR INTERNAL COMPUTATIONS.
C
C        H        DOUBLE COMPLEX(NA,N)
C                 SCRATCH ARRAY USED FOR INTERNAL COMPUTATIONS.
C
C        IPVT     INTEGER(N)
C                 SCRATCH ARRAY USED FOR INTERNAL COMPUTATIONS.
C
C        ZC       DOUBLE COMPLEX(N)
C                 SCRATCH ARRAY USED FOR INTERNAL COMPUTATIONS.
C
C        ZR       DOUBLE PRECISION(N)
C                 SCRATCH ARRAY USED FOR INTERNAL COMPUTATIONS.
C
C     THIS VERSION DATED JUNE 1982.
C     ALAN J. LAUB, UNIVERSITY OF SOUTHERN CALIFORNIA.
C
C     SUBROUTINES AND FUNCTIONS CALLED:
C
C     BALANC(EISPACK),ZHECO,ZHEFA,ZHESL,HQR(EISPACK),DHETR
C
C     INTERNAL VARIABLES:
C
      INTEGER I,IGH,J,K,KK,KP,LOW
      DOUBLE PRECISION T
      DOUBLE COMPLEX ZDUM
C
C     FORTRAN FUNCTIONS CALLED:
C
      DOUBLE COMPLEX DCMPLX
C
C     INTERNAL FUNCTION:
C
      DOUBLE PRECISION DREAL
      DREAL(ZDUM) = ZDUM
C
      IF (.NOT. FIRST) GO TO 150
      IF (IERR .GE. 0) GO TO 10
      LOW = 1
      IGH = N
      GO TO 90
   10 CONTINUE
      CALL BALANC (NA,N,A,LOW,IGH,ZR)
C
C     ADJUST B AND C MATRICES BASED ON INFORMATION IN THE VECTOR
C     ZR WHICH DESCRIBES THE BALANCING OF A AND IS DEFINED IN THE
C     SUBROUTINE BALANC
C
      DO 40 K = 1,N
         KK = N-K+1
         IF (KK .GE. LOW .AND. KK .LE. IGH) GO TO 40
         IF (KK .LT. LOW) KK = LOW-KK
         KP = ZR(KK)
         IF (KP .EQ. KK) GO TO 40
C
C        PERMUTE ROWS OF B
C
         DO 20 J = 1,M
            T = B(KK,J)
            B(KK,J) = B(KP,J)
            B(KP,J) = T
   20    CONTINUE
C
C        PERMUTE COLUMNS OF C
C
         DO 30 I = 1,L
            T = C(I,KK)
            C(I,KK) = C(I,KP)
            C(I,KP) = T
   30    CONTINUE
C
   40 CONTINUE
      IF (IGH .EQ. LOW) GO TO 80
      DO 70 K = LOW,IGH
         T = ZR(K)
C
C        SCALE COLUMNS OF PERMUTED C
C
         DO 50 I = 1,L
            C(I,K) = C(I,K)*T
   50    CONTINUE
C
C        SCALE ROWS OF PERMUTED B
C
         DO 60 J = 1,M
            B(K,J) = B(K,J)/T
   60    CONTINUE
C
   70 CONTINUE
   80 CONTINUE
   90 CONTINUE
C
C     REDUCE A TO HESSENBERG FORM BY ORTHOGONAL SIMILARITIES AND
C     ACCUMULATE THE ORTHOGONAL TRANSFORMATIONS INTO B AND C
C
      CALL DHETR (NA,NB,NC,L,M,N,LOW,IGH,A,B,C,ZR)
      IF (IERR .LT. 0) GO TO 140
C
C     TEMPORARILY STORE HESSENBERG FORM OF A IN THE ARRAY H
C
      DO 110 J = 1,N
         DO 100 I = 1,N
            H(I,J) = DCMPLX(A(I,J),0.0D0)
  100    CONTINUE
  110 CONTINUE
C
C     COMPUTE THE EIGENVALUES OF A IF THAT OPTION IS REQUESTED
C
      CALL HQR (NA,N,LOW,IGH,A,EVRE,EVIM,IERR)
C
C     RESTORE UPPER HESSENBERG FORM OF A TO THE ARRAY A
C
      DO 130 J = 1,N
         DO 120 I = 1,N
            A(I,J) = DREAL(H(I,J))
  120    CONTINUE
  130 CONTINUE
  140 CONTINUE
      FIRST = .FALSE.
      IF (IERR .GT. 0) RETURN
C
C     UPDATE  H := (FREQ * I) - A   WITH APPROPRIATE VALUE OF FREQ
C
  150 CONTINUE
      DO 170 J = 1,N
         DO 160 I = 1,N
            H(I,J) = -DCMPLX(A(I,J),0.0D0)
  160    CONTINUE
         H(J,J) = FREQ+H(J,J)
  170 CONTINUE
      IF (INFO .LT. 0) GO TO 180
C
C     FACTOR THE COMPLEX HESSENBERG MATRIX WITH NO CONDITION
C     ESTIMATE
C
      CALL ZHEFA (H,NA,N,IPVT,INFO)
      IF (INFO .EQ. 0) GO TO 190
      RETURN
  180 CONTINUE
C
C     FACTOR THE COMPLEX HESSENBERG MATRIX AND ESTIMATE ITS
C     CONDITION
C
      CALL ZHECO (H,NA,N,IPVT,RCOND,ZC)
      T = 1.0D0+RCOND
      IF (T .EQ. 1.0D0) RETURN
  190 CONTINUE
C
C     COMPUTE  (H-INVERSE)*B
C
      DO 220 J = 1,M
         DO 200 I = 1,N
            ZC(I) = DCMPLX(B(I,J),0.0D0)
  200    CONTINUE
         CALL ZHESL (H,NA,N,IPVT,ZC)
         DO 210 I = 1,N
            AINVB(I,J) = ZC(I)
  210    CONTINUE
  220 CONTINUE
C
C     COMPUTE  C*(H-INVERSE)*B
C
      DO 260 J = 1,M
         DO 230 I = 1,L
            G(I,J) = (0.0D0,0.0D0)
  230    CONTINUE
         DO 250 K = 1,N
            DO 240 I = 1,L
               G(I,J) = G(I,J)+DCMPLX(C(I,K),0.0D0)*AINVB(K,J)
  240       CONTINUE
C
C        G NOW CONTAINS THE DESIRED FREQUENCY RESPONSE MATRIX
C
  250    CONTINUE
  260 CONTINUE
      RETURN
      END


program project3
!------------------------------------------------------------------------------------------------
! Fortran program to solve the traffic problem using the original closure equation.
! v = v_max * (1 - rho**2/rho_max**2)
! Various flux functions:
! (1) Exact Riemann Solution
!                 F(rho_L,rho_R) = rho_max * v_max / 4  (a_L <= 0 <= a_R)
!                                = f(rho_L)             (a_L + a_R >= 0)
!                                = f(rho_R)             else
! (2) Lax-Wendroff Flux Formula
!                 F(rho_L,rho_R) = f(1/2*(rho_L+rho_R) - Delta_t/(2*Delta_x)*(f(rho_R)-f(rho_L)))
! (3) Roe's Approximate Riemann Solver
!                 F(rho_L,rho_R) = f(rho_L)             (a_L + a_R >= 0)
!                                = f(rho_R)             else
! (4) Roe's Approximate Riemann Solver with Entropy Fix
!                 F(rho_L,rho_R) = 1/2*(f(rho_L) + f(rho_R) - 1/2*(a_R-a_L)*(rho_R-rho_L) sonic case
!                                = f(rho_L)                                               (a_L + a_R >= 0)
!                                = f(rho_R)                                               else

implicit none

! define variables
integer :: nn, i
integer, parameter :: M = 151, N = 251 ! large enough mesh sizes
real :: rho_max, rho_L, rho_R, v_max, Dx, Dt, SafeFactor, temp, a_max
real, allocatable, dimension(:,:) :: rho1, rho2, rho3, rho4
real, dimension(1:M) :: F1, F2, F3, F4, a, x
real, dimension(1:N) :: t

	write (*, '(/a/a/)') "------------------------------------------------------------",		&
				"Fortran solver to traffic equation using the original closure equation."
  write (*, '(a)') "Enter safe factor:"
  read (*,*) SafeFactor

  Dx = 50. ! space step Delta_x
  rho_max = 0.1 ! maximum density
  rho_L = rho_max ! initial left density
  rho_R = 0. ! initial right density
  v_max = 50. ! maximum velocity

  ! create arrays storing data for four schemes
  call create_array(M,N,rho1)
  call create_array(M,N,rho2)
  call create_array(M,N,rho3)
  call create_array(M,N,rho4)

  ! specify the range [-1000,6500] of space coordinate
  do i = 1, M
    x(i) = 0.0 - 1000.0 + (real(i)-1.0)*Dx
  end do

  ! 1st scheme - Exact Riemann solver
  nn = 1
  t(1) = 0. ! initial time
  do
    a_max = 0.
    do i = 1, M
      a(i) = v_max * (1.0 - 2.0*rho1(i,nn)/rho_max)
      temp = abs(a(i))
      if (temp > a_max) then
        a_max = temp
      end if
    end do
    Dt = SafeFactor * Dx/a_max ! the timestep has to allow the numerical scheme to catch all the characteristics

    if (t(nn)+Dt <= 60.) then
      F1(1) = 0. ! the very left flux is zero
      do i = 2, M-1
        F1(i) = F_ER(rho1(i,nn), rho1(i+1,nn)) ! calculate all fluxes
      end do
      F1(M) = f(rho1(M,nn)) ! determine the rightmost flux using its left neighbor

      ! calculate solution in next time step
      do i = 2, M
        rho1(i,nn+1) = rho1(i,nn) - Dt/Dx * (F1(i) - F1(i-1))
      end do

      t(nn+1) = t(nn) + Dt ! increment the total simulation time
      nn = nn + 1 ! increment the time step number
    else
      exit ! if the total time exceeds 60 seconds, terminate the loop
    end if
  end do

  write (*,'(a)') "Output for Exact Riemann:"
  call output(rho1,M,N,x,t,17) ! store the solution in a single file

  ! 2nd scheme - Lax-Wendroff scheme
  nn = 1
  t(1) = 0. ! initial time
  do
    a_max = 0.
    do i = 1, M
      a(i) = v_max * (1.0 - 2.0*rho1(i,nn)/rho_max)
      temp = abs(a(i))
      if (temp > a_max) then
        a_max = temp
      end if
    end do
    Dt = SafeFactor * Dx/a_max ! the timestep has to allow the numerical scheme to catch all the characteristics

    if (t(nn)+Dt <= 60.) then
      F2(1) = 0. ! the very left flux is zero
      do i = 2, M-1
        F2(i) = F_LW(rho2(i,nn),rho2(i+1,nn),Dt,Dx) ! calculate all fluxes
      end do
      F2(M) = f(rho2(M,nn)) ! determine the rightmost flux using its left neighbor

      ! calculate solution in next time step
      do i = 2, M
        rho2(i,nn+1) = rho2(i,nn) - Dt/Dx * (F2(i) - F2(i-1))
      end do

      t(nn+1) = t(nn) + Dt ! increment the total simulation time
      nn = nn + 1 ! increment the time step number
    else
      exit ! if the total time exceeds 60 seconds, terminate the loop
    end if
  end do

  write (*,'(a)') "Output for Lax-Wendroff:"
  call output(rho2,M,N,x,t,21) ! store the solution in a single file

  ! 3rd scheme - Roe's Approximate Riemann Solver
  nn = 1
  t(1) = 0. ! initial time
  do
    a_max = 0.
    do i = 1, M
      a(i) = v_max * (1.0 - 2.0*rho1(i,nn)/rho_max)
      temp = abs(a(i))
      if (temp > a_max) then
        a_max = temp
      end if
    end do
    Dt = SafeFactor * Dx/a_max ! the timestep has to allow the numerical scheme to catch all the characteristics

    if (t(nn)+Dt <= 60.) then
      F3(1) = 0. ! the very left flux is zero
      do i = 2, M-1
        F3(i) = F_RA(rho3(i,nn), rho3(i+1,nn)) ! calculate all fluxes
      end do
      F3(M) = f(rho3(M,nn)) ! determine the rightmost flux using its left neighbor

      ! calculate solution in next time step
      do i = 2, M
        rho3(i,nn+1) = rho3(i,nn) - Dt/Dx * (F3(i) - F3(i-1))
      end do

      t(nn+1) = t(nn) + Dt ! increment the total simulation time
      nn = nn + 1 ! increment the time step number
    else
      exit ! if the total time exceeds 60 seconds, terminate the loop
    end if
  end do

  write (*,'(a)') "Output for Roe Approximate:"
  call output(rho3,M,N,x,t,25) ! store the solution in a single file

  ! 4th scheme - Roe's Approximate Riemann Solver with Entropy Fix
  nn = 1
  t(1) = 0. ! initial time
  do
    a_max = 0.
    do i = 1, M
      a(i) = v_max * (1.0 - 2.0*rho1(i,nn)/rho_max)
      temp = abs(a(i))
      if (temp > a_max) then
        a_max = temp
      end if
    end do
    Dt = SafeFactor * Dx/a_max ! the timestep has to allow the numerical scheme to catch all the characteristics

    if (t(nn)+Dt <= 60.) then
      F4(1) = 0. ! the very left flux is zero
      do i = 2, M-1
        F4(i) = F_EF(rho4(i,nn), rho4(i+1,nn)) ! calculate all fluxes
      end do
      F4(M) = f(rho4(M,nn)) ! determine the rightmost flux using its left neighbor

      ! calculate solution in next time step
      do i = 2, M
        rho4(i,nn+1) = rho4(i,nn) - Dt/Dx * (F4(i) - F4(i-1))
      end do

      t(nn+1) = t(nn) + Dt ! increment the total simulation time
      nn = nn + 1 ! increment the time step number
    else
      exit ! if the total time exceeds 60 seconds, terminate the loop
    end if
  end do

  write (*,'(a)') "Output for Entropy Fix:"
  call output(rho4,M,N,x,t,29) ! store the solution in a single file

  ! output the exact solution in a separate file
  call output_exact(M,N,x,t,31)

  ! end of the main program
  ! *****************************************************************
  ! beginning of the subroutines and functions

contains
  ! create solution array
  subroutine create_array(M,N,rho)
    implicit none
    integer :: alstat_1, i
    integer, intent(in) :: M, N
    real, allocatable, dimension(:,:), intent(out) :: rho

    ! allocate two dimension array for storing the points of the grid
    allocate (rho(1:M, 1:N), stat = alstat_1)
    if (alstat_1 /= 0) then
      write (*, '(2x, a, /a)') "Error, unable to allocate memory. ", "Program terminated."
      stop
    end if
    ! initialize the array
    rho = 0.
    ! initial condition
    do i = 2, 21
      rho(i,1) = 0.1 ! left boundary densities are all zero, while the densities in the range of [-1000,0] are all 0.1
    end do
  end subroutine create_array

  ! interface flux function for four schemes
  function F_ER(rho_l,rho_r) ! Exact Riemann
    real :: rho_l, rho_r, a_L, a_R, F_ER
    a_L = v_max * (1 - 2*rho_l/rho_max)
    a_R = v_max * (1 - 2*rho_r/rho_max)
    if (a_L <= 0 .and. 0 <= a_R) then
      F_ER = rho_max*v_max/4.0
    else if (a_L + a_R >= 0) then
      F_ER = f(rho_l)
    else
      F_ER = f(rho_r)
    end if
  end function F_ER

  function F_LW(rho_l,rho_r,Delta_t,Delta_x) ! Lax-Wendroff
    real :: rho_l, rho_r, Delta_t, Delta_x, F_LW, ff
    ff = (rho_l+rho_r)/2.0 - Delta_t/2.0/Delta_x*(f(rho_r)-f(rho_l))
    F_LW = f(ff)
  end function F_LW

  function F_RA(rho_l,rho_r) ! Roe's Approximate Riemann Solver
    real :: rho_l, rho_r, a_L, a_R, F_RA
    a_L = v_max * (1 - 2*rho_l/rho_max)
    a_R = v_max * (1 - 2*rho_r/rho_max)
    if (a_L + a_R >= 0) then
      F_RA = f(rho_l)
    else
      F_RA = f(rho_r)
    end if
  end function F_RA

  function F_EF(rho_l,rho_r) ! Roe's Approximate Riemann Solver Entropy Fix
    real :: rho_l, rho_r, a_L, a_R, F_EF
    a_L = v_max * (1 - 2*rho_l/rho_max)
    a_R = v_max * (1 - 2*rho_r/rho_max)
    if (a_L <= 0 .and. a_R >= 0) then ! sonic case
      F_EF = 1.0/2.0*(f(rho_l)+f(rho_r)-1.0/2.0*(a_R-a_L)*(rho_r-rho_l))
    else if (a_L + a_R >= 0) then
      F_EF = f(rho_l)
    else
      F_EF = f(rho_r)
    end if
  end function F_EF

  function f(x)
    real :: f, x
    f = x * v_max * (1.0 - x/rho_max)
  end function f

  ! solution output subroutine
  subroutine output(rho,M,N,x,t,file_num)
    implicit none
    character(30) :: wrfile_output
    integer :: wropst_1, i, nn
    integer, intent(in) :: M, N, file_num
    real, dimension(1:M), intent(in) :: x
    real, dimension(1:N), intent(in) :: t
    real, allocatable, dimension(:,:), intent(in) :: rho

    ! prompt for the errors output file name
    do
      write (*, '(2x, a)', advance = "no") "Output File Name: "

      ! read errors output file name
      read (*,*) wrfile_output

      ! open output file (read access)
      ! if open successful, exit loop
      ! 		otherwise, display error message
      open(file_num, file = wrfile_output, status="new", 					&
            action="write", position="rewind", 					&
            iostat=wropst_1)
      if (wropst_1 == 0) exit
      write (*, '(2x, a, a/, a)') "Unable to create ",					&
                  "output file.", "Please re-enter..."
    end do

    ! store the values of space coordinates in the first row of the solution file
    write (file_num, '(2x, f10.5)', advance = "no") 0.0 ! merely a placeholder without physical meaning
    do i = 1, M
      write (file_num, '(2x, f10.4)', advance = "no") x(i)
    end do
    write (file_num,*)

    do nn = 1, N
      write (file_num, '(2x, f10.7)', advance = "no") t(nn) ! store the values of time in the first column of the solution file
      do i = 1, M
        write (file_num, '(2x, f10.7)', advance = "no") rho(i,nn)
      end do
      write (file_num,*)
    end do

    write (*, '(2x, a)') "Solution output successfully done!"
  end subroutine output

  ! exact solution output subroutine
  subroutine output_exact(M,N,x,t,file_num)
    implicit none
    character(30) :: wrfile_output
    integer :: wropst_1, i, nn
    integer, intent(in) :: M, N, file_num
    real :: a_L, a_R
    real, dimension(1:M), intent(in) :: x
    real, dimension(1:N), intent(in) :: t

    ! prompt for the errors output file name
    do
      write (*, '(2x, a)', advance = "no") "Output File Name: "

      ! read errors output file name
      read (*,*) wrfile_output

      ! open output file (read access)
      ! if open successful, exit loop
      ! 		otherwise, display error message
      open(file_num, file = wrfile_output, status="new", 					&
            action="write", position="rewind", 					&
            iostat=wropst_1)
      if (wropst_1 == 0) exit
      write (*, '(2x, a, a/, a)') "Unable to create ",					&
                  "output file.", "Please re-enter..."
    end do

    ! store the values of space coordinates in the first row of the solution file
    write (file_num, '(2x, f10.5)', advance = "no") 0.0 ! merely a placeholder without physical meaning
    do i = 1, M
      write (file_num, '(2x, f10.4)', advance = "no") x(i)
    end do
    write (file_num,*)

    ! write the initial condition into the second row of the solution file
    do i = 1, M
      if (i >= 3 .and. i <= 22 ) then
        write (file_num, '(2x, f10.5)', advance = "no") 0.1
      else
        write (file_num, '(2x, f10.5)', advance = "no") 0.0
      end if
    end do
    write (file_num,*)

    a_L = v_max * (1 - 2*0.1/rho_max)
    a_R = v_max * (1 - 2*0.0/rho_max)
    do nn = 2, N
      write (file_num, '(2x, f10.7)', advance = "no") t(nn) ! store the values of time in the first column of the solution file
      do i = 1, M
        if (x(i)/t(nn) < a_L) then
          write (file_num, '(2x, f10.7)', advance = "no") 0.1
        else if (x(i)/t(nn) > a_R) then
          write (file_num, '(2x, f10.7)', advance = "no") 0.0
        else
          write (file_num, '(2x, f10.7)', advance = "no") rho_max/2.0*(1.0-x(i)/t(nn)/v_max)
        end if
      end do
      write (file_num,*)
    end do

    write (*, '(2x, a)') "Exact solution output successfully done!"
  end subroutine output_exact

end program project3


  program loops

      implicit none

!     Program to demonstrate use of loops in fortran
!    (Lines that start with * or C are comments; all code starts in
!     at least column 7 and can't go past 72 in general)
!

!**** START OF PROGRAM *****
! Non-executable statements
!     Declare variables first
      integer*4  i, j    ! This is a comment, i and j loop variables
      integer, dimension(10,10) :: iarray
      logical done       ! Logical variable type

! Start of excutable statements

!***  Output what this program does
      write(*,100)
 100  format('Program to demonstrate loops')

!***  Standard loop
      write(*,200)
 200  format('Standard do loop',/, &
             '   I   I**2 ')         ! This is a continuation line
!    This loop loops from 1 to 10 increments of 1.  We could use
!     integer variables instead of 1 and 10 e.g.
!     n = 1
!     m = 10
!     do i = n, m   ! is the equivalent code
!     do i = m, n, -1  ! count down instead of up.
      do i = 1, 10
         ! Could add a cycle commnd.
         ! if( i > 3 .and. i < 5 ) cycle
         ! Could add an exit command
         ! if( i > 5 ) exit
         write(*,210) i,i**2
 210     format(1x,i3,1x,i6)
      end do

!***  Do while loop
!     The other loop is a do while loop which is useful if the
!     bounds are not known.  (See inout.f)
      write(*,220)
 220  format('Output from do while loop',/,'   I   I**2 ')
      done = .false.
      i = 0
      do while ( .not. done )
         i = i + 1
         if( i.ge.10 ) done = .true.
         write(*,210) i,i**2     ! Notice here we use the earlier format
      end do

!     Fortran 90 also allows the forall construction
      print *,'FORALL ARRAY Initialization'
      iarray = -1   ! Initialize the array with -1 values
      forall ( i=1:10 , j = 1:10 , j<i )
         iarray(i,j) = i*j
      end forall
      write(*,'(10(I4,1x))') iarray

  end


!--------------------------------------------------
!PHY1038 Assignment 5 Linear Algebra
!URN: 6408056
!MAY 2017
!--------------------------------------------------

PROGRAM Linear_Algebra

IMPLICIT NONE

REAL, DIMENSION(1:3,1:3) :: A, B, C, D, Inverse
REAL, DIMENSION(1:3,1:1) :: Answers, Solved
CHARACTER :: MainLoop, MatrixChoice, Sect, Choice, First

OPEN(unit=20,file='matrix.dat')  !Reading matrix A from file
READ(20,*) A(1,1), A(1,2), A(1,3)
READ(20,*) A(2,1), A(2,2), A(2,3)
READ(20,*) A(3,1), A(3,2), A(3,3)
CLOSE(20)

WRITE(6,*) 'This program can calculate the determinant of a 3*3 array, its cofactor and its'
WRITE(6,*) 'inverse, it can also solve simulataneous equations with 3 unknows, given the'
WRITE(6,*) 'coefficents of the unknowns in matrix form, and the asnwers to the equations'
WRITE(6,*) 'It can do this with a user inputed matrix, or the preprogrammed matrix ''A'' that can be'
WRITE(6,*) 'used as an example.'
!^Intro describing functions of program
MainLoop='Y' !Set so main do loop plays on the first run
Choice='N' !Set so that the programe asks user to enter matrix
First='T'!Set to describe to user in what form to enter the matrix on their first run

DO WHILE(MainLoop=='Y'.or. MainLoop=='y')

  IF (Choice=='N' .or. Choice=='n') THEN !This if is here, as at the end of the program the user
                                         !is asked if they want to use the same matrix again
                                         !Or not, if they select no they will be given the option
                                         !To enter a matrix/choose A
    WRITE(6,*) 'Would you like to use the preprogrammed matrix A? Where A='
    WRITE(6,*) A(1,1), A(1,2), A(1,3)
    WRITE(6,*) A(2,1), A(2,2), A(2,3)
    WRITE(6,*) A(3,1), A(3,2), A(3,3)
    WRITE(6,*) 'Or would you like to use your own matrix?'
    WRITE(6,*) 'Type A to use the preprogrammed matrix, or B to use your own matrix.'
    !^offering user to choose between the preprogrammed matrix or for them to enter their own
    DO
      READ(5,*) MatrixChoice
      IF(MatrixChoice=='A' .OR. MatrixChoice=='a') THEN !Plays if they chose to use matrix A
        B=A
        ANSWERS(1,1)=0 ; ANSWERS(2,1)=3 ; ANSWERS(3,1)=1
        !^Setting matrix to A and the answers to equations to those given in assignment
        EXIT
      ELSE IF (MatrixChoice=='B' .OR. MatrixChoice=='b') THEN
        !^Plays if they chose to enter their own matrix

        DO!This Do loop will replay if user says they entered matrix wrong
          IF(First=='T') THEN !Will tell user in what form to enter matrix on their first run
            WRITE(6,*) 'Please enter your matrix (1st row then 2nd etc.) If you intend to solve a'
            WRITE(6,*) 'simultaneous equation, the different coefficents of each '
            WRITE(6,*) 'unknown must be in the same columns, ie. all of X''s coefficents will'
            WRITE(6,*) 'be in column one, and Y''s in column one.'
            First='F'
            !^Prevents this writing to screen everytime
          ELSE
            WRITE(6,*) 'Please enter your matrix'
            !^Will play on second, third run etc.
          END IF

          READ(6,*) B(1,1), B(1,2), B(1,3)
          READ(6,*) B(2,1), B(2,2), B(2,3)
          READ(6,*) B(3,1), B(3,2), B(3,3)
          !^Reading users matrix
          WRITE(6,*) 'You entered:'

          WRITE(6,*) B(1,1), B(1,2), B(1,3)
          WRITE(6,*) B(2,1), B(2,2), B(2,3)
          WRITE(6,*) B(3,1), B(3,2), B(3,3)

          WRITE(6,*) 'Is this correct? Type Y for yes, or N to try again.'
          !Checking matrix is correct
          DO !This do loop will replay till user enters valid choice
            READ(5,*) Choice
            IF (Choice=='Y' .OR. Choice=='y' .OR. Choice=='N' .OR. Choice=='n') THEN
              EXIT
              !Do loop will exit if they enter valid choice
            END IF
            WRITE(6,*) 'Please enter a valid choice.'
          END DO

          IF (Choice=='Y' .OR. Choice=='y') THEN
            EXIT !The do loop will exit if they say they entered the correct matrix
            !Otherwise it will ask them to enter their matrix again
          END IF
        END DO !End of do loop asking them to enter their matrix

        EXIT !Exits do loop asking them to choose between A and or the users matrix

       ELSE
        WRITE(6,*) 'Please enter a valid choice.'
        !^Will play if user enters something other than A or B
      END IF
      !^End of if seperating A and B choices
    END DO
    !^End of Do ensuring A or B is chosen
  END IF
  !^End of if that allows for the choice to use the same matrix again

  DO!Do loop will replay if a valid choice is not entered
    WRITE(6,*) 'If you would like to calculate the determinant of a 3*3 matrice type D, type C to'
    WRITE(6,*) 'calculate its cofactor, of S to solve simultaneous equations'
    READ(5,*) Sect
    IF(Sect=='S' .or. Sect=='s' .or. Sect=='D' .or. Sect=='d' .or. Sect=='C' .or. Sect=='c') THEN
      EXIT!Exits do loop when valid choice is entered
    END IF
    WRITE(6,*) 'Please enter a valid choice'
  END DO

  IF (Sect=='D' .OR. Sect=='d') THEN!This if loop seperates the calculations possible in the
                                          !Program
    WRITE(6,*) 'The determinant of your matrix is:', Determinant(B)!Calls on determinant function
                                                                   !And prints to screen
  ELSE IF (Sect=='C' .OR. Sect=='c') THEN

    WRITE(6,*) 'The cofactor of your matrx is:'
    CALL Cofactor(C,B)   !Calls on cofactor subroutine and prints cofactor to screen
    WRITE(6,*) C(1,1), C(1,2), C(1,3)
    WRITE(6,*) C(2,1), C(2,2), C(2,3)
    WRITE(6,*) C(3,1), C(3,2), C(3,3)

  ELSE IF (Sect=='S' .OR. Sect=='s') THEN

    IF (MatrixChoice=='B'.OR. MatrixChoice=='b') THEN !If user chose to enter their own matrix
                                                      !this plays, asking them to enter the
                                                      !Answers to their simultaneous equations
      DO  !Will replay if the user says they entered the wrong answers
        WRITE(6,*) 'Please enter the 3 answers to your simultaenous equations, in the order to'
        WRITE(6,*) 'conform with the order you entered the equations.'
          READ(5,*) Answers(1,1), Answers(2,1), Answers(3,1) !Reading answers
          WRITE(6,*) 'You entered:'
          WRITE(6,*) Answers(1,1), Answers(2,1), Answers(3,1), 'Is this correct? Type Y for yes, or N'
          WRITE(6,*) 'to try again'

          DO!Do loop will replay if user doesnt enter valid choice
            READ(5,*) Choice
            IF(Choice=='Y' .or. Choice=='y' .or. Choice=='N' .or. Choice=='n') THEN
              EXIT!Exits do loop when valid choice is entered
            END IF
            WRITE(6,*) 'Please enter valid choice'
          END DO

          IF(Choice=='Y' .or. Choice=='y') THEN
            EXIT!Exits do loop when they say they entered correct answers
          END IF

      END DO

    ELSE IF (MatrixChoice=='A' .OR. MatrixChoice=='a') THEN !Plays if user chose to use matrix A
      WRITE(6,*) 'As you chose A as the preprogrammed matrix the answers to the simultaneous'
      WRITE(6,*) 'equations have been set as:'
      WRITE(6,*) Answers(1,1), Answers(2,1), Answers(3,1)
      !Prints answers that were set earlier, as according to assignment script
    END IF

    CALL Cofactor(C, B)!Calculating cofactor
    D = Transpose(C) !Transposing cofactor
    Inverse=(1/Determinant(B))*D  !Calculating inverse
    Solved=Matmul(Inverse,Answers) !Saving unknowns values in matrice, by multiplying inverse by
                                   !The simultaneous equations

    WRITE(6,*) 'The value of your unknown in your matrices collumn one is', Solved(1,1)
    WRITE(6,*) 'Column two''s unknown is',Solved(2,1)
    WRITE(6,*) 'Column three''s unknown is',Solved(3,1) !Printing answers

  END IF!End of if that seperates determinant/cofactor/equations sections

  WRITE(6,*) 'Would you like to run the program again?'
  DO !will replay if valid choice is not entered
    WRITE(6,*) 'Type Y for yes, or N for no.'
    READ(5,*) Mainloop
    IF(Mainloop=='Y' .or. Mainloop=='y' .or. Mainloop=='N' .or. Mainloop=='n') THEN
      EXIT!Exits when valid choice is entered
    END IF
    WRITE(6,*) 'Please enter valid choice'
  END DO
  IF(Mainloop=='N' .or. Mainloop=='n') THEN
    EXIT!Exits main do loop when N is selected, exiting programme
  END IF

  WRITE(6,*)'Would you like to use the same matrix?'
  DO !Do loop replays when valid choice is not entered
    WRITE(6,*) 'Type Y for yes, or N for no.'
    READ(5,*) Choice !This choice is then used at the start of the programme, if Y is entered the
                     !Option to enter a matrix/use matrix A is skipped, and the programme skips
                     !to asking what calculation they want to do
    IF(Choice=='Y' .or. Choice=='y' .or. Choice=='N' .or. Choice=='n') THEN
      EXIT !Exits do loop when valid choice is entered
    END IF
    WRITE(6,*) 'Please enter valid choice'
  END DO

END DO

WRITE(6,*) 'Thank you for using the programme.'  !Plays on exit

CONTAINS

FUNCTION Determinant(B)
  IMPLICIT NONE
  REAL, DIMENSION(1:3,1:3) :: B
  REAL :: Determinant, X

  X = B(1,1)*(B(2,2)*B(3,3)-B(2,3)*B(3,2))!calculates the three 2*2 determinants

  X = X - B(2,1)*((B(1,2)*B(3,3))-(B(1,3)*B(3,2)))

  Determinant = X+B(3,1)*((B(1,2)*B(2,3))-(B(1,3)*B(2,2))) !Final sum

END FUNCTION

SUBROUTINE Cofactor(C,B)
  IMPLICIT NONE
  REAL, DIMENSION(1:3,1:3) :: B, C

  C(1,1) = B(2,2)*B(3,3)-B(2,3)*B(3,2)

  C(1,2) = -(B(2,1)*B(3,3)-B(2,3)*B(3,1))

  C(1,3) = B(2,1)*B(3,2)-B(2,2)*B(3,1)

  C(2,1) = -(B(1,2)*B(3,3)-B(1,3)*B(3,2))

  C(2,2) = B(1,1)*B(3,3)-B(1,3)*B(3,1)

  C(2,3) = -(B(1,1)*B(3,2)-B(1,2)*B(3,1))

  C(3,1) = B(1,2)*B(2,3)-B(1,3)*B(2,2)

  C(3,2) = -(B(1,1)*B(2,3)-B(1,3)*B(2,1))

  C(3,3) = (B(1,1)*B(2,2)-B(1,2)*B(2,1))

!Calculates all the cofactor values in normal way, ie calcualtes determinants of values that
!Do not have a matching row or collumn, and multiplying them by -1 to the power of the sum
!of row and column, it saves the values to matrix C, the value is then printed outside the
!Subroutine so that the cofactor is not printed unnecessarily when calculating inverse
END SUBROUTINE

END PROGRAM


! --------------------------------------------------------------------
!
! Copyright (C) 2015 Rocco Meli
!
! This program is free software: you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation, either version 3 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
! ---------------------------------------------------------------------

MODULE ELECTRONIC

    USE FACT
    USE GAUSSIAN
    USE CONSTANTS
    USE NUCLEAR, only: f, boys

    IMPLICIT NONE

    CONTAINS

        FUNCTION theta(l,l1,l2,a,b,r,g) result(t)
            !----------------------------------------
            ! Coefficient theta
            !----------------------------------------
            !
            ! Source:
            !     Handbook of Computational Chemistry
            !     David Cook
            !     Oxford University Press
            !     1998
            !
            !----------------------------------------

            IMPLICIT NONE

            ! INPUT
            INTEGER, intent(in) :: l, l1, l2, r
            REAL*8, intent(in) :: a, b, g

            ! OUTPUT
            REAL*8 :: t

            t = 1.0D0
            t = t * f(l,l1,l2,a,b) * factorial(l) * g**(r-l)
            t = t / ( factorial(r) * factorial(l - 2*r) )

        END FUNCTION theta

        FUNCTION B(l,ll,r,rr,i,l1,l2,Ra,Rb,Rp,g1,l3,l4,Rc,Rd,Rq,g2,delta)
            !----------------------------------------
            ! Coefficient B
            !----------------------------------------
            !
            ! Source:
            !     Handbook of Computational Chemistry
            !     David Cook
            !     Oxford University Press
            !     1998
            !
            !----------------------------------------

            IMPLICIT NONE

            ! INPUT
            INTEGER, intent(in) :: l, ll, r, rr, i, l1, l2, l3, l4
            REAL*8, intent(in) :: Ra, Rb, Rp, g1, Rc, Rd, Rq, g2, delta

            ! OUTPUT
            REAL*8 :: B

            B = 1.0D0
            B = B * (-1)**(l) * theta(l,l1,l2,Rp-Ra,Rp-Rb,r,g1)
            B = B * theta(ll,l3,l4,Rq-Rc,Rq-Rd,rr,g2) * (-1)**i
            B = B * (2.0D0*delta)**(2*(r+rr)) * factorial(l + ll - 2 * r - 2 * rr)
            B = B * delta**i * (Rp-Rq)**(l+ll - 2*(r+rr+i))
            B = B / ( (4.0D0*delta)**(l+ll) * factorial(i) * factorial(l+ll - 2*(r+rr+i)) )

        END FUNCTION B

        FUNCTION electronic_coeff(ax,ay,az,bx,by,bz,cx,cy,cz,dx,dy,dz,aa,bb,cc,dd,Ra,Rb,Rc,Rd) result(G)
            !--------------------------------------------------------------------------
            ! Compute electron-electron integral between two cartesia Gaussian function
            !--------------------------------------------------------------------------
            !
            ! Source:
            !     Handbook of Computational Chemistry
            !     David Cook
            !     Oxford University Press
            !     1998
            !
            !--------------------------------------------------------------------------

            IMPLICIT NONE

            ! INPUT
            INTEGER, intent(in) :: ax, ay, az, bx, by, bz, cx, cy, cz, dx, dy, dz   ! Angular momentum coefficients
            REAL*8, intent(in) :: aa, bb, cc, dd                                    ! Exponential Gaussian coefficients
            REAL*8, dimension(3), intent(in) :: Ra, Rb, Rc, Rd                      ! Gaussian centers

            ! INTERMEDIATE VARIABLES
            REAL*8 :: delta
            REAL*8 :: g1, g2                        ! Gaussian produc exponential coefficient
            REAL*8, dimension(3) :: Rp, Rq          ! Gaussian produc center
            REAL*8 :: c1, c2                        ! Gaussian product multiplicative constant
            REAL*8 :: BBx, BBy, BBz                 ! Temporary calls to FUNCTION B
            INTEGER :: nu                           ! Boys function index
            INTEGER :: l, r, i, ll, rr              ! Indices loop 1
            INTEGER :: m, s, j, mm, ss              ! Indices loop 2
            INTEGER :: n, t, k, nn, tt              ! Indices loop 3

            ! OUTPUT
            REAL*8 :: G ! Electron-electron repulsion coefficient

            G = 0.0D0

            CALL gaussian_product(aa,bb,Ra,Rb,g1,Rp,c1) ! Gaussian product of left gaussians
            CALL gaussian_product(cc,dd,Rc,Rd,g2,Rq,c2) ! Gaussian product of right gaussians

            delta = 1.0D0 / (4.0D0 * g1) + 1.0D0 / (4.0D0 * g2)

            DO l = 0, ax + bx
                DO r = 0, FLOOR(l / 2.0)
                    DO ll = 0, cx + dx
                        DO rr = 0, FLOOR(ll / 2.0)
                            DO i = 0, FLOOR((l+ll-2*r-2*rr) / 2.0)

                                 BBx = B(l,ll,r,rr,i,ax,bx,Ra(1),Rb(1),Rp(1),g1,&
                                         cx,dx,Rc(1),Rd(1),Rq(1),g2,delta)

                                 DO m = 0, ay + by
                                     DO s = 0, FLOOR(m / 2.0)
                                         DO mm = 0, cy + dy
                                             DO ss = 0, FLOOR(mm / 2.0)
                                                 DO j = 0, FLOOR((m+mm-2*s-2*ss) / 2.0)
                                                    BBy = B(m,mm,s,ss,j,ay,by,Ra(2),Rb(2),Rp(2),&
                                                            g1,cy,dy,Rc(2),Rd(2),Rq(2),g2,delta)

                                                    DO n = 0, az + bz
                                                        DO t = 0, FLOOR(n / 2.0)
                                                            DO nn = 0, cz + dz
                                                                DO tt = 0, FLOOR(nn / 2.0)
                                                                    DO k = 0, FLOOR((n+nn-2*t-2*tt) / 2.0)

                                                                        BBz = B(n,nn,t,tt,k,az,bz,Ra(3),Rb(3),Rp(3),g1,&
                                                                                cz,dz,Rc(3),Rd(3),Rq(3),g2,delta)

                                                                        nu = l+ll+m+mm+n+nn - 2*(r+rr+s+ss+t+tt) - (i + j + k)

                                                                        G = G + BBx * BBy * BBz *&
                                                                         boys(nu,DOT_PRODUCT(Rp-Rq,Rp-Rq)*g1*g2/(g1+g2))

                                                                    END DO ! tt
                                                                END DO ! nn
                                                            END DO ! k
                                                        END DO ! t
                                                    END DO ! n

                                                END DO ! ss
                                            END DO ! mm
                                        END DO ! j
                                    END DO ! s
                                END DO ! m

                            END DO ! rr
                        END DO ! ll
                    END DO ! i
                END DO ! r
            END DO ! k

            G = G * norm(ax,ay,az,aa) * norm(bx,by,bz,bb) * norm(cx,cy,cz,cc) * norm(dx,dy,dz,dd)
            G = G * c1 * c2 * 2.0D0 * PI**2 / (g1 * g2) * SQRT(PI / (g1 + g2))

        END FUNCTION electronic_coeff

        ! ---------------------------------------
        ! GENERATE LIST OF TWO-ELECTRON INTEGRALS
        ! ---------------------------------------
        SUBROUTINE ee_list(Kf,c,basis_D,basis_A,basis_L,basis_R,ee)

            IMPLICIT NONE

            ! TODO Allow flexibility for basis sets other than STO-3G
            INTEGER, intent(in) :: c ! Number of contractions per basis function

            ! INPUT
            INTEGER, intent(in) :: Kf                       ! Number of basis functions
            REAL*8, dimension(Kf,3), intent(in) :: basis_R  ! Basis set niclear positions
            INTEGER, dimension(Kf,3), intent(in) :: basis_L ! Basis set angular momenta
            REAL*8, dimension(Kf,c), intent(in) :: basis_D  ! Basis set contraction coefficients
            REAL*8, dimension(Kf,c), intent(in) :: basis_A  ! Basis set exponential contraction coefficients

            ! INTERMEDIATE VARIABLES
            INTEGER :: i,j,k,l  ! Indices running over basis functions
            INTEGER :: m,n,o,p  ! Indices running over contractions
            REAL*8 :: tmp

            ! OUTPUT
            REAL*8, dimension(Kf,Kf,Kf,Kf), intent(out) :: ee   ! List of electron-electron integrals

            ee(:,:,:,:) = 0.0D0

            DO i = 1,Kf
                DO j = 1,Kf
                    DO k = 1,Kf
                        DO l = 1,Kf

                            DO m = 1,c
                                DO n = 1,c
                                    DO o = 1,c
                                        DO p = 1,c

                                            ! Contraction coefficients
                                            tmp = basis_D(i,m) * basis_D(j,n) * basis_D(k,o) * basis_D(l,p)

                                            tmp = tmp * electronic_coeff(   basis_L(i,1),&  ! lx for basis function i
                                                                            basis_L(i,2),&  ! ly for basis function i
                                                                            basis_L(i,3),&  ! lz for basis function i
                                                                            basis_L(j,1),&  ! lx for basis function j
                                                                            basis_L(j,2),&  ! ly for basis function j
                                                                            basis_L(j,3),&  ! lz for basis function j
                                                                            basis_L(k,1),&  ! lx for basis function k
                                                                            basis_L(k,2),&  ! ly for basis function k
                                                                            basis_L(k,3),&  ! lz for basis function k
                                                                            basis_L(l,1),&  ! lx for basis function l
                                                                            basis_L(l,2),&  ! ly for basis function l
                                                                            basis_L(l,3),&  ! lz for basis function l
                                                                            basis_A(i,m),&  ! Exponential coefficient for basis function i, contraction m
                                                                            basis_A(j,n),&  ! Exponential coefficient for basis function j, contraction n
                                                                            basis_A(k,o),&  ! Exponential coefficient for basis function k, contraction o
                                                                            basis_A(l,p),&  ! Exponential coefficient for basis function l, contraction p
                                                                            basis_R(i,:),&  ! Center of basis function i
                                                                            basis_R(j,:),&  ! Center of basis function j
                                                                            basis_R(k,:),&  ! Center of basis function i
                                                                            basis_R(l,:))   ! Center of basis function j

                                            ee(i,j,k,l) = ee(i,j,k,l) + tmp

                                        END DO ! p
                                    END DO ! o
                                END DO ! m
                            END DO ! n

                        END DO ! l
                    END DO ! k
                END DO ! j
            END DO ! i

        END SUBROUTINE ee_list

        ! ----------------------------------
        ! ELECTRON-ELECTRON REPULSION MATRIX
        ! ----------------------------------
        SUBROUTINE G_ee(Kf,ee,P,G)
            ! -----------------------------------------------------------------------
            ! Compute the electron-electron repulsion matrix using the density matrix
            ! -----------------------------------------------------------------------
            !
            ! Source:
            !   Szabo and Ostlund
            !   Modern Quantum Chemistry
            !   Doever
            !   1989
            !
            ! ------------------------------------------------------------------------

            IMPLICIT NONE

            ! INPUT
            INTEGER, intent(in) :: Kf                           ! Number of basis functions
            REAL*8, dimension(Kf,Kf,Kf,Kf), intent(in) :: ee    ! Electron-electron list
            REAL*8, dimension(Kf,Kf) :: P                       ! Density matrix

            ! INTERMEDIATE VARIABLES
            INTEGER :: i, j, k, l

            ! OUTPUT
            REAL*8, dimension(Kf,Kf), intent(out) :: G          ! Electron-electron repulsion matrix

            G(:,:) = 0.0D0

            DO i = 1, Kf
                DO j = 1, Kf
                    DO k = 1, Kf
                        DO l = 1, Kf
                            G(i,j) = G(i,j) + P(k,l) * (ee(i,j,l,k) - 0.5D0 * ee(i,k,l,j))
                        END DO ! l
                    END DO ! k
                END DO ! j
            END DO ! i

        END SUBROUTINE G_ee

        ! ---------------------------------------------------------------
        ! ELECTRON-ELECTRON REPULSION MATRIX FOR SPIN UNRESTRICTED SYSTEM
        ! ---------------------------------------------------------------
        SUBROUTINE G_ee_spin(Kf,ee,Ptot,P,G)
            ! -----------------------------------------------------------------------
            ! Compute the electron-electron repulsion matrix using the density matrix
            ! -----------------------------------------------------------------------
            !
            ! Source:
            !   Szabo and Ostlund
            !   Modern Quantum Chemistry
            !   Doever
            !   1989
            !
            ! ------------------------------------------------------------------------

            IMPLICIT NONE

            ! INPUT
            INTEGER, intent(in) :: Kf                           ! Number of basis functions
            REAL*8, dimension(Kf,Kf,Kf,Kf), intent(in) :: ee    ! Electron-electron list
            REAL*8, dimension(Kf,Kf) :: Ptot                    ! Total density matrix
            REAL*8, dimension(Kf,Kf) :: P                       ! Spin density matrix

            ! INTERMEDIATE VARIABLES
            INTEGER :: i, j, k, l

            ! OUTPUT
            REAL*8, dimension(Kf,Kf), intent(out) :: G          ! Electron-electron repulsion matrix

            G(:,:) = 0.0D0

            DO i = 1, Kf
                DO j = 1, Kf
                    DO k = 1, Kf
                        DO l = 1, Kf
                            G(i,j) = G(i,j) + Ptot(k,l) * ee(i,j,l,k) - P(k,l) * ee(i,k,l,j)
                        END DO ! l
                    END DO ! k
                END DO ! j
            END DO ! i

        END SUBROUTINE G_ee_spin

END MODULE ELECTRONIC


*DECK TSTURM
      SUBROUTINE TSTURM (NM, N, EPS1, D, E, E2, LB, UB, MM, M, W, Z,
     +   IERR, RV1, RV2, RV3, RV4, RV5, RV6)
C***BEGIN PROLOGUE  TSTURM
C***PURPOSE  Find those eigenvalues of a symmetric tridiagonal matrix
C            in a given interval and their associated eigenvectors by
C            Sturm sequencing.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4A5, D4C2A
C***TYPE      SINGLE PRECISION (TSTURM-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine finds those eigenvalues of a TRIDIAGONAL
C     SYMMETRIC matrix which lie in a specified interval and their
C     associated eigenvectors, using bisection and inverse iteration.
C
C     On Input
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameter, Z, as declared in the calling program
C          dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix.  N is an INTEGER variable.
C          N must be less than or equal to NM.
C
C        EPS1 is an absolute error tolerance for the computed eigen-
C          values.  It should be chosen so that the accuracy of these
C          eigenvalues is commensurate with relative perturbations of
C          the order of the relative machine precision in the matrix
C          elements.  If the input EPS1 is non-positive, it is reset
C          for each submatrix to a default value, namely, minus the
C          product of the relative machine precision and the 1-norm of
C          the submatrix.  EPS1 is a REAL variable.
C
C        D contains the diagonal elements of the symmetric tridiagonal
C          matrix.  D is a one-dimensional REAL array, dimensioned D(N).
C
C        E contains the subdiagonal elements of the symmetric
C          tridiagonal matrix in its last N-1 positions.  E(1) is
C          arbitrary.  E is a one-dimensional REAL array, dimensioned
C          E(N).
C
C        E2 contains the squares of the corresponding elements of E.
C          E2(1) is arbitrary.  E2 is a one-dimensional REAL array,
C          dimensioned E2(N).
C
C        LB and UB define the interval to be searched for eigenvalues.
C          If LB is not less than UB, no eigenvalues will be found.
C          LB and UB are REAL variables.
C
C        MM should be set to an upper bound for the number of
C          eigenvalues in the interval.  MM is an INTEGER variable.
C          WARNING -  If more than MM eigenvalues are determined to lie
C          in the interval, an error return is made with no values or
C          vectors found.
C
C     On Output
C
C        EPS1 is unaltered unless it has been reset to its
C          (last) default value.
C
C        D and E are unaltered.
C
C        Elements of E2, corresponding to elements of E regarded as
C          negligible, have been replaced by zero causing the matrix to
C          split into a direct sum of submatrices.  E2(1) is also set
C          to zero.
C
C        M is the number of eigenvalues determined to lie in (LB,UB).
C          M is an INTEGER variable.
C
C        W contains the M eigenvalues in ascending order if the matrix
C          does not split.  If the matrix splits, the eigenvalues are
C          in ascending order for each submatrix.  If a vector error
C          exit is made, W contains those values already found.  W is a
C          one-dimensional REAL array, dimensioned W(MM).
C
C        Z contains the associated set of orthonormal eigenvectors.
C          If an error exit is made, Z contains those vectors already
C          found.  Z is a one-dimensional REAL array, dimensioned
C          Z(NM,MM).
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          3*N+1      if M exceeds MM no eigenvalues or eigenvectors
C                     are computed,
C          4*N+J      if the eigenvector corresponding to the J-th
C                     eigenvalue fails to converge in 5 iterations, then
C                     the eigenvalues and eigenvectors in W and Z should
C                     be correct for indices 1, 2, ..., J-1.
C
C        RV1, RV2, RV3, RV4, RV5, and RV6 are temporary storage arrays,
C          dimensioned RV1(N), RV2(N), RV3(N), RV4(N), RV5(N), and
C          RV6(N).
C
C     The ALGOL procedure STURMCNT contained in TRISTURM
C     appears in TSTURM in-line.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  R1MACH
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  TSTURM
C
      INTEGER I,J,K,M,N,P,Q,R,S,II,IP,JJ,MM,M1,M2,NM,ITS
      INTEGER IERR,GROUP,ISTURM
      REAL D(*),E(*),E2(*),W(*),Z(NM,*)
      REAL RV1(*),RV2(*),RV3(*),RV4(*),RV5(*),RV6(*)
      REAL U,V,LB,T1,T2,UB,UK,XU,X0,X1,EPS1,EPS2,EPS3,EPS4
      REAL NORM,MACHEP,S1,S2
      LOGICAL FIRST
C
      SAVE FIRST, MACHEP
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  TSTURM
      IF (FIRST) THEN
         MACHEP = R1MACH(4)
      ENDIF
      FIRST = .FALSE.
C
      IERR = 0
      T1 = LB
      T2 = UB
C     .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES ..........
      DO 40 I = 1, N
         IF (I .EQ. 1) GO TO 20
         S1 = ABS(D(I)) + ABS(D(I-1))
         S2 = S1 + ABS(E(I))
         IF (S2 .GT. S1) GO TO 40
   20    E2(I) = 0.0E0
   40 CONTINUE
C     .......... DETERMINE THE NUMBER OF EIGENVALUES
C                IN THE INTERVAL ..........
      P = 1
      Q = N
      X1 = UB
      ISTURM = 1
      GO TO 320
   60 M = S
      X1 = LB
      ISTURM = 2
      GO TO 320
   80 M = M - S
      IF (M .GT. MM) GO TO 980
      Q = 0
      R = 0
C     .......... ESTABLISH AND PROCESS NEXT SUBMATRIX, REFINING
C                INTERVAL BY THE GERSCHGORIN BOUNDS ..........
  100 IF (R .EQ. M) GO TO 1001
      P = Q + 1
      XU = D(P)
      X0 = D(P)
      U = 0.0E0
C
      DO 120 Q = P, N
         X1 = U
         U = 0.0E0
         V = 0.0E0
         IF (Q .EQ. N) GO TO 110
         U = ABS(E(Q+1))
         V = E2(Q+1)
  110    XU = MIN(D(Q)-(X1+U),XU)
         X0 = MAX(D(Q)+(X1+U),X0)
         IF (V .EQ. 0.0E0) GO TO 140
  120 CONTINUE
C
  140 X1 = MAX(ABS(XU),ABS(X0)) * MACHEP
      IF (EPS1 .LE. 0.0E0) EPS1 = -X1
      IF (P .NE. Q) GO TO 180
C     .......... CHECK FOR ISOLATED ROOT WITHIN INTERVAL ..........
      IF (T1 .GT. D(P) .OR. D(P) .GE. T2) GO TO 940
      R = R + 1
C
      DO 160 I = 1, N
  160 Z(I,R) = 0.0E0
C
      W(R) = D(P)
      Z(P,R) = 1.0E0
      GO TO 940
  180 X1 = X1 * (Q-P+1)
      LB = MAX(T1,XU-X1)
      UB = MIN(T2,X0+X1)
      X1 = LB
      ISTURM = 3
      GO TO 320
  200 M1 = S + 1
      X1 = UB
      ISTURM = 4
      GO TO 320
  220 M2 = S
      IF (M1 .GT. M2) GO TO 940
C     .......... FIND ROOTS BY BISECTION ..........
      X0 = UB
      ISTURM = 5
C
      DO 240 I = M1, M2
         RV5(I) = UB
         RV4(I) = LB
  240 CONTINUE
C     .......... LOOP FOR K-TH EIGENVALUE
C                FOR K=M2 STEP -1 UNTIL M1 DO --
C                (-DO- NOT USED TO LEGALIZE -COMPUTED GO TO-) ..........
      K = M2
  250    XU = LB
C     .......... FOR I=K STEP -1 UNTIL M1 DO -- ..........
         DO 260 II = M1, K
            I = M1 + K - II
            IF (XU .GE. RV4(I)) GO TO 260
            XU = RV4(I)
            GO TO 280
  260    CONTINUE
C
  280    IF (X0 .GT. RV5(K)) X0 = RV5(K)
C     .......... NEXT BISECTION STEP ..........
  300    X1 = (XU + X0) * 0.5E0
         S1 = 2.0E0*(ABS(XU) + ABS(X0) + ABS(EPS1))
         S2 = S1 + ABS(X0 - XU)
         IF (S2 .EQ. S1) GO TO 420
C     .......... IN-LINE PROCEDURE FOR STURM SEQUENCE ..........
  320    S = P - 1
         U = 1.0E0
C
         DO 340 I = P, Q
            IF (U .NE. 0.0E0) GO TO 325
            V = ABS(E(I)) / MACHEP
            IF (E2(I) .EQ. 0.0E0) V = 0.0E0
            GO TO 330
  325       V = E2(I) / U
  330       U = D(I) - X1 - V
            IF (U .LT. 0.0E0) S = S + 1
  340    CONTINUE
C
         GO TO (60,80,200,220,360), ISTURM
C     .......... REFINE INTERVALS ..........
  360    IF (S .GE. K) GO TO 400
         XU = X1
         IF (S .GE. M1) GO TO 380
         RV4(M1) = X1
         GO TO 300
  380    RV4(S+1) = X1
         IF (RV5(S) .GT. X1) RV5(S) = X1
         GO TO 300
  400    X0 = X1
         GO TO 300
C     .......... K-TH EIGENVALUE FOUND ..........
  420    RV5(K) = X1
      K = K - 1
      IF (K .GE. M1) GO TO 250
C     .......... FIND VECTORS BY INVERSE ITERATION ..........
      NORM = ABS(D(P))
      IP = P + 1
C
      DO 500 I = IP, Q
  500 NORM = MAX(NORM, ABS(D(I)) + ABS(E(I)))
C     .......... EPS2 IS THE CRITERION FOR GROUPING,
C                EPS3 REPLACES ZERO PIVOTS AND EQUAL
C                ROOTS ARE MODIFIED BY EPS3,
C                EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW ..........
      EPS2 = 1.0E-3 * NORM
      UK = SQRT(REAL(Q-P+5))
      EPS3 = UK * MACHEP * NORM
      EPS4 = UK * EPS3
      UK = EPS4 / SQRT(UK)
      GROUP = 0
      S = P
C
      DO 920 K = M1, M2
         R = R + 1
         ITS = 1
         W(R) = RV5(K)
         X1 = RV5(K)
C     .......... LOOK FOR CLOSE OR COINCIDENT ROOTS ..........
         IF (K .EQ. M1) GO TO 520
         IF (X1 - X0 .GE. EPS2) GROUP = -1
         GROUP = GROUP + 1
         IF (X1 .LE. X0) X1 = X0 + EPS3
C     .......... ELIMINATION WITH INTERCHANGES AND
C                INITIALIZATION OF VECTOR ..........
  520    V = 0.0E0
C
         DO 580 I = P, Q
            RV6(I) = UK
            IF (I .EQ. P) GO TO 560
            IF (ABS(E(I)) .LT. ABS(U)) GO TO 540
            XU = U / E(I)
            RV4(I) = XU
            RV1(I-1) = E(I)
            RV2(I-1) = D(I) - X1
            RV3(I-1) = 0.0E0
            IF (I .NE. Q) RV3(I-1) = E(I+1)
            U = V - XU * RV2(I-1)
            V = -XU * RV3(I-1)
            GO TO 580
  540       XU = E(I) / U
            RV4(I) = XU
            RV1(I-1) = U
            RV2(I-1) = V
            RV3(I-1) = 0.0E0
  560       U = D(I) - X1 - XU * V
            IF (I .NE. Q) V = E(I+1)
  580    CONTINUE
C
         IF (U .EQ. 0.0E0) U = EPS3
         RV1(Q) = U
         RV2(Q) = 0.0E0
         RV3(Q) = 0.0E0
C     .......... BACK SUBSTITUTION
C                FOR I=Q STEP -1 UNTIL P DO -- ..........
  600    DO 620 II = P, Q
            I = P + Q - II
            RV6(I) = (RV6(I) - U * RV2(I) - V * RV3(I)) / RV1(I)
            V = U
            U = RV6(I)
  620    CONTINUE
C     .......... ORTHOGONALIZE WITH RESPECT TO PREVIOUS
C                MEMBERS OF GROUP ..........
         IF (GROUP .EQ. 0) GO TO 700
C
         DO 680 JJ = 1, GROUP
            J = R - GROUP - 1 + JJ
            XU = 0.0E0
C
            DO 640 I = P, Q
  640       XU = XU + RV6(I) * Z(I,J)
C
            DO 660 I = P, Q
  660       RV6(I) = RV6(I) - XU * Z(I,J)
C
  680    CONTINUE
C
  700    NORM = 0.0E0
C
         DO 720 I = P, Q
  720    NORM = NORM + ABS(RV6(I))
C
         IF (NORM .GE. 1.0E0) GO TO 840
C     .......... FORWARD SUBSTITUTION ..........
         IF (ITS .EQ. 5) GO TO 960
         IF (NORM .NE. 0.0E0) GO TO 740
         RV6(S) = EPS4
         S = S + 1
         IF (S .GT. Q) S = P
         GO TO 780
  740    XU = EPS4 / NORM
C
         DO 760 I = P, Q
  760    RV6(I) = RV6(I) * XU
C     .......... ELIMINATION OPERATIONS ON NEXT VECTOR
C                ITERATE ..........
  780    DO 820 I = IP, Q
            U = RV6(I)
C     .......... IF RV1(I-1) .EQ. E(I), A ROW INTERCHANGE
C                WAS PERFORMED EARLIER IN THE
C                TRIANGULARIZATION PROCESS ..........
            IF (RV1(I-1) .NE. E(I)) GO TO 800
            U = RV6(I-1)
            RV6(I-1) = RV6(I)
  800       RV6(I) = U - RV4(I) * RV6(I-1)
  820    CONTINUE
C
         ITS = ITS + 1
         GO TO 600
C     .......... NORMALIZE SO THAT SUM OF SQUARES IS
C                1 AND EXPAND TO FULL ORDER ..........
  840    U = 0.0E0
C
         DO 860 I = P, Q
  860    U = U + RV6(I)**2
C
         XU = 1.0E0 / SQRT(U)
C
         DO 880 I = 1, N
  880    Z(I,R) = 0.0E0
C
         DO 900 I = P, Q
  900    Z(I,R) = RV6(I) * XU
C
         X0 = X1
  920 CONTINUE
C
  940 IF (Q .LT. N) GO TO 100
      GO TO 1001
C     .......... SET ERROR -- NON-CONVERGED EIGENVECTOR ..........
  960 IERR = 4 * N + R
      GO TO 1001
C     .......... SET ERROR -- UNDERESTIMATE OF NUMBER OF
C                EIGENVALUES IN INTERVAL ..........
  980 IERR = 3 * N + 1
 1001 LB = T1
      UB = T2
      RETURN
      END