!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!
!!!!   MIT License
!!!!
!!!!   ParaMonte: plain powerful parallel Monte Carlo library.
!!!!
!!!!   Copyright (C) 2012-present, The Computational Data Science Lab
!!!!
!!!!   This file is part of the ParaMonte library.
!!!!
!!!!   Permission is hereby granted, free of charge, to any person obtaining a
!!!!   copy of this software and associated documentation files (the "Software"),
!!!!   to deal in the Software without restriction, including without limitation
!!!!   the rights to use, copy, modify, merge, publish, distribute, sublicense,
!!!!   and/or sell copies of the Software, and to permit persons to whom the
!!!!   Software is furnished to do so, subject to the following conditions:
!!!!
!!!!   The above copyright notice and this permission notice shall be
!!!!   included in all copies or substantial portions of the Software.
!!!!
!!!!   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
!!!!   EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
!!!!   MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
!!!!   IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
!!!!   DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
!!!!   OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE
!!!!   OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
!!!!
!!!!   ACKNOWLEDGMENT
!!!!
!!!!   ParaMonte is an honor-ware and its currency is acknowledgment and citations.
!!!!   As per the ParaMonte library license agreement terms, if you use any parts of
!!!!   this library for any purposes, kindly acknowledge the use of ParaMonte in your
!!!!   work (education/research/industry/development/...) by citing the ParaMonte
!!!!   library as described on this page:
!!!!
!!!!       https://github.com/cdslaborg/paramonte/blob/main/ACKNOWLEDGMENT.md
!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!>  \brief This module contains procedures for sorting arrays.
!>  \author Amir Shahmoradi

module Sort_mod

    implicit none

    character(*), parameter :: MODULE_NAME = "@Sort_mod"

    interface sortArray
        module procedure :: sortArray_RK, sortAscending_RK, sortAscendingWithRooter_RK
    end interface sortArray

    interface sortAscending
        module procedure :: sortAscending_RK, sortAscendingWithRooter_RK
    end interface sortAscending

    interface indexArray
        module procedure :: indexArray_IK, indexArray_RK
    end interface indexArray

    interface getMedian
        module procedure :: getMedian_RK
    end interface getMedian

contains

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    !> \brief
    !> Sort (recursively) the input real array of arbitrary size from the smallest value to the largest and
    !> return the result inside the input array.
    !>
    !> @param[inout] array : The input vector to be sorted.
    !>
    !> \warning
    !> On return, the contents of the input array is completely overwritten.
    pure recursive subroutine sortArray_RK(array)
#if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
        !DEC$ ATTRIBUTES DLLEXPORT :: sortArray_RK
#endif
        use Constants_mod, only: IK, RK
        implicit none
        real(RK), intent(inout) :: array(:)
        integer(IK)             :: iq

        if(size(array) > 1) then
            call partition(array, iq)
            call sortArray_RK(array(:iq-1))
            call sortArray_RK(array(iq:))
        endif
    end subroutine sortArray_RK

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    pure subroutine partition(array, marker)
#if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
        !DEC$ ATTRIBUTES DLLEXPORT :: partition
#endif
        use Constants_mod, only: IK, RK
        implicit none
        real(RK)   , intent(inout) :: array(:)
        integer(IK), intent(out)   :: marker
        integer(IK)                :: i, j
        real(RK)                   :: temp
        real(RK)                   :: x      ! pivot point
        x = array(1)
        i= 0
        j= size(array) + 1
        do
            j = j-1
            do
                if (array(j) <= x) exit
                j = j-1
            end do
            i = i+1
            do
                if (array(i) >= x) exit
                i = i+1
            end do
            if (i < j) then ! exchange array(i) and array(j)
                temp = array(i)
                array(i) = array(j)
                array(j) = temp
            elseif (i == j) then
                marker = i+1
                return
            else
                marker = i
                return
            endif
        end do
  end subroutine partition

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    !> \brief
    !> Sort (recursively) the input real array of arbitrary size from the smallest value to the largest and
    !> return the result inside the input array.
    !>
    !> @param[in]       np      :   The length of the input vector to be sorted.
    !> @param[inout]    Point   :   The input vector to be sorted.
    !> @param[out]      Err     :   An object of class [Err_type](@ref err_mod::err_type).
    !>
    !> \warning
    !> On return, the contents of the input array is completely overwritten by the output sorted array.
    !>
    !> \warning
    !> On return, the value of `Err%occurred` must be checked for any potential occurrences of errors during sorting.
    pure subroutine sortAscending_RK(np,Point,Err)
#if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
        !DEC$ ATTRIBUTES DLLEXPORT :: sortAscending_RK
