Line data Source code
1 :
2 :
3 : module mod_qsort
4 :
5 : use const_def, only: dp
6 :
7 : implicit none
8 :
9 : contains
10 :
11 : ! FILE: sort.f
12 : ! PURPOSE: demonstrate the use of "qsort_inline.inc" and
13 : ! "qsort_inline_index.inc". These can be used as specific
14 : ! sort procedures under a common SORT generic name.
15 : !---------------------------------------------------------------
16 : ! Sort a string array, with any string length.
17 0 : subroutine sortp_string(array_size,index,string)
18 : integer, intent(in) :: array_size
19 : integer, intent(out) :: index(:) ! (array_size)
20 : character(len=*), intent(in) :: string(:) ! (array_size)
21 : #include "qsort_inline.inc"
22 : contains
23 : ! set up initial index:
24 0 : subroutine init()
25 : integer :: i
26 0 : do i=1,array_size
27 0 : index(i)=i
28 : end do
29 0 : end subroutine init
30 :
31 : ! swap indices a,b
32 0 : subroutine swap(a,b)
33 : integer, intent(in) :: a,b
34 : integer :: hold
35 0 : hold=index(a)
36 0 : index(a)=index(b)
37 0 : index(b)=hold
38 0 : end subroutine swap
39 :
40 : ! circular shift-right by one:
41 0 : subroutine rshift(left,right)
42 : integer, intent(in) :: left, right
43 : integer :: hold, i
44 0 : hold=index(right)
45 : ! This syntax is valid, but has poor optimization in GFortran:
46 : ! index(left+1:right)=index(left:right-1)
47 0 : do i=right,left+1,-1
48 0 : index(i)=index(i-1)
49 : end do
50 0 : index(left)=hold
51 0 : end subroutine rshift
52 :
53 : logical &
54 0 : function less_than(a,b)
55 : integer, intent(in) :: a,b
56 0 : if ( string(index(a)) == string(index(b)) ) then
57 0 : less_than = ( index(a) < index(b) )
58 : else
59 0 : less_than = ( string(index(a)) < string(index(b)) )
60 : end if
61 0 : end function less_than
62 :
63 : end subroutine sortp_string
64 : !---------------------------------------------------------------
65 : ! Sort an array of indices into a string array, with any string length.
66 19 : subroutine sortp_string_index(array_size,index,str_index,string)
67 : integer, intent(in) :: array_size
68 : integer, intent(out) :: index(:) ! (array_size)
69 : integer, intent(in) :: str_index(:) ! (array_size)
70 : character(len=*), intent(in) :: string(:) ! 1..maxval(str_index)
71 : #include "qsort_inline.inc"
72 : contains
73 : ! set up initial index:
74 19 : subroutine init()
75 : integer :: i
76 1330 : do i=1,array_size
77 1330 : index(i)=i
78 : end do
79 19 : end subroutine init
80 :
81 : ! swap indices a,b
82 1047 : subroutine swap(a,b)
83 : integer, intent(in) :: a,b
84 : integer :: hold
85 1047 : hold=index(a)
86 1047 : index(a)=index(b)
87 1047 : index(b)=hold
88 1047 : end subroutine swap
89 :
90 : ! circular shift-right by one:
91 721 : subroutine rshift(left,right)
92 : integer, intent(in) :: left, right
93 : integer :: hold, i
94 721 : hold=index(right)
95 : ! This syntax is valid, but has poor optimization in GFortran:
96 : ! index(left+1:right)=index(left:right-1)
97 2820 : do i=right,left+1,-1
98 2820 : index(i)=index(i-1)
99 : end do
100 721 : index(left)=hold
101 721 : end subroutine rshift
102 :
103 : logical &
104 8778 : function less_than(a,b)
105 : integer, intent(in) :: a,b
106 8778 : if ( string(str_index(index(a))) == string(str_index(index(b))) ) then
107 219 : less_than = ( str_index(index(a)) < str_index(index(b)) )
108 : else
109 8559 : less_than = ( string(str_index(index(a))) < string(str_index(index(b))) )
110 : end if
111 8778 : end function less_than
112 :
113 : end subroutine sortp_string_index
114 : !---------------------------------------------------------------
115 : ! Sort a double-precision array by index
116 3 : subroutine sortp_dp(array_size,index,value)
117 : integer, intent(in) :: array_size
118 : integer, intent(inout) :: index(:) ! (array_size)
119 : real(dp), intent(in) :: value(:) ! (array_size)
120 : #include "qsort_inline.inc"
121 : contains
122 : ! set up initial index:
123 3 : subroutine init()
124 : integer :: i
125 145 : do i=1,array_size
126 145 : index(i)=i
127 : end do
128 3 : end subroutine init
129 :
130 : ! swap indices a,b
131 144 : subroutine swap(a,b)
132 : integer, intent(in) :: a,b
133 : integer :: hold
134 144 : hold=index(a)
135 144 : index(a)=index(b)
136 144 : index(b)=hold
137 144 : end subroutine swap
138 :
139 : ! circular shift-right by one:
140 75 : subroutine rshift(left,right)
141 : integer, intent(in) :: left, right
142 : integer :: hold, i
143 75 : hold=index(right)
144 : ! This syntax is valid, but has poor optimization in GFortran:
145 : ! index(left+1:right)=index(left:right-1)
146 304 : do i=right,left+1,-1
147 304 : index(i)=index(i-1)
148 : end do
149 75 : index(left)=hold
150 75 : end subroutine rshift
151 :
152 : logical &
153 915 : function less_than(a,b)
154 : integer, intent(in) :: a,b
155 915 : less_than = value(index(a)) < value(index(b))
156 915 : end function less_than
157 :
158 : end subroutine sortp_dp
159 :
160 : end module mod_qsort
|
