!==========================================
!     Full Naive Evaluation of Voronoi
!==========================================

SUBROUTINE EVAL_MESH(int_prods, app_int_prods, mesh)
  USE ISO_FORTRAN_ENV, ONLY : REAL64
  IMPLICIT NONE
  ! Subroutine for evaluating a standard voronoi mesh at a set of
  ! points given the products have already been calculated.
  REAL(KIND=REAL64), DIMENSION(:,:), INTENT(IN) :: int_prods
  REAL(KIND=REAL64), DIMENSION(:,:), INTENT(IN) :: app_int_prods
  REAL(KIND=REAL64), DIMENSION(SIZE(app_int_prods,1),SIZE(int_prods,1)), &
       INTENT(OUT) :: mesh
  ! Local variables
  REAL(KIND=REAL64) :: max_ratio, ratio, numerator, denominator
  INTEGER :: y, xi, c
  ! Loop for computing the mesh
  approx_points : DO y = 1, SIZE(app_int_prods,1)
     !$omp parallel do private(xi,c,max_ratio,ratio,numerator,denominator)
     interp_points : DO xi = 1, SIZE(int_prods,1)
        max_ratio = 0
        cell_centers : DO c = 1, SIZE(int_prods,1)
           ! Cycle when we are considering a cell's center and itself
           IF (c .EQ. xi) CYCLE
           ! Calculate the ratio
           numerator = app_int_prods(y,c) - app_int_prods(y,xi) - &
                int_prods(xi,c) + int_prods(xi,xi)
           denominator = int_prods(c,c) - int_prods(c,xi) - &
                int_prods(xi,c) + int_prods(xi,xi)
           valid_denom : IF (ABS(denominator) .GT. EPSILON(ratio)) THEN
              ratio = numerator / denominator
              track_max : IF (ratio > max_ratio) THEN
                 max_ratio = ratio
              END IF track_max
           END IF valid_denom
        END DO cell_centers
        ! Store the ratio for this cell in the mesh
        mesh(y,xi) = MAX(REAL(1,KIND=REAL64) - max_ratio, REAL(0,KIND=REAL64))
     END DO interp_points
     !$omp end parallel do
     ! Normalize the mesh across the interpolation points (to be convex combinations)
     mesh(y,:) = mesh(y,:) / SUM(mesh(y,:))
  END DO approx_points
END SUBROUTINE EVAL_MESH

!===============================================
!     Cached Dynamic Computation of Voronoi
!===============================================

SUBROUTINE MAKE_HUGE(DOTS)
  USE ISO_FORTRAN_ENV, ONLY: REAL64
  ! Given a REAL64 matrix, assign the maximum value to all elements.
  REAL(KIND=REAL64), INTENT(OUT), DIMENSION(:,:) :: DOTS
  DOTS = HUGE(DOTS(1,1))
END SUBROUTINE MAKE_HUGE

SUBROUTINE PREDICT(POINTS, DOTS, EVAL_PT, WEIGHTS, ERROR)
  ! Given column-vector POINTS, pairwise dot product matrix DOTS, and
  ! a single evaluation point EVAL_PT, compute the WEIGHTS associated
  ! with each input point.
  USE ISO_FORTRAN_ENV, ONLY: REAL64
  IMPLICIT NONE
  ! Inputs and outputs
  REAL(KIND=REAL64), INTENT(IN),    DIMENSION(:,:)                           :: POINTS
  REAL(KIND=REAL64), INTENT(IN),    DIMENSION(SIZE(POINTS,1))                :: EVAL_PT
  REAL(KIND=REAL64), INTENT(INOUT), DIMENSION(SIZE(POINTS,2),SIZE(POINTS,2)) :: DOTS
  REAL(KIND=REAL64), INTENT(OUT),   DIMENSION(SIZE(POINTS,2))                :: WEIGHTS
  INTEGER,           INTENT(OUT)                                             :: ERROR
  ! Local variables
  INTEGER :: I_CENTER, I_OTHER, IC, IO, I
  INTEGER, DIMENSION(SIZE(POINTS,2))           :: INDICES
  REAL(KIND=REAL64), DIMENSION(SIZE(POINTS,2)) :: PROJECTIONS, DISTANCES
  REAL(KIND=REAL64), DIMENSION(SIZE(POINTS,1)) :: TO_EVAL, TO_OTHER
  LOGICAL, DIMENSION(SIZE(POINTS,2)) :: SKIP
  REAL(KIND=REAL64) :: DIST_C_TO_PT, DIST_C_TO_O, RATIO, MAX_RATIO
  REAL(KIND=REAL64), PARAMETER :: MAX_VAL = HUGE(MAX_VAL)
  REAL(KIND=REAL64), PARAMETER :: MIN_VAL = SQRT(EPSILON(MIN_VAL))
  ! Initiallly assume no points should be skipped
  SKIP(:) = .FALSE.
  WEIGHTS(:) = 0.
  ERROR = 0
  ! Distances to all points from evaluation point.
  DO I = 1, SIZE(POINTS, 2)
     ! TODO: Use a faster distance calculation method here.
     DISTANCES(I) = SUM((EVAL_PT - POINTS(:,I)) ** 2)
  END DO
  ! Check for overflow encountered in the squared distance computation.
  IF (MAXVAL(DISTANCES(:)) .GT. MAX_VAL) THEN
     ERROR = 1
     RETURN
  END IF
  ! Get the sorted list of points (by distance to evaluation point)
  CALL QSORTC(DISTANCES, INDICES)
  ! Identification of weights
  centers : DO I_CENTER = 1, SIZE(INDICES)
     ! Get the actual index of the center point.
     IC = INDICES(I_CENTER)
     IF (SKIP(IC)) CYCLE
     MAX_RATIO = 0.
     others : DO I_OTHER = 1, SIZE(INDICES)
        ! Get the actual index of the boundary point.
        IO = INDICES(I_OTHER)
        IF (IC .EQ. IO) CYCLE others
        ! Check to see if the dot products have been computed (cache them).
        IF (DOTS(IC,IC) .EQ. MAX_VAL) THEN
           DOTS(IC,IC) = SUM(POINTS(:,IC)**2)
           ! Check for overflow encountered in the squared length computation.
           IF (DOTS(IC,IC) .GT. MAX_VAL) THEN
              ERROR = 1
              RETURN
           END IF
        END IF
        IF (DOTS(IO,IO) .EQ. MAX_VAL) THEN
           DOTS(IO,IO) = SUM(POINTS(:,IO)**2)
           ! Check for overflow encountered in the squared length computation.
           IF (DOTS(IO,IO) .GT. MAX_VAL) THEN
              ERROR = 1
              RETURN
           END IF
        END IF
        IF (DOTS(IC,IO) .EQ. MAX_VAL) THEN
           DOTS(IC, IO) = SUM(POINTS(:,IC) * POINTS(:,IO))
           DOTS(IO, IC) = DOTS(IC, IO)
           ! Check for overflow encountered in the dot product.
           IF (DOTS(IO,IC) .GT. MAX_VAL) THEN
              ERROR = 1
              RETURN
           END IF
        END IF
        ! Compute the projected distance (center -> interpolation point)
        DIST_C_TO_PT = SUM(EVAL_PT(:) * POINTS(:,IO)) + DOTS(IC,IC) - &
             (SUM(EVAL_PT(:) * POINTS(:,IC)) + DOTS(IC,IO))
        ! Compute the projected distance (center -> other)
        DIST_C_TO_O = DOTS(IO,IO) + DOTS(IC,IC) - 2*DOTS(IC,IO)
        ! If the denominator is not zero (should never happen for
        ! unique interpolation points) then...
        IF (ABS(DIST_C_TO_O) .GT. MIN_VAL) THEN
           RATIO = DIST_C_TO_PT / DIST_C_TO_O
           IF      (RATIO .GT. MAX_RATIO) THEN; MAX_RATIO = RATIO
           ELSE IF (RATIO .LT. 0.)        THEN; SKIP(IO) = .TRUE.
           ELSE IF (RATIO .GE. 1.)        THEN
              WEIGHTS(IC) = 0.
              CYCLE centers
           END IF
        ELSE
           ! Duplicated center points, error! Return.
           ERROR = 2
           RETURN
        END IF
     END DO others
     WEIGHTS(IC) = MAX(1. - MAX_RATIO, 0.)
  END DO centers
  ! Normalize the weights to be convex.
  WEIGHTS(:) = WEIGHTS(:) / SUM(WEIGHTS)
  RETURN

CONTAINS

  SUBROUTINE QSORTC(A, IDX)
    ! This is a QuickSort routine adapted from Orderpack 2.0.
    !
    ! Also, this implementation incorporates ideas from "A Practical Introduction
    ! to Data Structures and Algorithm Analysis", by Clifford Shaffer.
    !
    ! It sorts real numbers into ascending numerical order
    ! and keeps an index of the value's original array position.
    !
    ! Author: Will Thacker, Winthrop University, July 2013.
    !
    ! QSORTC sorts the real array A and keeps the index of the value's
    ! original array position along with the value (integer array IDX).
    !
    ! On input:
    !
    ! A(:) is the array to be sorted.
    !
    ! On output:
    !
    ! A(:) is sorted.
    !
    ! IDX(1:SIZEOF(A)) contains the original positions of the sorted values.
    !    I.e., sorted(i) = orginal_unsorted(IDX(i)).
    !
    !
    REAL(KIND=REAL64), DIMENSION(:), INTENT(IN OUT):: A
    INTEGER, DIMENSION(SIZE(A)), INTENT(OUT):: IDX
    ! Local variables
    INTEGER:: I   ! Loop iteration variable.
    ! Initialize the array of original positions.
    FORALL (I=1:SIZE(A)) IDX(I)=I
    ! Call the sorting helper
    CALL QSORTC_HELPER(A, IDX, 1, SIZE(A))
  END SUBROUTINE QSORTC

  RECURSIVE SUBROUTINE QSORTC_HELPER(A, IDX, ISTART, ISTOP)
    ! This internal recursive subroutine performs the recursive quicksort
    ! algorithm.  It is needed because the boundaries of the part of the
    ! array being sorted change and the initial call to the sort routine
    ! does not need to specify boundaries since, generally, the user will
    ! want to sort the entire array passed.
    !
    ! On input:
    !
    ! A(:) contains a subpart to be sorted.
    !
    ! IDX(i) contains the initial position of the value A(i) before sorting.
    !
    ! ISTART is the starting position of the subarray to be sorted.
    !
    ! ISTOP is the ending position of the subarray to be sorted.
    !
    ! On output:
    !
    ! A(ISTART:ISTOP) will be sorted.
    !
    ! IDX(i) contains the original position for the value at A(i).
    !
    !
    REAL(KIND=REAL64), DIMENSION(:), INTENT (IN OUT):: A
    INTEGER, DIMENSION(SIZE(A)), INTENT(IN OUT):: IDX
    INTEGER, INTENT(IN):: ISTART, ISTOP

    !  Local variables
    INTEGER:: ILEFT ! A position on the left to be swapped with value at IRIGHT.
    INTEGER:: IMID ! The middle position used to select the pivot.
    INTEGER:: IRIGHT ! A position on the right to be swapped with value at ILEFT.
    INTEGER:: ITEMP  ! Used for swapping within IDX.
    REAL(KIND=REAL64):: ATEMP ! Used for swapping.
    REAL(KIND=REAL64):: PIVOT ! Holds the temporary pivot.

    ! INSMAX is used to stop recursively dividing the array and to instead
    ! use a sort that is more efficient for small arrays than quicksort.
    !
    ! The best cutoff point is system dependent.

    INTEGER, PARAMETER:: INSMAX=24

    ! Check to see if we have enough values to make quicksort useful.
    ! Otherwise let the insertion sort handle it.

    IF ((ISTOP - ISTART) < INSMAX) THEN
       CALL INSERTION(A, IDX, ISTART, ISTOP)
    ELSE

       ! Use the median of the first, middle and last items for the pivot
       ! and place the median (pivot) at the end of the list.
       ! Putting it at the end of the list allows for a guard value to keep
       ! the loop from falling off the right end of the array (no need to
       ! check for at the end of the subarray EACH time through the loop).

       IMID = (ISTART + ISTOP)/2

       IF (A(ISTOP) < A(ISTART)) THEN
          ATEMP = A(ISTART)
          A(ISTART) = A(ISTOP)
          A(ISTOP) = ATEMP

          ITEMP = IDX(ISTART)
          IDX(ISTART) = IDX(ISTOP)
          IDX(ISTOP) = ITEMP
       END IF

       IF (A(IMID) < A(ISTOP)) THEN
          ATEMP = A(ISTOP)
          A(ISTOP) = A(IMID)
          A(IMID) = ATEMP

          ITEMP = IDX(ISTOP)
          IDX(ISTOP) = IDX(IMID)
          IDX(IMID) = ITEMP

          IF (A(ISTOP) < A(ISTART)) THEN
             ATEMP = A(ISTOP)
             A(ISTOP) = A(ISTART)
             A(ISTART) = ATEMP

             ITEMP = IDX(ISTOP)
             IDX(ISTOP) = IDX(ISTART)
             IDX(ISTART) = ITEMP
          END IF
       END IF

       ! Now, the first position has a value that is less or equal to the
       ! partition. So, we know it belongs in the left side of the partition
       ! and we can skip it. Also, the pivot is at the end.  So, there is
       ! no need to compare the pivot with itself.

       PIVOT = A(ISTOP)
       ILEFT = ISTART + 1
       IRIGHT = ISTOP - 1

       DO WHILE (ILEFT < IRIGHT)
          ! Find a value in the left side that is bigger than the pivot value.
          ! Pivot is at the right end so ILEFT will not fall off the end
          ! of the subarray.

          DO WHILE (A(ILEFT) < PIVOT)
             ILEFT = ILEFT + 1
          END DO

          DO WHILE (IRIGHT .NE. ILEFT)
             IF (A(IRIGHT) .LT. PIVOT) EXIT
             IRIGHT = IRIGHT - 1
          END DO

          ! Now we have a value bigger than pivot value on the left side that can be
          ! swapped with a value smaller than the pivot on the right side.
          !
          ! This gives us all values less than pivot on the left side of the
          ! array and all values greater than the pivot on the right side.

          ATEMP = A(IRIGHT)
          A(IRIGHT) = A(ILEFT)
          A(ILEFT) = ATEMP

          ITEMP = IDX(IRIGHT)
          IDX(IRIGHT) = IDX(ILEFT)
          IDX(ILEFT) = ITEMP

       END DO
       !
       ! The last swap was in error (since the while condition is not checked
       ! until after the swap is done) so we swap again to fix it.

       ! This is done (once) rather than having an if (done many times) in the
       ! loop to prevent the swapping.

       ATEMP = A(IRIGHT)
       A(IRIGHT) = A(ILEFT)
       A(ILEFT) = ATEMP

       ITEMP = IDX(IRIGHT)
       IDX(IRIGHT) = IDX(ILEFT)
       IDX(ILEFT) = ITEMP

       ! Put the pivot value in its correct spot (between the 2 partitions)
       ! When the WHILE condition finishes, ILEFT is greater than IRIGHT.
       ! So, ILEFT has the position of the first value in the right side.
       ! This is where we can put the pivot (and where it will finally rest,
       ! so no need to look at it again).  Also, place the first value of
       ! the right side (being displaced by the pivot) at the end of the
       ! subarray (since it is bigger than the pivot).

       ATEMP = A(ISTOP)
       A(ISTOP) = A(ILEFT)
       A(ILEFT) = ATEMP

       ITEMP = IDX(ISTOP)
       IDX(ISTOP) = IDX(ILEFT)
       IDX(ILEFT) = ITEMP

       CALL QSORTC_HELPER(A, IDX, ISTART, ILEFT-1)
       CALL QSORTC_HELPER(A, IDX, ILEFT+1, ISTOP)
    END IF

  END SUBROUTINE QSORTC_HELPER

  SUBROUTINE INSERTION(A, IDX, ISTART, ISTOP)
    ! This subroutine performs an insertion sort used for sorting
    ! small subarrays efficiently.
    !
    ! This subroutine sorts a subarray of A (between positions ISTART
    ! and ISTOP) keeping a record of the original position (array IDX).
    !
    ! On input:
    !
    ! A(:) contains a subpart to be sorted.
    !
    ! IDX(i) contains the initial position of the value A(i) before sorting.
    !
    ! ISTART is the starting position of the subarray to be sorted.
    !
    ! ISTOP is the ending position of the subarray to be sorted.
    !
    ! On output:
    !
    ! A(ISTART:ISTOP) will be sorted.
    !
    ! IDX(i) contains the original position for the value at A(i).
    !

    REAL(KIND=REAL64), DIMENSION(:), INTENT (IN OUT):: A
    INTEGER, DIMENSION(SIZE(A)), INTENT(IN OUT)::IDX
    INTEGER, INTENT(IN):: ISTART, ISTOP

    ! Local variables.

    REAL(KIND=REAL64):: AMIN  ! Temporary minimum.
    REAL(KIND=REAL64):: ATEMP  ! The value to be inserted.
    INTEGER:: I    ! Index variable.
    INTEGER:: IABOVE ! Index to find insertion point.
    INTEGER:: IMIN ! Temporary minimum position.
    INTEGER:: ITEMP ! Temporary for swapping.

    IF (ISTOP .EQ. ISTART) THEN
       RETURN
    END IF

    ! Find the smallest and put it at the top as a "guard" so there is
    ! no need for the DO WHILE to check if it is going past the top.

    AMIN = A(ISTART)
    IMIN = ISTART

    DO I=ISTOP,ISTART+1,-1
       IF (A(I) < AMIN) THEN
          AMIN = A(I)
          IMIN = I
       END IF
    END DO

    A(IMIN) = A(ISTART)
    A(ISTART) = AMIN

    ITEMP = IDX(ISTART)
    IDX(ISTART) = IDX(IMIN)
    IDX(IMIN) = ITEMP

    ! Insertion sort the rest of the array.
    DO I=ISTART+2,ISTOP
       ATEMP = A(I)
       ITEMP = IDX(I)
       IABOVE = I - 1
       IF (ATEMP < A(IABOVE)) THEN
          A(I) = A(IABOVE)
          IDX(I) = IDX(IABOVE)
          IABOVE = IABOVE - 1

          ! Stop moving items down when the position for "insertion" is found.
          !
          ! Do not have to check for "falling off" the beginning of the
          ! array since the smallest value is a guard value in the first position.

          DO WHILE (ATEMP < A(IABOVE))
             A(IABOVE+1) = A(IABOVE)
             IDX(IABOVE+1) = IDX(IABOVE)
             IABOVE = IABOVE - 1
          END DO
       END IF
       A(IABOVE+1) = ATEMP
       IDX(IABOVE+1) = ITEMP
    END DO
  END SUBROUTINE INSERTION

