!  Copyright (C) 2015-2019 Richard Weed.
!  All rights reserved.
  
!  Redistribution and use in source and binary forms, with or without 
!  modification, are permitted provided that the following conditions are met:
  
!  1. Redistributions of source code, in whole or in part, must retain the  
!  above copyright notice, this list of conditions and the following 
!  disclaimer.
  
!  2. Redistributions in binary form, in whole or in part, must reproduce the 
!  above copyright notice, this list of conditions and the following disclaimer 
!  in the documentation and/or other materials provided with the distribution.
  
!  3. The names of the contributors may not be used to endorse or promote from 
!  products derived from this software without specific prior written 
!  permission.

!  4. Redistributions of this software, in whole or in part, in any form, 
!  must be freely available and licensed under this original License. The 
!  U.S. Government may add additional restrictions to their modified and 
!  redistributed software as required by Law. However, these restrictions 
!  do not apply to the original software distribution.
 
!  5. Redistribution of this source code, including any modifications, may 
!  not be intentionally obfuscated.
  
!  6. Other code may make use of this software, in whole or in part, without 
!  restriction, provided that it does not apply any restriction to this 
!  software other than outlined above.
  
!  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
!  IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
!  THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!  PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS AND
!  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 
!  EXEMPLARARY OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 
!  PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; 
!  OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 
!  WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR 
!  OTHERWISE), ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
!  ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Program testqsort

  Use ISO_FORTRAN_ENV, ONLY: INT32, REAL32, REAL64 
  Use quicksort,       ONLY: qsort, ASCENDING, DESCENDING
  Use point,           ONLY: point_et

  Implicit NONE

  Type(point_et)    :: points(4)
  Real(REAL32)      :: a(21), at(21)
  Real(REAL64)      :: a64(21)
  Integer           :: permute(21), ia(21)
  Integer           :: permute4(4)
  Character(LEN=21) :: astring
  Character(LEN=1)  :: ac(21)

  Integer :: i, j

  Do i = 1,21
   a(i) = REAL(i,REAL32)
   ia(i) = 21-i
  EndDo

  a64(1) = 1.0_REAL64
  Do i=2,21
   a64(i) = REAL(i,REAL64)*a64(i-1)
  EndDo

  astring="aBcDefGhIJKlmnOPRSt@!"
  Do i=1,21
    ac(i) = astring(i:i)
  EndDo

  Print *,' original Real32 array a'
  Print *,''

  Call printarray(a,1,21)

  Do i=1,6
    Call Swap(a,21,i, 21-i)
  EndDo

  Do i=1, 6
    Call Swap(a64,21, i, 21-1)
  EndDo

  Print *,''
  Print *,' *** Real32 array a after swap ***'
  Print *,''

  Call printarray(a,1, 21)

  Print *,''
  Print *,' ***** testing qsort REAL32 array with permutation array'
  Print *,''

  Call qsort(a, 1, 21, PERMUTE=permute)

  Do i=1,21
    at(i) = a(permute(i))
  EndDo
  Print *,' *** array at after applying permutation matrix ***'
  Print *,''

  Call printarray(at,1,21)

  Print *,''
  Print *,' ***** testing qsort REAL32 array in place *****'

  Call qsort(a, 1, 21)

  Print *,''
  Print *,' *** REAL32 array a after sorting in place ***'
  Print *,''
  Call printarray(a,1, 21)

  Print *,''
  Print *,' ***** testing qsort in place with an integer array *****'
  Print *,''
  Call printarray(ia, 1, 21)


  Call qsort(ia, 1, 21)

  Print *,''
  Print *,' *** Integer array ia after sorting in place *** '
  Print *,''
  Call printarray(ia,1,21)
 
  Print *,''
  Print *,' ***** testing qsort with an Real64 array into decending order *****'
  Print *,''
  Print *,' *** original array after swap ***'
  Call printarray(a64,1,21)

  Call qsort(a64,1,21, ORDER=DESCENDING)

  Print *,''
  Print *,' *** sorted array after sorting in place in decending order ***'
  Call printarray(a64,1,21)

  Print *,''
  Print *,' ***** testing in place qsort with an array of characters *****'
  Print *,''
  Do i=1,21
    Write(*,"(' *** original array ac(',i2,') = ', a1)") i, ac(i)
  EndDo

  Call qsort(ac, 1, 21)

  Print *,''
  Do i=1,21
    Write(*,"(' *** sorted array ac(',i2,') = ', a1)") i, ac(i)
  EndDo
  Print *,''
  Print *,' ***** testing in place with string *****'
  Print *,''
  Print *,' *** original string *** '
  Print *,''
  Print *,' string = ', astring(1:21)
  Print *,''
 
  Call qsort(astring, order=DESCENDING)

  Print *,' *** sorted string (decending order) = ', astring(1:21)
  Print *,''
 

  Print *,' ***** test sort in place of point type on distance *****'
  Print *,''

  points(1) = point_et(-100., 2., 20.)
  points(2) = point_et(1000., -1., 0.5)
  points(3) = point_et(-.1, 0.01, 0.001)
  points(4) = point_et(1., 2., 3.)

  Print *,' *** initial user values and distance ***'
  Print *,''
  Do i=1,4
    Print *,' index = ', i
    Call points(i)%printValue()
  EndDo 

  Call qsort(points)

  Print *,' *** sorted point values and distance ***'
  Print *,''
  Do i=1,4
    Print *,' index = ', i
    Call points(i)%printValue()
  EndDo 
 
  Print *,' ***** test sort by index of point type on distance in Desending order *****'
  Print *,''

  points(1) = point_et(-100., 2., 20.)
  points(2) = point_et(1000., -1., 0.5)
  points(3) = point_et(-.1, 0.01, 0.001)
  points(4) = point_et(1., 2., 3.)

  Print *,''
  Print *,' *** initial point values and distance ***'
  Do i=1,4
    Print *,' index = ', i
    Call points(i)%printValue()
  EndDo
 
  Call qsort(points, PERMUTE=permute4, ORDER=DESCENDING)

  Print *,''
  Print *,' *** sorted user values and norm for index sort in desending order ***'
  Print *,''
  Do j=1,4
    i = permute4(j) 
    Print *,' j = ', j, ' index(j) = ', i
    Call points(i)%printValue()
  EndDo 

Contains

Subroutine printarray(a, left, right )

  Implicit NONE

  Integer,  Intent(IN) :: left, right 
  Class(*), Intent(IN) :: a(left:right)

  Integer  :: i
  Do i=left,right
    Select Type(v=>a(i))

      Type is(REAL(REAL32))
        Print *,' a(i) = ', v
     Type is(REAL(REAL64))
        Print *,' a64(i) = ', v
     Type is (Integer)
        Print *,' ia(i) = ', v
    End Select

 End Do

End Subroutine printarray

Subroutine swap(a,n, i,j)

  Implicit NONE

  Integer(INT32), Intent(IN)    :: n, i,j
  Class(*),       Intent(INOUT) :: a(n)

  Real(REAL32) :: t32
  Real(REAL64) :: t64

  Select Type(v=>a(i))

   Type is (REAL(REAL32))
     t32 = v
     Select Type(w=>a(j))
       Type is (REAL(REAL32))
        v = w 
        w = t32
     End Select
   Type is (REAL(REAL64))
     t64 = v
     Select Type(w=>a(j))
       Type is (REAL(REAL64))
        v = w 
        w = t64
     End Select
  End Select 

 End Subroutine swap 

End Program testqsort