! This file (box_spline_basis.f95) contains the module
! box_spline_basis that declares the subroutines (compute_boxes,
! evaluate_boxes) for generating and evaluating a box spline hypercube
! basis model for continuous multidimensional (d<=20) data with real
! response values.

! The following LAPACK routines are used:
!    + DGELS

! compute_boxes(x_data, response, boxes, widths, weights)
!   x_data   -- matrix of n-dimensions by m-data points (nxm) stored as
!               column vectors. x_data(:,1) should be the first point.
!   response -- array of length "m" holding response values at each x-point
!   boxes    -- matrix of n-dimensions by p-boxes (nxp), will be
!               overwritten with the output boxes
!   widths   -- array of length "p" holding the width of each box
!   weights  -- array of length "p" holding the weight for each box function

MODULE fit_box
  USE ISO_FORTRAN_ENV, ONLY: REAL64
  IMPLICIT NONE

CONTAINS
  SUBROUTINE compute_boxes(x_data, response, boxes, widths, weights)
    ! This is a serial implementation of the hypercube box-spline
    ! basis approximation algorithm.

    REAL (KIND=REAL64), INTENT(IN), DIMENSION(:,:) :: x_data
    ! The matrix of data points (stored in rows as x-vectors)

    REAL (KIND=REAL64), INTENT(IN), DIMENSION(UBOUND(x_data,2)) :: response
    ! The vector of response values associated with each point

    REAL (KIND=REAL64), INTENT(OUT), DIMENSION(:,:) :: boxes
    ! Holder for the center coordinates of each box-spline support region

    REAL (KIND=REAL64), INTENT(OUT), DIMENSION(UBOUND(boxes,2)) :: widths
    ! Holder for the width of each box-spline support region

    REAL (KIND=REAL64), INTENT(OUT), DIMENSION(UBOUND(boxes,2)) :: weights
    ! Holder for the multiplier weight of each box-spline basis
    !   (solved for with LAPACK least squares)

    !     Local workspace variables
    !===================================

    REAL (KIND=REAL64), DIMENSION(:), ALLOCATABLE :: dgels_work_array

    REAL (KIND=REAL64), DIMENSION(UBOUND(boxes,2),UBOUND(x_data,2)) :: coef_matrix
    ! The matrix of coefficients in the least squares solve, holds
    ! the evaluation of all box-splines at each x data point

    REAL (KIND=REAL64), DIMENSION(UBOUND(x_data,2)) :: local_response
    ! Local copy of 'response' so that the original is not tampered with

    REAL (KIND=REAL64), DIMENSION((UBOUND(x_data,2)*(UBOUND(x_data,2)-1))/2) :: distances
    ! Holder for the pairwise distances between data points (m*(m-1))/2

    INTEGER, DIMENSION((UBOUND(x_data,2)*(UBOUND(x_data,2)-1))/2) :: distance_indices
    ! Holder for the original un-sorted indices of pairwise distances

    REAL(KIND=REAL64), DIMENSION(2*UBOUND(x_data,1),UBOUND(boxes,2)) :: box_widths
    ! Storage for hyperbox dimensions before they are converted to
    ! hypercube, box_widths(:UBOUND(x_data,1),:) holds the lower
    ! widths, box_widths(UBOUND(x_data,1)+1:,:) holds the upper widths

    LOGICAL, DIMENSION(UBOUND(x_data,2)) :: is_center_point
    ! Holder for which data points are box centers

    INTEGER :: num_box_centers, step, idx, first, second, dim, info
    ! num_box_centers -- Number of box centers, SUM(IF is_center_point 1)
    ! step -- Iterator used for stepping through various algorithms
    ! idx -- An index in the list of pairwise distances or boxes
    ! first -- The index of the first point in a pair
    ! second -- The index of the second point in a pair
    ! dim -- Index of which dimension is being checked for a data point
    ! info -- Used to send / receive messages from DGELS

    REAL (KIND=REAL64) :: random_num
    ! random_num -- Holder for random numbers in the range [0,1]

    !     Initialization
    !========================

    ! Initialization of local arrays
    local_response = response
    num_box_centers = UBOUND(x_data,2)
    is_center_point = .TRUE.

    !     Step 1: Identify box-spline centers
    !=============================================
    !     n = UBOUND(boxes,2)  ! "number of boxes desired"
    !     m = UBOUND(x_data,2) ! "number of x-data points"
    !     d = UBOUND(x_data,1) ! "dimension of the x-data"
    !     Computation overview:
    !         d m (m-1) / 2    ! pairwise L2 distance between points
    !       + m log_2(m)       ! sorting the pairwise distances
    !       + n                ! picking the box centers to keep

    ! Pairwise 2-norm distance between points
    step = 1
    pairwise_outer_loop : DO first = 1, UBOUND(x_data,2)-1
       pairwise_inner_loop : DO second = first+1, UBOUND(x_data,2)
          distances(step) = SUM((x_data(:,first) - x_data(:,second))**2)
          step = step + 1
       END DO pairwise_inner_loop
    END DO pairwise_outer_loop

    ! Sorting the pairwise distances
    CALL QSORTC(distances, distance_indices)

    ! Picking the box centers to keep (well spaced, QNSTOP algorithm)
    step = 0
    ! Starting with the closest pair and working to more spaced pairs,
    ! randomly select points from each pair to be dropped until there
    ! are only "n" points left to use as the centers of boxes.
    identify_centers : DO WHILE (num_box_centers > UBOUND(boxes,2))
       step = step + 1
       ! Identify the two points that compose the next closest pair
       idx = distance_indices(step)
       ! Map (pair index) -> (first point index, second point index)
       CALL idx_to_pair(idx, UBOUND(x_data,2), first, second)
       ! If both are still in the 'to keep' set, then remove one randomly
       IF (is_center_point(first) .AND. is_center_point(second)) THEN
          CALL RANDOM_NUMBER(random_num)
          IF (random_num > 0.5) THEN
             is_center_point(first) = .FALSE.
          ELSE
             is_center_point(second) = .FALSE.
          END IF
          num_box_centers = num_box_centers - 1
       END IF
    END DO identify_centers

    !     Step 2: Calculate box-spline hypercube widths
    !=======================================================
    !     n = UBOUND(boxes,2)  ! "number of boxes desired"
    !     d = UBOUND(x_data,1) ! "number of x-data points"
    !     Computation overview:
    !       n *                ! "for each box-center"
    !      (  n d              ! "calculate Linf distance to other centers"
    !       + n log_2(n)       ! "sort other boxes by Linf distances"
    !       + n d        )     ! "identify largest box width in each
    !                          !  dimension allowed without overlap"
    !       + n d              ! "identify smallest cube containing
    !                             the max-Linf bounding rectangle"

    ! Initialize all box centers
    idx = 1
    step = 1
    initialize_boxes : DO step=1,UBOUND(is_center_point,1)
       IF (is_center_point(step)) THEN
          boxes(:,idx) = x_data(:,step)
          idx = idx + 1
       END IF
    END DO initialize_boxes

    ! Calculate the shapes of the max-boxes
    CALL max_boxes(boxes,box_widths)
    ! Use the smallest bounding hyper-cube for each box size
    widths = MAXVAL(box_widths,1)

    !     Step 3: Perform least-squares fit of data
    !===================================================
    !     d = UBOUND(x_data,1) ! "number of dimensions for x-data"
    !     m = UBOUND(x_data,2) ! "number of x-data points"
    !     n = UBOUND(boxes,2)  ! "number of boxes desired"
    !     A = [ m x n ] matrix ! "coefficient matrix of box spline
    !                             function values at all x-data points"
    !     y = [ m ] vector     ! "true response values at each x "
    !     Computation overview:
    !       n d m              ! "computing the box-splines at datum"
    !       + n^2 m            ! "computing A^t A"
    !       + n m              ! "computing A^t y"
    !       + n^3              ! "computing LU decomposition of A"

    ! Evaluate all box-spline values at all of the x-data points,
    ! generate the "coef_matrix" to be used for least squares
    CALL eval_box_coefs(boxes, widths, x_data, coef_matrix)

    info = 0
    ! Call LAPACK DGELS to query the appropriate size for the work array
    CALL DGELS('T', UBOUND(coef_matrix,1), UBOUND(coef_matrix,2), 1, &
         coef_matrix, UBOUND(coef_matrix,1), local_response, &
         UBOUND(local_response,1), local_response, -1, info)
    ! Check for errors in identifying amount of storage space necessary
    IF (info .EQ. 0) THEN
       dim = local_response(1)
    ELSE
       PRINT *, 'ERROR: unsuccessful query of work-array size for DGELS.'
       dim = 2 * UBOUND(coef_matrix,2) * UBOUND(x_data,2)
    END IF
    ! Allocate space for the working array
    ALLOCATE( dgels_work_array(1:dim) )

    ! Copy in the true respose values for the DGELS solve
    info = 0
    local_response = response
    ! Call the LAPACK routine for doing least squares minimization of Ax = B
    CALL DGELS('T', UBOUND(coef_matrix,1), UBOUND(coef_matrix,2), 1, &
         coef_matrix, UBOUND(coef_matrix,1), local_response, &
         UBOUND(local_response,1), dgels_work_array, dim, info)
    !   'T'                   -- Transpose of A necessary
    !   UBOUND(coef_matrix,1) -- number of rows in A
    !   UBOUND(coef_matrix,2) -- number of columns in A
    !   1                     -- Number of right hand sides
    !   coef_matrix           -- A
    !   UBOUND(coef_matrix,1) -- Leading dimension of A (number of rows)
    !   local_response        -- B (will be overwritten to hold X after call)
    !   UBOUND(response,1)    -- Leading dimension of B (number of rows)
    !   dgels_work_array      -- Workspace array for DGELS
    !   dim                   -- Size of dgels_work_array
    !   info                  -- For verifying successful execution

    ! Extract the weights from the output array for DGELS
    weights = local_response(1:UBOUND(weights,1))
    ! End of the subroutine "compute_boxes"

  CONTAINS

    ! Function for calculating the index number of a point based on
    ! the index of the pair (assuming pairs are [1,2], [1,3]... [2,3]...)
    SUBROUTINE idx_to_pair(idx, num_individuals, first, second)
      INTEGER, INTENT(IN) :: idx, num_individuals
      INTEGER, INTENT(OUT) :: first, second
      REAL (KIND=REAL64) :: pair_num, i
      ! pair_num -- The number whose integer part represents the index
      !             of the first point and fractional part the index of
      !             second point in "distance_indices"
      ! i        -- holds the converted index (for the math to work)

      ! First figure out how many pairs there will be, convert to
      ! backwards index (required to use functional form)
      i = ( num_individuals * (num_individuals - 1) ) / 2 - idx
      ! Get the pair number (using function whos whole + remainder form
      ! the sequence [1,2], [1,3], ... [1,num_individuals], [2,3], ...)
      pair_num = (1.0_REAL64 + SQRT(1.0_REAL64 + 8.0_REAL64 * i)) / 2.0_REAL64
      ! 'first' is determined by the whole part of "pair_num"
      first = FLOOR(pair_num)
      ! 'second' is determined by the (rounded) remainder part of "pair_num"
      second = (pair_num - first) * first + 0.5_REAL64
      ! Shift first and second to start at the front of the list
      second = num_individuals - second
      first = num_individuals - first
    END SUBROUTINE idx_to_pair

  END SUBROUTINE compute_boxes

  ! Subroutine for computing the max-box around given points
  !  where the max-box is the box defined by a center, lower, and
  !  upper widths such that MIN(lower,upper) is maximized
  SUBROUTINE max_boxes(pts, box_widths)
    REAL(KIND=REAL64), INTENT(IN), DIMENSION(:,:) :: pts
    ! Column vectors of points
    REAL(KIND=REAL64), INTENT(OUT), &
         DIMENSION(2*UBOUND(pts,1),UBOUND(pts,2)) :: box_widths
    ! Holder for the upper and lower widths surrounding each point
    REAL(KIND=REAL64), DIMENSION(UBOUND(pts,2)) :: distances
    ! Distances between points
    INTEGER, DIMENSION(UBOUND(pts,2)) :: distance_indices
    ! Indices of distances (for use in sorting)
    LOGICAL, DIMENSION(UBOUND(pts,1)) :: in_lower, in_upper
    ! Holder for checking if a point is inside of a box
    INTEGER :: step, dim, idx, other_pt_idx, other_pt
    ! Miscellaneous integers for stepping

    ! Initialize all box widths to be 'undefined'
    box_widths= -1.0_REAL64
    ! Iterate over box centers (points)
    compute_box_shapes : DO step = 1,UBOUND(pts,2)
       ! Find the infinity norm distances to each other point
       linf_distances : DO CONCURRENT (idx = 1: UBOUND(pts,2))
          distances(idx) = MAXVAL(ABS(pts(:,idx) - pts(:,step)))
       END DO linf_distances
       ! Sort the Linf distances between pts
       CALL QSORTC(distances, distance_indices)
       ! Identify the max-Linf-width bounding rectangle
       calculate_box_width : DO other_pt = 1, UBOUND(pts,2)
          other_pt_idx = distance_indices(other_pt)
          ! Don't try to use the current box center as a boundary
          IF (other_pt_idx .EQ. step) CYCLE
          ! Logical testing if a point is inside a box:
          !  -- lower width undefined .OR. (box - other) < lower width
          in_lower = (box_widths(:UBOUND(pts,1),step) .LT. 0.0_REAL64) .OR. &
               (pts(:,step)-pts(:,other_pt_idx) < box_widths(:UBOUND(pts,1),step))
          !  -- upper width undefined .OR. (other - box) < upper width
          in_upper = (box_widths(UBOUND(pts,1)+1:,step) .LT. 0.0_REAL64) .OR. &
               (box_widths(UBOUND(pts,1)+1:,step) > pts(:,other_pt_idx)-pts(:,step))
          ! If all conditions are satisfied, the point is in the box
          IF (ALL(in_lower .AND. in_upper)) THEN
             ! Find the dimension of max magnitude (Linf) difference
             dim = MAXLOC(ABS(pts(:,other_pt_idx) &
                  - pts(:,step)),1)
             ! Check if we are adjusting the upper or lower width of
             ! the box, and adjust the boundary for this point
             IF (pts(dim,step) > pts(dim,other_pt_idx)) THEN
                box_widths(dim,step) = &
                     pts(dim,step) - pts(dim,other_pt_idx)
             ELSE
                box_widths(dim+UBOUND(pts,1),step) = &
                     pts(dim,other_pt_idx) - pts(dim,step)
             END IF
          END IF
       END DO calculate_box_width
    END DO compute_box_shapes
  END SUBROUTINE max_boxes

  ! Subroutine for computing the values of all the boxes at an x-point
  SUBROUTINE eval_box_coefs(boxes, widths, x_points, box_vals)
    REAL (KIND=REAL64), INTENT(IN), DIMENSION(:,:) :: boxes
    REAL (KIND=REAL64), INTENT(IN), DIMENSION(:)   :: widths
    REAL (KIND=REAL64), INTENT(IN), DIMENSION(:,:) :: x_points
    REAL (KIND=REAL64), INTENT(OUT), DIMENSION(UBOUND(boxes,2)&
         &,UBOUND(x_points,2)) :: box_vals
    ! ^^ Holder for the evaluation of each box at the given x-point
    INTEGER :: pt_num, box_num
    REAL (KIND=REAL64), DIMENSION(UBOUND(boxes,1)) :: shifted_box
    ! ^^ local variables for computing the box evaluations

    ! Compute the linear box spline for each cube
    box_evals : DO CONCURRENT (pt_num=1:UBOUND(x_points,2), &
         box_num=1:UBOUND(boxes,2))
       ! Calculate the normalized distance from center of this box
       shifted_box = ABS((boxes(:,box_num) - x_points(:,pt_num)) / &
            widths(box_num))
       ! Store the evaluation of this box for this x-data point

       ! Order 1 approximation
       box_vals(box_num,pt_num) = PRODUCT(&
            MAX(1.0_REAL64 - shifted_box, 0.0_REAL64))

       ! ! Order 2 approximation
       ! shifted_box = 1.5_REAL64 + 1.5_REAL64 * shifted_box
       ! WHERE ((1.0_REAL64 .LE. shifted_box) .AND. &
       !      (shifted_box .LT. 2.0_REAL64)) shifted_box = (&
       !      -(2*shifted_box**2 - 6*shifted_box + 3) )
       ! WHERE ((2.0_REAL64 .LE. shifted_box) .AND. &
       !      (shifted_box .LE. 3.0_REAL64)) shifted_box = (&
       !      (shifted_box - 3)**2)
       ! WHERE (shifted_box .GT. 3.0_REAL64) shifted_box = 0.0_REAL64
       ! box_vals(box_num,pt_num) = PRODUCT(shifted_box)

    END DO box_evals
  END SUBROUTINE eval_box_coefs

  ! Subroutine for evaluating an approximation at a set of x-points
  SUBROUTINE eval_boxes(boxes, widths, weights, x_points, response)
    REAL (KIND=REAL64), INTENT(IN), DIMENSION(:,:) :: boxes
    REAL (KIND=REAL64), INTENT(IN), DIMENSION(:)   :: widths
    REAL (KIND=REAL64), INTENT(IN), DIMENSION(:)   :: weights
    REAL (KIND=REAL64), INTENT(IN), DIMENSION(:,:) :: x_points
    REAL (KIND=REAL64), INTENT(OUT), DIMENSION(UBOUND(x_points,2))  :: response
    ! Local variables
    INTEGER :: x_pt
    REAL (KIND=REAL64), DIMENSION(UBOUND(boxes,2),UBOUND(x_points,2)) :: box_coefs

    ! Get the box-spline values for each box at each point
    CALL eval_box_coefs(boxes, widths, x_points, box_coefs)

    DO CONCURRENT (x_pt=1:UBOUND(x_points,2))
       ! Calculate the value using the box-splines and weights
       response(x_pt) = SUM(box_coefs(:,x_pt) * weights)
    END DO
  END SUBROUTINE eval_boxes

  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.
    DO CONCURRENT (I=1:SIZE(A)); IDX(I)=I; END DO

    CALL QSORTC_HELPER(A, IDX, 1, SIZE(A))
    RETURN

  CONTAINS
    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 QSORTC