#endif
        use Constants_mod, only: IK, RK
        use Misc_mod, only: swap
        use Err_mod, only: Err_type

        implicit none

        integer(IK)     , parameter     :: nn = 15, NSTACK = 100
        integer(IK)     , intent(in)    :: np
        real(RK)        , intent(inout) :: Point(np)
        type(Err_type)  , intent(out)   :: Err

        character(*)    , parameter     :: PROCEDURE_NAME = MODULE_NAME//"@sortAscending_RK()"
        real(RK)                        :: dummy
        integer(IK)                     :: k,i,j,jstack,m,r,istack(NSTACK)

        Err%occurred = .false.

        jstack=0
        m = 1
        r = np
        do
            if (r-m < nn) then
                do j = m+1,r
                    dummy = Point(j)
                    do i = j-1,m,-1
                        if (Point(i) <=  dummy) exit
                        Point(i+1) = Point(i)
                    end do
                    Point(i+1) = dummy
                end do
                if (jstack == 0) return
                r = istack(jstack)
                m = istack(jstack-1)
                jstack = jstack-2
            else
                k = (m+r)/2
                call swap(Point(k),Point(m+1))
                if (Point(m)>Point(r)) call swap(Point(m),Point(r))
                if (Point(m+1)>Point(r)) call swap(Point(m+1),Point(r))
                if (Point(m)>Point(m+1)) call swap(Point(m),Point(m+1))
                i = m+1
                j = r
                dummy = Point(m+1)
                do
                    do
                        i = i+1
                        if (Point(i) >= dummy) exit
                    end do
                    do
                        j = j-1
                        if (Point(j) <= dummy) exit
                    end do
                    if (j < i) exit
                    call swap(Point(i),Point(j))
                end do
                Point(m+1) = Point(j)
                Point(j) = dummy
                jstack = jstack+2
                if (jstack > NSTACK) then
                    ! LCOV_EXCL_START
                    Err%occurred = .true.
                    Err%msg = PROCEDURE_NAME//": NSTACK is too small."
                    return
                    ! LCOV_EXCL_STOP
                end if
                if (r-i+1 >= j-m) then
                    istack(jstack) = r
                    istack(jstack-1) = i
                    r = j-1
                else
                    istack(jstack) = j-1
                    istack(jstack-1) = m
                    m = i
                end if
            end if
        end do
    end subroutine sortAscending_RK

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    !> \brief
    !> Given the real `Array(1:n)` return the array `Indx(1:n)` such that `Array(Indx(j)), j=1:n` is in ascending order.
    !>
    !> @param[in]   n       :   The length of the input vector to be sorted.
    !> @param[in]   Array   :   The input vector of length `n` to be sorted.
    !> @param[out]  Indx    :   The output integer vector of indices of the sorted vector.
    !> @param[out]  Err     :   An object of class [Err_type](@ref err_mod::err_type).
    !>
    !> \warning
    !> On return, the value of `Err%%occurred` must be checked for any potential occurrences of errors during sorting.
    pure subroutine indexArray_RK(n,Array,Indx,Err)
#if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
        !DEC$ ATTRIBUTES DLLEXPORT :: indexArray_RK
#endif
        use Constants_mod, only: IK, RK
        use Misc_mod, only: swap
        use Err_mod, only: Err_type

        implicit none

        integer(IK)     , intent(in)    :: n
        real(RK)        , intent(in)    :: Array(n)
        integer(IK)     , intent(out)   :: Indx(n)
        type(Err_type)  , intent(out)   :: Err

        character(*)    , parameter     :: PROCEDURE_NAME = MODULE_NAME//"@indexArray_RK()"
        integer(IK)     , parameter     :: nn=15, NSTACK=50
        integer(IK)                     :: k,i,j,indext,jstack,l,r
        integer(IK)                     :: istack(NSTACK)
        real(RK)                        :: a

        Err%occurred = .false.

        do j = 1,n
            Indx(j) = j
        end do
        jstack=0
        l=1
        r=n
        do
            if (r-l < nn) then
                do j=l+1,r
                    indext=Indx(j)
                    a=Array(indext)
                    do i=j-1,l,-1
                        if (Array(Indx(i)) <= a) exit
                        Indx(i+1)=Indx(i)
                    end do
                    Indx(i+1)=indext
                end do
                if (jstack == 0) return
                r=istack(jstack)
                l=istack(jstack-1)
                jstack=jstack-2
            else
                k=(l+r)/2
                call swap(Indx(k),Indx(l+1))
                call exchangeIndex(Indx(l),Indx(r))
                call exchangeIndex(Indx(l+1),Indx(r))
                call exchangeIndex(Indx(l),Indx(l+1))
                i=l+1
                j=r
                indext=Indx(l+1)
                a=Array(indext)
                do
                    do
                        i=i+1
                        if (Array(Indx(i)) >= a) exit
                    end do
                    do
                        j=j-1
                        if (Array(Indx(j)) <= a) exit
                    end do
                    if (j < i) exit
                    call swap(Indx(i),Indx(j))
                end do
                Indx(l+1)=Indx(j)
                Indx(j)=indext
                jstack=jstack+2
                if (jstack > NSTACK) then
                    ! LCOV_EXCL_START
                    Err%occurred = .true.
                    Err%msg = PROCEDURE_NAME//": NSTACK is too small."
                    return
                    ! LCOV_EXCL_STOP
                end if
                if (r-i+1 >= j-l) then
                    istack(jstack)=r
                    istack(jstack-1)=i
                    r=j-1
                else
                    istack(jstack)=j-1
                    istack(jstack-1)=l
                    l=i
                end if
            end if
        end do
    contains
        pure subroutine exchangeIndex(i,j)
            integer(IK), intent(inout) :: i,j
            integer(IK)                :: swp
            if (Array(j) < Array(i)) then
                swp=i
                i=j
                j=swp
            end if
        end subroutine exchangeIndex
    end subroutine indexArray_RK

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    !> \brief
    !> Given the integer `Array(1:n)` return the array `Indx(1:n)` such that `Array(Indx(j)), j=1:n` is in ascending order.
    !>
    !> @param[in]   n       :   The length of the input vector to be sorted.
    !> @param[in]   Array   :   The input vector of length `n` to be sorted.
    !> @param[out]  Indx    :   The output integer vector of indices of the sorted vector.
    !> @param[out]  Err     :   An object of class [Err_type](@ref err_mod::err_type).
    !>
    !> \warning
    !> On return, the value of `Err%%occurred` must be checked for any potential occurrences of errors during sorting.
    pure subroutine indexArray_IK(n,Array,Indx,Err)
