libsim Versione 7.1.11
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
24FUNCTION count_distinct_sorted/**/vol7d_poly_types(vect, mask) RESULT(count_distinct_sorted)
25vol7d_poly_type,INTENT(in) :: vect(:)
26LOGICAL,INTENT(in),OPTIONAL :: mask(:)
27INTEGER :: count_distinct_sorted
28
29INTEGER :: i, j
30
31count_distinct_sorted = 0
32
33j=1
34i = 1
35do 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
52end do
53
54END FUNCTION count_distinct_sorted/**/vol7d_poly_types
55#endif
56
58FUNCTION count_distinct/**/vol7d_poly_types(vect, mask, back) RESULT(count_distinct)
59vol7d_poly_type,INTENT(in) :: vect(:)
60LOGICAL,INTENT(in),OPTIONAL :: mask(:), back
61INTEGER :: count_distinct
62
63#ifdef VOL7D_POLY_TYPE_AUTO
64vol7d_poly_type_auto(vect) :: pack_distinct(SIZE(vect))
65#else
66vol7d_poly_type :: pack_distinct(SIZE(vect))
67#endif
68INTEGER :: i, j
69LOGICAL :: lback
70
71IF (PRESENT(back)) THEN
72 lback = back
73ELSE
74 lback = .false.
75ENDIF
76count_distinct = 0
77
78IF (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
104ELSE
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
126ENDIF
127
128END FUNCTION count_distinct/**/vol7d_poly_types
129
130
131#ifndef VOL7D_NO_PACK
132
133#ifdef ENABLE_SORT
134
135FUNCTION pack_distinct_sorted/**/vol7d_poly_types(vect, dim, mask) &
136 result(pack_distinct_sorted)
137vol7d_poly_type,INTENT(in) :: vect(:)
138INTEGER,INTENT(in) :: dim
139LOGICAL,INTENT(in),OPTIONAL :: mask(:)
140vol7d_poly_type :: pack_distinct_sorted(dim)
141
142INTEGER :: i,count_distinct
143
144if (dim < 1) return
145
146count_distinct = 0
147
148DO 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
162ENDDO
163
164END FUNCTION pack_distinct_sorted/**/vol7d_poly_types
165#endif
166
168FUNCTION pack_distinct/**/vol7d_poly_types(vect, dim, mask, back) &
169 result(pack_distinct)
170vol7d_poly_type,INTENT(in) :: vect(:)
171INTEGER,INTENT(in) :: dim
172LOGICAL,INTENT(in),OPTIONAL :: mask(:), back
173vol7d_poly_type :: pack_distinct(dim)
174
175INTEGER :: count_distinct
176INTEGER :: i, j
177LOGICAL :: lback
178
179IF (PRESENT(back)) THEN
180 lback = back
181ELSE
182 lback = .false.
183ENDIF
184count_distinct = 0
185
186IF (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
214ELSE
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
238ENDIF
239
240END FUNCTION pack_distinct/**/vol7d_poly_types
241
242
243FUNCTION count_and_pack_distinct/**/vol7d_poly_types(vect, pack_distinct, mask, back) RESULT(count_distinct)
244vol7d_poly_type,INTENT(in) :: vect(:)
245#ifdef VOL7D_POLY_TYPE_AUTO
246vol7d_poly_type_auto(vect),INTENT(out) :: pack_distinct(:)
247#else
248vol7d_poly_type,INTENT(out) :: pack_distinct(:)
249#endif
250LOGICAL,INTENT(in),OPTIONAL :: mask(:), back
251INTEGER :: count_distinct
252
253INTEGER :: i, j
254LOGICAL :: lback
255
256IF (PRESENT(back)) THEN
257 lback = back
258ELSE
259 lback = .false.
260ENDIF
261count_distinct = 0
262
263IF (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
289ELSE
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
311ENDIF
312
313END FUNCTION count_and_pack_distinct/**/vol7d_poly_types
314#endif
315
317FUNCTION map_distinct/**/vol7d_poly_types(vect, mask, back) RESULT(map_distinct)
318vol7d_poly_type,INTENT(in) :: vect(:)
319LOGICAL,INTENT(in),OPTIONAL :: mask(:), back
320INTEGER :: map_distinct(SIZE(vect))
321
322INTEGER :: count_distinct
323#ifdef VOL7D_POLY_TYPE_AUTO
324vol7d_poly_type_auto(vect) :: pack_distinct(SIZE(vect))
325#else
326vol7d_poly_type :: pack_distinct(SIZE(vect))
327#endif
328INTEGER :: i, j
329LOGICAL :: lback
330
331IF (PRESENT(back)) THEN
332 lback = back
333ELSE
334 lback = .false.
335ENDIF
336count_distinct = 0
337map_distinct(:) = 0
338
339IF (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
375ELSE
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
407ENDIF
408
409END FUNCTION map_distinct/**/vol7d_poly_types
410
411
413FUNCTION map_inv_distinct/**/vol7d_poly_types(vect, dim, mask, back) &
414 result(map_inv_distinct)
415vol7d_poly_type,INTENT(in) :: vect(:)
416INTEGER,INTENT(in) :: dim
417LOGICAL,INTENT(in),OPTIONAL :: mask(:), back
418INTEGER :: map_inv_distinct(dim)
419
420INTEGER :: count_distinct
421#ifdef VOL7D_POLY_TYPE_AUTO
422vol7d_poly_type_auto(vect) :: pack_distinct(SIZE(vect))
423#else
424vol7d_poly_type :: pack_distinct(SIZE(vect))
425#endif
426INTEGER :: i, j
427LOGICAL :: lback
428
429IF (PRESENT(back)) THEN
430 lback = back
431ELSE
432 lback = .false.
433ENDIF
434count_distinct = 0
435map_inv_distinct(:) = 0
436
437IF (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
467ELSE
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
493ENDIF
494
495END FUNCTION map_inv_distinct/**/vol7d_poly_types
496
497
499FUNCTION index/**/vol7d_poly_types(vect, search, mask, back, cache) &
500 result(index_)
501vol7d_poly_type,INTENT(in) :: vect(:), search
502LOGICAL,INTENT(in),OPTIONAL :: mask(:)
503LOGICAL,INTENT(in),OPTIONAL :: back
504INTEGER,INTENT(in),OPTIONAL :: cache
505INTEGER :: index_
506
507INTEGER :: i, lcache
508LOGICAL :: lback
509
510IF (PRESENT(back)) THEN
511 lback = back
512ELSE
513 lback = .false.
514ENDIF
515index_ = 0
516
517IF (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
535ELSE
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
567ENDIF
568
569END FUNCTION index/**/vol7d_poly_types
570
571
572#ifdef ENABLE_SORT
573
574
576recursive FUNCTION index_sorted/**/vol7d_poly_types(vect, search) &
577 result(index_)
578vol7d_poly_type,INTENT(in) :: vect(:), search
579INTEGER :: index_
580
581integer :: 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
613END 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
698Subroutine sort/**/vol7d_poly_types (XDONT)
699
700! Sorts XDONT into ascending order - Quicksort
701! Michel Olagnon - Apr. 2000
702! _________________________________________________________
703
704vol7d_poly_type, Dimension (:), Intent (InOut) :: xdont
705integer :: 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
713End Subroutine sort/**/vol7d_poly_types
714Recursive 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
867subroutine heapsort/**/vol7d_poly_types(a)
868
869vol7d_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
877integer :: start, n, bottom
878
879n = size(a)
880do start = (n - 2) / 2, 0, -1
881 call siftdown(a, start, n);
882end do
883
884do bottom = n - 1, 1, -1
885 temp = a(0)
886 a(0) = a(bottom)
887 a(bottom) = temp;
888 call siftdown(a, 0, bottom)
889end do
890
891contains
892subroutine siftdown(a, start, bottom)
893
894vol7d_poly_type, intent(in out) :: a(0:)
895
896#ifdef VOL7D_POLY_TYPE_AUTO
897vol7d_poly_type_auto(a) :: temp
898#else
899vol7d_poly_type :: temp
900#endif
901
902integer, intent(in) :: start, bottom
903integer :: child, root
904
905root = start
906do 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
921end do
922
923end subroutine siftdown
924
925end 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!*****************************************************
945SUBROUTINE hpsort/**/vol7d_poly_types(RA)
946
947vol7d_poly_type,intent(INOUT) :: ra(:)
948
949#ifdef VOL7D_POLY_TYPE_AUTO
950vol7d_poly_type_auto(ra) :: rra
951#else
952vol7d_poly_type rra
953#endif
954
955integer :: i,j,l,ir
956
957ir=size(ra)
958l=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.
964do 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
979do 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
989end do
990
991ra(i)=rra
992
993end do
994
995END 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.