END MODULE fit_box


program logistic_map
    use, intrinsic :: iso_fortran_env, only : error_unit
    implicit none
    integer, parameter :: nr_iters = 10000, nr_x_vals = 100, nr_r_vals = 1000
    real, parameter :: delta_x = 1.0/nr_x_vals, delta_r = 4.0/nr_r_vals
    real, dimension(0:nr_x_vals, 0:nr_r_vals) :: vals
    real :: x, x0, r
    real :: start_time, end_time
    integer :: i, i_r, i_x0

    call cpu_time(start_time)
    do i_r = 0, nr_r_vals
        r = i_r*delta_r
        do i_x0 = 0, nr_x_vals
            x0 = i_x0*delta_x
            x = x0
            do i = 1, nr_iters
                x = r*x*(1.0 - x)
            end do
            vals(i_x0, i_r) = x
        end do
    end do
    call cpu_time(end_time)
    write (unit=error_unit, fmt='(A, F15.7)') &
        'time = ', end_time - start_time

    do i_r = 0, nr_r_vals
        r = i_r*delta_r
        do i_x0 = 0, nr_x_vals
            x0 = i_x0*delta_x
            print '(3F12.7)', r, x0, vals(i_x0, i_r)
        end do
    end do

end program logistic_map


program writeSampleBinData_parallel

    ! Created by Manuel A. Diaz, ENSMA 2020

    USE HDF5 ! This module contains all necessary modules

    implicit none

    ! USE MPI ! This module should contains all necessary modules, but ...
    include "mpif.h" ! This module contains all necessary modules.

    ! IMPORTANT NOTE:
    ! Number of processes and size of data in x-direction should be multiples of 2 (1,2,4,8)

    !-------- initialize variables -------------
    character(len=30) :: output_file0 = "fields_d0_it0.bin"
    character(len=30) :: output_file1 = "xp.dat"
    character(len=30) :: output_file2 = "yp.dat"
    character(len=30) :: output_file3 = "zp.dat"
    character(len=10)  :: Nx_char
    character(len=10)  :: Ny_char
    character(len=10)  :: Nz_char

    integer              :: Nx, Ny, Nz       ! Array dimensions
    integer              :: output_file_id=3 ! File identifier
    real(8)              :: Lx, Ly, Lz       ! mesh Lengths
    real(8)              :: dx, dy, dz       ! mesh cell's sizes
    real(8), allocatable :: x(:), y(:), z(:) ! Axis points arrays
    real(8), allocatable :: p(:,:,:)         ! Buffer for array
    integer              :: i, j, k          ! dummy indexes

    ! MPI definitions and calls.
    integer :: info = MPI_INFO_NULL
    integer :: comm = MPI_COMM_WORLD
    integer :: MPIsize, MPIrank, MPIerror
    integer :: new_type, data_type = MPI_REAL8;
    integer (kind = MPI_OFFSET_KIND) :: disp=0
    integer, dimension(3) :: dims  ! dimensions full array
    integer, dimension(3) :: count ! dimensions subarray
    integer, dimension(3) :: start ! start coordinates

    !-------- Parse arguments from command --------
    if ( command_argument_count() .NE. 3 ) then
        print*, "Mode of use: ./sample_binData.run [Nx] [Ny] [Nz]"; stop
    else
        call get_command_argument(1,Nx_char); read(Nx_char,*) Nx
        call get_command_argument(2,Ny_char); read(Ny_char,*) Ny
        call get_command_argument(3,Nz_char); read(Nz_char,*) Nz
        print*, "Attemping to write ",Nx,"Nx",Ny,"Ny",Nz,"Nz array."
    end if

    ! --------------- Initialize MPI ---------------------------
    CALL MPI_INIT(MPIerror)
    CALL MPI_COMM_SIZE(comm, MPIsize, MPIerror)
    CALL MPI_COMM_RANK(comm, MPIrank, MPIerror)

    !-----define file space and local rank memory space --------
    ! Set dimensions filespace
    dims(1) = Nx
    dims(2) = Ny
    dims(3) = Nz
    ! Set dimensions of the memory space in each rank
    count(1) = dims(1)/MPIsize  ! dims(1)          ! dims(1)
    count(2) = dims(2)          ! dims(2)/MPIsize  ! dims(2)
    count(3) = dims(3)          ! dims(3)          ! dims(3)/MPIsize
    ! Define hyperslab starting point
    start(1) = MPIrank*count(1) ! 0                ! 0
    start(2) = 0                ! MPIrank*count(2) ! 0
    start(3) = 0                ! 0                ! MPIrank*count(3)

    !----------- Allocate the rank's memory space  -------------
    if (MPIrank.eq.0) then
        allocate( x(Nx) )
        allocate( y(Ny) )
        allocate( z(Nz) )
    end if
    allocate ( p(count(1),count(2),count(3)) )

    !-------- only root-rank builds the mesh grid axis ---------
    if (MPIrank.eq.0) then
        Lx = 1.0; dx = Lx / (Nx-1)
        Ly = 1.0; dy = Ly / (Ny-1)
        Lz = 1.0; dz = Lz / (Nz-1)
        do i = 1,Nx
            x(i) = dx*real(i-1)
        end do
        do j = 1,Ny
            y(j) = dy*real(j-1)
        end do
        do k = 1,Nz
            z(k) = dz*real(k-1)
        end do
    end if

    !----------------- Initialize data buffer ------------------
    ! use trivial data
    p = 10 + MPIrank

    !--------------- write data buffer to file------------------
    call MPI_FILE_OPEN(MPI_COMM_WORLD, output_file0, MPI_MODE_CREATE + MPI_MODE_RDWR, MPI_INFO_NULL, output_file_id, MPIerror)
    call MPI_BARRIER(MPI_COMM_WORLD, MPIerror)
    call MPI_TYPE_CREATE_SUBARRAY(3, dims, count, start, MPI_ORDER_FORTRAN, data_type, new_type, MPIerror)
    call MPI_TYPE_COMMIT(new_type, MPIerror)
    call MPI_FILE_SET_VIEW(output_file_id, disp, data_type, new_type, 'native', MPI_INFO_NULL, MPIerror)
    call MPI_FILE_WRITE_ALL(output_file_id, p, count(1)*count(2)*count(3), data_type, MPI_STATUS_IGNORE, MPIerror)
    call MPI_TYPE_FREE(new_type, MPIerror)
    call MPI_BARRIER(MPI_COMM_WORLD, MPIerror)
    call MPI_FILE_CLOSE(output_file_id, MPIerror)

    !--------------- only root-rank writes geometry ------------
    if (MPIrank.eq.0) then
        open (output_file_id,file=trim(output_file1), form='formatted', action='write')
        do i = 1, Nx
            write(output_file_id,'(F10.8)') x(i)
        end do
        close(output_file_id)
        open (output_file_id,file=trim(output_file2), form='formatted', action='write')
        do i = 1, Ny
            write(output_file_id,'(F10.8)') y(i)
        end do
        close(output_file_id)
        open (output_file_id,file=trim(output_file3), form='formatted', action='write')
        do i = 1, Nz
            write(output_file_id,'(F10.8)') z(i)
        end do
        close(output_file_id)
    end if

    ! if everything goes well then report that:
    if (MPIrank.eq.0) then
        print*, "outputs: ", output_file0, output_file1, output_file2, output_file3
        deallocate(x)
        deallocate(y)
        deallocate(z)
    end if
    deallocate(p) ! all ranks deallocate

    ! ------------ Finalize MPI -----------------
    CALL MPI_FINALIZE(MPIerror)

    end program writeSampleBinData_parallel