#if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
        !DEC$ ATTRIBUTES DLLEXPORT :: indexArray_IK
#endif
        use Constants_mod, only: IK, RK
        use Misc_mod, only: swap
        use Err_mod, only: Err_type

        implicit none

        integer(IK)     , intent(in)    :: n
        integer(IK)     , intent(in)    :: Array(n)
        integer(IK)     , intent(out)   :: Indx(n)
        type(Err_type)  , intent(out)   :: Err

        character(*)    , parameter     :: PROCEDURE_NAME = MODULE_NAME//"@indexArray_IK()"
        integer(IK)     , parameter     :: nn=15_IK, NSTACK=50_IK
        integer(IK)                     :: k,i,j,indext,jstack,l,r
        integer(IK)                     :: istack(NSTACK)
        integer(IK)                     :: a

        Err%occurred = .false.

        do j = 1,n
            Indx(j) = j
        end do
        jstack=0
        l=1
        r=n
        do
            if (r-l < nn) then
                do j=l+1,r
                    indext=Indx(j)
                    a=Array(indext)
                    do i=j-1,l,-1
                        if (Array(Indx(i)) <= a) exit
                        Indx(i+1)=Indx(i)
                    end do
                    Indx(i+1)=indext
                end do
                if (jstack == 0) return
                r=istack(jstack)
                l=istack(jstack-1)
                jstack=jstack-2
            else
                k=(l+r)/2
                call swap(Indx(k),Indx(l+1))
                call exchangeIndex(Indx(l),Indx(r))
                call exchangeIndex(Indx(l+1),Indx(r))
                call exchangeIndex(Indx(l),Indx(l+1))
                i=l+1
                j=r
                indext=Indx(l+1)
                a=Array(indext)
                do
                    do
                        i=i+1
                        if (Array(Indx(i)) >= a) exit
                    end do
                    do
                        j=j-1
                        if (Array(Indx(j)) <= a) exit
                    end do
                    if (j < i) exit
                    call swap(Indx(i),Indx(j))
                end do
                Indx(l+1)=Indx(j)
                Indx(j)=indext
                jstack=jstack+2
                if (jstack > NSTACK) then
                    ! LCOV_EXCL_START
                    Err%occurred = .true.
                    Err%msg = PROCEDURE_NAME//": NSTACK is too small."
                    return
                    ! LCOV_EXCL_STOP
                end if
                if (r-i+1 >= j-l) then
                    istack(jstack)=r
                    istack(jstack-1)=i
                    r=j-1
                else
                    istack(jstack)=j-1
                    istack(jstack-1)=l
                    l=i
                end if
            end if
        end do
    contains
        pure subroutine exchangeIndex(i,j)
            integer(IK), intent(inout) :: i,j
            integer(IK)                :: swp
            if (Array(j) < Array(i)) then
                swp=i
                i=j
                j=swp
            end if
        end subroutine exchangeIndex
  end subroutine indexArray_IK

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    !> \brief
    !> Sort the real `Leader(1:lenLeader)` in ascending order using Quicksort while making the corresponding rearrangement of real `Rooter(1:lenLeader)`.
    !>
    !> @param[in]       lenLeader   :   The length of the input vector to be sorted.
    !> @param[inout]    Leader      :   The vector of length `lenLeader` to be sorted.
    !> @param[inout]    Rooter      :   The vector of length `lenLeader` to be sorted according to the rearrangement of the elements of `Leader`.
    !> @param[out]      Err         :   An object of class [Err_type](@ref err_mod::err_type).
    !>
    !> \warning
    !> On return, the value of `Err%%occurred` must be checked for any potential occurrences of errors during sorting.
    pure subroutine sortAscendingWithRooter_IK(lenLeader,Leader,Rooter,Err)