END SUBROUTINE PREDICT


!> @brief   Functions for the conversion between cartesian and keplerian states
!!
!> @anchor  slam_astro_conversions
!!
!> @author  Vitali Braun (VB)
!> @author  Christopher Kebschull (CHK)
!!
!> @date

!!
VB:  13.11.2015 (moved to slam and added mean2true and true2mean)

!!
VB:  30.06.2013 (initial design)

!!
VB:  03.06.2014 (added 'getGeographicalLongitude' function)

!!
CHK: 13.11.2015 (added to libslam)

!!
CHK: 16.11.2015 (added getGeodeticLatLon and getRadiusLatLon)

!!

!!
!> @copyright Institute of Space Systems / TU Braunschweig
!!------------------------------------------------------------------------------------
module slam_astro_conversions

  use slam_astro,             only: getEarthGravity, getEarthRadius, getEesqrd
  use slam_math,              only: angle, eps9, eps15, cross, deg2rad, halfpi, infinite, mag, pi, redang, rot1, rot3, twopi, undefined
  use slam_orbit_types,       only: kepler_t, state_t
  use slam_Reduction_class,   only: Reduction_type
  use slam_units
  use slam_types

  implicit none

  !** orbit types
  integer, parameter :: CIRCULAR_INCLINED     = 1
  integer, parameter :: ELLIPTICAL_INCLINED   = 2
  integer, parameter :: ELLIPTICAL_EQUATORIAL = 3
  integer, parameter :: CIRCULAR_EQUATORIAL   = 4

  public :: getGeographicLongitude

  !** generic interfaces
  !-----------------------------------------------
  interface rv2coe
    module procedure rv2coe_long, rv2coe_short
  end interface

  interface coe2rv
    module procedure coe2rv_long, coe2rv_short
  end interface
  !-----------------------------------------------

contains
  !==============================================================================
  !
  !> @anchor      getGeographicLongitude
  !!
  !> @brief       Get geographic longitude from Kepler elements and current date
  !> @author      Vitali Braun
  !!
  !> @param[in]   time_mjd    Modified julian day
  !> @param[in]   kepel       Kepler elements
  !!
  !> @date

  !!
 03.06.2014 (initial design)

  !!

  !!
  !!-----------------------------------------------------------------------------
  real(dp) function getGeographicLongitude(time_mjd, kepel, reduction) result(lon)

    implicit none

    real(dp), intent(in)       :: time_mjd
    type(kepler_t), intent(in) :: kepel
    type(Reduction_type)       :: reduction

    character(len=*), parameter :: csubid = "getGeographicLongitude"

    type(state_t) :: stateGCRF
    type(state_t) :: stateITRF

    lon = undefined

    if(isControlled()) then
      if(hasToReturn()) return
      call checkIn(csubid)
    end if

    !** convert kepler elements to cartesian state vector
    call coe2rv(kepel, stateGCRF)

    !** convert GCRF to ITRF
    call reduction%inertial2earthFixed(stateGCRF%r, time_mjd, stateITRF%r)

    !** now compute geographic longitude
    lon = atan2(stateITRF%r(2), stateITRF%r(1))

    !** done!
    if(isControlled()) then
      call checkOut(csubid)
    end if

    return

  end function getGeographicLongitude

  !>----------------------------------------------------------------------------------
  !>  @anchor rv2coe_long
  !!
  !>  @brief Find kepler elements given geocentric cartesian state vector
  !!
  !>  @author  David Vallado (modified by V.Braun)
  !>  @version 1.0
  !!
  !>  @param[in]  r         geocentric radius vector
  !>  @param[in]  v         geocentric velocity vector
  !>  @param[out] otype     orbit type
  !>  @param[out] p         semi-latus rectum (km)
  !>  @param[out] a         semi-major axis (km)
  !>  @param[out] ecc       eccentricity
  !>  @param[out] incl      inclination (rad)
  !>  @param[out] omega     right ascension of ascending node (rad)
  !>  @param[out] argp      argument of perigee (rad)
  !>  @param[out] nu        true anomaly (rad)
  !>  @param[out] m         mean anomaly (rad)
  !>  @param[out] arglat    argument of latitude (rad)
  !>  @param[out] truelon   true longitude (rad)
  !>  @param[out] lonper    longitude of perigee (rad)
  !!
  !>  @date

  !!