!
! ej8a.f90
!
! Copyright 2016 Bruno S <bruno@oac.unc.edu.ar>
!
! 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.
!
program logimap

use precision, pr => dp

implicit none
integer, parameter      :: N = 500
integer                 :: i, j, k, t
real(pr), dimension(:)  :: xt(4), xt_1(4), x0(4), r(5)
character(len=4)        :: rj

x0 = (/0.06_pr, 0.3_pr, 0.6_pr, 0.9_pr/)
r = (/1.5_pr, 3.3_pr, 3.5_pr, 3.55_pr, 4._pr/)

do j =1, 5
    write(rj, '(F4.2)') r(j)
    print *, 'ej8a_r_'//trim(rj)//'.dat'
    open(unit=10, file='ej8a_r_'//trim(rj)//'.dat', status='UNKNOWN',&
         &action='WRITE')
    write(10, *) "#  t   xt_006   xt_03   xt_06  xt_09  r"

    t = 0
    xt_1 = x0

    do i = 1, N
        xt = r(j) * xt_1 * (1._pr - xt_1)
        write(10, *) t + i, xt(1), xt(2), xt(3), xt(4), r(j)
        xt_1 = xt
    end do

    close(10)
end do

end program logimap


!====================================================================
    MODULE MOD_VARS