#if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
        !DEC$ ATTRIBUTES DLLEXPORT :: sortAscendingWithRooter_IK
#endif
        use Constants_mod, only: IK
        use Err_mod, only: Err_type

        implicit none

        integer(IK)     , intent(in)    :: lenLeader
        integer(IK)     , intent(inout) :: Leader(lenLeader), Rooter(lenLeader)
        type(Err_type)  , intent(out)   :: Err

        character(*)    , parameter     :: PROCEDURE_NAME = MODULE_NAME//"@sortAscendingWithRooter_RK()"
        integer(IK)                     :: Indx(lenLeader)

        call indexArray_IK(lenLeader,Leader,Indx,Err)
        ! LCOV_EXCL_START
        if (Err%occurred) then
            Err%msg = PROCEDURE_NAME//": NSTACK is too small."
            return
        end if
        ! LCOV_EXCL_STOP
        Leader = Leader(Indx)
        Rooter = Rooter(Indx)
    end subroutine sortAscendingWithRooter_IK

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    !> \brief
    !> Sort the real `Leader(1:lenLeader)` in ascending order using Quicksort while making the corresponding rearrangement of real `Rooter(1:lenLeader)`.
    !>
    !> @param[in]       lenLeader   :   The length of the input vector to be sorted.
    !> @param[inout]    Leader      :   The vector of length `lenLeader` to be sorted.
    !> @param[inout]    Rooter      :   The vector of length `lenLeader` to be sorted according to the rearrangement of the elements of `Leader`.
    !> @param[out]      Err         :   An object of class [Err_type](@ref err_mod::err_type).
    !>
    !> \warning
    !> On return, the value of `Err%%occurred` must be checked for any potential occurrences of errors during sorting.
    pure subroutine sortAscendingWithRooter_RK(lenLeader,Leader,Rooter,Err)
#if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
        !DEC$ ATTRIBUTES DLLEXPORT :: sortAscendingWithRooter_RK
#endif
        use Constants_mod, only: IK, RK
        use Err_mod, only: Err_type

        implicit none

        integer(IK)     , intent(in)    :: lenLeader
        real(RK)        , intent(inout) :: Leader(lenLeader), Rooter(lenLeader)
        type(Err_type)  , intent(out)   :: Err

        character(*)    , parameter     :: PROCEDURE_NAME = MODULE_NAME//"@sortAscendingWithRooter_RK()"
        integer(IK)                     :: Indx(lenLeader)

        call indexArray_RK(lenLeader,Leader,Indx,Err)
        ! LCOV_EXCL_START
        if (Err%occurred) then
            Err%msg = PROCEDURE_NAME//": NSTACK is too small."
            return
        end if
        ! LCOV_EXCL_STOP
        Leader = Leader(Indx)
        Rooter = Rooter(Indx)
    end subroutine sortAscendingWithRooter_RK

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    !> \brief
    !> Return the median of the input vector.
    !>
    !> @param[in]       lenArray    :   The length of the input vector.
    !> @param[in]       Array       :   The input vector of length `lenArray` whose median is to be found.
    !> @param[out]      median      :   The median of the input `Array`.
    !> @param[out]      Err         :   An object of class [Err_type](@ref err_mod::err_type).
    !>
    !> \warning
    !> On return, the value of `Err%%occurred` must be checked for any potential occurrences of errors during sorting.
    pure subroutine getMedian_RK(lenArray,Array,median,Err)
#if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
        !DEC$ ATTRIBUTES DLLEXPORT :: getMedian_RK
#endif
        use Constants_mod, only: IK, RK
        use Err_mod, only: Err_type

        implicit none

        integer(IK)     , intent(in)    :: lenArray
        real(RK)        , intent(in)    :: Array(lenArray)
        real(RK)        , intent(out)   :: median
        type(Err_type)  , intent(out)   :: Err

        character(*)    , parameter     :: PROCEDURE_NAME = MODULE_NAME//"@median_RK()"
        real(RK)                        :: ArrayDummy(lenArray)
        integer(IK)                     :: lenArrayHalf

        ArrayDummy = Array
        call sortAscending(np=lenArray,Point=ArrayDummy,Err=Err)
        ! LCOV_EXCL_START
        if (Err%occurred) then
            Err%msg = PROCEDURE_NAME//Err%msg
            return
        end if
        ! LCOV_EXCL_STOP

        lenArrayHalf = lenArray / 2
        median = ArrayDummy(lenArrayHalf+1)
        if (2*lenArrayHalf==lenArray) median = 0.5_RK * ( ArrayDummy(lenArrayHalf) + median )

    end subroutine getMedian_RK

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