30.06.2013 (imported into car2kep module)

  !!

  !!
  !>  @todo 	Implement special case for i=90°, circular orbit (use exact velocity). At the moment
  !!			the result for mean anomaly is wrong. For the exact velocity the result is
  !!			meananomaly=90° instead of meananomaly=0°
  !!
  !!-----------------------------------------------------------------------------------
  !
  !                           SUBROUTINE rv2coe
  !
  !  this subroutine finds the classical orbital elements given the Geocentric
  !    Equatorial Position and Velocity vectors.
  !
  !  Author        : David Vallado                  719-573-2600    1 Mar 2001
  !  Edited by     : Vitali Braun                                  21 Jul 2012
  !
  !  Inputs          Description                    Range / Units
  !    R           - IJK Position vector            km
  !    V           - IJK Velocity vector            km / s
  !
  !  Outputs       :
  !    P           - SemiLatus rectum               km
  !    A           - semimajor axis                 km
  !    Ecc         - Eccentricity
  !    Incl        - inclination                    0.0D0 to Pi rad
  !    Omega       - Longitude of Ascending Node    0.0D0 to 2Pi rad
  !    Argp        - Argument of Perigee            0.0D0 to 2Pi rad
  !    Nu          - True anomaly                   0.0D0 to 2Pi rad
  !    M           - Mean anomaly                   0.0D0 to 2Pi rad
  !    ArgLat      - Argument of Latitude      (CI) 0.0D0 to 2Pi rad
  !    LamTrue     - True Longitude            (CE) 0.0D0 to 2Pi rad
  !    LonPer      - Longitude of Periapsis    (EE) 0.0D0 to 2Pi rad
  !
  !  Locals        :
  !    HBar        - Angular Momentum H Vector      km2 / s
  !    EBar        - Eccentricity     E Vector
  !    NBar        - Line of Nodes    N Vector
  !    c1          - V**2 - u/R
  !    RDotV       - R dot V
  !    Hk          - Hk norm vector
  !    SME         - Specfic Mechanical Energy      km2 / s2
  !    i           - index
  !    E           - Eccentric, Parabolic,
  !                  Hyperbolic Anomaly             rad
  !    Temp        - Temporary variable
  !    TypeOrbit   - Type of orbit                  EE, EI, CE, CI
  !
  !  Coupling      :
  !    mag         - Magnitude of a vector
  !    dot         - dot product of two vectors
  !    angle       - Find the angle between two vectors
  !    true2mean   - Find the mean anomaly
  !
  !  References    :
  !    Vallado       2007, 121, Alg 9, Ex 2-5
  !
  ! ------------------------------------------------------------------------------
  !
  subroutine rv2coe_long(          &
                           R,      & ! <-- DBL()   position vector (km)
                           V,      & ! <-- DBL()   velocity vector (km/s)
                           P,      & ! --> DBL     semi-latus rectum (km)
                           A,      & ! --> DBL     semi-major axis (km)
                           Ecc,    & ! --> DBL     eccentricity
                           Incl,   & ! --> DBL     inclination (rad)
                           Omega,  & ! --> DBL     RAAN (rad)
                           Argp,   & ! --> DBL     argument of perigee (rad)
                           Nu,     & ! --> DBL     true anomaly (rad)
                           M,      & ! --> DBL     mean anomaly (rad)
                           ArgLat, & ! --> DBL     argument of latitude (circular inclined, rad)
                           TrueLon,& ! --> DBL     true longitude (circular equatorial, rad)
                           LonPer, & ! --> DBL     longitude of periapsis (equatorial eccentric, rad)
                           otype   & ! --> INT     orbit type
                        )

  !** interface
  !--------------------------------------------------------------
  real(dp), intent(in) :: R(3)
  real(dp), intent(in) :: V(3)

  integer,   intent(out) :: otype
  real(dp),  intent(out) :: P
  real(dp),  intent(out) :: A
  real(dp),  intent(out) :: Ecc
  real(dp),  intent(out) :: Incl
  real(dp),  intent(out) :: Omega
  real(dp),  intent(out) :: Argp
  real(dp),  intent(out) :: Nu
  real(dp),  intent(out) :: M
  real(dp),  intent(out) :: ArgLat
  real(dp),  intent(out) :: TrueLon
  real(dp),  intent(out) :: LonPer
  !--------------------------------------------------------------

  ! -----------------------------  Locals  ------------------------------
  real(dp) :: c1, RDotV, hk, SME, Hbar(3), Ebar(3), Nbar(3), E, Temp, maghbar, magnbar, magr, magv
  integer :: i
  character(len=2) :: TypeOrbit

  ! --------------------  Implementation   ----------------------
  magr = mag( R )
  magv = mag( V )

  ! ------------------  Find H N and E vectors   ----------------
  HBar = cross( R, V)
  maghbar = mag(Hbar)

  if ( maghbar > eps9 ) then

    NBar(1) = -HBar(2)
    NBar(2) =  HBar(1)
    NBar(3) =   0.0D0
    magnbar = mag( Nbar )
    c1      = magv**2.d0 - getEarthGravity()/magr
    RDotV   = dot_product( R, V )

    do i = 1, 3

      EBar(i) = (c1*R(i) - RDotV*V(i))/getEarthGravity()

    end do

    Ecc = mag( EBar )
    ! ------------  Find a e and semi-Latus rectum   ----------
    SME = ( magv*magv*0.5D0 ) - ( getEarthGravity()/magr )

    if ( abs( SME ) > eps9 ) then

      A = -getEarthGravity() / (2.0D0*SME)

    else

      A = infinite

    endif

    P = maghbar*maghbar/getEarthGravity()

    ! -----------------  Find inclination   -------------------
    Hk = HBar(3)/maghbar

         if ( abs( abs(Hk) - 1.d0 ) < eps9 ) then
             ! -------------  Equatorial Orbits   ------------------
             if ( abs(HBar(3)) > 0.0D0 ) then
                 Hk= sign(1.0D0, HBar(3))
               endif
           endif

    Incl = acos( Hk )

    ! --------  Determine type of orbit for Later use  --------
    ! ------ Elliptical, Parabolic, Hyperbolic Inclined -------
    TypeOrbit = 'EI'
    otype     = ELLIPTICAL_INCLINED

    if ( Ecc < eps9 ) then

      ! ----------------  Circular Equatorial ---------------
      if ( (Incl < eps9).or.(dabs(Incl - pi) < eps9) ) then

        TypeOrbit = 'CE'
        otype     = CIRCULAR_EQUATORIAL

      else

        ! --------------  Circular Inclined ---------------
        TypeOrbit = 'CI'
        otype     = CIRCULAR_INCLINED

      endif

    else

      ! - Elliptical, Parabolic, Hyperbolic Equatorial --
      if ( (Incl<eps9).or.(abs(Incl - pi)<eps9) ) then

        TypeOrbit = 'EE'
        otype     = ELLIPTICAL_EQUATORIAL

      endif

    endif

    ! ----------  Find Longitude of Ascending Node ------------
    if ( magnbar > eps9 ) then

      Temp = NBar(1) / magnbar

      if ( abs(Temp) > 1.0D0 ) then

        Temp = sign(1.0D0, Temp)

      endif

      Omega = acos( Temp )

      if ( NBar(2) < 0.0D0 ) then

        Omega = twoPi - Omega

      endif

      Omega = redang(Omega,2,1,.false.)

    else

      Omega = undefined

    endif

    ! ---------------- Find Argument of perigee ---------------

    if ( TypeOrbit == 'EI' ) then

      CALL angle( NBar, EBar, Argp )

      if ( EBar(3) < 0.0D0 ) then

        Argp = twoPi - Argp

      endif

      Argp = redang(Argp,2,1,.false.)

    else

      Argp = undefined

    endif

    ! ------------  Find True Anomaly at Epoch    -------------
    if ( TypeOrbit(1:1) == 'E' ) then

      CALL angle( EBar, r, Nu )

      if ( RDotV < 0.0D0 ) then

        Nu = twoPi - Nu

      endif

      Nu = redang(Nu,2,1,.false.)

    else

      Nu = undefined

    endif

    ! ----  Find Argument of Latitude - Circular Inclined -----
    if ( TypeOrbit == 'CI' ) then

      CALL angle( NBar, R, ArgLat )

      if ( R(3) < 0.0D0 ) then

        ArgLat = TwoPi - ArgLat

      endif

      ArgLat = redang(ArgLat,2,1,.false.)

    else

      ArgLat = undefined

    endif

    ! -- Find Longitude of Perigee - Elliptical Equatorial ----
    if ( ( Ecc>eps9 ) .and. (TypeOrbit=='EE') ) then

      Temp = EBar(1)/Ecc

      if ( abs(Temp) > 1.0D0 ) then

        Temp = sign(1.0D0, Temp)

      endif

      LonPer = acos( Temp )

      if ( EBar(2) < 0.0D0 ) then

        LonPer = twoPi - LonPer

      endif

      if ( Incl > halfPi ) then

        LonPer = twoPi - LonPer

      endif

      LonPer = redang(LonPer,2,1,.false.)

    else

      LonPer = undefined

    endif

    ! -------- Find True Longitude - Circular Equatorial ------
    if ( ( magr>eps9 ) .and. ( TypeOrbit=='CE' ) ) then

      Temp = R(1)/magr

      if ( abs(Temp) > 1.0D0 ) then

        Temp = sign(1.0D0, Temp)

      endif

      TrueLon= acos( Temp )

      if ( R(2) < 0.0D0 ) then

        TrueLon = twoPi - TrueLon

      endif

      if ( Incl > halfPi ) then

        TrueLon = twoPi - TrueLon

      endif

      TrueLon = redang(TrueLon,2,1,.false.)

    else

      TrueLon = undefined

    endif

    ! ------------ Find Mean Anomaly for all orbits -----------
    if(TypeOrbit(1:1) == 'E') then

      CALL true2mean(Ecc, Nu, E, M )

    else if(TypeOrbit == 'CI') then

      M = ArgLat

    else if(TypeOrbit == 'CE') then

      M = TrueLon

    end if

  else

    P       = undefined
    A       = undefined
    Ecc     = undefined
    Incl    = undefined
    Omega   = undefined
    Argp    = undefined
    Nu      = undefined
    M       = undefined
    ArgLat  = undefined
    TrueLon = undefined
    LonPer  = undefined

  endif

  return

  end subroutine rv2coe_long
  !>----------------------------------------------------------------------------------
  !> @anchor  rv2coe_short
  !!
  !> @brief   Find kepler elements given geocentric cartesian state vector,
  !!          based on derived types
  !!
  !> @author  V. Braun
  !!
  !> @param[in]   car     geocentric cartesian state vector
  !> @param[out]  kep     classical kepler elements
  !> @param[out]  otype   orbit type
  !!
  !> @date

  !!
30.06.2013 (initial design)

  !!
19.11.2014 (now also epoch is provided)

  !!

  !!
  !!-----------------------------------------------------------------------------------
  subroutine rv2coe_short(car, kep, otype)

    type(state_t),  intent(in)  :: car
    type(kepler_t), intent(out) :: kep
    integer,        intent(out) :: otype    ! orbit type

    real(dp) :: semipar   ! semiparameter p

    call rv2coe_long(               &
                       car%R,       & ! <-- DBL()   position vector (km)
                       car%V,       & ! <-- DBL()   velocity vector (km/s)
                       semipar,     & ! --> DBL     semi-latus rectum (km)
                       kep%sma,     & ! --> DBL     semi-major axis (km)
                       kep%ecc,     & ! --> DBL     eccentricity
                       kep%inc,     & ! --> DBL     inclination (rad)
                       kep%raan,    & ! --> DBL     RAAN (rad)
                       kep%aop,     & ! --> DBL     argument of perigee (rad)
                       kep%tran,    & ! --> DBL     true anomaly (rad)
                       kep%man,     & ! --> DBL     mean anomaly (rad)
                       kep%arglat,  & ! --> DBL     argument of latitude (circular inclined, rad)
                       kep%truelon, & ! --> DBL     true longitude (circular equatorial, rad)
                       kep%lonper,  & ! --> DBL     longitude of periapsis (equatorial eccentric, rad)
                       otype        & ! --> INT     orbit type
                    )

    kep%sma_unit    = UNIT_KM
    kep%angles_unit = UNIT_RAD

    kep%epoch       = car%epoch

    return

  end subroutine rv2coe_short

  !>----------------------------------------------------------------------------------
  !! @anchor coe2rv_long
  !!
  !> @brief Find geocentric cartesian state vector given the classical kepler
  !!        elements
  !!
  !> @author  David Vallado (modified by V.Braun)
  !> @version 1.0
  !!
  !>  @param[in]  p_in      semi-latus rectum (km)
  !>  @param[in]  ecc       eccentricity
  !>  @param[in]  incl      inclination (rad)
  !>  @param[in]  omega_in  right ascension of ascending node (rad)
  !>  @param[in]  argp_in   argument of perigee (rad)
  !>  @param[in]  nu_in     true anomaly (rad)
  !>  @param[in]  arglat    argument of latitude (rad)
  !>  @param[in]  truelon   true longitude (rad)
  !>  @param[in]  lonper    longitude of perigee (rad)
  !>  @param[out] r         geocentric radius vector
  !>  @param[out] v         geocentric velocity vector
  !!
  !>  @date

  !!
30.06.2013 (imported into car2kep module)

  !!

  !!
  ! ------------------------------------------------------------------------------
  !
  !                           SUBROUTINE coe2rv
  !
  !  this subroutine finds the position and velocity vectors in Geocentric
  !    Equatorial (IJK) system given the classical orbit elements.
  !
  !  Author        : David Vallado                  719-573-2600    1 Mar 2001
  !  Edited by     : Vitali Braun                                  22 Jul 2012
  !
  !  Inputs          Description                    Range / Units
  !    P           - SemiLatus rectum               km
  !    Ecc         - Eccentricity
  !    Incl        - inclination                    0.0D0 to Pi rad
  !    Omega       - Longitude of Ascending Node    0.0D0 to 2Pi rad
  !    Argp        - Argument of Perigee            0.0D0 to 2Pi rad
  !    Nu          - True anomaly                   0.0D0 to 2Pi rad
  !    ArgLat      - Argument of Latitude      (CI) 0.0D0 to 2Pi rad
  !    LamTrue     - True Longitude            (CE) 0.0D0 to 2Pi rad
  !    LonPer      - Longitude of Periapsis    (EE) 0.0D0 to 2Pi rad
  !
  !  Outputs       :
  !    R           - IJK Position vector            km
  !    V           - IJK Velocity vector            km / s
  !
  !  Locals        :
  !    Temp        - Temporary REAL*8 value
  !    Rpqw        - PQW Position vector            km
  !    Vpqw        - PQW Velocity vector            km / s
  !    SinNu       - Sine of Nu
  !    CosNu       - Cosine of Nu
  !    TempVec     - PQW Velocity vector
  !
  !  Coupling      :
  !    rot3        - Rotation about the 3rd axis
  !    rot1        - Rotation about the 1st axis
  !
  !  References    :
  !    Vallado       2007, 126, Alg 10, Ex 2-5
  !
  ! ------------------------------------------------------------------------------
  subroutine coe2rv_long(          &
                          P_in,    &  ! <-- DBL   semi-latus rectum (km)
                          Ecc,     &  ! <-- DBL   eccentricity
                          Incl,    &  ! <-- DBL   inclination (rad)
                          Omega_in,&  ! <-- DBL   raan (rad)
                          Argp_in, &  ! <-- DBL   argument of perigee (rad)
                          Nu_in,   &  ! <-- DBL   true anomaly
                          ArgLat,  &  ! <-- DBL   argument of latitude (CI, rad)
                          TrueLon, &  ! <-- DBL   true longitude (CE, rad)
                          LonPer,  &  ! <-- DBL   longitude of perigee (EE, rad)
                          R,       &  ! --> DBL() radius vector (km/s)
                          V        &  ! --> DBL() velocity vector (km/s)
                        )

  !** interface
  !--------------------------------------------------------------
  real(dp), intent(in) :: P_in
  real(dp), intent(in) :: Ecc
  real(dp), intent(in) :: Incl
  real(dp), intent(in) :: Omega_in
  real(dp), intent(in) :: Argp_in
  real(dp), intent(in) :: Nu_in
  real(dp), intent(in) :: ArgLat
  real(dp), intent(in) :: TrueLon
  real(dp), intent(in) :: LonPer

  real(dp), dimension(3), intent(out) :: R
  real(dp), dimension(3), intent(out) :: V
  !--------------------------------------------------------------

  ! -----------------------------  Locals  ------------------------------
  real(dp), dimension(3) :: Rpqw
  real(dp), dimension(3) :: Vpqw
  real(dp), dimension(3) :: TempVec, TempVec2
  real(dp) :: Temp
  real(dp) :: SinNu
  real(dp) :: CosNu
  real(dp) :: Argp
  real(dp) :: P
  real(dp) :: Omega
  real(dp) :: Nu

  ! --------------------  Implementation   ----------------------
  !  Determine what type of orbit is involved and set up the
  !  set up angles for the special cases.
  ! -------------------------------------------------------------
  if ( Ecc < eps9 ) then

    ! ----------------  Circular Equatorial  ------------------
    if ( (Incl<eps9).or.( abs(Incl-pi)< eps9 ) ) then

      Argp  = 0.d0
      Omega = 0.d0
      Nu    = TrueLon

    else

      ! --------------  Circular Inclined  ------------------
      Argp  = 0.d0
      Omega = Omega_in
      Nu    = ArgLat

    endif

  else

    ! ---------------  Elliptical Equatorial  -----------------
    if ( ( Incl<eps9) .or. (abs(Incl-Pi)<eps9) ) then

      Argp  = LonPer
      Omega = 0.d0

    else

      Argp  = Argp_in
      Omega = Omega_in

    end if

    Nu = Nu_in

  endif

  ! ----------  Form PQW position and velocity vectors ----------
  CosNu   = cos(Nu)
  SinNu   = sin(Nu)
  Temp    = P_in/ (1.d0 + Ecc*CosNu)
  Rpqw(1) = Temp*CosNu
  Rpqw(2) = Temp*SinNu
  Rpqw(3) = 0.d0

  if ( abs(P_in) < eps9 ) then

    P = eps9

  else

    P = P_in

  end if

  if(SinNu == 0.d0) then
    Vpqw(1) = 0.d0
  else
    Vpqw(1)=    -SinNu    * sqrt(getEarthGravity()/P)
  end if

  Vpqw(2)=  (Ecc + CosNu) * sqrt(getEarthGravity()/P)
  Vpqw(3)=      0.d0

  ! ----------------  Perform transformation to IJK  ------------
  if(Argp < eps15) then
    TempVec = Rpqw
  else
    call rot3( Rpqw   , -Argp , TempVec )
  end if

  if(Incl < eps15) then ! case for equatorial orbits
    TempVec2(:) = TempVec(:)
  else if(abs(2.d0*Incl - pi) < eps15) then  ! case for 90 deg inclination /polar orbits
    TempVec2(1) =  TempVec(1)
    TempVec2(2) = -TempVec(3)
    TempVec2(3) =  TempVec(2)
  else
    call rot1( TempVec, -Incl , TempVec2 )
  end if

  call rot3( TempVec2, -Omega,  R     )

  if(Argp < eps15) then
    TempVec = Vpqw
  else
    call rot3( Vpqw   , -Argp , TempVec )
  end if

  if(Incl < eps15) then ! case for equatorial orbits
    TempVec2(:) = TempVec(:)
  else if(abs(2.d0*Incl - pi) < eps15) then  ! case for 90 deg inclination /polar orbits
    TempVec2(1) =  TempVec(1)
    TempVec2(2) = -TempVec(3)
    TempVec2(3) =  TempVec(2)
  else
    call rot1( TempVec, -Incl , TempVec2 )
  end if

  call rot3( TempVec2, -Omega, V     )

  return

  end subroutine coe2rv_long

  !>----------------------------------------------------------------------------------
  !> @anchor  coe2rv_short
  !!
  !> @brief   Find geocentric cartesian state vector given classical kepler elements,
  !!          based on derived types
  !!
  !> @author  V.Braun
  !!
  !> @param[in]    kep     classical kepler elements
  !> @param[out]   car     geocentric cartesian state vector
  !!
  !> @date

  !!