!====================================================================
    REAL*8, PARAMETER :: PI = 4*ATAN(1.D0)

    INTEGER*8         :: NPTS  ! NUMBER OF NODE POINTS
    INTEGER*8         :: ISSYM ! FLOW SYMMETRY (Y:1, N:0 - KUTTA AT THETA = 150DEG.)
    REAL*8            :: ALPHA ! FREESTREAM FLOW ANGLE

    REAL*8, DIMENSION(:),  ALLOCATABLE :: NODEX, NODEY, CTRLX, CTRLY ! COORDINATES
    REAL*8, DIMENSION(:),  ALLOCATABLE :: THETA, SGMNT               ! GEOMETRY
    REAL*8, DIMENSION(:),  ALLOCATABLE :: GAMMA, FRVEL               ! VRTX STRENGTH, VEL. BY FREESTREAM
    REAL*8, DIMENSION(:),  ALLOCATABLE :: VLCTY, PCOEF, THWTS        ! VELOCITY, C_P, BL SEP. CRITERION
    REAL*8, DIMENSION(:,:), ALLOCATABLE :: CN1, CN2, AN              ! MATRICES FOR BC (NO NORMAL PENETRATION)

    CONTAINS
!====================================================================
! SUBROUTINES========================================================
!====================================================================
    SUBROUTINE READ
