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
31 count_distinct_sorted = 0
35 do while (i <=
size(vect))
36 if (
present(mask))
then 37 do while (.not. mask(i))
39 if ( i >
size(vect))
return 43 if (i==j) count_distinct_sorted = count_distinct_sorted + 1
45 if (vect(j) /= vect(i))
then 46 count_distinct_sorted = count_distinct_sorted + 1
54 END FUNCTION count_distinct_sorted/**/vol7d_poly_types
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
63 #ifdef VOL7D_POLY_TYPE_AUTO 64 vol7d_poly_type_auto(vect) :: pack_distinct(
SIZE(vect))
66 vol7d_poly_type :: pack_distinct(
SIZE(vect))
71 IF (
PRESENT(back))
THEN 78 IF (
PRESENT (mask))
THEN 80 vectm1:
DO i = 1,
SIZE(vect)
81 IF (.NOT.mask(i)) cycle vectm1
85 DO j = count_distinct, 1, -1
86 IF (pack_distinct(j) == vect(i)) cycle vectm1
88 count_distinct = count_distinct + 1
89 pack_distinct(count_distinct) = vect(i)
92 vectm2:
DO i = 1,
SIZE(vect)
93 IF (.NOT.mask(i)) cycle vectm2
97 DO j = 1, count_distinct
98 IF (pack_distinct(j) == vect(i)) cycle vectm2
100 count_distinct = count_distinct + 1
101 pack_distinct(count_distinct) = vect(i)
106 vect1:
DO i = 1,
SIZE(vect)
109 DO j = count_distinct, 1, -1
110 IF (pack_distinct(j) == vect(i)) cycle vect1
112 count_distinct = count_distinct + 1
113 pack_distinct(count_distinct) = vect(i)
116 vect2:
DO i = 1,
SIZE(vect)
119 DO j = 1, count_distinct
120 IF (pack_distinct(j) == vect(i)) cycle vect2
122 count_distinct = count_distinct + 1
123 pack_distinct(count_distinct) = vect(i)
128 END FUNCTION count_distinct/**/vol7d_poly_types
131 #ifndef VOL7D_NO_PACK 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)
142 INTEGER :: i,count_distinct
149 IF (
PRESENT (mask))
THEN 150 IF (.NOT.mask(i)) cycle
153 if (count_distinct == 0)
then 154 count_distinct = count_distinct + 1
155 pack_distinct_sorted(count_distinct)=vect(i)
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)
164 END FUNCTION pack_distinct_sorted/**/vol7d_poly_types
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)
175 INTEGER :: count_distinct
179 IF (
PRESENT(back))
THEN 186 IF (
PRESENT (mask))
THEN 188 vectm1:
DO i = 1,
SIZE(vect)
189 IF (.NOT.mask(i)) cycle vectm1
193 DO j = count_distinct, 1, -1
194 IF (pack_distinct(j) == vect(i)) cycle vectm1
196 count_distinct = count_distinct + 1
197 IF (count_distinct > dim)
EXIT 198 pack_distinct(count_distinct) = vect(i)
201 vectm2:
DO i = 1,
SIZE(vect)
202 IF (.NOT.mask(i)) cycle vectm2
206 DO j = 1, count_distinct
207 IF (pack_distinct(j) == vect(i)) cycle vectm2
209 count_distinct = count_distinct + 1
210 IF (count_distinct > dim)
EXIT 211 pack_distinct(count_distinct) = vect(i)
216 vect1:
DO i = 1,
SIZE(vect)
219 DO j = count_distinct, 1, -1
220 IF (pack_distinct(j) == vect(i)) cycle vect1
222 count_distinct = count_distinct + 1
223 IF (count_distinct > dim)
EXIT 224 pack_distinct(count_distinct) = vect(i)
227 vect2:
DO i = 1,
SIZE(vect)
230 DO j = 1, count_distinct
231 IF (pack_distinct(j) == vect(i)) cycle vect2
233 count_distinct = count_distinct + 1
234 IF (count_distinct > dim)
EXIT 235 pack_distinct(count_distinct) = vect(i)
240 END FUNCTION pack_distinct/**/vol7d_poly_types
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(:)
248 vol7d_poly_type,
INTENT(out) :: pack_distinct(:)
250 LOGICAL,
INTENT(in),
OPTIONAL :: mask(:), back
251 INTEGER :: count_distinct
256 IF (
PRESENT(back))
THEN 263 IF (
PRESENT (mask))
THEN 265 vectm1:
DO i = 1,
SIZE(vect)
266 IF (.NOT.mask(i)) cycle vectm1
270 DO j = count_distinct, 1, -1
271 IF (pack_distinct(j) == vect(i)) cycle vectm1
273 count_distinct = count_distinct + 1
274 pack_distinct(count_distinct) = vect(i)
277 vectm2:
DO i = 1,
SIZE(vect)
278 IF (.NOT.mask(i)) cycle vectm2
282 DO j = 1, count_distinct
283 IF (pack_distinct(j) == vect(i)) cycle vectm2
285 count_distinct = count_distinct + 1
286 pack_distinct(count_distinct) = vect(i)
291 vect1:
DO i = 1,
SIZE(vect)
294 DO j = count_distinct, 1, -1
295 IF (pack_distinct(j) == vect(i)) cycle vect1
297 count_distinct = count_distinct + 1
298 pack_distinct(count_distinct) = vect(i)
301 vect2:
DO i = 1,
SIZE(vect)
304 DO j = 1, count_distinct
305 IF (pack_distinct(j) == vect(i)) cycle vect2
307 count_distinct = count_distinct + 1
308 pack_distinct(count_distinct) = vect(i)
313 END FUNCTION count_and_pack_distinct/**/vol7d_poly_types
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))
322 INTEGER :: count_distinct
323 #ifdef VOL7D_POLY_TYPE_AUTO 324 vol7d_poly_type_auto(vect) :: pack_distinct(
SIZE(vect))
326 vol7d_poly_type :: pack_distinct(
SIZE(vect))
331 IF (
PRESENT(back))
THEN 339 IF (
PRESENT (mask))
THEN 341 vectm1:
DO i = 1,
SIZE(vect)
342 IF (.NOT.mask(i)) cycle vectm1
347 DO j = count_distinct, 1, -1
348 IF (pack_distinct(j) == vect(i))
THEN 353 count_distinct = count_distinct + 1
354 pack_distinct(count_distinct) = vect(i)
355 map_distinct(i) = count_distinct
358 vectm2:
DO i = 1,
SIZE(vect)
359 IF (.NOT.mask(i)) cycle vectm2
364 DO j = 1, count_distinct
365 IF (pack_distinct(j) == vect(i))
THEN 370 count_distinct = count_distinct + 1
371 pack_distinct(count_distinct) = vect(i)
372 map_distinct(i) = count_distinct
377 vect1:
DO i = 1,
SIZE(vect)
381 DO j = count_distinct, 1, -1
382 IF (pack_distinct(j) == vect(i))
THEN 387 count_distinct = count_distinct + 1
388 pack_distinct(count_distinct) = vect(i)
389 map_distinct(i) = count_distinct
392 vect2:
DO i = 1,
SIZE(vect)
396 DO j = 1, count_distinct
397 IF (pack_distinct(j) == vect(i))
THEN 402 count_distinct = count_distinct + 1
403 pack_distinct(count_distinct) = vect(i)
404 map_distinct(i) = count_distinct
409 END FUNCTION map_distinct/**/vol7d_poly_types
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)
420 INTEGER :: count_distinct
421 #ifdef VOL7D_POLY_TYPE_AUTO 422 vol7d_poly_type_auto(vect) :: pack_distinct(
SIZE(vect))
424 vol7d_poly_type :: pack_distinct(
SIZE(vect))
429 IF (
PRESENT(back))
THEN 435 map_inv_distinct(:) = 0
437 IF (
PRESENT (mask))
THEN 439 vectm1:
DO i = 1,
SIZE(vect)
440 IF (.NOT.mask(i)) cycle vectm1
444 DO j = count_distinct, 1, -1
445 IF (pack_distinct(j) == vect(i)) cycle vectm1
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
453 vectm2:
DO i = 1,
SIZE(vect)
454 IF (.NOT.mask(i)) cycle vectm2
458 DO j = 1, count_distinct
459 IF (pack_distinct(j) == vect(i)) cycle vectm2
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
469 vect1:
DO i = 1,
SIZE(vect)
472 DO j = count_distinct, 1, -1
473 IF (pack_distinct(j) == vect(i)) cycle vect1
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
481 vect2:
DO i = 1,
SIZE(vect)
484 DO j = 1, count_distinct
485 IF (pack_distinct(j) == vect(i)) cycle vect2
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
495 END FUNCTION map_inv_distinct/**/vol7d_poly_types
499 FUNCTION index/**/vol7d_poly_types(vect, search, mask, back, cache) &
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
510 IF (
PRESENT(back))
THEN 517 IF (
PRESENT (mask))
THEN 519 vectm1:
DO i =
SIZE(vect), 1, -1
520 IF (.NOT.mask(i)) cycle vectm1
521 IF (vect(i) == search)
THEN 527 vectm2:
DO i = 1,
SIZE(vect)
528 IF (.NOT.mask(i)) cycle vectm2
529 IF (vect(i) == search)
THEN 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 545 IF (vect(i) == search)
THEN 552 vect1:
DO i =
SIZE(vect), 1, -1
553 IF (vect(i) == search)
THEN 559 vect2:
DO i = 1,
SIZE(vect)
560 IF (vect(i) == search)
THEN 569 END FUNCTION index/**/vol7d_poly_types
576 recursive FUNCTION index_sorted/**/vol7d_poly_types(vect, search) &
578 vol7d_poly_type,
INTENT(in) :: vect(:), search
583 mid =
size(vect)/2 + 1
596 if (
size(vect) < 10)
then 598 index_=
index(vect, search)
600 else if (vect(mid) > search)
then 602 index_= index_sorted/**/vol7d_poly_types(vect(:mid-1), search)
603 else if (vect(mid) < search)
then 605 index_ = index_sorted/**/vol7d_poly_types(vect(mid+1:), search)
606 if (index_ /= 0)
then 607 index_ = mid + index_
613 END FUNCTION index_sorted/**/vol7d_poly_types
698 Subroutine sort/**/vol7d_poly_types (XDONT)
704 vol7d_poly_type,
Dimension (:),
Intent (InOut) :: xdont
710 Call subsor/**/vol7d_poly_types(xdont, 1,
Size (xdont), recursion)
711 Call inssor/**/vol7d_poly_types(xdont)
713 End Subroutine sort/**/vol7d_poly_types
714 Recursive Subroutine subsor/**/vol7d_poly_types (XDONT, IDEB1, IFIN1, recursion)
717 vol7d_poly_type,
dimension (:),
Intent (InOut) :: xdont
718 Integer,
Intent (In) :: IDEB1, IFIN1
719 Integer,
Intent (InOut) :: recursion
721 Integer,
Parameter :: NINS = 16 , maxrec=5000
722 Integer :: ICRS, IDEB, IDCR, IFIN, IMIL
724 #ifdef VOL7D_POLY_TYPE_AUTO 725 vol7d_poly_type_auto(xdont) :: xpiv, xwrk
727 vol7d_poly_type :: xpiv, xwrk
730 print *,
"recursion:",recursion
732 recursion=recursion+1
739 If ((ifin - ideb) > nins .and. recursion <= maxrec*2 )
Then 740 print *,
"subsor:",ifin-ideb
742 imil = (ideb+ifin) / 2
746 If (xdont(imil) < xdont(ideb))
Then 748 xdont(ideb) = xdont(imil)
751 If (xdont(imil) > xdont(ifin))
Then 753 xdont(ifin) = xdont(imil)
755 If (xdont(imil) < xdont(ideb))
Then 757 xdont(ideb) = xdont(imil)
771 If (icrs >= idcr)
Then 783 If (xdont(icrs) > xpiv)
Exit 786 If (xdont(idcr) <= xpiv)
Exit 788 If (icrs >= idcr)
Then 797 xdont(idcr) = xdont(icrs)
803 Call subsor/**/vol7d_poly_types(xdont, ideb1, icrs-1, recursion)
804 Call subsor/**/vol7d_poly_types(xdont, idcr, ifin1, recursion)
811 End Subroutine Subsor/**/vol7d_poly_types
823 Subroutine inssor/**/vol7d_poly_types (XDONT)
826 vol7d_poly_type,
dimension (:),
Intent (InOut) :: xdont
828 Integer :: ICRS, IDCR
830 #ifdef VOL7D_POLY_TYPE_AUTO 831 vol7d_poly_type_auto(xdont) :: xwrk
833 vol7d_poly_type :: xwrk
836 print *,
"inssor:",
size(xdont)
839 Do icrs = 2,
Size (xdont)
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)
852 End Subroutine inssor/**/vol7d_poly_types
867 subroutine heapsort/**/vol7d_poly_types(a)
869 vol7d_poly_type,
intent(in out) :: a(0:)
871 #ifdef VOL7D_POLY_TYPE_AUTO 872 vol7d_poly_type_auto(a) :: temp
874 vol7d_poly_type :: temp
877 integer :: start, n, bottom
880 do start = (n - 2) / 2, 0, -1
881 call siftdown(a, start, n);
884 do bottom = n - 1, 1, -1
888 call siftdown(a, 0, bottom)
892 subroutine siftdown(a, start, bottom)
894 vol7d_poly_type,
intent(in out) :: a(0:)
896 #ifdef VOL7D_POLY_TYPE_AUTO 897 vol7d_poly_type_auto(a) :: temp
899 vol7d_poly_type :: temp
902 integer,
intent(in) :: start, bottom
903 integer :: child, root
906 do while(root*2 + 1 < bottom)
909 if (child + 1 < bottom)
then 910 if (a(child) < a(child+1)) child = child + 1
913 if (a(root) < a(child))
then 923 end subroutine siftdown
925 end subroutine heapsort/**/vol7d_poly_types
945 SUBROUTINE hpsort/**/vol7d_poly_types(RA)
947 vol7d_poly_type,
intent(INOUT) :: ra(:)
949 #ifdef VOL7D_POLY_TYPE_AUTO 950 vol7d_poly_type_auto(ra) :: rra
981 if(ra(j) < ra(j+1)) j=j+1
995 END SUBROUTINE HPSORT/**/vol7d_poly_types