30.06.2013 (initial design)

  !!
19.11.2014 (now also epoch is provided)

  !!

  !!
  !!-----------------------------------------------------------------------------------
  subroutine coe2rv_short(kep, car)

    type(kepler_t), intent(in)  :: kep
    type(state_t),  intent(out) :: car

    real(dp) :: semipar         ! semiparameter p
    type(kepler_t) :: kep_loc   ! local kepler elements to account for units in degrees

    semipar = kep%sma*(1.d0 - kep%ecc*kep%ecc)

    kep_loc = kep

    if(kep%angles_unit == UNIT_DEG) then

      kep_loc%inc     = kep%inc *deg2rad
      kep_loc%raan    = kep%raan*deg2rad
      kep_loc%aop     = kep%aop *deg2rad
      kep_loc%man     = kep%man *deg2rad
      kep_loc%ecan    = kep%ecan*deg2rad
      kep_loc%tran    = kep%tran*deg2rad

      kep_loc%arglat  = kep%arglat *deg2rad
      kep_loc%lonper  = kep%lonper *deg2rad
      kep_loc%truelon = kep%truelon*deg2rad

    end if

    call coe2rv_long(                   &
                       semipar,         & ! <-- DBL     semi-latus rectum (km)
                       kep_loc%ecc,     & ! <-- DBL     eccentricity
                       kep_loc%inc,     & ! <-- DBL     inclination (rad)
                       kep_loc%raan,    & ! <-- DBL     RAAN (rad)
                       kep_loc%aop,     & ! <-- DBL     argument of perigee (rad)
                       kep_loc%tran,    & ! <-- DBL     true anomaly (rad)
                       kep_loc%arglat,  & ! <-- DBL     argument of latitude (circular inclined, rad)
                       kep_loc%truelon, & ! <-- DBL     true longitude (circular equatorial, rad)
                       kep_loc%lonper,  & ! <-- DBL     longitude of periapsis (equatorial eccentric, rad)
                       car%R,           & ! --> DBL()   position vector (km)
                       car%V            & ! --> DBL()   velocity vector (km/s)
                    )

    car%epoch = kep%epoch

    return

  end subroutine coe2rv_short

  !>----------------------------------------------------------------------------------
  !> @anchor  getOrbitType
  !!
  !> @brief   Determines the type of orbit (circular, equatorial, ...)
  !!
  !> @author  V.Braun
  !> @version 1.0
  !!
  !> @param[in]     kep      classical kepler elements
  !> @param[out]    orbtype  orbit type: 'CE' = circular equatorial, 'CI' = circular inclined, 'EE' = eccentric equatorial, 'EI' = eccentric inclined
  !!
  !> @date

  !!
15.07.2013 (initial design)

  !!

  !!
  !!-----------------------------------------------------------------------------------
  subroutine getOrbitType(kep, orbtype)

    type(kepler_t), intent(inout) :: kep
    integer, intent(out)          :: orbtype

    if (kep%ecc < eps9 ) then

      ! ----------------  Circular Equatorial  ------------------
      if ( (kep%inc < eps9 ) .or. ( abs(kep%inc-pi) < eps9 ) ) then

        kep%aop  = 0.d0
        kep%raan = 0.d0
        kep%tran = kep%truelon
        orbtype  = CIRCULAR_EQUATORIAL

      else

        ! --------------  Circular Inclined  ------------------
        kep%aop  = 0.d0
        kep%tran = kep%arglat
        orbtype  = CIRCULAR_INCLINED

      endif

    else

      ! ---------------  Elliptical Equatorial  -----------------
      if ( ( kep%inc < eps9) .or. (abs(kep%inc - Pi) < eps9) ) then

        kep%aop  = kep%lonper
        kep%raan = 0.d0
        orbtype = ELLIPTICAL_EQUATORIAL

      else

        orbtype = ELLIPTICAL_INCLINED

      end if

    endif

  end subroutine getOrbitType

!>----------------------------------------------------------------------------------
!> @anchor  true2mean
!!
!> @brief   Solve Keplers equation to find mean anomaly from true anomaly
!!
!> @author  Vallado modified by V. Braun
!!
!> @param[in]    Ecc     Eccentricity                   0.0D0 to
!> @param[in]    NU      True Anomaly                   -2Pi to 2Pi rad
!> @param[out]   E0      Eccentric Anomaly              0.0D0 to 2Pi rad       153.02 deg
!> @param[out]   M       Mean Anomaly                   0.0D0 to 2Pi rad       151.7425 deg
!!
!!-----------------------------------------------------------------------------------
!                           subroutine true2mean
!
!  This subroutine solves Keplers equation when the true anomaly is known.
!    The Mean and Eccentric, parabolic, or hyperbolic anomaly is also found.
!    The parabolic limit at 168ø is arbitrary. The hyperbolic anomaly is also
!    limited. The hyperbolic sine is used because it's not double valued.
!
!  Author        : David Vallado                  719-573-2600    1 Mar 2001
!  Edited by     : Vitali Braun                                  22 Jul 2012
!
!  Inputs          Description                    Range / Units
!    Ecc         - Eccentricity                   0.0D0 to
!    Nu          - True Anomaly                   -2Pi to 2Pi rad
!
!  Outputs       :
!    E0          - Eccentric Anomaly              0.0D0 to 2Pi rad       153.02 deg
!    M           - Mean Anomaly                   0.0D0 to 2Pi rad       151.7425 deg
!
!  Locals        :
!    E1          - Eccentric Anomaly, next value  rad
!    SinE        - Sine of E
!    CosE        - Cosine of E
!    Ktr         - Index
!
!  Coupling      :
!    ASINH       - Arc hyperbolic sine
!    SINH        - Hyperbolic Sine
!
!  References    :
!    Vallado       2007, 85, Alg 5
!
! ------------------------------------------------------------------------------
subroutine true2mean(       &
                      Ecc,  & ! <-- DBL eccentricity
                      Nu,   & ! <-- DBL true anomly in rad
                      E0,   & ! --> DBL eccentric anomaly in rad
                      M     & ! --> DBL mean anomaly in rad
                    )

  use slam_math, only: infinite, deg2rad, pi, twopi, eps6
  use slam_types

  implicit none

  real(dp), intent(in) :: Ecc
  real(dp), intent(in) :: Nu

  real(dp), intent(out) :: E0
  real(dp), intent(out) :: M

  real(dp) :: SinE
  real(dp) :: CosE

  ! --------------------  Implementation   ----------------------
  E0 = infinite
  M  = infinite

  ! --------------------------- Circular ------------------------
  if (abs( Ecc ) < eps6) then

    M  = Nu
    E0 = Nu

  else

    ! ---------------------- Elliptical -----------------------
    if ( Ecc < 0.999d0 ) then

      SinE = ( sqrt( 1.d0 - Ecc*Ecc ) * sin(Nu) ) / ( 1.d0 + Ecc*cos(Nu) )
      CosE = ( Ecc + cos(Nu) ) / ( 1.d0 + Ecc*cos(Nu) )

      E0   = atan2( SinE, CosE )
      M    = E0 - Ecc*sin(E0)

    else

      ! -------------------- Hyperbolic  --------------------
      if ( Ecc > 1.0001D0 ) then

        if ((Ecc > 1.0D0) .and. (abs(Nu) + 1.d-5 <  (pi - acos(1.0D0/Ecc)))) then

          SinE = (sqrt(Ecc*Ecc - 1.0D0 ) * sin(Nu) ) / ( 1.d0 + Ecc*dcos(Nu) )

          E0   = asinh(SinE)
          M    = Ecc*sinh(E0) - E0

        endif

      else

        ! ----------------- Parabolic ---------------------
        if (abs(Nu) < 168.d0*deg2rad) then

          E0 = dtan( Nu*0.5D0 )
          M  = E0 + (E0*E0*E0)/3.d0

        endif

      endif

    endif

  endif

  if ( Ecc < 1.d0 ) then

    M = mod( M, twoPi )

    if ( M < 0.d0 ) then

      M = M + twoPi

    endif

    E0 = mod( E0, twoPi )

  endif

  return

  end subroutine true2mean

!>----------------------------------------------------------------------------------
!> @anchor  mean2true
!!
!> @brief Solve Keplers equation to find true anomaly from mean anomaly
!!
!> @details   performs the Newton Rhapson iteration to find the
!!   Eccentric Anomaly given the Mean anomaly.  The True Anomaly is also
!!   calculated.
!!
!> @author  Vallado modified by V. Braun
!!
!> @param[in]    Ecc     Eccentricity                   0.0D0 to
!> @param[in]    M       Mean Anomaly                   0.0D0 to 2Pi rad
!> @param[out]   E0      Eccentric Anomaly              0.0D0 to 2Pi rad
!> @param[out]   NU      True Anomaly                   -2Pi to 2Pi rad
!!
!!-----------------------------------------------------------------------------------
!
!                           subroutine mean2true
!
!  this subroutine performs the Newton Rhapson iteration to find the
!    Eccentric Anomaly given the Mean anomaly.  The True Anomaly is also
!    calculated.
!
!  Author        : David Vallado                  719-573-2600    1 Mar 2001
!  Edited by     : Vitali Braun (20 Feb 2014)
!
!  Inputs          Description                    Range / Units
!    Ecc         - Eccentricity                   0.0D0 to
!    M           - Mean Anomaly                   -2Pi to 2Pi rad
!
!  Outputs       :
!    E0          - Eccentric Anomaly              0.0D0 to 2Pi rad
!    Nu          - True Anomaly                   0.0D0 to 2Pi rad
!
!  Locals        :
!    E1          - Eccentric Anomaly, next value  rad
!    Sinv        - Sine of Nu
!    Cosv        - Cosine of Nu
!    Ktr         - Index
!    R1r         - CUBIC roots - 1 to 3
!    R1i         - imaginary component
!    R2r         -
!    R2i         -
!    R3r         -
!    R3i         -
!    S           - Variables for parabolic solution
!    W           - Variables for parabolic solution
!
!  Coupling      :
!    CUBIC       - Solves a CUBIC polynomial
!    SINH        - Hyperbolic Sine
!    COSH        - Hyperbolic Cosine
!
!  References    :
!    Vallado       2001, 73, Alg 2, Ex 2-1
!
! ------------------------------------------------------------------------------
!
subroutine mean2true(         &
                      Ecc,    &  ! <-- DBL  eccentricity
                      M,      &  ! <-- DBL  mean anomaly / rad
                      E0,     &  ! --> DBL  eccentric anomaly / rad
                      Nu      &  ! --> DBL  true anomaly / rad
                    )

  use slam_math, only: cubic, eps9, pi
  use slam_types

  implicit none

  real(dp), intent(in) :: Ecc
  real(dp), intent(in) :: M

  real(dp), intent(out) :: E0
  real(dp), intent(out) :: Nu

  EXTERNAL DCot

  integer  :: Ktr, NumIter
  real(dp) :: E1, Sinv, Cosv, R1r, R1i, R2r, R2i, R3r, R3i, DCot

  ! --------------------  Implementation   ----------------------
  NumIter =    50

  ! -------------------------- Hyperbolic  ----------------------
  if ((Ecc - 1.0D0) >= eps9 ) then
    ! -------------------  Initial Guess -----------------------
    if ( Ecc < 1.6D0 ) then
      if ( ((M < 0.0D0) .and. (M > -pi)) .or. (M > pi) ) then
        E0 = M - Ecc
      else
        E0 = M + Ecc
      endif

    else

      if ((Ecc < 3.6D0) .and. (abs(M) > pi) ) then
        E0 = M - sign(1.0D0, M)*Ecc
      else
        E0= M/(Ecc-1.0D0)
      endif

    endif

    Ktr = 1
    E1 = E0 + ( (M-Ecc*sinh(E0)+E0) / (Ecc*cosh(E0) - 1.0D0) )

    do while ((abs(E1-E0) > eps9 ) .and. ( Ktr <= NumIter ))

      E0= E1
      E1= E0 + ( ( M - Ecc*sinh(E0) + E0 ) / ( Ecc*cosh(E0) - 1.0D0 ) )
      Ktr = Ktr + 1

    end do

    ! ----------------  Find True Anomaly  --------------------
    Sinv = -( sqrt( Ecc*Ecc - 1.0D0 ) * sinh(E1) ) / ( 1.0D0 - Ecc*cosh(E1) )
    Cosv= ( cosh(E1) - Ecc ) / ( 1.0D0 - Ecc*cosh(E1) )
    Nu  = atan2( Sinv, Cosv )

  else
    ! --------------------- Parabolic -------------------------
    if (abs( Ecc-1.0D0 ) < eps9 ) then

      call cubic( 1.0D0/3.0D0, 0.0D0, 1.0D0, -M, R1r, R1i, R2r, R2i, R3r, R3i )

      E0  = R1r
