1! This file is part of xtb. 2! 3! Copyright (C) 2017-2020 Stefan Grimme 4! 5! xtb is free software: you can redistribute it and/or modify it under 6! the terms of the GNU Lesser General Public License as published by 7! the Free Software Foundation, either version 3 of the License, or 8! (at your option) any later version. 9! 10! xtb is distributed in the hope that it will be useful, 11! but WITHOUT ANY WARRANTY; without even the implied warranty of 12! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13! GNU Lesser General Public License for more details. 14! 15! You should have received a copy of the GNU Lesser General Public License 16! along with xtb. If not, see <https://www.gnu.org/licenses/>. 17 18recursive subroutine qsort(a, first, last, ind) 19 use xtb_mctc_accuracy, only : wp 20 implicit none 21 real(wp) :: a(*), x, t 22 integer :: ind(*) 23 integer :: first, last 24 integer :: i, j, ii 25 26 x = a( (first+last) / 2 ) 27 i = first 28 j = last 29 do 30 do while (a(i) < x) 31 i=i+1 32 end do 33 do while (x < a(j)) 34 j=j-1 35 end do 36 if (i >= j) exit 37 t = a(i); a(i) = a(j); a(j) = t 38 ii=ind(i); ind(i) = ind(j); ind(j) = ii 39 i=i+1 40 j=j-1 41 end do 42 if (first < i-1) call qsort(a, first, i-1, ind) 43 if (j+1 < last) call qsort(a, j+1, last, ind) 44end subroutine qsort 45 46recursive subroutine qqsort(a, first, last) 47 use xtb_mctc_accuracy, only : wp 48 implicit none 49 real(wp) :: a(*), x, t 50 integer :: first, last 51 integer :: i, j, ii 52 53 x = a( (first+last) / 2 ) 54 i = first 55 j = last 56 do 57 do while (a(i) < x) 58 i=i+1 59 end do 60 do while (x < a(j)) 61 j=j-1 62 end do 63 if (i >= j) exit 64 t = a(i); a(i) = a(j); a(j) = t 65 i=i+1 66 j=j-1 67 end do 68 if (first < i-1) call qqsort(a, first, i-1) 69 if (j+1 < last) call qqsort(a, j+1, last) 70end subroutine qqsort 71