!====================================================================
    IMPLICIT NONE
    CHARACTER*10 :: DUMMY
    INTEGER*8 :: N

    OPEN(10,FILE='input.in')

    READ(10,*) DUMMY
    READ(10,*) NPTS, ALPHA, ISSYM
    READ(10,*) DUMMY

    ALLOCATE(NODEX(NPTS+1))
    ALLOCATE(NODEY(NPTS+1))

    DO N = 1, NPTS
        READ(10,*) NODEX(N), NODEY(N)
    ENDDO

    CLOSE(10)

    RETURN
    END SUBROUTINE READ
!====================================================================
    SUBROUTINE ALLOCATE
!====================================================================
    IMPLICIT NONE

    ALLOCATE(CTRLX(NPTS))
    ALLOCATE(CTRLY(NPTS))
    ALLOCATE(THETA(NPTS))
    ALLOCATE(SGMNT(NPTS))
    ALLOCATE(GAMMA(NPTS+1))
    ALLOCATE(FRVEL(NPTS+1))
    ALLOCATE(VLCTY(NPTS))
    ALLOCATE(PCOEF(NPTS))
    ALLOCATE(THWTS(NPTS))
    ALLOCATE(CN1(NPTS,NPTS))
    ALLOCATE(CN2(NPTS,NPTS))
    ALLOCATE(AN(NPTS+1,NPTS+1))

    RETURN
    END SUBROUTINE ALLOCATE