!      S = 0.5D0 * (HalfPi - DATAN( 1.5D0*M ) )
!      W = DATAN( DTAN( S )**(1.0D0/3.0D0) )
!      E0= 2.0D0*DCOT(2.0D0*W)
      Ktr = 1
      Nu  = 2.0D0 * atan(E0)

    else
    ! -------------------- Elliptical ----------------------
      if ( Ecc > eps9 ) then
        ! -----------  Initial Guess -------------
        if ( ((M < 0.0D0) .and. (M > -pi)) .or. (M > Pi) ) then

          E0 = M - Ecc

        else

          E0 = M + Ecc

        endif

        Ktr = 1
        E1  = E0 + ( M - E0 + Ecc*sin(E0) ) / ( 1.0D0 - Ecc*cos(E0) )

        do while (( abs(E1-E0) > eps9 ) .and. ( Ktr <= NumIter ))

          Ktr = Ktr + 1
          E0  = E1
          E1  = E0 + ( M - E0 + Ecc*sin(E0) ) / ( 1.0D0 - Ecc*cos(E0) )

        enddo

        ! -------------  Find True Anomaly  ---------------
        Sinv = ( sqrt( 1.0D0 - Ecc*Ecc ) * sin(E1) ) / ( 1.0D0-Ecc*cos(E1) )
        Cosv = ( cos(E1)-Ecc ) / ( 1.0D0 - Ecc*cos(E1) )
        Nu   = atan2( Sinv, Cosv )

      else
        ! -------------------- Circular -------------------
        Ktr = 0
        Nu  = M
        E0  = M

      endif

    endif

  endif

  return

end subroutine mean2true

!> @anchor      getGeodeticLatLon
!!
!> @brief       Geodetic latitude and longitude from ITRF radius
!> @author      Vitali Braun
!!
!> @date

!!
 23.01.2013 (initial design)

!!
 04.02.2014 (transformed to F95 and added saved parameters to save computation time)

!!

!!
!> @param[in]   r_ecef      radius vector in ECEF
!!
!> @param[out]  altitude    geodetic altitude (km)
!> @param[out]  lat         geodetic latitude (rad)
!> @param[out]  lon         geodetic longitude (rad)
!!
!> @details     This routine computes the geodetic latitude, as well as longitude and
!!              geodetic altitude. The geodetic latitude is computed iteratively using
!!              the algorithm as described in Vallado (2007), p. 179.
!!
!!------------------------------------------------------------------------------------------------
subroutine getGeodeticLatLon(           &
                              r_ecef,   &  ! <-- DBL(3)  radius vector in ITRF
                              altitude, &  ! --> DBL     geodetic altitude (km)
                              lat,      &  ! --> DBL     geodetic latitude (rad)
                              lon       &  ! --> DBL     geodetic longitude (rad)
                            )

  implicit none

  !** interface
  !----------------------------------------
  real(dp), dimension(3), intent(in) :: r_ecef
  real(dp), intent(out) :: altitude
  real(dp), intent(out) :: lat
  real(dp), intent(out) :: lon
  !----------------------------------------

  real(dp) :: C       ! parameter C
  real(dp) :: delta   ! initial guess for geodetic latitude (geocentric latitude)
  real(dp) :: lat_old ! iteration value for geodetic latitude (rad)
  real(dp) :: rabs    ! absolute value of radius vector (km)
  real(dp) :: rdelta  ! component of radius vector in equatorial plane (km)
  real(dp) :: sinlat  ! sine of latitude

! This is unsave when used with OpenMP
!  real(dp), dimension(3), save :: last_r = -1.d0
!  real(dp), save :: last_lat, last_lon, last_altitude   ! save last values for subsequent calls with the same r_ecef
!
!  if(mag(last_r - r_ecef) < eps9 ) then   ! do not compute one more time - just return available values...
!
!    altitude = last_altitude
!    lat      = last_lat
!    lon      = last_lon
!    return
!
!  end if

  !** auxiliaries
  rabs   = mag(r_ecef)
  rdelta = sqrt(r_ecef(1)*r_ecef(1) + r_ecef(2)*r_ecef(2))

  lon = acos(r_ecef(1)/rdelta)

  if(r_ecef(2) < 0.d0) then
    lon = twoPi - lon
  end if

  delta = asin(r_ecef(3)/rabs)

  !** initialise phi_gd
  lat_old = delta

  do

    sinlat = sin(lat_old)

    C = getEarthRadius()/sqrt(1.d0 - getEesqrd()*sinlat*sinlat)
    lat = atan((r_ecef(3) + C*getEEsqrd()*sinlat)/rdelta)

    if(abs(lat - lat_old) < eps9) exit

    lat_old = lat

  end do

  altitude = rdelta/cos(lat) - C

!  last_altitude = altitude
!  last_lat      = lat
!  last_lon      = lon

  return

end subroutine getGeodeticLatLon

!==============================================================================
!
!> @anchor      getRadiusLatLon
!!
!> @brief       Geocentric latitude and longitude from ITRF radius
!> @author      Vitali Braun
!!
!> @param[in]   r      Position vector in ITRF
!> @param[in]   v      velocity vector in ITRF
!> @param[out]  rabs   magnitude of radius (km)
!> @param[out]  lat    latitude
!> @param[out]  lon    longitude
!!
!---------------------------------------------------------------
subroutine getRadiusLatLon(         &
                             r,     &  ! <-- DBL(3)  radius vector in ITRF
                             v,     &  ! <-- DBL(3)  velocity vector in ITRF, required for
                                       !             determination of longitude at poles
                             rabs,  &  ! --> DBL     magnitude of radius (km)
                             lat,   &  ! --> DBL     geocentric latitude (rad)
                             lon    &  ! --> DBL     geocentric longitude (rad)
                          )
!---------------------------------------------------------------

  implicit none

  !** interface
  !----------------------------------------
  real(dp), dimension(3), intent(in) :: r
  real(dp), dimension(3), intent(in) :: v

  real(dp), intent(out) :: rabs
  real(dp), intent(out) :: lat
  real(dp), intent(out) :: lon
  !----------------------------------------

  real(dp) :: temp      ! temporary

  !** radius
  rabs = mag(r)

  !** longitude
  temp = sqrt(r(1)*r(1) + r(2)*r(2))

  if(temp < eps9) then

    lon = atan2(v(2), v(1))

  else

    lon = atan2(r(2), r(1))

  end if

  !** latitude
  lat = asin(r(3)/rabs)

  return

end subroutine getRadiusLatLon

end module slam_astro_conversions


c=======================================================================
c
c     subroutine SHRINKAGETARGET
c
c     Shrinkage target in the Ledoit-Wolf formula
c
c-----------------------------------------------------------------------
      SUBROUTINE shrinkagetarget ( p, cov, f, corrmean, info )
c-----------------------------------------------------------------------
c
c     INPUT
c
c            p      : number of assets (p > 1)                    integer
c            cov    : covariance matrix (p*p)                     double
c
c     OUTPUT
c
c            f   : shrinkage target  (p*p)          double
c            corrmean: mean of the correlation matrix values      double
c            info: array of dimension 1, diagnostic argument     integer
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER p, info
      DOUBLE PRECISION cov(*), f(*), corrmean
c
c     local variables
      integer i, j
      double precision temp
c
c     external subroutines
      external cormean
c
c     intrinsic functions
      intrinsic sqrt
c
c-----------------------------------------------------------------------
c
c     mean of the non-diagonal elements of the correlation matrix
      call cormean ( p, cov, corrmean, info )
      if (info .lt. 0) then
        return
      endif
c
c     Shrinkage target matrix
      DO i = 1,p
         DO j = 1,i-1
            temp = corrmean*sqrt(cov((i-1)*p+i)*cov((j-1)*p+j))
            f((i-1)*p+j) = temp
            f((j-1)*p+i) = temp
         ENDDO
         f((i-1)*p+i) = cov((i-1)*p+i)
      ENDDO
c
      RETURN
      END


program randomize_list
  implicit none
  integer, dimension(1000) :: numlist
  real, dimension(:), allocatable :: rand_num_list
  integer, dimension(:), allocatable :: rand_index_list
  integer :: i, r, n
  integer :: temp
  integer :: read_status

  print *, "Please enter some numbers, one per line:"

  do i=1, size(numlist)
     read(unit=*,fmt=*,iostat=read_status) numlist(i)
     if( read_status < 0 ) exit ! EOF
     n = i
  end do

  if( n > 0 ) then
     allocate( rand_num_list(n) )
     allocate( rand_index_list(n) )
     call random_seed
     call random_number(rand_num_list)
     rand_index_list = int(rand_num_list*n) + 1
     if( any(rand_index_list < 1 .or. rand_index_list > n) ) then
        print *, "Error in converting random numbers to random ints"
        do i=1, n
           write(unit=*,fmt=*) i, rand_index_list(i)
        end do
        stop
     end if
     do i=1,n
        r = rand_index_list(i)
        temp = numlist(i)
        numlist(i) = numlist(r)
        numlist(r) = temp
     end do
     do i=1,n
        print *, numlist(i)
     end do
  end if
end program randomize_list


c     program DRDRANE
c>> 2001-05-22 DRDRANE  Krogh Minor change for making .f90 version.
c>> 1996-05-28 DRDRANE  Krogh Added external statement.
c>> 1994-10-19 DRDRANE  Krogh  Changes to use M77CON
c>> 1987-12-09 DRDRANE  Lawson  Initial Code.
c--D replaces "?": DR?RANE, ?RANE, ?STAT1, ?STAT2
c
c     Driver to demonstrate use of DRANE to generate random numbers
c     from the exponential distribution with standard deviation, STDDEV.
c     Program computes histogram for N numbers
c     ------------------------------------------------------------------
      integer I, NCELLS
      parameter(NCELLS = 12+2)
      integer IHIST(NCELLS), N
      external DRANE
      double precision  DRANE, STATS(5), STDDEV, Y1, Y2, YTAB(1), ZERO
c
      parameter(ZERO = 0.0D0)
      data N / 10000 /
      data Y1, Y2 / 0.0D0, 6.0D0 /
      data STDDEV / 1.0D0 /
c     ------------------------------------------------------------------
      STATS(1) = ZERO
      do 20 I = 1, N
c                             Get random number
        YTAB(1) = DRANE(STDDEV)
c                          Accumulate statistics and histogram.
c
        call DSTAT1(YTAB(1), 1, STATS, IHIST, NCELLS, Y1, Y2)
   20 continue
c
      print '(11x,a)','Exponential random numbers from DRANE'
      print '(11x,a,g12.4,/1x)','with STDDEV = ',STDDEV
c
c                          Print the statistics and histogram.
c
      call DSTAT2(STATS, IHIST, NCELLS, Y1, Y2)
      stop
      end


** Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
** See https://llvm.org/LICENSE.txt for license information.
** SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

*   PARAMETER statements for LOGICAL constants.  Also,
*   constant folding of logical  expressions.

      implicit logical (a, o)
      logical t1, t2, f1, f2
      parameter (t1 = .true.)
      parameter (f1 = .false., t2 = .not..false., f2 = .not.t1)

      parameter (a1 = f1 .and. .false.,
     +           a2 = a1 .and. .true. ,
     +           a3 = .true..and..false.,
     +           a4 = .true..and..true.  )

      parameter (o1 = f1 .or. f1,
     +           o2 = f1 .or. t1,
     +           o3 = t1 .or. f1,
     +           o4 = t1 .or. t1  )

      logical e1, e2, e3, e4, n1, n2, n3, n4
      parameter (e1 = f1 .eqv. f1,
     +           e2 = f1 .eqv. t1,
     +           e3 = t1 .eqv. f1,
     +           e4 = t1 .eqv. t1  )

      parameter (n1 = f1 .neqv. f1,
     +           n2 = f1 .neqv. t1,
     +           n3 = t1 .neqv. f1,
     +           n4 = t1 .neqv. t1  )

      logical x1, x2, x3, x4
      parameter(N = 24)
      logical rslts(N), expect(N)
      parameter( x1 = (.true. .and. .false.) .or. (.false. .eqv. f1) )
      parameter(x2  = 3 .gt. 4 .or. 6 .eq. 1)
      parameter(x3 = .not.f1.and.t1  .neqv.  f1.or..false..or..false.)
      parameter(x4 = .not. (2 .le. 3 .eqv. 78 .eq. 78) )

      data expect / .true., .false., .true., .false.,
c tests 5 - 8:   AND operation
     +              .false., .false., .false., .true.,
c tests 9 - 12:  OR operation
     +              .false., .true., .true., .true.,
c tests 13 - 16: EQV operation
     +              .true., .false., .false., .true.,
c tests 17 - 20: NEQV operation
     +              .false., .true., .true., .false.,
c tests 21 - 24: miscellaneous combinations
     +              .true., .false., .true., .false.   /

      data (rslts(i), i = 1, 16) / t1, f1, t2, f2,
     +                             a1, a2, a3, a4,
     +                             o1, o2, o3, o4,
     +                             e1, e2, e3, e4  /

      data (rslts(i), i = 17, 20)/ n1, n2, n3, n4  /

      rslts(21) = x1
      rslts(22) = x2
      rslts(23) = x3
      rslts(24) = x4
      if (x4)   rslts(24) = .true.

      call check(rslts, expect, N)
      end


! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

! do concurrent locality list

integer, parameter :: N = 6
integer, target    :: a(N,N,N) ! operand via p
integer            :: r(N,N)   ! result, unspecified locality
integer            :: s(N,N)   ! shared locality
integer            :: t(N,N)   ! local locality
integer, pointer   :: p(:,:,:) ! local_init locality

p => a

do concurrent (integer(kind=1)::i=N:1:-1)
  do j = 1,N
    a(i,j,:) = 2*(i+j)
    s(i,j)   = -i-j
  enddo
enddo

do concurrent (integer(2)::i=1:N,j=1:N,i.ne.j) local(t) local_init(p) shared(s)
  do k=1,N
    do concurrent (m=1:N)
      t(k,m) = p(k,m,k)
    enddo
  enddo
  r(i,j) = t(i,j) + s(i,j)
enddo

! print*, r !    0    3    4    5    6    7
            !    3    0    5    6    7    8
            !    4    5    0    7    8    9
            !    5    6    7    0    9   10
            !    6    7    8    9    0   11
            !    7    8    9   10   11    0  -->  sums to 210

if (sum(r).ne.210) print*, 'FAIL'
if (sum(r).eq.210) print*, 'PASS'

end


! Advent of Code 2021 : https://adventofcode.com/2021
! Puzzle for Day 04 part 01 :
! Build with:  gfortran -static-libgcc -o aoc_day04_p1 aoc_day04_p1.f90

