-
Notifications
You must be signed in to change notification settings - Fork 0
/
binary_heap.f90
132 lines (94 loc) · 3.04 KB
/
binary_heap.f90
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
MODULE binary_heap
USE vector
IMPLICIT NONE
PUBLIC :: HEAPIFY, HEAP_PUSH, HEAP_POP, HEAP_GET_KEY, HEAP_GET_VALUE
PRIVATE :: SIFT_UP, SIFT_DOWN, GET_KEY
TYPE :: HEAP_ELEM
INTEGER :: KEY
CLASS(*), ALLOCATABLE :: VALUE
END TYPE HEAP_ELEM
CONTAINS
SUBROUTINE HEAPIFY(V)
TYPE(VEC), INTENT(INOUT) :: V
INTEGER :: I
DO I = SHIFTR(V%SIZE, 1), 1, -1
CALL SIFT_DOWN(V, I)
END DO
END SUBROUTINE HEAPIFY
SUBROUTINE HEAP_PUSH(V, KEY, VALUE)
TYPE(VEC), INTENT(INOUT) :: V
INTEGER, INTENT(IN) :: KEY
CLASS(*), INTENT(IN) :: VALUE
TYPE(HEAP_ELEM) :: ELEM
ELEM%KEY = KEY
ALLOCATE (ELEM%VALUE, SOURCE=VALUE)
CALL VEC_PUSH_BACK(V, ELEM)
CALL SIFT_UP(V, V%SIZE)
END SUBROUTINE HEAP_PUSH
SUBROUTINE HEAP_POP(V)
TYPE(VEC), INTENT(INOUT) :: V
IF (V%SIZE > 1) THEN
V%DATA(1)%VALUE = V%DATA(V%SIZE)%VALUE
CALL VEC_POP_BACK(V)
CALL SIFT_DOWN(V, 1)
ELSE
CALL VEC_POP_BACK(V)
END IF
END SUBROUTINE HEAP_POP
FUNCTION HEAP_GET_KEY(V) RESULT(KEY)
TYPE(VEC), INTENT(INOUT) :: V
INTEGER :: KEY
KEY = GET_KEY(V, 1)
END FUNCTION HEAP_GET_KEY
FUNCTION HEAP_GET_VALUE(V) RESULT(VALUE)
TYPE(VEC), INTENT(INOUT) :: V
CLASS(*), ALLOCATABLE :: VALUE
SELECT TYPE (ELEM => V%DATA(1)%VALUE)
TYPE IS (HEAP_ELEM)
ALLOCATE (VALUE, SOURCE=ELEM%VALUE)
END SELECT
END FUNCTION HEAP_GET_VALUE
SUBROUTINE SIFT_UP(V, INDEX)
TYPE(VEC), INTENT(INOUT) :: V
INTEGER, INTENT(IN) :: INDEX
INTEGER :: CURRENT, PARENT
CURRENT = INDEX
PARENT = SHIFTR(CURRENT, 1)
DO WHILE (CURRENT > 1 .AND. GET_KEY(V, CURRENT) < GET_KEY(V, PARENT))
CALL VEC_SWAP(V, CURRENT, PARENT)
CURRENT = PARENT
PARENT = SHIFTR(CURRENT, 1)
END DO
END SUBROUTINE SIFT_UP
SUBROUTINE SIFT_DOWN(V, INDEX)
TYPE(VEC), INTENT(INOUT) :: V
INTEGER, INTENT(IN) :: INDEX
INTEGER :: CURRENT, LESS, LEFT, RIGHT
CURRENT = INDEX
DO
LESS = CURRENT
LEFT = SHIFTL(CURRENT, 1)
RIGHT = LEFT + 1
IF (LEFT <= V%SIZE .AND. GET_KEY(V, LEFT) < GET_KEY(V, LESS)) THEN
LESS = LEFT
END IF
IF (RIGHT <= V%SIZE .AND. GET_KEY(V, RIGHT) < GET_KEY(V, LESS)) THEN
LESS = RIGHT
END IF
IF (LESS == CURRENT) THEN
EXIT
END IF
CALL VEC_SWAP(V, CURRENT, LESS)
CURRENT = LESS
END DO
END SUBROUTINE SIFT_DOWN
FUNCTION GET_KEY(V, INDEX) RESULT(KEY)
TYPE(VEC), INTENT(INOUT) :: V
INTEGER, INTENT(IN) :: INDEX
INTEGER :: KEY
SELECT TYPE (ELEM => V%DATA(INDEX)%VALUE)
TYPE IS (HEAP_ELEM)
KEY = ELEM%KEY
END SELECT
END FUNCTION GET_KEY
END MODULE binary_heap