!====================================================================
    SUBROUTINE KUTTACON
!====================================================================
    IMPLICIT NONE
    REAL*8 :: KT
    REAL*8 :: ANG1, ANG2, GAM
    REAL*8 :: NX(NPTS), NY(NPTS)
    INTEGER*8 :: M, N, NEXT

    NX = NODEX(1:NPTS)
    NY = NODEY(1:NPTS)

    IF (ISSYM .EQ. 0) THEN
        KT = -5./6. * PI
    ELSE
        KT = PI
    ENDIF

    DO N = 1, NPTS
        ANG1 = ATAN2(NODEY(N),NODEX(N)) - KT
        ANG2 = ATAN2(NODEY(N+1),NODEX(N+1)) - KT
        IF (ANG1 * ANG2 .LT. 0.) THEN
            EXIT
        ENDIF
    ENDDO

    NX = CSHIFT(NX, N-1)
    NY = CSHIFT(NY, N-1)

    NODEX(1:NPTS) = NX
    NODEY(1:NPTS) = NY
    NODEX(NPTS+1) = NX(1)
    NODEY(NPTS+1) = NY(1)

    RETURN
    END SUBROUTINE KUTTACON
!====================================================================
    SUBROUTINE CTRLPNTS
!====================================================================
    IMPLICIT NONE
    INTEGER*8 :: N
    REAL*8, DIMENSION(NPTS) :: ANGLE

    DO N = 1, NPTS
        CTRLX(N) = (NODEX(N)+NODEX(N+1))/2.
        CTRLY(N) = (NODEY(N)+NODEY(N+1))/2.
        ANGLE(N) = ATAN2(CTRLY(N),CTRLX(N))*180./PI
    ENDDO

    WRITE(*,*) '***************ANGLE***************'
    WRITE(*,*) ANGLE

    RETURN
    END SUBROUTINE CTRLPNTS
!====================================================================
    SUBROUTINE GEOMETRY
!====================================================================
    IMPLICIT NONE
    INTEGER*8 :: N
    REAL*8    :: DX, DY

    DO N = 1, NPTS
        DX = NODEX(N+1)-NODEX(N)
        DY = NODEY(N+1)-NODEY(N)
        SGMNT(N) = (DX**2.+DY**2.)**.5
        THETA(N) = ATAN2(DY,DX)
    ENDDO

    RETURN
    END SUBROUTINE GEOMETRY
!====================================================================
    SUBROUTINE BCMATRIX
!====================================================================
    IMPLICIT NONE
    INTEGER*8 :: M, N

    CN1 = 0.
    CN2 = 0.

    DO M = 1, NPTS
        DO N = 1, NPTS
            IF (M .EQ. N) THEN
                CN1(M,N) = -1.
                CN2(M,N) = 1.
            ELSE
                CN2(M,N) = D(M,N) + .5*Q(M,N)*F(M,N)/SGMNT(N) &
                           - (A(M,N)*C(M,N) + D(M,N)*E(M,N))*G(M,N)/SGMNT(N)
                CN2(M,N) = NINT(CN2(M,N)*1E6)/1.E6 ! REMOVING FLOATING POINT ERROR
                CN1(M,N) = .5*D(M,N)*F(M,N) + C(M,N)*G(M,N) - CN2(M,N)
                CN1(M,N) = NINT(CN1(M,N)*1E6)/1.E6 ! REMOVING FLOATING POINT ERROR
            ENDIF
        ENDDO
    ENDDO

    DO M = 1, NPTS
        AN(M,1) = CN1(M,1)
        AN(M,NPTS+1) = CN2(M,NPTS)
        DO N = 2, NPTS
            AN(M,N) = CN1(M,N) + CN2(M,N-1)
        ENDDO
        FRVEL(M) = SIN(THETA(M)-ALPHA)
    ENDDO
    AN(NPTS+1,1) = 1.
    AN(NPTS+1,NPTS+1) = 1.
    DO N = 2, NPTS
        AN(NPTS+1, N) = 0.
    ENDDO
    FRVEL(NPTS+1) = 0.

    AN = INV(AN)

    RETURN
    END SUBROUTINE BCMATRIX
!====================================================================
    SUBROUTINE VELOCITY
!====================================================================
    IMPLICIT NONE
    INTEGER*8, PARAMETER :: DIVM = 100
    INTEGER*8 :: M, N, DIV
    REAL*8 :: X, Y, G, VX, VY

    DO M = 1, NPTS
        VX = -COS(ALPHA)
        VY = -SIN(ALPHA)
        DO N = 1, NPTS
            DO DIV = 1, DIVM
                X = (NODEX(N+1)-NODEX(N))/DIVM*(DIV-1) + NODEX(N)
                Y = (NODEY(N+1)-NODEY(N))/DIVM*(DIV-1) + NODEY(N)
                G = (GAMMA(N+1)-GAMMA(N))/DIVM*(DIV-1) + GAMMA(N)

                IF (((CTRLX(M)-X)**2.+(CTRLY(M)-Y)**2.).GT.1.E-32) THEN
                    VX = VX + (G*SGMNT(N)/DIVM)/((CTRLX(M)-X)**2. &
                         +(CTRLY(M)-Y)**2.)*(-(CTRLY(M)-Y))
                    VY = VY + (G*SGMNT(N)/DIVM)/((CTRLX(M)-X)**2. &
                         +(CTRLY(M)-Y)**2.)*(CTRLX(M)-X)
                ENDIF
            ENDDO
        ENDDO
        VX = VX
        VY = VY
        VLCTY(M) = 2.*(VX**2.+VY**2.)**.5
    ENDDO

    WRITE(*,*) '***************VELOCITY***************'
    WRITE(*,*) VLCTY

    RETURN
    END SUBROUTINE VELOCITY