program aoc_day04_p1

	use, intrinsic :: iso_fortran_env
	implicit none

	! Declare and set constants the AOC day and part
	integer,parameter :: day = 4, part = 1

	! Declare file related variables
	character(len=*), parameter :: filename = "day04-input.txt"
	character(len=*), parameter :: error1 = "file: '"//''//filename//''//"' not found"

	! Variables to track and manage the bingo cards and associated numbers
	integer :: total_call_nums = 0
	integer :: i, j, k   ! do loop variable
	integer, allocatable :: numbersArray(:) ! imported bingo 'call numbers' array
	integer :: card(5,5), card_nums, win=-1,house,win_card ! bingo card array, total for card numbers and win outcome
	logical :: matches(10,5,5) ! track the game status as numbers are called as truth table
	integer, allocatable :: bingo_cards(:,:,:) ! all bingo numbers called
	logical, allocatable :: called(:,:,:) ! track numbers drawn to match bingo cards status as truth table
	logical, allocatable :: won(:) ! track numbers that matched bingo cards numbers and won as truth table

	! Output startup message
	call display_welcome(day,part)

	if (.NOT. file_exists(filename)) stop error1

	call get_bingo_call_numbers(filename,numbersArray,total_call_nums)

	write(*,'(A,I0,A,I0,A)') " » Bingo calls to be made: ",total_call_nums," [array check: ",size(numbersArray),"]"
	!write(*,'(I2.2)') numbersArray ! print all bingo call numbers extracted from input

	call setup_bingo_cards(filename, card_nums, card, bingo_cards)
	write(*,'(A,I0)') " » Bingo cards created: ",card_nums
	print *, ""

	! allocated arrays to track called numbers and any winning cards sized on total number of cards created 'card_nums'
	allocate(called(card_nums,5,5))
	allocate(won(card_nums))

	matches = .false.
	do i=1,5
		matches(i,i,:) = .true.
		matches(i+5,:,i) = .true.
	end do

	called = .false.
	won = .false.

	outer: do i=1,total_call_nums
		if (win .gt. 0) exit
		!print *, "Called number is: ",numbersArray(i)
		called = called .or. (bingo_cards .eq. numbersArray(i))
		!print *, "Called check is: ", called
		do j=1,card_nums
			!print *, "Checking bingo card: ",j
			if (won(j)) then
				print *, "Skipping winning bingo card: ",j
				cycle ! if card won already - loop through rest still
			end if
			do k=1,10
				!print *, "Card matches are",(count(called(j,:,:) .and. matches(k,:,:)))
				if (count(called(j,:,:) .and. matches(k,:,:)) .eq. 5) then  ! if called number and matches in card row or column
					!print *, "Match is",(count(called(j,:,:) .and. matches(k,:,:)))
					print *, "HOUSE!! Called wining number is: ",numbersArray(i)," for bingo card: ",j
					house = numbersArray(i)*sum(bingo_cards(j,:,:), mask = .not. called(j,:,:))
					if (win .lt. 0) then
						win=house
						win_card = j
					end if
					won(j) = .true.  ! add wining card to 'won' array
					exit
				end if
			end do
		end do
	end do outer

	print *, ""
	write(*,'(A,I0)') "First winning bingo card is: ",win_card
	write(*,'(A,I0)') "Final score for bingo card is: ",win
	print *, ""

	! clean up arrays allocated
	deallocate(numbersArray)
	deallocate(bingo_cards)
	deallocate(called)
	deallocate(won)

contains

	! Display the AoC puzzle day and part being resolved
	subroutine display_welcome(day,part)
		implicit none
		integer, intent(in) :: day,part
		print *,""
		write (*,'(A,I2.2,A,I2.2)') "AoC 2021 - solution for Day ",day," part ",part
		print *,""
	end subroutine display_welcome

	! Check input filename exists
	function file_exists(filename) result (exists)
		implicit none
		character(len=*), intent(in) :: filename
		logical :: exists ! variable for the return.  NB: no intent(out) needed.

		inquire(file=filename, exist=exists)
	end function file_exists

	! Check how many numbers exists for the bingo calls - first input line of numbers
	! Read all numbers extracted into the array 'numbersArray'
	subroutine get_bingo_call_numbers (filename,numbersArray,call_nums)
		character(len=*), intent(in) :: filename
		integer, allocatable,intent(inout) :: numbersArray(:)
		integer :: fileunit,io
		character(len=1) :: A
		integer, intent(inout) :: call_nums

		open(newunit=fileunit, file=filename, action='read', position='rewind')
		call_nums = 1  ! one more number that commas - so start at 1 not 0
		do
			read(fileunit,'(A)',advance='no',iostat=io) A
			if (io /= 0) exit
			if (A .EQ. ",") call_nums = call_nums + 1
		end do

		rewind(fileunit)

		allocate(numbersArray(call_nums))
		read(fileunit,*) numbersArray
		close(fileunit)
	end subroutine get_bingo_call_numbers

	! Check bingo cards numbers and setup arrays to hold allocated numbers.
	! Created management arrays to hold and track called and matched numbers.
	subroutine setup_bingo_cards(filename, card_nums, card, bingo_cards)
		character(len=*), intent(in) :: filename
		integer, intent(inout) :: card_nums, card(5,5)
		integer, allocatable, intent(inout) :: bingo_cards(:,:,:)
		integer :: fileunit, io, i

		open(newunit=fileunit, file=filename, action='read', position='rewind')
		card_nums = 0
		do
			read(fileunit,*,iostat=io)        ! read and skip first line as 'call numbers' - plus subsequent between cards
			if (io /= 0) exit
			read(fileunit,*,iostat=io) card   ! populate bingo card 5x5 array
			if (io /= 0) exit
			card_nums = card_nums + 1         ! track number of bingo cards read
		end do

		allocate(bingo_cards(card_nums,5,5))  ! create bingo cards array based on now known total number of cards read

		rewind(fileunit)                      ! move back to start of the input file

		read(fileunit,*)                          ! read to skip first line as 'call numbers'
		do i=1,card_nums
			read(fileunit,*)                      ! read to skip blank line before card numbers
			read(fileunit,*) bingo_cards(I,:,:)   ! read bingo card number into array
		end do

		close(fileunit)
	end subroutine setup_bingo_cards

end program aoc_day04_p1


! solve b=Ax using parallel log-ent mart.
! Matlab by Joshua Semeter
! Fortran by Michael Hirsch

program test_logmart

use, intrinsic:: iso_fortran_env, only: stderr=>error_unit
use art, only: logmart
use random_utils, only: init_random_seed, randn, wp

implicit none

integer, parameter :: N=4, M=4
real(wp), dimension(N,M) :: A1, A2
real(wp) :: x(M)
logical :: ok=.true., add_noise = .true.

call init_random_seed()

A1 = reshape([5,0,0,0, &
              0,5,0,0, &
              0,0,5,0, &
              0,0,0,5], shape(A1), order=[2,1])

A2 = reshape([0,1,2,3, &
              1,0,1,2, &
              2,1,0,1, &
              3,2,1,0], shape(A2), order=[2,1])

x = [1._wp, 3._wp, 0.5_wp, 2._wp]

if (.not. run_test(A1, x, 20,add_noise)) then
  ok = .false.
  write(stderr,*) 'failed on identity test'
endif

if (.not. run_test(A2, x, 2000, add_noise)) then
  ok = .false.
  write(stderr,*) 'failed on Fiedler test'
endif

if (.not. ok) error stop

print *, 'OK: logmart'

contains

logical function run_test(A, x, max_iter, add_noise)

real(wp), intent(in) :: A(:,:), x(:)
logical, intent(in) :: add_noise
integer, intent(in) :: max_iter

real(wp), parameter :: errtol=0.05_wp
real(wp), dimension(size(A,1)) :: noise, x_est, b

run_test = .true.

block
integer :: i
print *, 'A ='
do i = 1,size(A,1)
  print '(3F10.3)', A(i,:)
enddo
end block

! ---- noisy observation
b = matmul(A,x)

if (add_noise) then
  call randn(noise)
  noise = 0.01_wp * noise
  print '(/,A,3F10.3)', 'noise',noise
  b = b + noise
endif

! ---- inversion
call logmart(A,b, max_iter=max_iter, x=x_est)

! --- check estimate
if (any(abs(x_est-x) > errtol*maxval(x))) then
  print *,x_est
  write (stderr,*) 'larger than',errtol*100,' % error'
  run_test = .false.
endif

end function run_test

end program


      SUBROUTINE slDTPV (XI, ETA, V0, V)