end module Sort_mod


! { dg-do run }
  integer :: a(10,10)
  integer :: tot
  a(:,:) = 0
  forall (i = 1:10)
    forall (j = 1:10)
      a(i,j) = 1
    end forall
    forall (k = 1:10)
      a(i,k) = a(i,k) + 1
    end forall
  end forall
  tot = sum(a(:,:))
! print *, tot
  if (tot .ne. 200) STOP 1
end


! Optimization Example
! v1.0 - 2012/02/01 - carlos@tacc.utexas.edu

PROGRAM main
  IMPLICIT NONE
  INTEGER, PARAMETER :: MAX_SIZE = 50000
  INTEGER :: i, k, rate, tStart, tSetup, tStop
  REAL    :: setup, kernel
  REAL    :: x(1:MAX_SIZE)
  REAL    :: y(1:MAX_SIZE)

  setup  = 0.0
  kernel = 0.0
  CALL SYSTEM_CLOCK( COUNT_RATE = rate )
  ! External loop is only used to make things take longer
  ! DO NOT CHANGE THIS EXTERNAL LOOP
  DO k = 1, 1000

    ! Initialize the arrays
    CALL SYSTEM_CLOCK( COUNT = tStart )
    DO i = 1, MAX_SIZE
        x(i) = 2.0*i
    END DO
    CALL SYSTEM_CLOCK( COUNT = tSetup )

    DO i = 1, MAX_SIZE
        y(i) = x(i)
    END DO

    ! KERNEL
    DO i = 2, MAX_SIZE-1
        x(i) = y(i-1)/4 + y(i)/2 + y(i+1)/4;
    END DO

    CALL SYSTEM_CLOCK( COUNT = tStop )

  setup  = setup  + REAL( ( tSetup - tStart ) ) / REAL( rate )
  kernel = kernel + REAL( ( tStop - tSetup ) ) / REAL( rate )
  END DO

  WRITE(*,*)'Two values for validation'
  WRITE(*,*)'========================='
  WRITE(*,*)'X(2) = ',x(2)
  WRITE(*,*)'X(',MAX_SIZE-1,') = ',x(MAX_SIZE-1)
  WRITE(*,*)
  WRITE(*,*)'Execution Times'
  WRITE(*,*)'==============='
  WRITE(*,*)'Setup Time  = ',setup
  WRITE(*,*)'Kernel Time = ',kernel
  WRITE(*,*)

 END PROGRAM


      subroutine cross(a,b,c)
c cross product of vectors
      implicit none
      real*8 a(3),b(3),c(3)
      c(1)=a(2)*b(3)-a(3)*b(2)
      c(2)=a(3)*b(1)-a(1)*b(3)
      c(3)=a(1)*b(2)-a(2)*b(1)
      return
      end


program decl_all
integer(KIND=8) a
integer :: b, c = -10
real(KIND=4) :: d = -99.34
logical :: e = .true.
real(4) :: arr(10,-1:100), f
integer(2), DIMENSION(1:10,-1:100, 9:10) :: g

end program decl_all


      PROGRAM drsdasl7
c>> 2008-10-26 DRSDASL7 Krogh Moved Format statements up for C conv.
c>> 2008-10-24 DRSDASL7 Krogh Removed in INCLUDE statement & cDEC$...
c>> 2008-08-27 DRSDASL7  compute initial y' value, change user codes
c>> 2006-04-26 DRSDASL7, Krogh Dimensioned ATOL and RTOL.
c>> 2006-04-24 DRSDASL7, Krogh Moved count initialization up.
c>> 2002-01-18 DRSDASL7, R. J. Hanson Example Code

c   SDASLX is used to solve an ODE problem, with a banded Jacobian.
c   Two runs with analytic partials are used.  Both forward and
c   reverse communication usage examples are illustrated.

c--S replaces "?": DR?DASL7, ?DASLX, ?DASSF7, ?EDIT2, ?GBFA, ?GBSL
      EXTERNAL sdassf7
      INTEGER ndig
      REAL             tol
c++S Default NDIG = 4
c++  Default NDIG = 8
c++ Substitute for NDIG below
      PARAMETER  (NDIG=4)
      PARAMETER  (tol=10.e0**(-ndig))
      INTEGER neq,liw,lrw,ml,mu,maxord,maxcon
      PARAMETER  (neq=25)
      PARAMETER  (liw=neq+30+2)
