Fortran_Modules/mod_Sorting.f90 at master · Onturenio/Fortran_Modules · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Short Documentation:
!
! This module provies the 'Sort' subroutine
!
! Sort(real matrix, integer indices, optional logical reverse?)
!
! JJ 2016
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

module Sorting
  save
  private
  public :: Sort
contains

  subroutine Sort(arr, indx, reverse)
    integer, dimension(:), intent(out) :: indx
    real, dimension(:), intent(in) :: arr
    logical, optional :: reverse

    integer :: n

    if(size(arr)/=size(indx))then
      stop 'array size missmatch in ''sort'' subroutine'
    endif

    n=size(arr)

    call indexx(n, arr, indx)

    if(present(reverse).and.reverse) indx=indx(n:1:-1)
  end subroutine

  subroutine indexx(n,arr,indx)
    !
    integer n,indx(n),m,nstack
    real  arr(n)
    parameter (m=7,nstack=50)
    integer i,indxt,ir,itemp,j,jstack,k,l,istack(nstack)
    real a
    !
    do j=1,nstack
    istack(j)=0
    enddo
    !
    do j=1,n
    indx(j)=j
    enddo
    jstack=0
    l=1
    ir=n
    1 if(ir-l.lt.m) then
      do j=l+1,ir
      indxt=indx(j)
      a=arr(indxt)
      do i=j-1,1,-1
      if(arr(indx(i)).le.a) goto 2
      indx(i+1)=indx(i)
      enddo
      i=0
      2     indx(i+1)=indxt
      enddo
      if (jstack.eq.0) return
      ir=istack(jstack)
      l=istack(jstack-1)
      jstack=jstack-2
    else
      k=(l+ir)/2
      itemp=indx(k)
      indx(k)=indx(l+1)
      indx(l+1)=itemp
      if(arr(indx(l+1)).gt.arr(indx(ir))) then
        itemp=indx(l+1)
        indx(l+1)=indx(ir)
        indx(ir)=itemp
      endif
      if(arr(indx(l)).gt.arr(indx(ir))) then
        itemp=indx(l)
        indx(l)=indx(ir)
        indx(ir)=itemp
      endif
      if(arr(indx(l+1)).gt.arr(indx(l))) then
        itemp=indx(l+1)
        indx(l+1)=indx(l)
        indx(l)=itemp
      endif
      i=l+1
      j=ir
      indxt=indx(l)
      a=arr(indxt)
      3   continue
      i=i+1
      if(arr(indx(i)).lt.a) goto 3
      4   continue
      j=j-1
      if(arr(indx(j)).gt.a) goto 4
      if(j.lt.i) goto 5
      itemp=indx(i)
      indx(i)=indx(j)
      indx(j)=itemp
      goto 3
      5   indx(l)=indx(j)
      indx(j)=indxt
      jstack=jstack+2
      if(jstack.gt.nstack) then
        print *,'*** nstack too small in indexx ***'
        stop
      endif
      if(ir-i+1.ge.j-l) then
        istack(jstack)=ir
        istack(jstack-1)=i
        ir=j-1
      else
        istack(jstack)=j-1
        istack(jstack-1)=l
        l=i
      endif
    endif
    goto 1
    !
  end subroutine
end module Sorting