!====================================================================
    SUBROUTINE PRESCOEF
!====================================================================
    IMPLICIT NONE
    INTEGER*8 :: N

    DO N = 1, NPTS
        PCOEF(N) = 1 - VLCTY(N)**2.
    ENDDO

    WRITE(*,*) '***************PCOEF****************'
    WRITE(*,*) PCOEF

    RETURN
    END SUBROUTINE PRESCOEF
!====================================================================
    SUBROUTINE THWAITES
!====================================================================
    IMPLICIT NONE
    REAL*8, DIMENSION(NPTS/2+1) :: S, VU, VL, KU, KL
    REAL*8 :: DVDX, INTD5, SS, SEPANGU, SEPANGL
    INTEGER*8 :: M, N

    SS = ATAN2(NODEY(1),NODEX(1))
    SS = -180.-SS*180./PI

    DO N = 1, NPTS/2+1
        S(N) = .5*(2.*PI/NPTS)*(N-1)
        VU(N) = VLCTY(N)
        VL(N) = VLCTY(NPTS-N+1)
    ENDDO

    KU = 0.
    KL = 0.

    DO N = 2, NPTS/2+1
        DVDX = ((VU(N+1)-VU(N))/(S(N+1)-S(N))+(VU(N)-VU(N-1))/(S(N)-S(N-1)))/2.
        INTD5 = 0.
        DO M = 1, N-1
            INTD5 = INTD5 + (VU(M)**5.+VU(M+1)**5.)/2.*(S(M+1)-S(M))
        ENDDO
        KU(N) = .45/VU(N)**6.*DVDX*INTD5 + .09
        DVDX = ((VL(N+1)-VL(N))/(S(N+1)-S(N))+(VL(N)-VL(N-1))/(S(N)-S(N-1)))/2.
        INTD5 = 0.
        DO M = 1, N-1
            INTD5 = INTD5 + (VL(M)**5.+VL(M+1)**5.)/2.*(S(M+1)-S(M))
        ENDDO
        KL(N) = .45/VL(N)**6.*DVDX*INTD5 + .09
    ENDDO

    WRITE(*,*) '***************KU****************'
    WRITE(*,*) KU

    DO N = 1, NPTS/2 + 1
        IF (KU(N)*KU(N+1).LT.0.) THEN
            SEPANGU = 2.*PI/NPTS*(N-1) + 2.*PI/NPTS*(ABS(KU(N))/(ABS(KU(N)+ABS(KU(N+1)))))
            SEPANGU = SEPANGU*180./PI
            EXIT
        ENDIF
    ENDDO

    DO N = 1, NPTS/2 + 1
        IF (KL(N)*KL(N+1).LT.0.) THEN
            SEPANGL = 2.*PI/NPTS*(N-1) + 2.*PI/NPTS*(ABS(KL(N))/(ABS(KL(N)+ABS(KL(N+1)))))
            SEPANGL = SEPANGL*180./PI
            EXIT
        ENDIF
    ENDDO

    WRITE(*,*) '***************SEPANG (UPPER, LOWER)****************'
    WRITE(*,*) 'STARTING FROM FRONT STAGNATION POINT'
    WRITE(*,*) SEPANGU, SEPANGL
    WRITE(*,*) SS

    RETURN
    END SUBROUTINE THWAITES
!====================================================================
    SUBROUTINE DEALLOCATE
!====================================================================
    IMPLICIT NONE

    DEALLOCATE(CTRLX)
    DEALLOCATE(CTRLY)
    DEALLOCATE(THETA)
    DEALLOCATE(SGMNT)
    DEALLOCATE(GAMMA)
    DEALLOCATE(FRVEL)
    DEALLOCATE(VLCTY)
    DEALLOCATE(PCOEF)
    DEALLOCATE(THWTS)
    DEALLOCATE(CN1)
    DEALLOCATE(CN2)
    DEALLOCATE(AN)

    RETURN
    END SUBROUTINE DEALLOCATE
!====================================================================
      SUBROUTINE PRINT_CURRENT_TIME
!====================================================================
    IMPLICIT NONE
    CHARACTER*8 ::  DATE
    CHARACTER*10::  NOW
    CHARACTER*5 ::  ZONE
    INTEGER*8   ::  VALS(8)

    CALL DATE_AND_TIME(DATE,NOW,ZONE,VALS)

    WRITE(*,101) VALS(1),VALS(2),VALS(3),VALS(5),VALS(6),VALS(7)
    WRITE(*,*) ''
101 FORMAT(' @ 'I0.4,'-',I0.2,'-',I0.2,' ',I0.2,':',I0.2,':',I0.2)

    RETURN
    END SUBROUTINE PRINT_CURRENT_TIME
!=====================================================================
! FUNCTIONS ==========================================================
!=====================================================================
    FUNCTION A(I,J) RESULT(AA)
!=====================================================================
    IMPLICIT NONE
    INTEGER*8, INTENT(IN) :: I, J
    REAL*8 :: AA

    AA = -(CTRLX(I)-NODEX(J))*COS(THETA(J))-(CTRLY(I)-NODEY(J))*SIN(THETA(J))

    END FUNCTION A
!====================================================================
    FUNCTION B(I,J) RESULT(BB)
!====================================================================
    IMPLICIT NONE
    INTEGER*8, INTENT(IN) :: I, J
    REAL*8 :: BB

    BB = (CTRLX(I)-NODEX(J))**2. + (CTRLY(I)-NODEY(J))**2.

    END FUNCTION B
!====================================================================
    FUNCTION C(I,J) RESULT(CC)
!====================================================================
    INTEGER*8, INTENT(IN) :: I, J
    REAL*8 :: CC

    CC = SIN(THETA(I)-THETA(J))

    END FUNCTION C
!====================================================================
!====================================================================
    FUNCTION D(I,J) RESULT(DD)
!====================================================================
    IMPLICIT NONE
    INTEGER*8, INTENT(IN) :: I, J
    REAL*8 :: DD

    DD = COS(THETA(I)-THETA(J))

    END FUNCTION D
