libsim  Versione 7.2.4
array_utilities_inc.F90
1 ! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
2 ! authors:
3 ! Davide Cesari <dcesari@arpa.emr.it>
4 ! Paolo Patruno <ppatruno@arpa.emr.it>
5 
6 ! sort from public domain utilities http://www.fortran-2000.com :
7 ! Michel Olagnon - Apr. 2000
8 
9 ! This program is free software; you can redistribute it and/or
10 ! modify it under the terms of the GNU General Public License as
11 ! published by the Free Software Foundation; either version 2 of
12 ! the License, or (at your option) any later version.
13 
14 ! This program is distributed in the hope that it will be useful,
15 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ! GNU General Public License for more details.
18 
19 ! You should have received a copy of the GNU General Public License
20 ! along with this program. If not, see <http://www.gnu.org/licenses/>.
21 
22 #ifdef ENABLE_SORT
23 
24 FUNCTION count_distinct_sorted/**/vol7d_poly_types(vect, mask) RESULT(count_distinct_sorted)
25 vol7d_poly_type,INTENT(in) :: vect(:)
26 LOGICAL,INTENT(in),OPTIONAL :: mask(:)
27 INTEGER :: count_distinct_sorted
28 
29 INTEGER :: i, j
30 
31 count_distinct_sorted = 0
32 
33 j=1
34 i = 1
35 do while (i <= size(vect))
36  if (present(mask)) then
37  do while (.not. mask(i))
38  i=i+1
39  if ( i > size(vect)) return
40  end do
41  end if
42  ! count the first
43  if (i==j) count_distinct_sorted = count_distinct_sorted + 1
44 
45  if (vect(j) /= vect(i)) then
46  count_distinct_sorted = count_distinct_sorted + 1
47  j = i
48  end if
49 
50  i = i+1
51 
52 end do
53 
54 END FUNCTION count_distinct_sorted/**/vol7d_poly_types
55 #endif
56 
58 FUNCTION count_distinct/**/vol7d_poly_types(vect, mask, back) RESULT(count_distinct)
59 vol7d_poly_type,INTENT(in) :: vect(:)
60 LOGICAL,INTENT(in),OPTIONAL :: mask(:), back
61 INTEGER :: count_distinct
62 
63 #ifdef VOL7D_POLY_TYPE_AUTO
64 vol7d_poly_type_auto(vect) :: pack_distinct(SIZE(vect))
65 #else
66 vol7d_poly_type :: pack_distinct(SIZE(vect))
67 #endif
68 INTEGER :: i, j
69 LOGICAL :: lback
70 
71 IF (PRESENT(back)) THEN
72  lback = back
73 ELSE
74  lback = .false.
75 ENDIF
76 count_distinct = 0
77 
78 IF (PRESENT (mask)) THEN
79  IF (lback) THEN
80  vectm1: DO i = 1, SIZE(vect)
81  IF (.NOT.mask(i)) cycle vectm1
82 ! DO j = i-1, 1, -1
83 ! IF (.NOT.mask(j)) CYCLE
84 ! IF (vect(j) == vect(i)) CYCLE vectm1
85  DO j = count_distinct, 1, -1
86  IF (pack_distinct(j) == vect(i)) cycle vectm1
87  ENDDO
88  count_distinct = count_distinct + 1
89  pack_distinct(count_distinct) = vect(i)
90  ENDDO vectm1
91  ELSE
92  vectm2: DO i = 1, SIZE(vect)
93  IF (.NOT.mask(i)) cycle vectm2
94 ! DO j = 1, i-1
95 ! IF (.NOT.mask(j)) CYCLE
96 ! IF (vect(j) == vect(i)) CYCLE vectm2
97  DO j = 1, count_distinct
98  IF (pack_distinct(j) == vect(i)) cycle vectm2
99  ENDDO
100  count_distinct = count_distinct + 1
101  pack_distinct(count_distinct) = vect(i)
102  ENDDO vectm2
103  ENDIF
104 ELSE
105  IF (lback) THEN
106  vect1: DO i = 1, SIZE(vect)
107 ! DO j = i-1, 1, -1
108 ! IF (vect(j) == vect(i)) CYCLE vect1
109  DO j = count_distinct, 1, -1
110  IF (pack_distinct(j) == vect(i)) cycle vect1
111  ENDDO
112  count_distinct = count_distinct + 1
113  pack_distinct(count_distinct) = vect(i)
114  ENDDO vect1
115  ELSE
116  vect2: DO i = 1, SIZE(vect)
117 ! DO j = 1, i-1
118 ! IF (vect(j) == vect(i)) CYCLE vect2
119  DO j = 1, count_distinct
120  IF (pack_distinct(j) == vect(i)) cycle vect2
121  ENDDO
122  count_distinct = count_distinct + 1
123  pack_distinct(count_distinct) = vect(i)
124  ENDDO vect2
125  ENDIF
126 ENDIF
127 
128 END FUNCTION count_distinct/**/vol7d_poly_types
129 
130 
131 #ifndef VOL7D_NO_PACK
132 
133 #ifdef ENABLE_SORT
134 
135 FUNCTION pack_distinct_sorted/**/vol7d_poly_types(vect, dim, mask) &
136  result(pack_distinct_sorted)
137 vol7d_poly_type,INTENT(in) :: vect(:)
138 INTEGER,INTENT(in) :: dim
139 LOGICAL,INTENT(in),OPTIONAL :: mask(:)
140 vol7d_poly_type :: pack_distinct_sorted(dim)
141 
142 INTEGER :: i,count_distinct
143 
144 if (dim < 1) return
145 
146 count_distinct = 0
147 
148 DO i = 1, SIZE(vect)
149  IF (PRESENT (mask)) THEN
150  IF (.NOT.mask(i)) cycle
151  end IF
152 
153  if (count_distinct == 0) then
154  count_distinct = count_distinct + 1
155  pack_distinct_sorted(count_distinct)=vect(i)
156  end if
157  if (pack_distinct_sorted(count_distinct) == vect(i)) cycle
158  count_distinct = count_distinct + 1
159  if (count_distinct > dim) return
160  pack_distinct_sorted(count_distinct)=vect(i)
161 
162 ENDDO
163 
164 END FUNCTION pack_distinct_sorted/**/vol7d_poly_types
165 #endif
166 
168 FUNCTION pack_distinct/**/vol7d_poly_types(vect, dim, mask, back) &
169  result(pack_distinct)
170 vol7d_poly_type,INTENT(in) :: vect(:)
171 INTEGER,INTENT(in) :: dim
172 LOGICAL,INTENT(in),OPTIONAL :: mask(:), back
173 vol7d_poly_type :: pack_distinct(dim)
174 
175 INTEGER :: count_distinct
176 INTEGER :: i, j
177 LOGICAL :: lback
178 
179 IF (PRESENT(back)) THEN
180  lback = back
181 ELSE
182  lback = .false.
183 ENDIF
184 count_distinct = 0
185 
186 IF (PRESENT (mask)) THEN
187  IF (lback) THEN
188  vectm1: DO i = 1, SIZE(vect)
189  IF (.NOT.mask(i)) cycle vectm1
190 ! DO j = i-1, 1, -1
191 ! IF (.NOT.mask(j)) CYCLE
192 ! IF (vect(j) == vect(i)) CYCLE vectm1
193  DO j = count_distinct, 1, -1
194  IF (pack_distinct(j) == vect(i)) cycle vectm1
195  ENDDO
196  count_distinct = count_distinct + 1
197  IF (count_distinct > dim) EXIT
198  pack_distinct(count_distinct) = vect(i)
199  ENDDO vectm1
200  ELSE
201  vectm2: DO i = 1, SIZE(vect)
202  IF (.NOT.mask(i)) cycle vectm2
203 ! DO j = 1, i-1
204 ! IF (.NOT.mask(j)) CYCLE
205 ! IF (vect(j) == vect(i)) CYCLE vectm2
206  DO j = 1, count_distinct
207  IF (pack_distinct(j) == vect(i)) cycle vectm2
208  ENDDO
209  count_distinct = count_distinct + 1
210  IF (count_distinct > dim) EXIT
211  pack_distinct(count_distinct) = vect(i)
212  ENDDO vectm2
213  ENDIF
214 ELSE
215  IF (lback) THEN
216  vect1: DO i = 1, SIZE(vect)
217 ! DO j = i-1, 1, -1
218 ! IF (vect(j) == vect(i)) CYCLE vect1
219  DO j = count_distinct, 1, -1
220  IF (pack_distinct(j) == vect(i)) cycle vect1
221  ENDDO
222  count_distinct = count_distinct + 1
223  IF (count_distinct > dim) EXIT
224  pack_distinct(count_distinct) = vect(i)
225  ENDDO vect1
226  ELSE
227  vect2: DO i = 1, SIZE(vect)
228 ! DO j = 1, i-1
229 ! IF (vect(j) == vect(i)) CYCLE vect2
230  DO j = 1, count_distinct
231  IF (pack_distinct(j) == vect(i)) cycle vect2
232  ENDDO
233  count_distinct = count_distinct + 1
234  IF (count_distinct > dim) EXIT
235  pack_distinct(count_distinct) = vect(i)
236  ENDDO vect2
237  ENDIF
238 ENDIF
239 
240 END FUNCTION pack_distinct/**/vol7d_poly_types
241 
242 
243 FUNCTION count_and_pack_distinct/**/vol7d_poly_types(vect, pack_distinct, mask, back) RESULT(count_distinct)
244 vol7d_poly_type,INTENT(in) :: vect(:)
245 #ifdef VOL7D_POLY_TYPE_AUTO
246 vol7d_poly_type_auto(vect),INTENT(out) :: pack_distinct(:)
247 #else
248 vol7d_poly_type,INTENT(out) :: pack_distinct(:)
249 #endif
250 LOGICAL,INTENT(in),OPTIONAL :: mask(:), back
251 INTEGER :: count_distinct
252 
253 INTEGER :: i, j
254 LOGICAL :: lback
255 
256 IF (PRESENT(back)) THEN
257  lback = back
258 ELSE
259  lback = .false.
260 ENDIF
261 count_distinct = 0
262 
263 IF (PRESENT (mask)) THEN
264  IF (lback) THEN
265  vectm1: DO i = 1, SIZE(vect)
266  IF (.NOT.mask(i)) cycle vectm1
267 ! DO j = i-1, 1, -1
268 ! IF (.NOT.mask(j)) CYCLE
269 ! IF (vect(j) == vect(i)) CYCLE vectm1
270  DO j = count_distinct, 1, -1
271  IF (pack_distinct(j) == vect(i)) cycle vectm1
272  ENDDO
273  count_distinct = count_distinct + 1
274  pack_distinct(count_distinct) = vect(i)
275  ENDDO vectm1
276  ELSE
277  vectm2: DO i = 1, SIZE(vect)
278  IF (.NOT.mask(i)) cycle vectm2
279 ! DO j = 1, i-1
280 ! IF (.NOT.mask(j)) CYCLE
281 ! IF (vect(j) == vect(i)) CYCLE vectm2
282  DO j = 1, count_distinct
283  IF (pack_distinct(j) == vect(i)) cycle vectm2
284  ENDDO
285  count_distinct = count_distinct + 1
286  pack_distinct(count_distinct) = vect(i)
287  ENDDO vectm2
288  ENDIF
289 ELSE
290  IF (lback) THEN
291  vect1: DO i = 1, SIZE(vect)
292 ! DO j = i-1, 1, -1
293 ! IF (vect(j) == vect(i)) CYCLE vect1
294  DO j = count_distinct, 1, -1
295  IF (pack_distinct(j) == vect(i)) cycle vect1
296  ENDDO
297  count_distinct = count_distinct + 1
298  pack_distinct(count_distinct) = vect(i)
299  ENDDO vect1
300  ELSE
301  vect2: DO i = 1, SIZE(vect)
302 ! DO j = 1, i-1
303 ! IF (vect(j) == vect(i)) CYCLE vect2
304  DO j = 1, count_distinct
305  IF (pack_distinct(j) == vect(i)) cycle vect2
306  ENDDO
307  count_distinct = count_distinct + 1
308  pack_distinct(count_distinct) = vect(i)
309  ENDDO vect2
310  ENDIF
311 ENDIF
312 
313 END FUNCTION count_and_pack_distinct/**/vol7d_poly_types
314 #endif
315 
317 FUNCTION map_distinct/**/vol7d_poly_types(vect, mask, back) RESULT(map_distinct)
318 vol7d_poly_type,INTENT(in) :: vect(:)
319 LOGICAL,INTENT(in),OPTIONAL :: mask(:), back
320 INTEGER :: map_distinct(SIZE(vect))
321 
322 INTEGER :: count_distinct
323 #ifdef VOL7D_POLY_TYPE_AUTO
324 vol7d_poly_type_auto(vect) :: pack_distinct(SIZE(vect))
325 #else
326 vol7d_poly_type :: pack_distinct(SIZE(vect))
327 #endif
328 INTEGER :: i, j
329 LOGICAL :: lback
330 
331 IF (PRESENT(back)) THEN
332  lback = back
333 ELSE
334  lback = .false.
335 ENDIF
336 count_distinct = 0
337 map_distinct(:) = 0
338 
339 IF (PRESENT (mask)) THEN
340  IF (lback) THEN
341  vectm1: DO i = 1, SIZE(vect)
342  IF (.NOT.mask(i)) cycle vectm1
343 ! DO j = i-1, 1, -1
344 ! IF (.NOT.mask(j)) CYCLE
345 ! IF (vect(j) == vect(i)) THEN
346 ! map_distinct(i) = map_distinct(j)
347  DO j = count_distinct, 1, -1
348  IF (pack_distinct(j) == vect(i)) THEN
349  map_distinct(i) = j
350  cycle vectm1
351  ENDIF
352  ENDDO
353  count_distinct = count_distinct + 1
354  pack_distinct(count_distinct) = vect(i)
355  map_distinct(i) = count_distinct
356  ENDDO vectm1
357  ELSE
358  vectm2: DO i = 1, SIZE(vect)
359  IF (.NOT.mask(i)) cycle vectm2
360 ! DO j = 1, i-1
361 ! IF (.NOT.mask(j)) CYCLE
362 ! IF (vect(j) == vect(i)) THEN
363 ! map_distinct(i) = map_distinct(j)
364  DO j = 1, count_distinct
365  IF (pack_distinct(j) == vect(i)) THEN
366  map_distinct(i) = j
367  cycle vectm2
368  ENDIF
369  ENDDO
370  count_distinct = count_distinct + 1
371  pack_distinct(count_distinct) = vect(i)
372  map_distinct(i) = count_distinct
373  ENDDO vectm2
374  ENDIF
375 ELSE
376  IF (lback) THEN
377  vect1: DO i = 1, SIZE(vect)
378 ! DO j = i-1, 1, -1
379 ! IF (vect(j) == vect(i)) THEN
380 ! map_distinct(i) = map_distinct(j)
381  DO j = count_distinct, 1, -1
382  IF (pack_distinct(j) == vect(i)) THEN
383  map_distinct(i) = j
384  cycle vect1
385  ENDIF
386  ENDDO
387  count_distinct = count_distinct + 1
388  pack_distinct(count_distinct) = vect(i)
389  map_distinct(i) = count_distinct
390  ENDDO vect1
391  ELSE
392  vect2: DO i = 1, SIZE(vect)
393 ! DO j = 1, i-1
394 ! IF (vect(j) == vect(i)) THEN
395 ! map_distinct(i) = map_distinct(j)
396  DO j = 1, count_distinct
397  IF (pack_distinct(j) == vect(i)) THEN
398  map_distinct(i) = j
399  cycle vect2
400  ENDIF
401  ENDDO
402  count_distinct = count_distinct + 1
403  pack_distinct(count_distinct) = vect(i)
404  map_distinct(i) = count_distinct
405  ENDDO vect2
406  ENDIF
407 ENDIF
408 
409 END FUNCTION map_distinct/**/vol7d_poly_types
410 
411 
413 FUNCTION map_inv_distinct/**/vol7d_poly_types(vect, dim, mask, back) &
414  result(map_inv_distinct)
415 vol7d_poly_type,INTENT(in) :: vect(:)
416 INTEGER,INTENT(in) :: dim
417 LOGICAL,INTENT(in),OPTIONAL :: mask(:), back
418 INTEGER :: map_inv_distinct(dim)
419 
420 INTEGER :: count_distinct
421 #ifdef VOL7D_POLY_TYPE_AUTO
422 vol7d_poly_type_auto(vect) :: pack_distinct(SIZE(vect))
423 #else
424 vol7d_poly_type :: pack_distinct(SIZE(vect))
425 #endif
426 INTEGER :: i, j
427 LOGICAL :: lback
428 
429 IF (PRESENT(back)) THEN
430  lback = back
431 ELSE
432  lback = .false.
433 ENDIF
434 count_distinct = 0
435 map_inv_distinct(:) = 0
436 
437 IF (PRESENT (mask)) THEN
438  IF (lback) THEN
439  vectm1: DO i = 1, SIZE(vect)
440  IF (.NOT.mask(i)) cycle vectm1
441 ! DO j = i-1, 1, -1
442 ! IF (.NOT.mask(j)) CYCLE
443 ! IF (vect(j) == vect(i)) CYCLE vectm1
444  DO j = count_distinct, 1, -1
445  IF (pack_distinct(j) == vect(i)) cycle vectm1
446  ENDDO
447  count_distinct = count_distinct + 1
448  pack_distinct(count_distinct) = vect(i)
449  IF (count_distinct > dim) EXIT
450  map_inv_distinct(count_distinct) = i
451  ENDDO vectm1
452  ELSE
453  vectm2: DO i = 1, SIZE(vect)
454  IF (.NOT.mask(i)) cycle vectm2
455 ! DO j = 1, i-1
456 ! IF (.NOT.mask(j)) CYCLE
457 ! IF (vect(j) == vect(i)) CYCLE vectm2
458  DO j = 1, count_distinct
459  IF (pack_distinct(j) == vect(i)) cycle vectm2
460  ENDDO
461  count_distinct = count_distinct + 1
462  pack_distinct(count_distinct) = vect(i)
463  IF (count_distinct > dim) EXIT
464  map_inv_distinct(count_distinct) = i
465  ENDDO vectm2
466  ENDIF
467 ELSE
468  IF (lback) THEN
469  vect1: DO i = 1, SIZE(vect)
470 ! DO j = i-1, 1, -1
471 ! IF (vect(j) == vect(i)) CYCLE vect1
472  DO j = count_distinct, 1, -1
473  IF (pack_distinct(j) == vect(i)) cycle vect1
474  ENDDO
475  count_distinct = count_distinct + 1
476  pack_distinct(count_distinct) = vect(i)
477  IF (count_distinct > dim) EXIT
478  map_inv_distinct(count_distinct) = i
479  ENDDO vect1
480  ELSE
481  vect2: DO i = 1, SIZE(vect)
482 ! DO j = 1, i-1
483 ! IF (vect(j) == vect(i)) CYCLE vect2
484  DO j = 1, count_distinct
485  IF (pack_distinct(j) == vect(i)) cycle vect2
486  ENDDO
487  count_distinct = count_distinct + 1
488  pack_distinct(count_distinct) = vect(i)
489  IF (count_distinct > dim) EXIT
490  map_inv_distinct(count_distinct) = i
491  ENDDO vect2
492  ENDIF
493 ENDIF
494 
495 END FUNCTION map_inv_distinct/**/vol7d_poly_types
496 
497 
499 FUNCTION index/**/vol7d_poly_types(vect, search, mask, back, cache) &
500  result(index_)
501 vol7d_poly_type,INTENT(in) :: vect(:), search
502 LOGICAL,INTENT(in),OPTIONAL :: mask(:)
503 LOGICAL,INTENT(in),OPTIONAL :: back
504 INTEGER,INTENT(in),OPTIONAL :: cache
505 INTEGER :: index_
506 
507 INTEGER :: i, lcache
508 LOGICAL :: lback
509 
510 IF (PRESENT(back)) THEN
511  lback = back
512 ELSE
513  lback = .false.
514 ENDIF
515 index_ = 0
516 
517 IF (PRESENT (mask)) THEN
518  IF (lback) THEN
519  vectm1: DO i = SIZE(vect), 1, -1
520  IF (.NOT.mask(i)) cycle vectm1
521  IF (vect(i) == search) THEN
522  index_ = i
523  RETURN
524  ENDIF
525  ENDDO vectm1
526  ELSE
527  vectm2: DO i = 1, SIZE(vect)
528  IF (.NOT.mask(i)) cycle vectm2
529  IF (vect(i) == search) THEN
530  index_ = i
531  RETURN
532  ENDIF
533  ENDDO vectm2
534  ENDIF
535 ELSE
536  IF (PRESENT(cache)) THEN
537  lcache = max(min(SIZE(vect),cache),1)
538  DO i = lcache, SIZE(vect)
539  IF (vect(i) == search) THEN
540  index_ = i
541  RETURN
542  ENDIF
543  ENDDO
544  DO i = 1, lcache-1
545  IF (vect(i) == search) THEN
546  index_ = i
547  RETURN
548  ENDIF
549  ENDDO
550  ELSE
551  IF (lback) THEN
552  vect1: DO i = SIZE(vect), 1, -1
553  IF (vect(i) == search) THEN
554  index_ = i
555  RETURN
556  ENDIF
557  ENDDO vect1
558  ELSE
559  vect2: DO i = 1, SIZE(vect)
560  IF (vect(i) == search) THEN
561  index_ = i
562  RETURN
563  ENDIF
564  ENDDO vect2
565  ENDIF
566  ENDIF
567 ENDIF
568 
569 END FUNCTION index/**/vol7d_poly_types
570 
571 
572 #ifdef ENABLE_SORT
573 
574 
576 recursive FUNCTION index_sorted/**/vol7d_poly_types(vect, search) &
577  result(index_)
578 vol7d_poly_type,INTENT(in) :: vect(:), search
579 INTEGER :: index_
580 
581 integer :: mid
582 
583  mid = size(vect)/2 + 1
584 
585 !!$ if (size(vect) == 0) then
586 !!$ index_ = 0 ! not found
587 !!$
588 !!$ else if (size(vect) == 1) then
589 !!$ if (vect(1) == search) then
590 !!$ index_ = 1
591 !!$ else
592 !!$ index_ = 0 ! not found
593 !!$ end if
594 !!$ else if .....
595 
596  if (size(vect) < 10) then
597  !print *,"call index with size: ",size(vect)
598  index_=index(vect, search) ! sequential search for few number
599  !print *,"returned: ",index_
600  else if (vect(mid) > search) then
601  !print *,"call index_sorted -->",mid-1
602  index_= index_sorted/**/vol7d_poly_types(vect(:mid-1), search)
603  else if (vect(mid) < search) then
604  !print *,"call index_sorted",mid+1,"<--"
605  index_ = index_sorted/**/vol7d_poly_types(vect(mid+1:), search)
606  if (index_ /= 0) then
607  index_ = mid + index_
608  end if
609  else
610  index_ = mid ! SUCCESS!!
611  end if
612 
613 END FUNCTION index_sorted/**/vol7d_poly_types
614 
615 
616 !!$Da Wikipedia, l'enciclopedia libera.
617 !!$Il merge sort un algoritmo di ordinamento abbastanza rapido che utilizza un processo di risoluzione ricorsivo.
618 !!$Raffigurazione grafica delle versioni iterativa e ricorsiva dell'algoritmo merge sort.
619 !!$
620 !!$L'idea alla base del merge sort il procedimento Divide et Impera, che consiste nella suddivisione del problema in sottoproblemi via via pi piccoli.
621 !!$
622 !!$Il merge sort opera quindi dividendo l'insieme da ordinare in due met e procedendo all'ordinamento delle medesime ricorsivamente. Quando si sono divise tutte le met si procede alla loro fusione (merge appunto) costruendo un insieme ordinato.
623 !!$
624 !!$L'algoritmo fu inventato da John von Neumann nel 1945.
625 !!$
626 !!$ Pseudocodice [modifica]
627 !!$
628 !!$ merge (a[], left, center, right)
629 !!$ i left
630 !!$ j center + 1
631 !!$ k 0
632 !!$
633 !!$ while ((i <= center) && (j <= right)) do
634 !!$ if (a[i] <= a[j])
635 !!$ then
636 !!$ b[k] a[i]
637 !!$ i i + 1
638 !!$ else
639 !!$ b[k] a[j]
640 !!$ j j + 1
641 !!$ k k + 1
642 !!$ end while
643 !!$
644 !!$ while (i <= center) do
645 !!$ b[k] a[i]
646 !!$ i i + 1
647 !!$ k k + 1
648 !!$ end while
649 !!$
650 !!$ while (j <= right) do
651 !!$ b[k] a[j]
652 !!$ j j + 1
653 !!$ k k + 1
654 !!$ end while
655 !!$
656 !!$ for k left to right do
657 !!$ a[k] b[k - left]
658 !!$
659 !!$ mergesort (a[], left, right)
660 !!$ if (left < right) then
661 !!$ center (left + right) / 2
662 !!$ mergesort(a, left, center)
663 !!$ mergesort(a, center+1, right)
664 !!$ merge(a, left, center, right)
665 !!$
666 
667 !!$Bottom-up merge sort
668 !!$
669 !!$ Bottom-up merge sort is a non-recursive variant of the merge sort,
670 !!$ in which the array is sorted by a sequence of passes. During each pass,
671 !!$ the array is divided into blocks of size m\,. (Initially, m=1\,).
672 !!$ Every two adjacent blocks are merged (as in normal merge sort), and the next pass is made with a twice larger value of m\,.
673 !!$
674 !!$In pseudo-code:
675 !!$
676 !!$Input: array a[] indexed from 0 to n-1.
677 !!$
678 !!$m = 1
679 !!$while m < n do
680 !!$ i = 0
681 !!$ while i < n-m do
682 !!$ merge subarrays a[i..i+m-1] and a[i+m .. min(i+2*m-1,n-1)] in-place.
683 !!$ i = i + 2 * m
684 !!$ m = m * 2
685 !!$
686 
698 Subroutine sort/**/vol7d_poly_types (XDONT)
699 
700 ! Sorts XDONT into ascending order - Quicksort
701 ! Michel Olagnon - Apr. 2000
702 ! _________________________________________________________
703 
704 vol7d_poly_type, Dimension (:), Intent (InOut) :: xdont
705 integer :: recursion
706 ! __________________________________________________________
707 !
708 !
709  recursion=0
710  Call subsor/**/vol7d_poly_types(xdont, 1, Size (xdont), recursion)
711  Call inssor/**/vol7d_poly_types(xdont)
712  Return
713 End Subroutine sort/**/vol7d_poly_types
714 Recursive Subroutine subsor/**/vol7d_poly_types (XDONT, IDEB1, IFIN1, recursion)
715 ! Sorts XDONT from IDEB1 to IFIN1
716 ! __________________________________________________________
717  vol7d_poly_type, dimension (:), Intent (InOut) :: xdont
718  Integer, Intent (In) :: IDEB1, IFIN1
719  Integer, Intent (InOut) :: recursion
720 ! __________________________________________________________
721  Integer, Parameter :: NINS = 16 , maxrec=5000 ! Max for insertion sort
722  Integer :: ICRS, IDEB, IDCR, IFIN, IMIL
723 
724 #ifdef VOL7D_POLY_TYPE_AUTO
725  vol7d_poly_type_auto(xdont) :: xpiv, xwrk
726 #else
727  vol7d_poly_type :: xpiv, xwrk
728 #endif
729 
730  print *,"recursion:",recursion
731 !
732  recursion=recursion+1
733  ideb = ideb1
734  ifin = ifin1
735 !
736 ! If we don't have enough values to make it worth while, we leave
737 ! them unsorted, and the final insertion sort will take care of them
738 !
739  If ((ifin - ideb) > nins .and. recursion <= maxrec*2 ) Then
740  print *,"subsor:",ifin-ideb
741 
742  imil = (ideb+ifin) / 2
743 !
744 ! One chooses a pivot, median of 1st, last, and middle values
745 !
746  If (xdont(imil) < xdont(ideb)) Then
747  xwrk = xdont(ideb)
748  xdont(ideb) = xdont(imil)
749  xdont(imil) = xwrk
750  End If
751  If (xdont(imil) > xdont(ifin)) Then
752  xwrk = xdont(ifin)
753  xdont(ifin) = xdont(imil)
754  xdont(imil) = xwrk
755  If (xdont(imil) < xdont(ideb)) Then
756  xwrk = xdont(ideb)
757  xdont(ideb) = xdont(imil)
758  xdont(imil) = xwrk
759  End If
760  End If
761  xpiv = xdont(imil)
762 !
763 ! One exchanges values to put those > pivot in the end and
764 ! those <= pivot at the beginning
765 !
766  icrs = ideb
767  idcr = ifin
768  ech2: Do
769  Do
770  icrs = icrs + 1
771  If (icrs >= idcr) Then
772 !
773 ! the first > pivot is IDCR
774 ! the last <= pivot is ICRS-1
775 ! Note: If one arrives here on the first iteration, then
776 ! the pivot is the maximum of the set, the last value is equal
777 ! to it, and one can reduce by one the size of the set to process,
778 ! as if XDONT (IFIN) > XPIV
779 !
780  Exit ech2
781 !
782  End If
783  If (xdont(icrs) > xpiv) Exit
784  End Do
785  Do
786  If (xdont(idcr) <= xpiv) Exit
787  idcr = idcr - 1
788  If (icrs >= idcr) Then
789  !
790 ! The last value < pivot is always ICRS-1
791 !
792  Exit ech2
793  End If
794  End Do
795 !
796  xwrk = xdont(idcr)
797  xdont(idcr) = xdont(icrs)
798  xdont(icrs) = xwrk
799  End Do ech2
800 !
801 ! One now sorts each of the two sub-intervals
802 !
803  Call subsor/**/vol7d_poly_types(xdont, ideb1, icrs-1, recursion)
804  Call subsor/**/vol7d_poly_types(xdont, idcr, ifin1, recursion)
805 
806 !!$ else
807 !!$ Call inssor/**/VOL7D_POLY_TYPES (XDONT(IDEB:IFIN))
808 
809  End If
810  Return
811  End Subroutine Subsor/**/vol7d_poly_types
812 
813 
823  Subroutine inssor/**/vol7d_poly_types (XDONT)
824 ! Sorts XDONT into increasing order (Insertion sort)
825 ! __________________________________________________________
826  vol7d_poly_type, dimension (:), Intent (InOut) :: xdont
827 ! __________________________________________________________
828  Integer :: ICRS, IDCR
829 
830 #ifdef VOL7D_POLY_TYPE_AUTO
831  vol7d_poly_type_auto(xdont) :: xwrk
832 #else
833  vol7d_poly_type :: xwrk
834 #endif
835 
836  print *,"inssor:",size(xdont)
837 
838 !
839  Do icrs = 2, Size (xdont)
840  xwrk = xdont(icrs)
841  If (xwrk >= xdont(icrs-1)) cycle
842  xdont(icrs) = xdont(icrs-1)
843  Do idcr = icrs - 2, 1, - 1
844  If (xwrk >= xdont(idcr)) Exit
845  xdont(idcr+1) = xdont(idcr)
846  End Do
847  xdont(idcr+1) = xwrk
848  End Do
849 !
850  Return
851 !
852  End Subroutine inssor/**/vol7d_poly_types
853 !
854 
855 
856 
857 !!$Heapsort is an in-place sorting algorithm with worst case and average
858 !!$complexity of O(n logn).
859 !!$
860 !!$The basic idea is to turn the array into a binary heap structure,
861 !!$which has the property that it allows efficient retrieval and removal
862 !!$of the maximal element. We repeatedly "remove" the maximal element
863 !!$from the heap, thus building the sorted list from back to
864 !!$front. Heapsort requires random access, so can only be used on an
865 !!$array-like data structure.
866 
867 subroutine heapsort/**/vol7d_poly_types(a)
868 
869 vol7d_poly_type, intent(in out) :: a(0:)
870 
871 #ifdef VOL7D_POLY_TYPE_AUTO
872  vol7d_poly_type_auto(a) :: temp
873 #else
874  vol7d_poly_type :: temp
875 #endif
876 
877 integer :: start, n, bottom
878 
879 n = size(a)
880 do start = (n - 2) / 2, 0, -1
881  call siftdown(a, start, n);
882 end do
883 
884 do bottom = n - 1, 1, -1
885  temp = a(0)
886  a(0) = a(bottom)
887  a(bottom) = temp;
888  call siftdown(a, 0, bottom)
889 end do
890 
891 contains
892 subroutine siftdown(a, start, bottom)
893 
894 vol7d_poly_type, intent(in out) :: a(0:)
895 
896 #ifdef VOL7D_POLY_TYPE_AUTO
897 vol7d_poly_type_auto(a) :: temp
898 #else
899 vol7d_poly_type :: temp
900 #endif
901 
902 integer, intent(in) :: start, bottom
903 integer :: child, root
904 
905 root = start
906 do while(root*2 + 1 < bottom)
907  child = root * 2 + 1
908 
909  if (child + 1 < bottom) then
910  if (a(child) < a(child+1)) child = child + 1
911  end if
912 
913  if (a(root) < a(child)) then
914  temp = a(child)
915  a(child) = a(root)
916  a(root) = temp
917  root = child
918  else
919  return
920  end if
921 end do
922 
923 end subroutine siftdown
924 
925 end subroutine heapsort/**/vol7d_poly_types
926 
927 
928 ! oppure
929 
930 
931 
932 !*****************************************************
933 !* Sorts an array RA of length N in ascending order *
934 !* by the Heapsort method *
935 !* ------------------------------------------------- *
936 !* INPUTS: *
937 !* N size of table RA *
938 !* RA table to be sorted *
939 !* OUTPUT: *
940 !* RA table sorted in ascending order *
941 !* *
942 !* NOTE: The Heapsort method is a N Log2 N routine, *
943 !* and can be used for very large arrays. *
944 !*****************************************************
945 SUBROUTINE hpsort/**/vol7d_poly_types(RA)
946 
947 vol7d_poly_type,intent(INOUT) :: ra(:)
948 
949 #ifdef VOL7D_POLY_TYPE_AUTO
950 vol7d_poly_type_auto(ra) :: rra
951 #else
952 vol7d_poly_type rra
953 #endif
954 
955 integer :: i,j,l,ir
956 
957 ir=size(ra)
958 l=ir/2+1
959 
960  !The index L will be decremented from its initial value during the
961  !"hiring" (heap creation) phase. Once it reaches 1, the index IR
962  !will be decremented from its initial value down to 1 during the
963  !"retirement-and-promotion" (heap selection) phase.
964 do while(.true.)
965  if(l > 1)then
966  l=l-1
967  rra=ra(l)
968  else
969  rra=ra(ir)
970  ra(ir)=ra(1)
971  ir=ir-1
972  if(ir.eq.1)then
973  ra(1)=rra
974  return
975  end if
976  end if
977  i=l
978  j=l+l
979 do while(j.le.ir)
980  if(j < ir)then
981  if(ra(j) < ra(j+1)) j=j+1
982  end if
983  if(rra < ra(j))then
984  ra(i)=ra(j)
985  i=j; j=j+j
986  else
987  j=ir+1
988  end if
989 end do
990 
991 ra(i)=rra
992 
993 end do
994 
995 END SUBROUTINE HPSORT/**/vol7d_poly_types
996 
997 
998 
999 !!$Selection sort
1000 !!$
1001 !!$L'ordinamento per selezione (selection sort) è un algoritmo di
1002 !!$ordinamento che opera in place ed in modo simile all'ordinamento per
1003 !!$inserzione. L'algoritmo è di tipo non adattivo, ossia il suo tempo di
1004 !!$esecuzione non dipende dall'input ma dalla dimensione dell'array.
1005 !!$
1006 !!$Descrizione dell'algoritmo
1007 !!$
1008 !!$L'algoritmo seleziona di volta in volta il numero minore nella
1009 !!$sequenza di partenza e lo sposta nella sequenza ordinata; di fatto la
1010 !!$sequenza viene suddivisa in due parti: la sottosequenza ordinata, che
1011 !!$occupa le prime posizioni dell'array, e la sottosequenza da ordinare,
1012 !!$che costituisce la parte restante dell'array.
1013 !!$
1014 !!$Dovendo ordinare un array A di lunghezza n, si fa scorrere l'indice i
1015 !!$da 1 a n-1 ripetendo i seguenti passi:
1016 !!$
1017 !!$ si cerca il più piccolo elemento della sottosequenza A[i..n];
1018 !!$ si scambia questo elemento con l'elemento i-esimo.
1019 !!$
1020 
1021 !!$! --------------------------------------------------------------------
1022 !!$! INTEGER FUNCTION FindMinimum():
1023 !!$! This function returns the location of the minimum in the section
1024 !!$! between Start and End.
1025 !!$! --------------------------------------------------------------------
1026 !!$
1027 !!$ INTEGER FUNCTION FindMinimum(x, Start, End)
1028 !!$ IMPLICIT NONE
1029 !!$ INTEGER, DIMENSION(1:), INTENT(IN) :: x
1030 !!$ INTEGER, INTENT(IN) :: Start, End
1031 !!$ INTEGER :: Minimum
1032 !!$ INTEGER :: Location
1033 !!$ INTEGER :: i
1034 !!$
1035 !!$ Minimum = x(Start) ! assume the first is the min
1036 !!$ Location = Start ! record its position
1037 !!$ DO i = Start+1, End ! start with next elements
1038 !!$ IF (x(i) < Minimum) THEN ! if x(i) less than the min?
1039 !!$ Minimum = x(i) ! Yes, a new minimum found
1040 !!$ Location = i ! record its position
1041 !!$ END IF
1042 !!$ END DO
1043 !!$ FindMinimum = Location ! return the position
1044 !!$ END FUNCTION FindMinimum
1045 !!$
1046 !!$! --------------------------------------------------------------------
1047 !!$! SUBROUTINE Swap():
1048 !!$! This subroutine swaps the values of its two formal arguments.
1049 !!$! --------------------------------------------------------------------
1050 !!$
1051 !!$ SUBROUTINE Swap(a, b)
1052 !!$ IMPLICIT NONE
1053 !!$ INTEGER, INTENT(INOUT) :: a, b
1054 !!$ INTEGER :: Temp
1055 !!$
1056 !!$ Temp = a
1057 !!$ a = b
1058 !!$ b = Temp
1059 !!$ END SUBROUTINE Swap
1060 !!$
1061 !!$! --------------------------------------------------------------------
1062 !!$! SUBROUTINE Sort():
1063 !!$! This subroutine receives an array x() and sorts it into ascending
1064 !!$! order.
1065 !!$! --------------------------------------------------------------------
1066 !!$
1067 !!$ SUBROUTINE Sort(x, Size)
1068 !!$ IMPLICIT NONE
1069 !!$ INTEGER, DIMENSION(1:), INTENT(INOUT) :: x
1070 !!$ INTEGER, INTENT(IN) :: Size
1071 !!$ INTEGER :: i
1072 !!$ INTEGER :: Location
1073 !!$
1074 !!$ DO i = 1, Size-1 ! except for the last
1075 !!$ Location = FindMinimum(x, i, Size) ! find min from this to last
1076 !!$ CALL Swap(x(i), x(Location)) ! swap this and the minimum
1077 !!$ END DO
1078 !!$ END SUBROUTINE Sort
1079 !!$
1080 
1081 
1082 !!$il Bubble sort o bubblesort (letteralmente: ordinamento a bolle) è un
1083 !!$semplice algoritmo di ordinamento di dati. Il suo funzionamento è
1084 !!$semplice: ogni coppia di elementi adiacenti della lista viene
1085 !!$comparata e se sono nell'ordine sbagliato vengono invertiti di
1086 !!$posizione. L'algoritmo continua poi a scorrere tutta la lista finché
1087 !!$non vengono più eseguiti scambi, situazione che indica che la lista è
1088 !!$ordinata.
1089 !!$
1090 !!$Il Bubble sort non è un algoritmo efficiente
1091 !!$
1092 !!$SUBROUTINE Bubble_Sort(a)
1093 !!$ REAL, INTENT(in out), DIMENSION(:) :: a
1094 !!$ REAL :: temp
1095 !!$ INTEGER :: i, j
1096 !!$ LOGICAL :: swapped
1097 !!$
1098 !!$ DO j = SIZE(a)-1, 1, -1
1099 !!$ swapped = .FALSE.
1100 !!$ DO i = 1, j
1101 !!$ IF (a(i) > a(i+1)) THEN
1102 !!$ temp = a(i)
1103 !!$ a(i) = a(i+1)
1104 !!$ a(i+1) = temp
1105 !!$ swapped = .TRUE.
1106 !!$ END IF
1107 !!$ END DO
1108 !!$ IF (.NOT. swapped) EXIT
1109 !!$ END DO
1110 !!$END SUBROUTINE Bubble_Sort
1111 
1112 
1113 !!$ lo Shaker sort, noto anche come Bubble sort bidirezionale, Cocktail
1114 !!$ sort, Cocktail shaker sort, Ripple sort, Happy hour sort o Shuttle
1115 !!$ sort è un algoritmo di ordinamento dei dati sviluppato dalla Sun
1116 !!$ Microsystems. Lo shaker sort è sostanzialmente una variante del
1117 !!$ bubble sort: si differenzia da quest'ultimo per l'indice del ciclo
1118 !!$ più interno che, anziché scorrere dall'inizio alla fine, inverte la
1119 !!$ sua direzione ad ogni ciclo. Pur mantenendo la stessa complessità,
1120 !!$ ovvero O(n²), lo shaker sort riduce la probabilità che l'ordinamento
1121 !!$ abbia un costo corrispondente al caso peggiore.
1122 !!$
1123 !!$
1124 !!$ SUBROUTINE Cocktail_sort(a)
1125 !!$ INTEGER, INTENT(IN OUT) :: a(:)
1126 !!$ INTEGER :: i, bottom, top, temp
1127 !!$ LOGICAL :: swapped
1128 !!$
1129 !!$ bottom = 1
1130 !!$ top = SIZE(a) - 1
1131 !!$ DO WHILE (bottom < top )
1132 !!$ swapped = .FALSE.
1133 !!$ DO i = bottom, top
1134 !!$ IF (array(i) > array(i+1)) THEN
1135 !!$ temp = array(i)
1136 !!$ array(i) = array(i+1)
1137 !!$ array(i+1) = temp
1138 !!$ swapped = .TRUE.
1139 !!$ END IF
1140 !!$ END DO
1141 !!$ IF (.NOT. swapped) EXIT
1142 !!$ DO i = top, bottom + 1, -1
1143 !!$ IF (array(i) < array(i-1)) THEN
1144 !!$ temp = array(i)
1145 !!$ array(i) = array(i-1)
1146 !!$ array(i-1) = temp
1147 !!$ swapped = .TRUE.
1148 !!$ END IF
1149 !!$ END DO
1150 !!$ IF (.NOT. swapped) EXIT
1151 !!$ bottom = bottom + 1
1152 !!$ top = top - 1
1153 !!$ END DO
1154 !!$ END SUBROUTINE Cocktail_sort
1155 
1156 #endif
Index method.

Generated with Doxygen.