c     The work space LRW has the banded matrix size
c     because with INFO(5)=4, the Jacobian matrix is stored in
c      banded form.  (Only MAXCON = 0 is allowed with the band solver.)
      PARAMETER  (ml=5,mu=0,maxord=5,maxcon=0,lrw=45+(maxord+maxcon+4)*
     & neq+(2*ml+mu+1)*neq+2*(neq/(ml+mu+1)+1))
      INTEGER i,idid,info(16),ires,iwork(liw),nerr,nqu,iout,lda,
     & ipvt(neq)
      REAL             atol(1),delta(neq),er,ero,erm,hu,rtol(1),
     & rwork(lrw),t,tout,y(neq),yprime(neq)

  120 FORMAT (' Demo Program for SDASLX',///1x,' Problem 7: y'' = A * y
     &, where',' A is a banded lower triangular matrix',/1x,' NEQ =',i3,
     &'   ML =',i2,'   MU =',i2,'( size, bandwidths)'/1x,' RTOL =',1p,
     & d10.1,'   ATOL =',d10.1,'( rel, abs tolerance)')
  130 FORMAT (1x,1p,d15.5,d14.3,i6,d14.3)
  140 FORMAT (/6x,'Example Results for an Index-0 Banded ODE Problem,','
     & Soln in Forward Comm',//9x,'T',11x,'Max Err',3x,
     & 'BDF Order Last Step=H')
  150 FORMAT (/6x,'Example Results for an Index-0 Banded ODE Problem,','
     & Soln in Reverse Comm',//9x,'T',11x,'Max Err',3x,
     & 'BDF Order Last Step=H')
c
c A constant coefficient, banded matrix:
c
      DO 10 i=1,16
        info(i)=0
   10 CONTINUE

c Banded matrix with user providing derivatives.
      info(5)=4
      iwork(1)=ml
      iwork(2)=mu
      lda=2*ml+mu+1

c     Tolerance:
      atol(1)=tol
      rtol(1)=0.e0
      WRITE (*,120) neq,ml,mu,rtol(1),atol(1)
      t=0.0e0
      DO 20 i=1,neq
        y(i)=0.0e0
        delta(i)=0.0e0
   20 CONTINUE
      y(1)=1.0e0
c     These are function and Jacobian evaluation counters.
      iwork(liw-1)=0
      iwork(liw)=0

c  The first call initializes internal data values, and the second
c  call gives a consistent value of YPRIME.  Note the reversed
c  positions of DELTA, YPRIME.  This usage computes a consistent value
c  of YPRIME in the case of Index 0 systems.
      DO 30 i=0,1
        ires=i
        CALL sdassf7 (t, y, delta, yprime, rwork, lda, rwork(1), ires,
     &   rwork, iwork)

   30 CONTINUE

      tout=0.01e0
      ero=0.0e0
      nerr=0
      WRITE (*,140)
c     This shows passing data from evaluation routine ?DASF = ?DASF7
c      to the calling program.
      DO 40 iout=1,6
        CALL sdaslx (sdassf7, neq, t, y, yprime, tout, info, rtol, atol,
     &    idid, rwork, lrw, iwork, liw)
        CALL sedit2 (y, t, erm)
        hu=rwork(7)
        nqu=iwork(8)
        WRITE (*,130) t,erm,nqu,hu
c
        IF (idid.lt.0) GO TO 50
        er=erm/atol(1)
        ero=max(ero,er)
        IF (er.gt.1.0e0) THEN
          nerr=nerr+1
        END IF
c Advance to the next output point.
        tout=tout*10.0e0
   40 CONTINUE
   50 CONTINUE

c Start over but solve banded linear system in reverse communication mod
      t=0.0e0
      DO 60 i=1,neq
        y(i)=0.0e0
        delta(i)=0.0e0
   60 CONTINUE
      y(1)=1.0e0

c  The first call initializes internal data values, and the second
c  call gives a consistent value of YPRIME. Note the reversed
c  positions of DELTA, YPRIME.  This computes a consistent value
c  of YPRIME in the case of Index 0 systems.
      DO 70 i=0,1
        ires=i
        CALL sdassf7 (t, y, delta, yprime, rwork, lda, rwork(1), ires,
     &   rwork, iwork)
   70 CONTINUE

      tout=0.01e0
      ero=0.0e0
      nerr=0
      info(1)=0

      WRITE (*,150)
      iwork(liw-1)=0
      iwork(liw)=0
c All work done using reverse communication:
      info(5)=-14
      DO 100 iout=1,6

   80   CALL sdaslx (sdassf7, neq, t, y, yprime, tout, info, rtol, atol,
     &    idid, rwork, lrw, iwork, liw)
c     When IDID == 4 the code returned for reverse communication.
c     Otherwise the integration has finished up to this output point.
        IF (idid.ne.4) GO TO 90
        ires=iwork(3)
