QR_MUMPS
qrm_sort_mod.F90
Go to the documentation of this file.
1 !! ##############################################################################################
2 !!
3 !! Copyright 2012 CNRS, INPT
4 !!
5 !! This file is part of qr_mumps.
6 !!
7 !! qr_mumps is free software: you can redistribute it and/or modify
8 !! it under the terms of the GNU Lesser General Public License as
9 !! published by the Free Software Foundation, either version 3 of
10 !! the License, or (at your option) any later version.
11 !!
12 !! qr_mumps is distributed in the hope that it will be useful,
13 !! but WITHOUT ANY WARRANTY; without even the implied warranty of
14 !! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 !! GNU Lesser General Public License for more details.
16 !!
17 !! You can find a copy of the GNU Lesser General Public License
18 !! in the qr_mumps/doc directory.
19 !!
20 !! ##############################################################################################
21 
22 
23 !! ##############################################################################################
33 
34 
37 
42 
44 
45  interface qrm_mergesort
46  module procedure qrm_mergesorti, qrm_mergesortd
47  end interface
48 
49 
50  interface qrm_mergeswap
53  end interface
54 
55 contains
56 
57  subroutine qrm_mergeswapii(n, l, a1, a2)
58  implicit none
59  integer :: n
60  integer,intent(inout) :: l(0:n+1), a1(n), a2(n)
61  integer :: i, lp, iswap
62 
63  lp = l(0)
64  i = 1
65  do
66  if ((lp .eq. 0).or.(i>n)) exit
67  do
68  if (lp >= i) exit
69  lp = l(lp)
70  end do
71  iswap = a1(lp)
72  a1(lp) = a1(i)
73  a1(i) = iswap
74  iswap = a2(lp)
75  a2(lp) = a2(i)
76  a2(i) = iswap
77  iswap = l(lp)
78  l(lp) = l(i)
79  l(i) = lp
80  lp = iswap
81  i = i + 1
82  enddo
83 
84  return
85 
86  end subroutine qrm_mergeswapii
87 
88  subroutine qrm_mergeswapi(n, l, a)
89 
90  integer :: i, lp, iswap, n
91  integer :: l(0:), a(:)
92 
93  lp = l(0)
94  i = 1
95  do
96  if ((lp .eq. 0).or.(i>n)) exit
97  do
98  if (lp >= i) exit
99  lp = l(lp)
100  end do
101  iswap = a(lp)
102  a(lp) = a(i)
103  a(i) = iswap
104  iswap = l(lp)
105  l(lp) = l(i)
106  l(i) = lp
107  lp = iswap
108  i = i + 1
109  enddo
110 
111  return
112 
113  end subroutine qrm_mergeswapi
114 
115 
116  subroutine qrm_mergeswapis(n, l, a1, a2)
118  integer :: i, lp, iswap, n
119  integer :: l(0:n+1), a1(n)
120  real(kind(1.e0)) :: a2(n)
121 
122  lp = l(0)
123  i = 1
124  do
125  if ((lp .eq. 0).or.(i>n)) exit
126  do
127  if (lp >= i) exit
128  lp = l(lp)
129  end do
130  iswap = a1(lp)
131  a1(lp) = a1(i)
132  a1(i) = iswap
133  iswap = a2(lp)
134  a2(lp) = a2(i)
135  a2(i) = iswap
136  iswap = l(lp)
137  l(lp) = l(i)
138  l(i) = lp
139  lp = iswap
140  i = i + 1
141  enddo
142 
143  return
144 
145  end subroutine qrm_mergeswapis
146 
147  subroutine qrm_mergeswapid(n, l, a1, a2)
149  integer :: i, lp, iswap, n
150  integer :: l(0:n+1), a1(n)
151  real(kind(1.d0)) :: a2(n), dswap
152 
153  lp = l(0)
154  i = 1
155  do
156  if ((lp .eq. 0).or.(i>n)) exit
157  do
158  if (lp >= i) exit
159  lp = l(lp)
160  end do
161  iswap = a1(lp)
162  a1(lp) = a1(i)
163  a1(i) = iswap
164  dswap = a2(lp)
165  a2(lp) = a2(i)
166  a2(i) = dswap
167  iswap = l(lp)
168  l(lp) = l(i)
169  l(i) = lp
170  lp = iswap
171  i = i + 1
172  enddo
173 
174  return
175 
176  end subroutine qrm_mergeswapid
177 
178  subroutine qrm_mergeswapd(n, l, a1)
180  integer :: i, lp, iswap, n
181  integer :: l(0:n+1)
182  real(kind(1.d0)) :: a1(n)
183 
184  lp = l(0)
185  i = 1
186  do
187  if ((lp .eq. 0).or.(i>n)) exit
188  do
189  if (lp >= i) exit
190  lp = l(lp)
191  end do
192  iswap = a1(lp)
193  a1(lp) = a1(i)
194  a1(i) = iswap
195  iswap = l(lp)
196  l(lp) = l(i)
197  l(i) = lp
198  lp = iswap
199  i = i + 1
200  enddo
201 
202  return
203 
204  end subroutine qrm_mergeswapd
205 
206  subroutine qrm_mergeswapic(n, l, a1, a2)
208  integer :: i, lp, iswap, n
209  integer :: l(0:n+1), a1(n)
210  complex(kind(1.e0)) :: a2(n)
211 
212  lp = l(0)
213  i = 1
214  do
215  if ((lp .eq. 0).or.(i>n)) exit
216  do
217  if (lp >= i) exit
218  lp = l(lp)
219  end do
220  iswap = a1(lp)
221  a1(lp) = a1(i)
222  a1(i) = iswap
223  iswap = a2(lp)
224  a2(lp) = a2(i)
225  a2(i) = iswap
226  iswap = l(lp)
227  l(lp) = l(i)
228  l(i) = lp
229  lp = iswap
230  i = i + 1
231  enddo
232 
233  return
234 
235  end subroutine qrm_mergeswapic
236 
237  subroutine qrm_mergeswapiz(n, l, a1, a2)
239  integer :: i, lp, iswap, n
240  integer :: l(0:n+1), a1(n)
241  complex(kind(1.d0)) :: a2(n)
242 
243  lp = l(0)
244  i = 1
245  do
246  if ((lp .eq. 0).or.(i>n)) exit
247  do
248  if (lp >= i) exit
249  lp = l(lp)
250  end do
251  iswap = a1(lp)
252  a1(lp) = a1(i)
253  a1(i) = iswap
254  iswap = a2(lp)
255  a2(lp) = a2(i)
256  a2(i) = iswap
257  iswap = l(lp)
258  l(lp) = l(i)
259  l(i) = lp
260  lp = iswap
261  i = i + 1
262  enddo
263 
264  return
265 
266  end subroutine qrm_mergeswapiz
267 
268 
269 
270  subroutine qrm_mergesorti(n, k, l, order)
272  implicit none
273  integer :: n
274  integer, intent(inout) :: k(n), l(0:n+1)
275  integer, optional :: order
276 
277  integer :: p, q, s, t, i, iord
278 
279  iord = 1
280  if(present(order)) iord = order
281 
282  if((iord .ne. 1) .and. (iord .ne. -1)) then
283  write(*,'("Wrong input in mergesort")')
284  return
285  end if
286 
287 100 continue
288  l(0) = 1
289  t = n + 1
290  do p = 1,n - 1
291  if (iord*k(p) .le. iord*k(p+1)) then
292  l(p) = p + 1
293  else
294  l(t) = - (p+1)
295  t = p
296  end if
297  end do
298  l(t) = 0
299  l(n) = 0
300 
301  if (l(n+1) .eq. 0) then
302  return
303  else
304  l(n+1) = iabs(l(n+1))
305  end if
306 
307 200 continue
308  s = 0
309  t = n+1
310  p = l(s)
311  q = l(t)
312 
313  if(q .eq. 0) return
314 
315 300 continue
316  if(iord*k(p) .gt. iord*k(q)) goto 600
317 
318 400 continue
319  l(s) = sign(p,l(s))
320  s = p
321  p = l(p)
322  if (p .gt. 0) goto 300
323 
324 500 continue
325  l(s) = q
326  s = t
327  do
328  t = q
329  q = l(q)
330  if (q .le. 0) exit
331  end do
332  goto 800
333 
334 600 continue
335  l(s) = sign(q, l(s))
336  s = q
337  q = l(q)
338  if (q .gt. 0) goto 300
339 
340 700 continue
341  l(s) = p
342  s = t
343  do
344  t = p
345  p = l(p)
346  if (p .le. 0) exit
347  end do
348 
349 800 continue
350  p = -p
351  q = -q
352  if(q.eq.0) then
353  l(s) = sign(p, l(s))
354  l(t) = 0
355  goto 200
356  end if
357 
358  goto 300
359 
360  return
361 
362  end subroutine qrm_mergesorti
363 
364 
365 
366  subroutine qrm_mergesortd(n, k, l, order)
368  ! Plain implementation of the merge-sort algorithm
369  ! as described in:
370 
371  ! D. E. Knuth "The Art of Computer Programming,"
372  ! vol.3: Sorting and Searching, Addison-Wesley, 1973
373  implicit none
374  integer :: n
375  integer, intent(inout) :: l(0:n+1)
376  real(kind(1.d0)) :: k(n)
377  integer, optional :: order
378 
379  integer :: p, q, s, t, i, iord
380 
381  iord = 1
382  if(present(order)) iord = order
383 
384  if((iord .ne. 1) .and. (iord .ne. -1)) then
385  write(*,'("Wrong input in mergesort")')
386  return
387  end if
388 
389 100 continue
390  l(0) = 1
391  t = n + 1
392  do p = 1,n - 1
393  if (iord*k(p) .le. iord*k(p+1)) then
394  l(p) = p + 1
395  else
396  l(t) = - (p+1)
397  t = p
398  end if
399  end do
400  l(t) = 0
401  l(n) = 0
402 
403  if (l(n+1) .eq. 0) then
404  return
405  else
406  l(n+1) = iabs(l(n+1))
407  end if
408 
409 200 continue
410  s = 0
411  t = n+1
412  p = l(s)
413  q = l(t)
414 
415  if(q .eq. 0) return
416 
417 300 continue
418  if(iord*k(p) .gt. iord*k(q)) goto 600
419 
420 400 continue
421  l(s) = sign(p,l(s))
422  s = p
423  p = l(p)
424  if (p .gt. 0) goto 300
425 
426 500 continue
427  l(s) = q
428  s = t
429  do
430  t = q
431  q = l(q)
432  if (q .le. 0) exit
433  end do
434  goto 800
435 
436 600 continue
437  l(s) = sign(q, l(s))
438  s = q
439  q = l(q)
440  if (q .gt. 0) goto 300
441 
442 700 continue
443  l(s) = p
444  s = t
445  do
446  t = p
447  p = l(p)
448  if (p .le. 0) exit
449  end do
450 
451 800 continue
452  p = -p
453  q = -q
454  if(q.eq.0) then
455  l(s) = sign(p, l(s))
456  l(t) = 0
457  goto 200
458  end if
459 
460  goto 300
461 
462  return
463 
464  end subroutine qrm_mergesortd
465 
466 end module qrm_sort_mod
This module contains routines for sorting.
subroutine qrm_mergesortd(n, k, l, order)
subroutine qrm_mergesorti(n, k, l, order)
subroutine qrm_mergeswapis(n, l, a1, a2)
subroutine qrm_mergeswapd(n, l, a1)
subroutine qrm_mergeswapi(n, l, a)
subroutine qrm_mergeswapii(n, l, a1, a2)
subroutine qrm_mergeswapiz(n, l, a1, a2)
subroutine qrm_mergeswapid(n, l, a1, a2)
subroutine qrm_mergeswapic(n, l, a1, a2)