*+
*     - - - - - -
*      D T P V
*     - - - - - -
*
*  Given the tangent-plane coordinates of a star and the direction
*  cosines of the tangent point, determine the direction cosines
*  of the star.
*
*  (double precision)
*
*  Given:
*     XI,ETA    d       tangent plane coordinates of star
*     V0        d(3)    direction cosines of tangent point
*
*  Returned:
*     V         d(3)    direction cosines of star
*
*  Notes:
*
*  1  If vector V0 is not of unit length, the returned vector V will
*     be wrong.
*
*  2  If vector V0 points at a pole, the returned vector V will be
*     based on the arbitrary assumption that the RA of the tangent
*     point is zero.
*
*  3  This routine is the Cartesian equivalent of the routine slDTPS.
*
*  P.T.Wallace   Starlink   11 February 1995
*
*  Copyright (C) 1995 Rutherford Appleton Laboratory
*
*  License:
*    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 2 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 (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      DOUBLE PRECISION XI,ETA,V0(3),V(3)

      DOUBLE PRECISION X,Y,Z,F,R

      X=V0(1)
      Y=V0(2)
      Z=V0(3)
      F=SQRT(1D0+XI*XI+ETA*ETA)
      R=SQRT(X*X+Y*Y)
      IF (R.EQ.0D0) THEN
         R=1D-20
         X=R
      END IF
      V(1)=(X-(XI*Y+ETA*X*Z)/R)/F
      V(2)=(Y+(XI*X-ETA*Y*Z)/R)/F
      V(3)=(Z+ETA*R)/F

      END


MODULE FUN_xyzINTERSECT
!!#### PURPOSE
!! Determine if two objects intersect and optionally return some information
!! about the intersection.
!
!! Routine Suffix   Object 1    Object 2   Optional Information
!!     _PnRy         Plane       Ray       distance to intersection, point of intersection
!!     _PnLn         Plane       Line      signed distance to plane, point of intersection
!!     _SpRy         Spere       Ray       distance to intersection, point of intersection
!!     _RyRy         Ray         Ray       distance to intersection, point of intersection

!!#### EXTERNAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp                               !!((01-A-KND_IntrinsicTypes.f90))

!!#### EXTERNAL PARAMETERS
USE PAR_Constants_Rsp,ONLY: c_0_Rsp => c_0 , c_1_Rsp => c_1 , c_2_Rsp => c_2 !!((02-A-PAR_Constants_Rsp.f90))
USE PAR_Constants_Rdp,ONLY: c_0_Rdp => c_0 , c_1_Rdp => c_1 , c_2_Rdp => c_2 !!((02-A-PAR_Constants_Rdp.f90))

!!#### EXTERNAL PROCEDURES
USE FUN_xyzVECTOR     ,ONLY: xyzVECTOR_PP                                    !!((03-A-FUN_xyzVECTOR.f90))
USE FUN_xyzDETERMINANT,ONLY: xyzDETERMINANT                                  !!((05-B-FUN_xyzDETERMINANT.f90))
USE FUN_xyzCROSS      ,ONLY: xyzCROSS_VV                                     !!((05-B-FUN_xyzCROSS.f90))
USE FUN_xyzNORMSQRD   ,ONLY: xyzNORMSQRD_V                                   !!((03-A-FUN_xyzNORMSQRD.f90))
USE FUN_xyzDOT        ,ONLY: xyzDOT_VV                                       !!((05-B-FUN_xyzDOT.f90))
USE FUN_xyzSDIST      ,ONLY: xyzSDIST_PnP                                    !!((06-B-FUN_xyzSDIST.f90))

!!#### DEFAULT IMPLICIT
IMPLICIT NONE

!!#### DEFAULT ACCESS
PRIVATE

!!#### PROCEDURE OVERLOADING
INTERFACE xyzINTERSECT_PnRy
 MODULE PROCEDURE xyzINTERSECT_PnRy_Rsp
 MODULE PROCEDURE xyzINTERSECT_PnRy_Rdp
END INTERFACE

INTERFACE xyzINTERSECT_PnLn
 MODULE PROCEDURE xyzINTERSECT_PnLn_Rsp
 MODULE PROCEDURE xyzINTERSECT_PnLn_Rdp
END INTERFACE

INTERFACE xyzINTERSECT_SpRy
 MODULE PROCEDURE xyzINTERSECT_SpRy_Rsp
 MODULE PROCEDURE xyzINTERSECT_SpRy_Rdp
END INTERFACE

INTERFACE xyzINTERSECT_RyRy
 MODULE PROCEDURE xyzINTERSECT_RyRy_Rsp
 MODULE PROCEDURE xyzINTERSECT_RyRy_Rdp
END INTERFACE

!!#### PUBLIC ACCESS LIST
PUBLIC :: xyzINTERSECT_PnRy
PUBLIC :: xyzINTERSECT_PnLn
PUBLIC :: xyzINTERSECT_SpRy
PUBLIC :: xyzINTERSECT_RyRy

CONTAINS

FUNCTION xyzINTERSECT_PnRy_Rsp( Pn , Ry , DIST , P_intersect ) RESULT(INTERSECT)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp                                !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_0 = c_0_Rsp
INCLUDE "07-B-FUN_xyzINTERSECT_PnRy.f90.hdr"
!!--begin--
INCLUDE "07-B-FUN_xyzINTERSECT_PnRy.f90.bdy"
!!--end--
END FUNCTION

FUNCTION xyzINTERSECT_PnRy_Rdp( Pn , Ry , DIST , P_intersect ) RESULT(INTERSECT)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp                                !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_0 = c_0_Rsp
INCLUDE "07-B-FUN_xyzINTERSECT_PnRy.f90.hdr"
!!--begin--
INCLUDE "07-B-FUN_xyzINTERSECT_PnRy.f90.bdy"
!!--end--
END FUNCTION

FUNCTION xyzINTERSECT_RyRy_Rsp( Ry_a , Ry_b , DIST_a , DIST_b , P_intersect ) RESULT(INTERSECT)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp                                !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_0 = c_0_Rsp
INCLUDE "07-B-FUN_xyzINTERSECT_RyRy.f90.hdr"
!!--begin--
INCLUDE "07-B-FUN_xyzINTERSECT_RyRy.f90.bdy"
!!--end--
END FUNCTION

FUNCTION xyzINTERSECT_RyRy_Rdp( Ry_a , Ry_b , DIST_a , DIST_b , P_intersect ) RESULT(INTERSECT)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp                                !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_0 = c_0_Rdp
INCLUDE "07-B-FUN_xyzINTERSECT_RyRy.f90.hdr"
!!--begin--
INCLUDE "07-B-FUN_xyzINTERSECT_RyRy.f90.bdy"
!!--end--
END FUNCTION

FUNCTION xyzINTERSECT_PnLn_Rsp( Pn , Ln , SDIST , P_intersect ) RESULT(INTERSECT)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp                                !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_0 = c_0_Rsp
INCLUDE "07-B-FUN_xyzINTERSECT_PnLn.f90.hdr"
!!--begin--
INCLUDE "07-B-FUN_xyzINTERSECT_PnLn.f90.bdy"
!!--end--
END FUNCTION

FUNCTION xyzINTERSECT_PnLn_Rdp( Pn , Ln , SDIST , P_intersect ) RESULT(INTERSECT)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp                                !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_0 = c_0_Rdp
INCLUDE "07-B-FUN_xyzINTERSECT_PnLn.f90.hdr"
!!--begin--
INCLUDE "07-B-FUN_xyzINTERSECT_PnLn.f90.bdy"
!!--end--
END FUNCTION

FUNCTION xyzINTERSECT_SpRy_Rsp( Sp , Ry , DIST , P_intersect ) RESULT(INTERSECT)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp                                !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_0 = c_0_Rsp
REAL(KIND_R),PARAMETER :: c_1 = c_1_Rsp
INCLUDE "07-B-FUN_xyzINTERSECT_SpRy.f90.hdr"
!!--begin--
INCLUDE "07-B-FUN_xyzINTERSECT_SpRy.f90.bdy"
!!--end--
END FUNCTION

FUNCTION xyzINTERSECT_SpRy_Rdp( Sp , Ry , DIST , P_intersect ) RESULT(INTERSECT)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp                                !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_0 = c_0_Rdp
REAL(KIND_R),PARAMETER :: c_1 = c_1_Rdp
INCLUDE "07-B-FUN_xyzINTERSECT_SpRy.f90.hdr"
!!--begin--
INCLUDE "07-B-FUN_xyzINTERSECT_SpRy.f90.bdy"
!!--end--
END FUNCTION

END MODULE


!Program follows algorithm for TGFSR generator given in lecture notes
program ex2p2
    implicit none
    integer, parameter:: ik=selected_int_kind(10)
    !Parameters and initial array
    integer(kind=ik)::i, k=0    !i is used just as a place holder variable
    integer(kind=ik), parameter:: w=16, p=25, q=11, a=43125,  n=25
    integer(kind=ik), dimension(n):: m=[(i, i=10, n+9, 1)]

    !a0 right shift by one bit
    i=RSHIFT(m(k+1), 1)

    !XOR operations do not require a specific order, so we start with the XOR
    !where the other element in the operation is chosen based on the LSB

    !Check the LSB and choose the correct XOR based on it
    if(BTEST(i, 0)) then
        i=XOR(i, a)
    else
        i=XOR(i, 0)
    end if

    !XOR with modulo and check the result
    m(k+1)=XOR(m(MOD(k+q, p)+1), i)
    print*, m(k+1)  !Gives 43109

end program ex2p2


SUBROUTINE DSTEVR_F95( D, E, W, Z, VL, VU, IL, IU, M, ISUPPZ, &
     &    ABSTOL, INFO )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS ..
      USE LA_PRECISION, ONLY: WP => DP
      USE LA_AUXMOD, ONLY: ERINFO
      USE F77_LAPACK, ONLY: STEVR_F77 => LA_STEVR, LAMCH_F77 => DLAMCH
!  .. IMPLICIT STATEMENT ..
      IMPLICIT NONE
!  .. SCALAR ARGUMENTS ..
      INTEGER, INTENT(IN), OPTIONAL :: IL, IU
      INTEGER, INTENT(OUT), OPTIONAL :: INFO, M
      REAL(WP), INTENT(IN), OPTIONAL :: ABSTOL, VL, VU
!  .. ARRAY ARGUMENTS ..
      INTEGER, INTENT(OUT), OPTIONAL, TARGET :: ISUPPZ(:)
      REAL(WP), INTENT(OUT), OPTIONAL, TARGET :: Z(:,:)
      REAL(WP), INTENT(INOUT) :: D(:), E(:)
      REAL(WP), INTENT(OUT) :: W(:)
!----------------------------------------------------------------------
!
! Purpose
! =======
!       LA_STEVR computes selected eigenvalues and, optionally, the
! corresponding eigenvectors of a real symmetric tridiagonal matrix A.
! Eigenvalues and eigenvectors can be selected by specifying either a
! range of values or a range of indices for the desired eigenvalues.
!       LA_STEVR uses a relatively robust representation (RRR) algorithm.
! It is usually the fastest algorithm of all and uses the least
! workspace.
!
! =========
!
!         SUBROUTINE LA_STEVR ( D, E, W, Z=z, VL=vl, VU=vu, &
!                         IL=il, IU=iu, M=m, ISUPPZ=isuppz, &
!                         ABSTOL=abstol, INFO=info )
!                 REAL(<wp>), INTENT(INOUT) :: D(:), E(:)
!                 REAL(<wp>), INTENT(OUT) :: W(:)
!                 REAL(<wp>), INTENT(OUT), OPTIONAL :: Z(:,:)
!                 INTEGER, INTENT(OUT), OPTIONAL :: ISUPPZ(:)
!                 REAL(<wp>), INTENT(IN), OPTIONAL :: VL, VU
!                 INTEGER, INTENT(IN), OPTIONAL :: IL, IU
!                 INTEGER, INTENT(OUT), OPTIONAL :: M
!                 REAL(<wp>), INTENT(IN), OPTIONAL :: ABSTOL
!                 INTEGER, INTENT(OUT), OPTIONAL :: INFO
!         where
!                 <wp> ::= KIND(1.0) | KIND(1.0D0)
!
! Arguments
! =========
!
! D      (input/output) REAL array, shape (:) with size(D) = n, where n
!        is the order of A.
!        On entry, the diagonal elements of the matrix A.
!        On exit, the original contents of D possibly multiplied by a
!        constant factor to avoid over/underflow in computing the
!        eigenvalues.
! E      (input/output) REAL array, shape (:) with size(E) = n.
!        On entry, the n-1 subdiagonal elements of A in E(1) to E(n-1) .
!        E(n) need not be set.
!        On exit, the original contents of E possibly multiplied by a
!        constant factor to avoid over/underflow in computing the
!        eigenvalues.
! W      (output) REAL array with size(W) = n.
!        The first M elements contain the selected eigenvalues in
!        ascending order.
! Z      Optional (output) REAL or COMPLEX array, shape (:,:) with
!        size(Z,1) = n and size(Z,2) = M.
!        The first M columns of Z contain the orthonormal eigenvectors of
!        A corresponding to the selected eigenvalues, with the i-th column
!        of Z containing the eigenvector associated with the eigenvalue in
!        W(i).
!        Note: The user must ensure that at least M columns are supplied
!        in the array Z. When the exact value of M is not known in advance,
!        an upper bound must be used. In all cases M <= n.
! VL,VU  Optional (input) REAL.
!        The lower and upper bounds of the interval to be searched for
!        eigenvalues. VL < VU.
!        Default values: VL = -HUGE(<wp>) and VU = HUGE(<wp>), where
!        <wp> ::= KIND(1.0) | KIND(1.0D0).
!        Note: Neither VL nor VU may be present if IL and/or IU is
!        present.
! IL,IU  Optional (input) INTEGER.
!        The indices of the smallest and largest eigenvalues to be
!        returned. The IL-th through IU-th eigenvalues will be found.
!        1 <= IL <= IU <= n.
!        Default values: IL = 1 and IU = n.
!        Note: Neither IL nor IU may be present if VL and/or VU is
!        present.
!        Note: All eigenvalues are calculated if none of the arguments
!        VL, VU, IL and IU are present.
! M      Optional (output) INTEGER.
!        The total number of eigenvalues found. 0 <= M <=  n.
!        Note: If IL and IU are present then M = IU - IL + 1.
! ISUPPZ Optional (output) INTEGER array, shape (:) with
!        size(ISUPPZ) = 2*max(1,M).
!        The support of the eigenvectors in A, i.e., the indices
!        indicating the nonzero elements. The i-th eigenvector is nonzero
!        only in elements ISUPPZ(2*i-1) through ISUPPZ(2*i).
! ABSTOL Optional (input) REAL.
!        The absolute error tolerance for the eigenvalues. An approximate
!        eigenvalue is accepted as converged when it is determined to lie
!        in an interval [a, b] of width less than or equal to
!        ABSTOL + EPSILON(1.0_<wp>) * max(| a |, | b |),
!        where <wp> is the working precision. If ABSTOL <= 0, then
!        EPSILON(1.0_<wp>)*||A||1 will be used in its place. Eigenvalues
!        will be computed most accurately if ABSTOL is set to
!        LA_LAMCH( 1.0_<wp>, 'Safe minimum'), not zero.
!        Default value: 0.0_<wp>.
! INFO   Optional (output) INTEGER
!        = 0: successful exit.
!        < 0: if INFO = -i, the i-th argument had an illegal value.
!        > 0: an internal error occurred.
!        If INFO is not present and an error occurs, then the program is
!        terminated with an error message.
!-----------------------------------------------------------------------
!  .. LOCAL PARAMETERS ..
      CHARACTER(LEN=8), PARAMETER :: SRNAME = 'LA_STEVR'
!  .. LOCAL SCALARS ..
      CHARACTER(LEN=1) :: LJOBZ, LRANGE
      INTEGER :: N, LD, LIL, LIU, LM, SISUPPZ, S1Z, S2Z, NN
      INTEGER :: LINFO, ISTAT, LWORK, LIWORK
      REAL(WP), TARGET :: LLZ(1,1)
      REAL(WP) :: LABSTOL, LVL, LVU
!  .. LOCAL ARRAYS ..
      INTEGER:: IWORKMIN(1), DUMMY(1)
      REAL(WP), TARGET :: WORKMIN(1)
      INTEGER, POINTER :: IWORK(:), LISUPPZ(:)
      REAL(WP), POINTER :: WORK(:)
!  .. INTRINSIC FUNCTIONS ..
      INTRINSIC HUGE, PRESENT, SIZE
!  .. EXECUTABLE STATEMENTS ..
   LINFO = 0; ISTAT = 0; N = SIZE(D); LD = MAX(1,N)
   NN=2*MAX(1,N)
   IF( PRESENT(ISUPPZ) )THEN; SISUPPZ = SIZE(ISUPPZ); ELSE; SISUPPZ = NN; END IF
   IF( PRESENT(VL) )THEN; LVL = VL; ELSE; LVL = -HUGE(LVL); ENDIF
   IF( PRESENT(VU) )THEN; LVU = VU; ELSE; LVU = HUGE(LVU); ENDIF
   IF( PRESENT(IL) )THEN; LIL = IL; ELSE; LIL = 1; ENDIF
   IF( PRESENT(IU) )THEN; LIU = IU; ELSE; LIU = N; ENDIF
   IF( PRESENT(Z) )THEN; S1Z = SIZE(Z,1); S2Z = SIZE(Z,2)
   ELSE; S1Z = 1; S2Z = 1; ENDIF
!  .. TEST THE ARGUMENTS
   IF( N < 0 ) THEN; LINFO = -1
   ELSE IF( SIZE( E ) /= N .AND. N/=0)THEN; LINFO = -2
   ELSE IF( SIZE( W ) /= N )THEN; LINFO = -3
   ELSE IF( PRESENT(Z) .AND. ( S1Z /= LD .OR. S2Z /= MAX(1,N) ) )THEN; LINFO = -4
   ELSE IF( SISUPPZ /= NN .OR. PRESENT(ISUPPZ).AND..NOT.PRESENT(Z) )THEN; LINFO = -5
   ELSE IF( LVU < LVL .AND. N>0)THEN; LINFO = -6
   ELSE IF( (PRESENT(VL) .OR. PRESENT(VU)) .AND. &
            (PRESENT(IL) .OR. PRESENT(IU)) )THEN; LINFO = -7
   ELSE IF (((LIU<LIL) .OR. (LIL<1)) .AND. (N>0))THEN; LINFO = -7
   ELSE IF( N < LIU )THEN; LINFO = -8
   ELSE IF( N > 0 )THEN
     IF( PRESENT(VL) .OR. PRESENT(VU) )THEN; LRANGE = 'V'; LM = N
     ELSE IF( PRESENT(IL) .OR. PRESENT(IU) )THEN; LRANGE = 'I'; LM = LIU-LIL+1
     ELSE; LRANGE = 'A'; LM = N; END IF
       IF( PRESENT(Z) ) THEN; LJOBZ = 'V'
       ELSE; LJOBZ = 'N'
       ENDIF
! .. DETERMINE THE WORKSPACE ..
! .. QUERING THE SIZE OF WORKSPACE ..
       LWORK = -1
       LIWORK = -1
       IF (PRESENT(Z)) THEN
         CALL STEVR_F77( LJOBZ, LRANGE, N, D, E,  LVL, LVU, &
     &       LIL, LIU, LABSTOL, LM, W, Z, S1Z, DUMMY, &
     &       WORKMIN, LWORK, IWORKMIN, LIWORK, LINFO )
       ELSE
         CALL STEVR_F77( LJOBZ, LRANGE, N, D, E,  LVL, LVU, &
     &       LIL, LIU, LABSTOL, LM, W, LLZ, S1Z, DUMMY, &
     &       WORKMIN, LWORK, IWORKMIN, LIWORK, LINFO )
       ENDIF
       LWORK = WORKMIN(1)
       LIWORK = IWORKMIN(1)

       ALLOCATE(IWORK(LIWORK), STAT=ISTAT)
       IF (ISTAT /= 0) THEN ; LINFO = -100; GOTO 100; ENDIF

       ALLOCATE(LISUPPZ(NN), STAT=ISTAT)
       IF (ISTAT /= 0) THEN ; LINFO = -100; GOTO 200; ENDIF

       ALLOCATE(WORK(LWORK), STAT=ISTAT)
       IF (ISTAT /= 0) THEN ; LINFO = -100; GOTO 300; ENDIF

       IF( PRESENT(ABSTOL) )THEN; LABSTOL = ABSTOL
       ELSE; LABSTOL = 2*LAMCH_F77('Safe minimum'); ENDIF

       IF (PRESENT (Z)) THEN
         CALL STEVR_F77( LJOBZ, LRANGE, N, D, E, LVL, LVU, LIL, LIU, &
     &     LABSTOL, LM, W, Z, S1Z, LISUPPZ, WORK, LWORK, &
     &     IWORK, LIWORK, LINFO )
       ELSE
         CALL STEVR_F77( LJOBZ, LRANGE, N, D, E, LVL, LVU, LIL, LIU, &
     &     LABSTOL, LM, W, LLZ, S1Z, LISUPPZ, WORK, LWORK, &
     &     IWORK, LIWORK, LINFO )
       ENDIF

       IF( PRESENT(M) ) M = LM

       DEALLOCATE(WORK)
300    DEALLOCATE(LISUPPZ)
200    DEALLOCATE(IWORK)
     ENDIF
100  CALL ERINFO(LINFO,SRNAME,INFO,ISTAT)
END SUBROUTINE DSTEVR_F95


*DECK GAMGEN
      SUBROUTINE GAMGEN
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON/TABLE/C(1200,6)
      DIMENSION Y(410),F(9)
      DATA PT15/0.15D0/,PT05/0.05D0/,PT184/0.184D0/,SIX/6.0D0/,
     $     FOUR/4.0D0/
C
C     INITIALIZE THE F(M,T) ROUTINE.
      CALL FMTSET(0,0,0)
C
C     GENERATE THE DESIRED F(M,T) FOR THE COMPLETE RANGE.
C     WE WILL COMPUTE F(0,T) THROUGH F(4,T) IN THIS SECTION.
      T=-PT15
      DO 10 I=1,404
      T=T+PT05
      CALL FMTGEN(F,T,6,ICK)
C     COPY THE RETURNED VALUES INTO PLACES WHERE THEY CAN BE
C     REACHED LATER.
      C(I,2)=F(1)
      C(I,3)=F(2)
      C(I,4)=F(3)
      C(I,5)=F(4)
      C(I,6)=F(5)
   10 Y(I  )=F(6)
C
C     COMPUTE THE INTERPOLATION TABLE WITH THE VALUES AVAILABLE.
C     THIS IS SOMEWHAT COMPLICATED BY THE FACT THAT SOME OF THE
C     INTEGRALS ARE IN Y RATHER THAN IN C.
      DO 40 K=1,6
      DO 40 I=1,400
      J=I+2
C     K INDEXES THE VALUE OF M IN F(M,T).
C     I INDEXES THE INTERPOLATION TABLE (C).
C     J INDEXES THE STORED VALUES OF F(M,T).
C     IF K .EQ. 5, WE MUST USE ALTERNATE CODE BECAUSE THE INTEGRALS
C     ARE STORED IN Y.
      IF(K-6)20,30,20
C     INTEGRALS IN C, PROCEED AS NORMAL.
   20 TEMP1=C(J+1,K+1)+C(J-1,K+1)-(C(J,K+1)+C(J,K+1))
      TEMP2=SIX*C(J,K+1)-FOUR*(C(J+1,K+1)+C(J-1,K+1))+C(J-2,K+1)+C(J+2,K
     $+1)
      C(I    ,K)=C(J,K+1)
      C(I+400,K)=C(J+1,K+1)-C(J,K+1)
      C(I+800,K)=(TEMP1-PT184*TEMP2)/SIX
      GO TO 40
C     ALTERNATE CODE USING Y.
   30 TEMP1=Y(J+1)+Y(J-1)-(Y(J)+Y(J))
      TEMP2=SIX*Y(J)-FOUR*(Y(J+1)+Y(J-1))+Y(J-2)+Y(J+2)
      C(I    ,K)=Y(J)
      C(I+400,K)=Y(J+1)-Y(J)
      C(I+800,K)=(TEMP1-PT184*TEMP2)/SIX
   40 CONTINUE
      RETURN
      END


	SUBROUTINE GCFLIN  ( x, y, np, coeffs, iret )
C************************************************************************
C* GCFLIN								*
C*									*
C* This subroutine finds the coefficients to fit a set of points with 	*
C* piecewise lines.  The coefficients are is dimensioned as (2,np).	*
C*									*
C* GCFLIN  ( X, Y, NP, COEFFS, IRET )					*
C*									*
C* Input parameters:							*
C*	X (NP)		REAL		X coordinates			*
C*	Y (NP)		REAL		Y coordinates			*
C*	NP		INTEGER		Number of points to plot	*
C*									*
C* Output parameters:							*
C*	COEFFS (2, NP)	REAL		Coefficients for each point	*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	12/85						*
C* I. Graffman/RDS	9/88	Document				*
C************************************************************************
	REAL		x (*), y (*), coeffs (2, *)
	INCLUDE		'ERROR.PRM'
C------------------------------------------------------------------------
	iret = 0
C
C*	Generate the coefficients.  Note that x(i+1) - x(i) is assumed to
C*	be non-zero.  This is currently only used for strictly monotonic
C* 	functions.
C
	DO  i = 1, np-1
	    coeffs (1, i) = ( y(i+1) - y(i) ) / ( x(i+1) - x(i) )
	    coeffs (2, i) =   y (i) - coeffs (1,i) * x (i)
	END DO
C*
	RETURN
	END


!_ ---------------------------------------------------------------------
!_ RCS lines preceded by "c_ "
!_ ---------------------------------------------------------------------
!_
!_ $Source: /home/geocmip/users/orr/gap/fortran/zm/RCS/intersecte.f90,v $
!_ $Revision: 1.1 $
!_ $Date: 2000/06/27 09:31:49 $   ;  $State: Exp $
!_ $Author: orr $ ;  $Locker:  $
!_
!_ ---------------------------------------------------------------------
!_ $Log: intersecte.f90,v $
!_ Revision 1.1  2000/06/27  09:31:49  orr
!_ Initial revision
!_
!_ ---------------------------------------------------------------------
!_
MODULE mpr_intersecte
CONTAINS
  FUNCTION intersecte(xseg1,yseg1,xseg2,yseg2,latitude,xint,yint)
!====================================================================
!     sous programme de calcul de l'intersection d'un segment avec une
!     ligne de latitude cte
!
!     variables d'entree :
!                segment: xseg1,yseg1,xseg2,yseg2
!                ligne de latitude: latitude
!
!     variable de sortie
!                intersecte :  1 si intersection
!                              0 si non intersection
!                              2 si confondu
!                xint,yint
!======================================================================

    IMPLICIT NONE

    REAL xseg1,yseg1,xseg2,yseg2,latitude
    REAL xint,yint
!   integer intersecte
    INTEGER intersecte

    IF (((yseg1.GT.latitude).AND.(yseg2.GT.latitude)).OR.       &
        &    ((yseg1.LT.latitude).AND.(yseg2.LT.latitude))) THEN
        intersecte = 0
    ELSE
        IF (((yseg1.EQ.latitude).AND.(yseg2.EQ.latitude))) THEN
            intersecte = 2
        ELSE
            xint=((xseg1-xseg2)/(yseg1-yseg2))*latitude+          &
            (((xseg2*yseg1)-(xseg1*yseg2))/(yseg1-yseg2))
            yint=latitude
            intersecte=1
        ENDIF
    ENDIF

    RETURN
  END FUNCTION intersecte
END MODULE mpr_intersecte


!        subroutine fft_damp(data,Nt,dt,out)
      program main
      implicit real*8(a-h,o-z)

      complex*16 :: im,z
      complex*16,dimension(:),allocatable :: cor
      real*8, dimension(:),allocatable :: t
      complex*16 out(1000)

!        common/four/Emin,Emax,de
!        Emax = 8d-2
        im = (0d0,1d0)
        Pi = 4.0d0*atan(1d0)
!        alfa = 1d0/2d0**6
!      alfa = 0d0
      np = 200
      emin = 0d0
      emax = 6d0
      de = (emax-emin)/(np-1)
!      alfa = 0d0
!        De = 2d0/(Nt*dt)
!        Emin = 0.015d0

      print *,'how many time steps?'
      read(*,*) nt
!      print *,'what is time interval?'
!      read(*,*) dt

!      nt = 4000

      allocate(cor(nt),t(nt))

      open(10,file='cor.dat')
      do i=1,nt
        read(10,*) t(i),a,b,c
        cor(i) = a+im*b
      enddo
      close(10)

      dt = t(2)-t(1)
      alfa = -log(1d-4)/t(nt)**2
      print *,'damping constant',alfa

      out = (0d0,0d0)

        i = 1
        do while (Emin+(i-1)*De<Emax.and.i<=Nt)
        en = Emin + (i-1)*de
        do j=1,Nt
          t = 0d0 +j*dt
          out(i) = 2d0*real(cor(j)*exp(-im*en*t(j)))*exp(-alfa*t(j)**2)*dt + out(i)
        enddo
        i=i+1
        end do

        out = out/(2.d0*pi)

      open(100,file='fft.dat')
      i = 1
      do while (Emin+(i-1)*De<Emax.and.i<=Nt)
        en = Emin + (i-1)*de
        write(100,1000) en,out(i)
        i=i+1
      end do

1000  format(20f14.6,1x)

        stop
        end program

        subroutine rfft_damp(data,Nt,dt,out)

        use cdat, only : pi, im

        implicit real*8(a-h,o-z)

        real*8 :: data(Nt),out(Nt)

        common/four/Emin,Emax,de
!        Emax = 8d-2
        alfa = 1d0/2d0**6
!      alfa = 0d0
!        De = 2d0/(Nt*dt)
!        Emin = 0.015d0
        out = 0d0

        i = 1
        do while (Emin+(i-1)*De<Emax.and.i<=Nt)
        en = Emin + (i-1)*de
        do j=1,Nt
          t = 0d0 +j*dt
          out(i) = 2d0*real(data(j)*exp(im*en*t))*exp(-alfa*t**2)*dt + out(i)
        enddo
        i=i+1
        end do

        out = out/(2.d0*pi)

        return
        end subroutine

        subroutine fft(data,Nt,dt,out)
        implicit real*8(a-h,o-z)
        complex*16 :: im,data(Nt),out(Nt)
        common/four/Emin,Emax,de
!        Emax = 8d-2
        im = (0d0,1d0)
        Pi = 4.0d0*atan(1d0)
      alfa = 0d0

!        De = 2d0/(Nt*dt)
!        Emin = 0.015d0
        out = (0d0,0d0)

        i = 1
        do while (Emin+(i-1)*de<Emax.and.i<=Nt)
        en = Emin + (i-1)*de
          do j=1,Nt
            t = 0d0 +j*dt
            out(i) = 2d0*real(data(j)*exp(im*en*t))*dt + out(i)
          enddo
          i=i+1
        end do
        out = out/(2.d0*pi)
        return
        end subroutine

! --- cosine FFT
      subroutine fft_cos(data,Nt,dt,out)

      use cdat, only : pi, im

      implicit real*8(a-h,o-z)

      complex*16 :: data(Nt),out(Nt)

      common/four/Emin,Emax,de
!      Emax = 8d-2
      alfa = 0d0
!        De = 2d0/(Nt*dt)
!        Emin = 0.015d0
        out = (0d0,0d0)

        i = 1
        do while (Emin+(i-1)*de<Emax.and.i<=Nt)
        en = Emin + (i-1)*de
          do j=1,Nt
            t = 0d0 +j*dt
            out(i) = 2d0*data(j)*cos(en*t)*dt + out(i)
          enddo
          i=i+1
        end do
        out = out/(2.d0*pi)
        return
        end subroutine

      subroutine fft_sin_damp(data,Nt,dt,out)

      use cdat, only : pi, im

      implicit real*8(a-h,o-z)

      real*8 :: data(Nt),out(Nt)

      common/four/Emin,Emax,de

      alfa = 1d0/2d0**6

      out = 0d0

        i = 1
        do while (Emin+(i-1)*de<Emax.and.i<=Nt)
        en = Emin + (i-1)*de
          do j=1,Nt
            t = 0d0 +j*dt
            out(i) = 2d0*data(j)*sin(en*t)*exp(-alfa*t**2)*dt + out(i)
          enddo
          i=i+1
        end do
        out = out/(2.d0*pi)
        return
        end subroutine


module constants
   integer, parameter :: MaxN = 180
   integer, parameter :: np = MaxN-1
   integer, parameter :: n = np*np
   integer, parameter :: nnz = n*3-2*np

   integer, parameter :: MaxTime=90000
   integer, parameter :: PrintEvery=100
   integer, parameter :: CentralDifference = 1
   integer, parameter :: ForwardDifference = 2
   integer, parameter :: BackwardDifference = 3
   integer, parameter :: CrossWind = 2

   double precision, parameter :: Cs = 0.1

   integer, parameter :: VarU = 1
   integer, parameter :: VarV = 2
   integer, parameter :: VarP = 4

   double precision, parameter :: dx = 1.0/MaxN
   double precision, parameter :: dy = 1.0/MaxN
   double precision, parameter :: dz = 1.0/MaxN
   double precision, parameter :: dt = dx-dx*dx*dx*dx

   double precision, parameter :: Re = 1000.0
end module constants
module variables
   integer :: Iter
   integer :: Cscheme = 1
   double precision, allocatable :: aUx1(:),bUx1(:),aUx2(:),bUx2(:)
   double precision, allocatable :: aUy1(:),bUy1(:),aUy2(:),bUy2(:)
   double precision, allocatable :: aVx1(:),bVx1(:),aVx2(:),bVx2(:)
   double precision, allocatable :: aVy1(:),bVy1(:),aVy2(:),bVy2(:)

   double precision, allocatable :: U(:,:),V(:,:),P(:,:)
   double precision, allocatable :: Uon(:,:),Von(:,:)
   double precision, allocatable :: Uo12(:,:),Vo12(:,:)
end module variables