c Evaluate residuals or partials:
        IF (ires.le.2) THEN
          CALL sdassf7 (t, y, yprime, rwork(iwork(4)), rwork(iwork(5)),
     &     lda, rwork(1), ires, rwork, iwork)

        END IF
c Factor the banded matrix:
        IF (ires.eq.3) THEN
c The matrix is contained in the RWORK array.
c With this request, IWORK(5) points to the matrix, and IWORK(3) == IRES
c Note that IWORK(3) gets the error code (==0 means non-singular matrix)
          CALL sgbfa (rwork(iwork(5)), lda, neq, ml, mu, ipvt, iwork(3))
        END IF

c Solve with the banded matrix:
        IF (ires.eq.4) THEN
c The right-hand side is contained in the RWORK array.
c With this request, IWORK(4) points to the right-hand side.
          CALL sgbsl (rwork(iwork(5)), lda, neq, ml, mu, ipvt,
     &     rwork(iwork(4)), 0)
        END IF
        GO TO 80
   90   CONTINUE
        CALL sedit2 (y, t, erm)
        hu=rwork(7)
        nqu=iwork(8)
        WRITE (*,130) t,erm,nqu,hu
c
        IF (idid.lt.0) GO TO 110
        er=erm/atol(1)
        ero=max(ero,er)
        IF (er.gt.1.0e0) THEN
          nerr=nerr+1
        END IF
c Advance to the next output point.
        tout=tout*10.0e0
  100 CONTINUE
  110 CONTINUE
      END

      SUBROUTINE sdassf7 (t, y, yprime, delta, pd, ldp, cj, ires, rwork,
     & iwork)
c
c     Example from SLATEC distribution.
c     This exercises the banded matrix solver.
      REAL             t,y(*),yprime(*),delta(*),pd(ldp,*),cj,rwork(*)
      INTEGER ires,iwork(*),i,j,k,mband,ng,ldp,ml,mu
      REAL             alph1,alph2,d
      INTEGER neq,liw
      PARAMETER  (neq=25)
c     The last two value of IWORK() pass evaluation counters
c     back to the main program.
      PARAMETER  (liw=neq+30+2)

      SAVE  alph1,alph2,ng,ml,mu
c This is the setup call.
      IF (ires.eq.0) THEN
        alph1=1.0e0
        alph2=1.0e0
        ng=5
        ml=5
        mu=0
      END IF

c The system residual value.
      IF (ires.eq.1) THEN
        DO 20 j=1,ng
          DO 10 i=1,ng
            k=i+(j-1)*ng
            d=-2.0e0*y(k)
            IF (i.ne.1) d=d+y(k-1)*alph1
            IF (j.ne.1) d=d+y(k-ng)*alph2
            delta(k)=d-yprime(k)
   10     CONTINUE
   20   CONTINUE
c Count residual evaluations using end of integer work array.
        iwork(liw-1)=iwork(liw-1)+1
      END IF

c The partial derivative matrix.
      IF (ires.eq.2) THEN
        mband=ml+mu+1
        DO 30 j=1,neq
          pd(mband,j)=-2.0e0-cj
          pd(mband+1,j)=alph1
          pd(mband+2,j)=0.0e0
          pd(mband+3,j)=0.0e0
          pd(mband+4,j)=0.0e0
          pd(mband+5,j)=alph2
   30   CONTINUE
        DO 40 j=1,neq,ng
          pd(mband+1,j)=0.0e0
   40   CONTINUE
c Count partial evaluations using end of integer work array.
        iwork(liw)=iwork(liw)+1

      END IF

      END

      SUBROUTINE sedit2 (y, t, erm)
c***BEGIN PROLOGUE  SEDIT2
c***SUBSIDIARY
c***LIBRARY   SLATEC (DASSL)
c***TYPE      DOUBLE PRECISION (EDIT2-S, SEDIT2-D)
c***AUTHOR  PETZOLD, LINDA R., (LLNL)
c***ROUTINES CALLED  (NONE)
c***END PROLOGUE  SEDIT2
      REAL             y(*),t,erm
      INTEGER i,j,k,ng
      REAL             alph1,alph2,a1,a2,big,er,ex,ri,rj,yt
      REAL             r1mach
      DATA alph1/1.0e0/,alph2/1.0e0/,ng/5/
      EXTERNAL r1mach
c***FIRST EXECUTABLE STATEMENT  SEDIT2
      erm=0.0e0
      IF (t.eq.0.0e0) RETURN
      ex=0.0e0
      big=.5e0*log(r1mach(2))

c Compute matrix exponential * initial data vector,
c for this particular lower triangular matrix.

      IF (t.lt.big) ex=exp(-2.0e0*t)
      a2=1.0e0
      DO 20 j=1,ng
        a1=1.0e0
        DO 10 i=1,ng
          k=i+(j-1)*ng
          yt=t**(i+j-2)*ex*a1*a2
          er=abs(y(k)-yt)
          erm=max(erm,er)
          ri=i
          a1=a1*alph1/ri
   10   CONTINUE
        rj=j
        a2=a2*alph2/rj
   20 CONTINUE
      RETURN
      END