!====================================================================
    FUNCTION E(I,J) RESULT(EE)
!====================================================================
    IMPLICIT NONE
    INTEGER*8, INTENT(IN) :: I, J
    REAL*8 :: EE

    EE = (CTRLX(I)-NODEX(J))*SIN(THETA(J))-(CTRLY(I)-NODEY(J))*COS(THETA(J))

    END FUNCTION E
!====================================================================
    FUNCTION F(I,J) RESULT(FF)
!====================================================================
    IMPLICIT NONE
    INTEGER*8, INTENT(IN) :: I, J
    REAL*8 :: FF

    FF = LOG(1.+(SGMNT(J)**2.+2*A(I,J)*SGMNT(J))/B(I,J))

    END FUNCTION F
!====================================================================
    FUNCTION G(I,J) RESULT(GG)
!====================================================================
    IMPLICIT NONE
    INTEGER*8, INTENT(IN) :: I, J
    REAL*8 :: GG

    GG = ATAN2(E(I,J)*SGMNT(J),B(I,J)+A(I,J)*SGMNT(J))

    END FUNCTION G
!====================================================================
    FUNCTION P(I,J) RESULT(PP)
!====================================================================
    IMPLICIT NONE
    INTEGER*8, INTENT(IN) :: I, J
    REAL*8 :: PP

    PP = (CTRLX(I)-NODEX(J))*SIN(THETA(I)-2.*THETA(J)) &
         + (CTRLY(I)-NODEY(J))*COS(THETA(I)-2.*THETA(J))

    END FUNCTION P
!====================================================================
    FUNCTION Q(I,J) RESULT(QQ)
!====================================================================
    IMPLICIT NONE
    INTEGER*8, INTENT(IN) :: I, J
    REAL*8 :: QQ

    QQ = (CTRLX(I)-NODEX(J))*COS(THETA(I)-2.*THETA(J)) &
         - (CTRLY(I)-NODEY(J))*SIN(THETA(I)-2.*THETA(J))

    END FUNCTION Q
!====================================================================
    FUNCTION INV(M) RESULT(MINV)
!====================================================================
    IMPLICIT NONE
    REAL*8, DIMENSION(:,:), INTENT(IN) :: M
    REAL*8, DIMENSION(SIZE(M,1), SIZE(M,2)) :: MINV

    REAL*8, DIMENSION(SIZE(M,1))    :: WK
    INTEGER*8, DIMENSION(SIZE(M,1)) :: IP
    INTEGER*8 :: N, INFO

    EXTERNAL DGETRF ! LAPACK LIB.
    EXTERNAL DGETRI ! LAPACK LIB.

    MINV = M
    N = SIZE(M,1)

    CALL DGETRF(N,N,MINV,N,IP,INFO)

    IF (INFO .NE. 0) THEN
        STOP 'SINGULAR'
    ENDIF

    CALL DGETRI(N,MINV,N,IP,WK,N,INFO)

    IF (INFO .NE. 0) THEN
        STOP 'FAILURE'
    ENDIF

    END FUNCTION INV
!====================================================================
    END MODULE MOD_VARS
!====================================================================

!====================================================================
    PROGRAM PROJECT_TWO
!====================================================================
    USE MOD_VARS
    IMPLICIT NONE
    INTEGER *8 :: I, M, N

    !=== READ NODE COORDINATES & BEGIN ALLOCATION
    CALL READ()
    CALL ALLOCATE()

    !=== REARRANGE POINT ORDER FOR KUTTA CONDITION
    CALL KUTTACON()

    !=== SET VALUES AND MATRICES BASED ON GIVEN NODES
    CALL CTRLPNTS()
    CALL GEOMETRY()
    CALL BCMATRIX()

    !=== ACQUIRE GAMMA USING INVERSE MATRIX MULTIPLICATION
    DO M = 1, NPTS + 1
            GAMMA(M) = 0.
        DO N = 1, NPTS + 1
            GAMMA(M) = GAMMA(M) + AN(M,N) * FRVEL(N)
        ENDDO
    ENDDO

    !=== CALCULATE TANGENTIAL VELOCITY AT EACH CONTROL POINT
    CALL VELOCITY()

    !=== CALCULATE PRESSURE COEFFICIENT ALONG SURFACE
    CALL PRESCOEF()

    !=== CALCULATE SEPARATION POINTS USING THWAITES' METHOD
    CALL THWAITES()

    !=== PRINT ENDTIME OF EXECUTION
    CALL PRINT_CURRENT_TIME()
    CALL DEALLOCATE()

    STOP
    END PROGRAM PROJECT_TWO
!====================================================================


      subroutine phi3(xth,xphi,p1,p2,p3,wt)
c     d^4 p2 d^4 p3 (2 pi)^4 delta(p1-p2-p3)/(2 pi)^6
c     particle (p1) with mass s decaying into p2 and p3 massless.
c     vectors p2 and p3 are returned in the same frame as p1 is supplied.
c result is 1/8/pi * 2|p|/sqrts  * domega/(4*pi)
      implicit none
      double precision p1(4),p2(4),p3(4),p3cm(4)
      double precision xth,xphi,s,roots,costh,sinth,phi,cphi,sphi,pi
      double precision wt0,wt
      integer j
      parameter(pi=3.141592654d0,wt0=1d0/8d0/pi)
      s=p1(4)**2-p1(1)**2-p1(2)**2-p1(3)**2
      roots=dsqrt(s)
      costh=2d0*xth-1d0
      phi=2d0*pi*xphi
      sinth=dsqrt(1d0-costh**2)
      cphi=dcos(phi)
      sphi=dsin(phi)
      wt=wt0

      p3cm(4)=roots/2d0
      p3cm(1)=p3cm(4)*sinth*sphi
      p3cm(2)=p3cm(4)*sinth*cphi
      p3cm(3)=p3cm(4)*costh

      call boost(roots,p1,p3cm,p3)
      do j=1,4
      p2(j)=p1(j)-p3(j)
      enddo

      return
      end