!
! Copyright (C) by Argonne National Laboratory
!     See COPYRIGHT in top-level directory
!

! This file created from test/mpi/f77/coll/exscanf.f with f77tof90

      subroutine uop( cin, cout, count, datatype )
      use mpi_f08
      integer cin(*), cout(*)
      integer count
      TYPE(MPI_Datatype) datatype
      integer i

      if (datatype .ne. MPI_INTEGER) then
         write(6,*) 'Invalid datatype passed to user_op()'
         return
      endif

      do i=1, count
         cout(i) = cin(i) + cout(i)
      enddo
      end
!
      program main
      use mpi_f08
      integer inbuf(2), outbuf(2)
      integer ans, rank, size
      TYPE(MPI_Comm) comm
      integer errs, ierr
      TYPE(MPI_Op) sumop
      external uop

      errs = 0

      call mtest_init( ierr )
!
! A simple test of exscan
      comm = MPI_COMM_WORLD

      call mpi_comm_rank( comm, rank, ierr )
      call mpi_comm_size( comm, size, ierr )

      inbuf(1) = rank
      inbuf(2) = -rank
      call mpi_exscan( inbuf, outbuf, 2, MPI_INTEGER, MPI_SUM, comm,  &
      &                 ierr )
! this process has the sum of i from 0 to rank-1, which is
! (rank)(rank-1)/2 and -i
      ans = (rank * (rank - 1))/2
      if (rank .gt. 0) then
         if (outbuf(1) .ne. ans) then
            errs = errs + 1
            print *, rank, ' Expected ', ans, ' got ', outbuf(1)
         endif
         if (outbuf(2) .ne. -ans) then
            errs = errs + 1
            print *, rank, ' Expected ', -ans, ' got ', outbuf(1)
         endif
      endif
!
! Try a user-defined operation
!
      call mpi_op_create( uop, .true., sumop, ierr )
      inbuf(1) = rank
      inbuf(2) = -rank
      call mpi_exscan( inbuf, outbuf, 2, MPI_INTEGER, sumop, comm,  &
      &                 ierr )
! this process has the sum of i from 0 to rank-1, which is
! (rank)(rank-1)/2 and -i
      ans = (rank * (rank - 1))/2
      if (rank .gt. 0) then
         if (outbuf(1) .ne. ans) then
            errs = errs + 1
            print *, rank, ' sumop: Expected ', ans, ' got ', outbuf(1)
         endif
         if (outbuf(2) .ne. -ans) then
            errs = errs + 1
            print *, rank, ' sumop: Expected ', -ans, ' got ', outbuf(1)
         endif
      endif
      call mpi_op_free( sumop, ierr )

!
! Try a user-defined operation (and don't claim it is commutative)
!
      call mpi_op_create( uop, .false., sumop, ierr )
      inbuf(1) = rank
      inbuf(2) = -rank
      call mpi_exscan( inbuf, outbuf, 2, MPI_INTEGER, sumop, comm,  &
      &                 ierr )
! this process has the sum of i from 0 to rank-1, which is
! (rank)(rank-1)/2 and -i
      ans = (rank * (rank - 1))/2
      if (rank .gt. 0) then
         if (outbuf(1) .ne. ans) then
            errs = errs + 1
            print *, rank, ' sumop2: Expected ', ans, ' got ', outbuf(1)
         endif
         if (outbuf(2) .ne. -ans) then
            errs = errs + 1
            print *, rank, ' sumop2: Expected ', -ans, ' got ',outbuf(1)
         endif
      endif
      call mpi_op_free( sumop, ierr )

      call mtest_finalize( errs )
      end


      FUNCTION BETACF(A,B,X)
      PARAMETER (ITMAX=100,EPS=3.E-7)
      AM=1.
      BM=1.
      AZ=1.
      QAB=A+B
      QAP=A+1.
      QAM=A-1.
      BZ=1.-QAB*X/QAP
      DO 11 M=1,ITMAX
        EM=M
        TEM=EM+EM
        D=EM*(B-M)*X/((QAM+TEM)*(A+TEM))
        AP=AZ+D*AM
        BP=BZ+D*BM
        D=-(A+EM)*(QAB+EM)*X/((A+TEM)*(QAP+TEM))
        APP=AP+D*AZ
        BPP=BP+D*BZ
        AOLD=AZ
        AM=AP/BPP
        BM=BP/BPP
        AZ=APP/BPP
        BZ=1.
        IF(ABS(AZ-AOLD).LT.EPS*ABS(AZ))GO TO 1
11    CONTINUE
      PAUSE 'A or B too big, or ITMAX too small'
1     BETACF=AZ
      RETURN
      END