|
CP2K 2.4 (Revision 12889)
|
00001 !-----------------------------------------------------------------------------! 00002 ! CP2K: A general program to perform molecular dynamics simulations ! 00003 ! Copyright (C) 2000 - 2013 CP2K developers group ! 00004 !-----------------------------------------------------------------------------! 00005 00006 ! ***************************************************************************** 00014 00015 MODULE btree_i8_k_cp2d_v 00016 00017 IMPLICIT NONE 00018 00019 PUBLIC :: btree 00020 PUBLIC :: btree_new, btree_add, btree_remove, btree_find,& 00021 btree_print_short, btree_delete, btree_get_entries 00022 00023 !PUBLIC keyt, valt 00024 00025 !INTEGER*8 :: ex_int64 00026 !INTEGER*4 :: ex_int32 00027 !INTEGER, PARAMETER :: keyt = KIND(ex_int64) 00028 !INTEGER, PARAMETER :: valt = KIND(ex_int32) 00029 00030 INTEGER, PARAMETER :: keyt = SELECTED_INT_KIND(10) 00031 INTEGER, PARAMETER :: valt = SELECTED_INT_KIND(5); 00032 INTEGER, PARAMETER :: sp = KIND(0.0) 00033 00034 TYPE cp2d 00035 COMPLEX(KIND=sp), DIMENSION(:,:), POINTER :: p 00036 LOGICAL :: tr 00037 END TYPE cp2d 00038 00039 PUBLIC :: cp2d 00040 00041 TYPE btree_node 00042 INTEGER id 00043 INTEGER :: filled 00044 INTEGER(KIND=keyt), DIMENSION(:), POINTER :: keys 00045 TYPE(cp2d), DIMENSION(:), POINTER :: values 00046 TYPE(btree_node_p), DIMENSION(:), POINTER :: subtrees 00047 TYPE(btree_node), POINTER :: parent 00048 END TYPE btree_node 00049 00050 TYPE btree_node_p 00051 TYPE(btree_node), POINTER :: node 00052 END TYPE btree_node_p 00053 00054 TYPE btree_node_structure 00055 INTEGER :: min_fill, max_fill 00056 INTEGER :: n 00057 INTEGER :: lastid 00058 INTEGER :: refcount 00059 TYPE(btree_node), POINTER :: root 00060 END TYPE btree_node_structure 00061 00062 TYPE btree 00063 TYPE(btree_node_structure) :: b 00064 END TYPE btree 00065 00066 CONTAINS 00067 00068 SUBROUTINE btree_new (tree, order) 00069 TYPE(btree), INTENT(OUT) :: tree 00070 INTEGER, INTENT(IN), OPTIONAL :: order 00071 00072 INTEGER :: maxs, mins 00073 00074 ! 00075 00076 IF (PRESENT (order)) THEN 00077 maxs = order-1 00078 ELSE 00079 maxs = 15 00080 ENDIF 00081 mins = ISHFT (maxs, -1) 00082 IF (mins*2 .GT. maxs) maxs = 2*maxs 00083 IF (mins .LT. 1) mins = 1 00084 IF (maxs .LT. 3) maxs = 3 00085 tree%b%min_fill = mins 00086 tree%b%max_fill = maxs 00087 tree%b%refcount = 1 00088 tree%b%n = 0 00089 NULLIFY(tree%b%root) 00090 tree%b%lastid = 0 00091 END SUBROUTINE btree_new 00092 00093 FUNCTION btree_get_entries (tree) RESULT (num_entries) 00094 TYPE(btree), INTENT(INOUT) :: tree 00095 INTEGER :: num_entries 00096 00097 num_entries = tree%b%n 00098 END FUNCTION btree_get_entries 00099 00100 00101 SUBROUTINE btree_delete (tree, keys, values) 00102 TYPE(btree), INTENT(INOUT) :: tree 00103 INTEGER(KIND=keyt), DIMENSION(:), 00104 INTENT(OUT), OPTIONAL :: keys 00105 TYPE(cp2d), DIMENSION(:), INTENT(OUT), 00106 OPTIONAL :: values 00107 00108 INTEGER :: pos 00109 00110 ! 00111 00112 IF (ASSOCIATED (tree%b%root)) THEN 00113 pos = 0 00114 IF (PRESENT (keys) .AND. PRESENT (values)) THEN 00115 pos = 1 00116 CALL btree_delete_node(tree%b%root, pos, keys, values) 00117 ELSE 00118 CALL btree_delete_node(tree%b%root) 00119 ENDIF 00120 ENDIF 00121 NULLIFY (tree%b%root) 00122 END SUBROUTINE btree_delete 00123 00124 RECURSIVE SUBROUTINE btree_delete_node (node, pos, keys, values) 00125 TYPE(btree_node), POINTER :: node 00126 INTEGER, INTENT(INOUT), OPTIONAL :: pos 00127 INTEGER(KIND=keyt), DIMENSION(:), 00128 INTENT(INOUT), OPTIONAL :: keys 00129 TYPE(cp2d), DIMENSION(:), 00130 INTENT(INOUT), OPTIONAL :: values 00131 00132 INTEGER :: i 00133 00134 ! 00135 ! 00136 00137 IF (node%filled.GT.0 .AND. ASSOCIATED (node%subtrees(1)%node)) THEN 00138 DO i = 1, node%filled+1 00139 IF (PRESENT (pos)) THEN 00140 CALL btree_delete_node (node%subtrees(i)%node, pos, keys, values) 00141 ELSE 00142 CALL btree_delete_node (node%subtrees(i)%node) 00143 ENDIF 00144 IF (PRESENT (pos) .AND. i .LE. node%filled) THEN 00145 keys(pos) = node%keys(i) 00146 values(pos) = node%values(i) 00147 pos = pos+1 00148 ENDIF 00149 ENDDO 00150 ELSEIF (PRESENT (pos) .AND. node%filled .GT. 0) THEN 00151 keys(pos:pos+node%filled-1) = node%keys(1:node%filled) 00152 values(pos:pos+node%filled-1) = node%values(1:node%filled) 00153 pos = pos+node%filled 00154 ENDIF 00155 CALL btree_free_node (node) 00156 END SUBROUTINE btree_delete_node 00157 00158 00159 ! Find the key 00160 ! IF node still has space, insert & update the node 00161 ! else 00162 ! 1. select median 00163 ! 2. split keys into two nodes (one is new) 00164 ! 3. insert separation key put into parent, and repeat upwards 00165 SUBROUTINE btree_add (tree, key, value, exists, existing_value, replace) 00166 TYPE(btree), INTENT(INOUT) :: tree 00167 INTEGER(KIND=keyt), INTENT(IN) :: key 00168 TYPE(cp2d), INTENT(IN) :: value 00169 LOGICAL, INTENT(OUT), OPTIONAL :: exists 00170 TYPE(cp2d), INTENT(OUT), OPTIONAL :: existing_value 00171 LOGICAL, INTENT(IN), OPTIONAL :: replace 00172 00173 INTEGER :: ge_pos, position 00174 TYPE(btree_node), POINTER :: node 00175 00176 ! 00177 ! 00178 00179 IF (PRESENT (exists)) THEN 00180 CALL btree_find_full (tree, key, node, position, ge_pos, short=.TRUE.) 00181 IF (position .GT. 0) THEN 00182 exists = .TRUE. 00183 existing_value = node%values(position) 00184 IF (PRESENT (replace)) THEN 00185 IF (replace) THEN 00186 node%values(position) = value 00187 ENDIF 00188 ENDIF 00189 RETURN 00190 ELSE 00191 exists = .FALSE. 00192 ENDIF 00193 ELSE 00194 CALL btree_find_leaf (tree, key, node, ge_pos) 00195 ENDIF 00196 CALL btree_add_into (tree, node, key, value, before=ge_pos) 00197 IF (PRESENT (exists)) existing_value = value 00198 tree%b%n = tree%b%n+1 00199 END SUBROUTINE btree_add 00200 00201 00202 RECURSIVE SUBROUTINE btree_add_into (tree, node, key, value, before, subtree) 00203 TYPE(btree), INTENT(INOUT) :: tree 00204 TYPE(btree_node), POINTER :: node 00205 INTEGER(KIND=keyt), INTENT(IN) :: key 00206 TYPE(cp2d), INTENT(IN) :: value 00207 INTEGER, INTENT(IN), OPTIONAL :: before 00208 TYPE(btree_node), OPTIONAL, POINTER :: subtree 00209 00210 INTEGER :: ge_pos, split_pos 00211 INTEGER(KIND=keyt) :: upgrade_key 00212 LOGICAL :: leaf 00213 TYPE(btree_node), POINTER :: new_node 00214 TYPE(cp2d) :: upgrade_value 00215 00216 ! 00217 ! 00218 ! Root is special 00219 00220 IF (.NOT. ASSOCIATED (node)) THEN 00221 CALL btree_new_root (tree, key, value) 00222 IF (PRESENT (subtree)) THEN 00223 tree%b%root%subtrees(2)%node => subtree 00224 subtree%parent => tree%b%root 00225 ENDIF 00226 RETURN 00227 ENDIF 00228 ! Where the insertion takes place. 00229 IF (PRESENT (before)) THEN 00230 ge_pos = before 00231 ELSE 00232 CALL btree_node_find_gt_pos (node%keys, key, ge_pos, node%filled) 00233 ENDIF 00234 ! Addition is easy if the node has enough space. 00235 leaf = .NOT. ASSOCIATED (node%subtrees(1)%node) 00236 IF (node%filled .LT. tree%b%max_fill) THEN 00237 IF (PRESENT (subtree)) THEN 00238 CALL btree_simple_insertion(node, key, value, ge_pos, subtree) 00239 ELSE 00240 CALL btree_simple_insertion(node, key, value, ge_pos) 00241 ENDIF 00242 RETURN 00243 ELSE 00244 split_pos = ISHFT (tree%b%max_fill+1, -1) 00245 ! I assert that split_pos <= SIZE(node%keys) 00246 CALL btree_new_node (tree, new_node) 00247 ! The key to be added falls in the left node 00248 node%filled = split_pos-1 00249 IF (ge_pos .LE. split_pos) THEN 00250 IF (ge_pos .EQ. split_pos) THEN 00251 upgrade_key = key 00252 upgrade_value = value 00253 ELSE 00254 upgrade_key = node%keys(split_pos-1) 00255 upgrade_value = node%values(split_pos-1) 00256 ENDIF 00257 IF (PRESENT (subtree)) THEN 00258 CALL btree_left_insertion (tree, node, new_node, key, value,& 00259 ge_pos, split_pos, subtree) 00260 !CALL btree_adopt_subtrees (new_node) 00261 ELSE 00262 CALL btree_left_insertion (tree, node, new_node, key, value,& 00263 ge_pos, split_pos) 00264 ENDIF 00265 ! 00266 ELSE 00267 upgrade_key = node%keys(split_pos) 00268 upgrade_value = node%values(split_pos) 00269 IF (PRESENT (subtree)) THEN 00270 CALL btree_right_insertion (tree, node, new_node, key, value,& 00271 ge_pos, split_pos, subtree) 00272 !CALL btree_adopt_subtrees (new_node) 00273 ELSE 00274 CALL btree_right_insertion (tree, node, new_node, key, value,& 00275 ge_pos, split_pos) 00276 ENDIF 00277 ! 00278 ENDIF 00279 ! 00280 new_node%parent => node%parent 00281 ! 00282 IF (.NOT. leaf) THEN 00283 CALL btree_adopt_subtrees(new_node) 00284 ENDIF 00285 ! 00286 CALL btree_add_into (tree, node%parent, upgrade_key, upgrade_value,& 00287 subtree=new_node) 00288 ! 00289 ENDIF 00290 END SUBROUTINE btree_add_into 00291 00292 SUBROUTINE btree_simple_insertion (node, key, value, before, subtree) 00293 TYPE(btree_node), INTENT(INOUT) :: node 00294 INTEGER(KIND=keyt), INTENT(IN) :: key 00295 TYPE(cp2d), INTENT(IN) :: value 00296 INTEGER, INTENT(IN) :: before 00297 TYPE(btree_node), OPTIONAL, POINTER :: subtree 00298 00299 ! 00300 ! Shift keys 00301 00302 node%keys(before+1:node%filled+1) = node%keys(before:node%filled) 00303 node%keys(before) = key 00304 ! Shift values 00305 node%values(before+1:node%filled+1) = node%values(before:node%filled) 00306 node%values(before) = value 00307 ! Shift subtree pointers, but only if node is not a leaf ; assume 00308 ! leaf <=> present(subtree) 00309 IF (PRESENT (subtree)) THEN 00310 node%subtrees(before+2:node%filled+2) =& 00311 node%subtrees(before+1:node%filled+1) 00312 node%subtrees(before+1)%node => subtree 00313 ENDIF 00314 node%filled = node%filled+1 00315 END SUBROUTINE btree_simple_insertion 00316 00317 SUBROUTINE btree_left_insertion (tree, node, new_node, key, value, before, split_pos, subtree) 00318 TYPE(btree), INTENT(IN) :: tree 00319 TYPE(btree_node), INTENT(INOUT) :: node, new_node 00320 INTEGER(KIND=keyt), INTENT(IN) :: key 00321 TYPE(cp2d), INTENT(IN) :: value 00322 INTEGER, INTENT(IN) :: before, split_pos 00323 TYPE(btree_node), OPTIONAL, POINTER :: subtree 00324 00325 ! 00326 00327 new_node%filled = (tree%b%max_fill) - (split_pos-1) 00328 new_node%keys(1:new_node%filled) =& 00329 node%keys(split_pos:tree%b%max_fill) 00330 new_node%values(1:new_node%filled) =& 00331 node%values(split_pos:tree%b%max_fill) 00332 !IF (ASSOCIATED (node%subtrees(1)%node)) THEN 00333 IF (PRESENT (subtree)) THEN 00334 IF (before .EQ. split_pos) THEN 00335 new_node%subtrees(2:new_node%filled+1) =& 00336 node%subtrees(split_pos+1:tree%b%max_fill+1) 00337 new_node%subtrees(1)%node => subtree 00338 ELSE 00339 new_node%subtrees(1:new_node%filled+1) =& 00340 node%subtrees(split_pos:tree%b%max_fill+1) 00341 ENDIF 00342 ENDIF 00343 ! Fill node%{keys,values}(1:node%filled), where node%filled 00344 ! is split_pos-1, but do insert the new value at ge_pos. The 00345 ! key/value at split_pos is to be inserted into the 00346 ! parent. 00347 ! The new tree is added to the right of the new insertion. 00348 node%keys(before+1:node%filled) = node%keys(before:node%filled-1) 00349 node%keys(before) = key 00350 node%values(before+1:node%filled) = node%values(before:node%filled-1) 00351 node%values(before) = value 00352 IF (PRESENT (subtree)) THEN 00353 node%subtrees(before+2:node%filled+1) =& 00354 node%subtrees(before+1:node%filled) 00355 node%subtrees(before+1)%node => subtree 00356 ELSE 00357 NULLIFY (node%subtrees(before+1)%node) 00358 ENDIF 00359 END SUBROUTINE btree_left_insertion 00360 00361 SUBROUTINE btree_right_insertion (tree, node, new_node, key, value, before, split_pos, subtree) 00362 TYPE(btree), INTENT(IN) :: tree 00363 TYPE(btree_node), INTENT(INOUT) :: node, new_node 00364 INTEGER(KIND=keyt), INTENT(IN) :: key 00365 TYPE(cp2d), INTENT(IN) :: value 00366 INTEGER, INTENT(IN) :: before, split_pos 00367 TYPE(btree_node), OPTIONAL, POINTER :: subtree 00368 00369 ! 00370 00371 new_node%filled = (tree%b%max_fill+1) - split_pos 00372 new_node%keys(1:before-split_pos-1) =& 00373 node%keys(split_pos+1:before-1) 00374 new_node%keys(before-split_pos) = key 00375 new_node%keys(before-split_pos+1:new_node%filled) =& 00376 node%keys(before:tree%b%max_fill) 00377 new_node%values(1:before-split_pos-1) =& 00378 node%values(split_pos+1:before-1) 00379 new_node%values(before-split_pos) = value 00380 new_node%values(before-split_pos+1:new_node%filled) =& 00381 node%values(before:tree%b%max_fill) 00382 IF (PRESENT (subtree)) THEN 00383 new_node%subtrees(1:before-split_pos) = & 00384 node%subtrees(split_pos+1:before) 00385 new_node%subtrees(before-split_pos+1)%node => subtree 00386 new_node%subtrees(before-split_pos+2:new_node%filled+1) =& 00387 node%subtrees(before+1:tree%b%max_fill+1) 00388 ENDIF 00389 END SUBROUTINE btree_right_insertion 00390 00391 ! node is a non-leaf node 00392 SUBROUTINE btree_adopt_subtrees (node) 00393 TYPE(btree_node), POINTER :: node 00394 00395 INTEGER :: i 00396 00397 ! 00398 ! Assume that node is not a leaf! 00399 00400 DO i = 1, node%filled+1 00401 !IF (ASSOCIATED (node%subtrees(i)%node)) THEN 00402 !IF (.NOT. ASSOCIATED (node%subtrees(i)%node%parent,& 00403 ! node)) THEN 00404 node%subtrees(i)%node%parent => node 00405 !ENDIF 00406 !ENDIF 00407 ENDDO 00408 END SUBROUTINE btree_adopt_subtrees 00409 00410 SUBROUTINE btree_remove (tree, key, value, exists) 00411 TYPE(btree), INTENT(INOUT) :: tree 00412 INTEGER(KIND=keyt), INTENT(IN) :: key 00413 TYPE(cp2d), INTENT(OUT), OPTIONAL :: value 00414 LOGICAL, INTENT(OUT), OPTIONAL :: exists 00415 00416 INTEGER :: ge_pos, position 00417 TYPE(btree_node), POINTER :: node 00418 00419 ! 00420 ! 00421 00422 CALL btree_find_full (tree, key, node, position, ge_pos, short=.TRUE.) 00423 IF (position .NE. 0) THEN 00424 IF (PRESENT (exists)) exists = .TRUE. 00425 IF (PRESENT (value)) value = node%values(position) 00426 tree%b%n = tree%b%n-1 00427 CALL btree_remove_from (tree, node, key, before=ge_pos) 00428 ELSE 00429 IF (PRESENT (exists)) exists = .FALSE. 00430 RETURN 00431 ENDIF 00432 END SUBROUTINE btree_remove 00433 00434 00435 ! When deleting, there are a few possibilities. 1) In a leaf node 00436 ! with more than a minimum number of elements, that element is 00437 ! deleted. 2.) In a leaf node with a minimum number of elements, 00438 ! that element is deleted and the tree must be adjusted. 3.) In an 00439 ! internal node with more than a minimum number of elements, that 00440 ! element is deleted and a new one brought in from the parent/sibling. 00441 00442 00443 ! 1) The keys and values greater than the deletee are, accordingly, 00444 ! shifted left. 00445 00446 ! 2) That node may be joined with a sibling node that also has only 00447 ! a minimum number of elements; it might be best to rearrange all of 00448 ! its siblings. Or, the element to be deleted is "brought in" from 00449 ! the parent and the parent must then take care of reordering 00450 ! itself. 00451 00452 ! 3) Delete the element and replace it with the largest element in 00453 ! the left subtree. Since the largest element is in a leaf node, the 00454 ! removal takes the form of one of the two leaf-node removal cases. 00455 00456 00457 SUBROUTINE btree_remove_from (tree, node, key_in, before) 00458 TYPE(btree), INTENT(INOUT) :: tree 00459 TYPE(btree_node), POINTER :: node 00460 INTEGER(KIND=keyt), INTENT(IN) :: key_in 00461 INTEGER, INTENT(IN), OPTIONAL :: before 00462 00463 INTEGER :: ge_pos, parent_pos 00464 INTEGER(KIND=keyt) :: key, raised_key 00465 TYPE(btree_node), POINTER :: descend_node, rebalance_node 00466 TYPE(cp2d) :: raised_value 00467 00468 ! 00469 ! 00470 00471 NULLIFY (rebalance_node) 00472 parent_pos = 0 00473 ! Position to delete from 00474 IF (PRESENT (before)) THEN 00475 ge_pos = before 00476 IF (ge_pos.GT.node%filled+1) ge_pos = node%filled+1 00477 key = node%keys(ge_pos) 00478 ELSE 00479 key = key_in 00480 CALL btree_node_find_gt_pos (node%keys, key, ge_pos, node%filled) 00481 ENDIF 00482 ! Do immediate stuff, different depending on whether node is an 00483 ! internal or leaf node. 00484 !IF (ASSOCIATED (node%subtrees(ge_pos)%node)) THEN 00485 IF (ASSOCIATED (node%subtrees(ge_pos)%node)) THEN 00486 parent_pos = ge_pos 00487 descend_node => node%subtrees(ge_pos)%node 00488 DO WHILE (ASSOCIATED (descend_node%subtrees(descend_node%filled+1)%node)) 00489 parent_pos = descend_node%filled+1 00490 descend_node => descend_node%subtrees(descend_node%filled+1)%node 00491 ENDDO 00492 raised_key = descend_node%keys(descend_node%filled) 00493 raised_value = descend_node%values(descend_node%filled) 00494 descend_node%filled = descend_node%filled-1 00495 IF (descend_node%filled .LT. tree%b%min_fill) THEN 00496 rebalance_node => descend_node 00497 ENDIF 00498 node%keys(ge_pos) = raised_key 00499 node%values(ge_pos) = raised_value 00500 ELSE 00501 ! Shift the keys and values. 00502 node%keys(ge_pos:node%filled-1) = node%keys(ge_pos+1:node%filled) 00503 node%values(ge_pos:node%filled-1) = node%values(ge_pos+1:node%filled) 00504 node%filled = node%filled - 1 00505 IF (node%filled .LT. tree%b%min_fill) THEN 00506 rebalance_node => node 00507 ENDIF 00508 ENDIF 00509 ! Now rebalance, if needed 00510 IF (ASSOCIATED (rebalance_node)) THEN 00511 IF (parent_pos .GT. 0) THEN 00512 CALL btree_rebalance(tree, rebalance_node, parent_pos) 00513 ELSE 00514 CALL btree_rebalance(tree, rebalance_node) 00515 ENDIF 00516 ENDIF 00517 END SUBROUTINE btree_remove_from 00518 00519 00520 RECURSIVE SUBROUTINE btree_rebalance (tree, node, parent_pos) 00521 TYPE(btree), INTENT(INOUT) :: tree 00522 TYPE(btree_node), POINTER :: node 00523 INTEGER, INTENT(IN), OPTIONAL :: parent_pos 00524 00525 INTEGER :: i, ppos 00526 LOGICAL :: left_exists, left_skinny, 00527 right_exists, right_skinny 00528 TYPE(btree_node), POINTER :: node_left, node_right, parent 00529 00530 ! 00531 ! 00532 !IF (.NOT. ASSOCIATED (node)) RETURN 00533 00534 IF (node%filled .GE. tree%b%min_fill) RETURN 00535 IF (.NOT. ASSOCIATED (node%parent)) THEN 00536 IF (node%filled.EQ.0) THEN 00537 IF (ASSOCIATED (node%subtrees(1)%node)) THEN 00538 tree%b%root => node%subtrees(1)%node 00539 NULLIFY (tree%b%root%parent) 00540 ELSE 00541 IF (tree%b%n .GT. 0) THEN 00542 WRITE(*,*)'btree_rebalance: Error: Can not switch to nonexistant root.',tree%b%n 00543 ENDIF 00544 ENDIF 00545 ENDIF 00546 RETURN 00547 ENDIF 00548 ! 00549 parent => node%parent 00550 IF (PRESENT (parent_pos)) THEN 00551 ppos = parent_pos 00552 ELSE 00553 ! Find my parent_position. Assume that the tree is ordered. 00554 ppos = 0 00555 DO i = 1, parent%filled+1 00556 IF (parent%subtrees(i)%node%id .EQ. node%id) THEN 00557 ppos = i 00558 EXIT 00559 ENDIF 00560 ENDDO 00561 ENDIF 00562 ! 00563 ! Check to see if we can merge with the left or right siblings. 00564 left_exists = .FALSE. 00565 right_exists = .FALSE. 00566 left_skinny = .FALSE. ; right_skinny = .FALSE. 00567 NULLIFY (node_left) 00568 IF (ppos .GT. 1) THEN 00569 left_exists = .TRUE. 00570 node_left => parent%subtrees(ppos-1)%node 00571 IF (node_left%filled .GT. tree%b%min_fill) THEN 00572 CALL btree_snatch_from_left(node_left, node, ppos-1) 00573 RETURN 00574 ENDIF 00575 left_skinny = .TRUE. 00576 ENDIF 00577 NULLIFY (node_right) 00578 IF (ppos .LE. parent%filled) THEN 00579 right_exists = .TRUE. 00580 node_right => parent%subtrees(ppos+1)%node 00581 IF (node_right%filled .GT. tree%b%min_fill) THEN 00582 CALL btree_snatch_from_right (node, node_right, ppos) 00583 RETURN 00584 ENDIF 00585 right_skinny = .TRUE. 00586 ENDIF 00587 IF (left_exists .AND. left_skinny) THEN 00588 CALL btree_merge (node_left, node, ppos-1) 00589 ELSEIF (right_exists .AND. right_skinny) THEN 00590 CALL btree_merge (node, node_right, ppos) 00591 ELSE 00592 WRITE(*,*)'btree_rebalance: Error: can not find node to merge with' 00593 ENDIF 00594 CALL btree_rebalance(tree, parent) 00595 END SUBROUTINE btree_rebalance 00596 00597 00598 ! Merges two nodes (it's assumed that their combined number of 00599 ! elements is less than the maximum node size. Their separator in 00600 ! the parent is added between their two sets of elements. Also fixes the parent 00601 SUBROUTINE btree_merge (node_left, node_right, left_pos) 00602 TYPE(btree_node), POINTER :: node_left, node_right 00603 INTEGER, INTENT(IN) :: left_pos 00604 00605 INTEGER :: full_fill, i 00606 LOGICAL :: leaf 00607 TYPE(btree_node), POINTER :: parent 00608 00609 ! 00610 ! 00611 00612 NULLIFY (parent) 00613 IF (ASSOCIATED (node_left%parent)) THEN 00614 parent => node_left%parent 00615 ELSE 00616 RETURN 00617 ENDIF 00618 leaf = .NOT. ASSOCIATED (node_left%subtrees(1)%node) 00619 full_fill = node_left%filled + 1 + node_right%filled 00620 ! Do the actual element merges 00621 node_left%keys(node_left%filled+1) = parent%keys(left_pos) 00622 node_left%values(node_left%filled+1) = parent%values(left_pos) 00623 ! 00624 node_left%keys(node_left%filled+2:full_fill) =& 00625 node_right%keys(1:node_right%filled) 00626 node_left%values(node_left%filled+2:full_fill) =& 00627 node_right%values(1:node_right%filled) 00628 IF (.NOT. leaf) THEN 00629 node_left%subtrees(node_left%filled+2:full_fill+1) =& 00630 node_right%subtrees(1:node_right%filled+1) 00631 ! Reset parents on the newly-acquired subtrees. 00632 DO i = node_left%filled+2, full_fill+1 00633 !IF (ASSOCIATED (node_left%subtrees(i)%node)) THEN 00634 node_left%subtrees(i)%node%parent => node_left 00635 !ENDIF 00636 ENDDO 00637 ENDIF 00638 node_left%filled = full_fill 00639 CALL btree_free_node (node_right) 00640 ! Now rearrange the root 00641 parent%keys(left_pos:parent%filled-1) =& 00642 parent%keys(left_pos+1:parent%filled) 00643 parent%values(left_pos:parent%filled-1) =& 00644 parent%values(left_pos+1:parent%filled) 00645 parent%subtrees(left_pos+1:parent%filled) =& 00646 parent%subtrees(left_pos+2:parent%filled+1) 00647 parent%filled = parent%filled-1 00648 END SUBROUTINE btree_merge 00649 00650 00651 00652 ! Takes an element from the right sibling into my own; it's assumed 00653 ! that node_right has more than the minimum number of elements and 00654 ! that node_left is below the minimum. left_pos is the position of 00655 ! node_left in its parent. 00656 SUBROUTINE btree_snatch_from_right (node_left, node_right, left_pos) 00657 TYPE(btree_node), POINTER :: node_left 00658 TYPE(btree_node), INTENT(INOUT) :: node_right 00659 INTEGER, INTENT(IN) :: left_pos 00660 00661 LOGICAL :: leaf 00662 00663 ! 00664 00665 leaf = .NOT. ASSOCIATED (node_left%subtrees(1)%node) 00666 node_left%keys(node_left%filled+1) = node_left%parent%keys(left_pos) 00667 node_left%values(node_left%filled+1) = node_left%parent%values(left_pos) 00668 IF (.NOT. leaf) THEN 00669 node_left%subtrees(node_left%filled+2) = node_right%subtrees(1) 00670 ! Reset parents on the newly-acquired subtrees. 00671 !IF (ASSOCIATED (node_left%subtrees(node_left%filled+2)%node)) THEN 00672 node_left%subtrees(node_left%filled+2)%node%parent => node_left 00673 !ENDIF 00674 ENDIF 00675 00676 node_left%filled = node_left%filled + 1 00677 ! 00678 node_left%parent%keys(left_pos) = node_right%keys(1) 00679 node_left%parent%values(left_pos) = node_right%values(1) 00680 ! 00681 node_right%keys(1:node_right%filled-1) =& 00682 node_right%keys(2:node_right%filled) 00683 node_right%values(1:node_right%filled-1) =& 00684 node_right%values(2:node_right%filled) 00685 IF (.NOT. leaf) THEN 00686 node_right%subtrees(1:node_right%filled) =& 00687 node_right%subtrees(2:node_right%filled+1) 00688 ENDIF 00689 NULLIFY (node_right%subtrees(node_right%filled+1)%node) 00690 node_right%filled = node_right%filled - 1 00691 END SUBROUTINE btree_snatch_from_right 00692 00693 00694 ! Takes an element from the left sibling into my own; it's assumed 00695 ! that node_left has more than the minimum number of elements and 00696 ! that node_right is below the minimum. left_pos is the position of 00697 ! node_left in its parent. 00698 SUBROUTINE btree_snatch_from_left (node_left, node_right, left_pos) 00699 TYPE(btree_node), INTENT(INOUT) :: node_left 00700 TYPE(btree_node), POINTER :: node_right 00701 INTEGER, INTENT(IN) :: left_pos 00702 00703 LOGICAL :: leaf 00704 00705 ! 00706 00707 leaf = .NOT. ASSOCIATED (node_left%subtrees(1)%node) 00708 node_right%keys(2:node_right%filled+1) =& 00709 node_right%keys(1:node_right%filled) 00710 node_right%values(2:node_right%filled+1) =& 00711 node_right%values(1:node_right%filled) 00712 IF (.NOT. leaf) THEN 00713 node_right%subtrees(2:node_right%filled+2) =& 00714 node_right%subtrees(1:node_right%filled+1) 00715 ENDIF 00716 ! 00717 node_right%keys(1) = node_right%parent%keys(left_pos) 00718 node_right%values(1) = node_right%parent%values(left_pos) 00719 IF (.NOT. leaf) THEN 00720 node_right%subtrees(1) = node_left%subtrees(node_left%filled+1) 00721 !IF (ASSOCIATED (node_right%subtrees(1)%node)) THEN 00722 node_right%subtrees(1)%node%parent => node_right 00723 !ENDIF 00724 ENDIF 00725 node_right%filled = node_right%filled+1 00726 ! 00727 node_right%parent%keys(left_pos) = node_left%keys(node_left%filled) 00728 node_right%parent%values(left_pos) = node_left%values(node_left%filled) 00729 ! 00730 node_left%filled = node_left%filled-1 00731 END SUBROUTINE btree_snatch_from_left 00732 00733 00734 SUBROUTINE btree_new_root (tree, key, value) 00735 TYPE(btree), INTENT(INOUT) :: tree 00736 INTEGER(KIND=keyt), INTENT(IN) :: key 00737 TYPE(cp2d), INTENT(IN) :: value 00738 00739 TYPE(btree_node), POINTER :: new_root, old_root 00740 00741 ! 00742 00743 CALL btree_new_node(tree, new_root) 00744 new_root%filled = 1 00745 new_root%keys(1) = key 00746 new_root%values(1) = value 00747 IF (ASSOCIATED (tree%b%root)) THEN 00748 old_root => tree%b%root 00749 old_root%parent => new_root 00750 new_root%subtrees(1)%node => old_root 00751 old_root%parent => new_root 00752 ENDIF 00753 tree%b%root => new_root 00754 END SUBROUTINE btree_new_root 00755 00756 00757 SUBROUTINE btree_new_node (tree, node) 00758 TYPE(btree), INTENT(INOUT) :: tree 00759 TYPE(btree_node), POINTER :: node 00760 00761 INTEGER :: i 00762 00763 ! 00764 00765 ALLOCATE (node) 00766 ALLOCATE (node%keys(tree%b%max_fill)) 00767 ALLOCATE (node%values(tree%b%max_fill)) 00768 ALLOCATE (node%subtrees(tree%b%max_fill+1)) 00769 DO i = 1, tree%b%max_fill+1 00770 NULLIFY (node%subtrees(i)%node) 00771 ENDDO 00772 node%filled = 0 00773 NULLIFY (node%parent) 00774 tree%b%lastid = tree%b%lastid+1 00775 node%id = tree%b%lastid 00776 END SUBROUTINE btree_new_node 00777 00778 SUBROUTINE btree_free_node (node) 00779 TYPE(btree_node), POINTER :: node 00780 00781 ! 00782 00783 DEALLOCATE (node%keys) 00784 DEALLOCATE (node%values) 00785 DEALLOCATE (node%subtrees) 00786 DEALLOCATE (node) 00787 END SUBROUTINE btree_free_node 00788 00789 00790 SUBROUTINE btree_find (tree, key, value, exists) 00791 TYPE(btree), INTENT(IN) :: tree 00792 INTEGER(KIND=keyt), INTENT(IN) :: key 00793 TYPE(cp2d), INTENT(OUT) :: value 00794 LOGICAL, INTENT(OUT), OPTIONAL :: exists 00795 00796 INTEGER :: position 00797 TYPE(btree_node), POINTER :: node 00798 00799 ! 00800 ! 00801 00802 CALL btree_find_full (tree, key, node, position, short=.TRUE.) 00803 IF (PRESENT (exists)) THEN 00804 exists = position .GT. 0 00805 ENDIF 00806 IF (position .GT. 0) THEN 00807 value = node%values(position) 00808 ENDIF 00809 END SUBROUTINE btree_find 00810 00811 00812 SUBROUTINE btree_pop_smallest (tree, key, value) 00813 TYPE(btree), INTENT(INOUT) :: tree 00814 INTEGER(KIND=keyt), INTENT(OUT) :: key 00815 TYPE(cp2d), INTENT(OUT) :: value 00816 00817 TYPE(btree_node), POINTER :: node 00818 00819 ! 00820 ! 00821 00822 NULLIFY(node) 00823 IF (tree%b%n .EQ. 0) RETURN 00824 ! Try to find the key in the given node. If it's found, then 00825 ! return the node. 00826 node => tree%b%root 00827 descent: DO WHILE (ASSOCIATED (node%subtrees(1)%node)) 00828 node => node%subtrees(1)%node 00829 END DO descent 00830 key = node%keys(1) 00831 value = node%values(1) 00832 tree%b%n = tree%b%n-1 00833 CALL btree_remove_from (tree, node, key, before=1) 00834 END SUBROUTINE btree_pop_smallest 00835 00836 SUBROUTINE btree_pop_greatest (tree, key, value) 00837 TYPE(btree), INTENT(INOUT) :: tree 00838 INTEGER(KIND=keyt), INTENT(OUT) :: key 00839 TYPE(cp2d), INTENT(OUT) :: value 00840 00841 INTEGER :: lv 00842 TYPE(btree_node), POINTER :: node 00843 00844 ! 00845 ! 00846 00847 NULLIFY(node) 00848 IF (tree%b%n .EQ. 0) RETURN 00849 ! Try to find the key in the given node. If it's found, then 00850 ! return the node. 00851 node => tree%b%root 00852 descent: DO WHILE (ASSOCIATED (node%subtrees(node%filled+1)%node)) 00853 node => node%subtrees(node%filled+1)%node 00854 END DO descent 00855 lv = node%filled 00856 key = node%keys(lv) 00857 value = node%values(lv) 00858 tree%b%n = tree%b%n-1 00859 CALL btree_remove_from (tree, node, key, before=lv) 00860 END SUBROUTINE btree_pop_greatest 00861 00862 SUBROUTINE btree_node_find_ge2_pos (keys, key, position, filled) 00863 INTEGER(KIND=keyt), DIMENSION(:) :: keys 00864 INTEGER(KIND=keyt), INTENT(IN) :: key 00865 INTEGER, INTENT(OUT) :: position 00866 INTEGER, INTENT(IN) :: filled 00867 00868 ! 00869 00870 position = 1 00871 DO WHILE (position .LE. filled) 00872 IF (keys(position) .GE. key) RETURN 00873 position = position + 1 00874 ENDDO 00875 END SUBROUTINE btree_node_find_ge2_pos 00876 SUBROUTINE btree_node_find_ge_pos (keys, key, position, filled) 00877 INTEGER(KIND=keyt), DIMENSION(:) :: keys 00878 INTEGER(KIND=keyt), INTENT(IN) :: key 00879 INTEGER, INTENT(OUT) :: position 00880 INTEGER, INTENT(IN) :: filled 00881 00882 INTEGER :: left, right 00883 00884 ! 00885 00886 IF (keys(1) .GE. key) THEN 00887 position = 1 00888 RETURN 00889 ENDIF 00890 IF (keys(filled) .LT. key) THEN 00891 position = filled+1 00892 RETURN 00893 ENDIF 00894 left = 2 00895 right = filled 00896 position = MAX(ISHFT (left+right, -1),left) 00897 DO WHILE (left .LE. right) 00898 IF (keys(position) .GE. key .AND. keys(position-1) .LT. key) THEN 00899 RETURN 00900 ENDIF 00901 IF (keys(position) .GE. key) right = MIN(position,right-1) 00902 IF (keys(position) .LT. key) left = MAX(position,left+1) 00903 position = MAX(ISHFT (left+right, -1),left) 00904 ENDDO 00905 END SUBROUTINE btree_node_find_ge_pos 00906 SUBROUTINE btree_node_find_gt2_pos (keys, key, position, filled) 00907 INTEGER(KIND=keyt), DIMENSION(:) :: keys 00908 INTEGER(KIND=keyt), INTENT(IN) :: key 00909 INTEGER, INTENT(OUT) :: position 00910 INTEGER, INTENT(IN) :: filled 00911 00912 ! 00913 00914 position = 1 00915 DO WHILE (position .LE. filled) 00916 IF (keys(position) .GT. key) RETURN 00917 position = position + 1 00918 ENDDO 00919 END SUBROUTINE btree_node_find_gt2_pos 00920 SUBROUTINE btree_node_find_gt_pos (keys, key, position, filled) 00921 INTEGER(KIND=keyt), DIMENSION(:) :: keys 00922 INTEGER(KIND=keyt), INTENT(IN) :: key 00923 INTEGER, INTENT(OUT) :: position 00924 INTEGER, INTENT(IN) :: filled 00925 00926 INTEGER :: left, right 00927 00928 ! 00929 00930 IF (keys(1) .GT. key) THEN 00931 position = 1 00932 RETURN 00933 ENDIF 00934 IF (keys(filled) .LE. key) THEN 00935 position = filled+1 00936 RETURN 00937 ENDIF 00938 left = 2 00939 right = filled 00940 position = MAX(ISHFT (left+right, -1),left) 00941 DO WHILE (left .LE. right) 00942 IF (keys(position) .GT. key .AND. keys(position-1) .LE. key) THEN 00943 RETURN 00944 ENDIF 00945 IF (keys(position) .GT. key) right = MIN(position,right-1) 00946 IF (keys(position) .LE. key) left = MAX(position,left+1) 00947 position = MAX(ISHFT (left+right, -1),left) 00948 ENDDO 00949 END SUBROUTINE btree_node_find_gt_pos 00950 SUBROUTINE btree_node_find_gte_pos (keys, key, position, filled, first) 00951 INTEGER(KIND=keyt), DIMENSION(:) :: keys 00952 INTEGER(KIND=keyt), INTENT(IN) :: key 00953 INTEGER, INTENT(OUT) :: position 00954 INTEGER, INTENT(IN) :: filled 00955 INTEGER, INTENT(IN), OPTIONAL :: first 00956 00957 INTEGER :: left, one, right 00958 00959 ! 00960 00961 one = 1 00962 IF (PRESENT (FIRST)) one = first 00963 IF (one .LE. filled) THEN 00964 IF (keys(one) .GT. key) THEN 00965 position = one 00966 RETURN 00967 ENDIF 00968 ENDIF 00969 IF (keys(filled) .LE. key) THEN 00970 position = filled+1 00971 RETURN 00972 ENDIF 00973 left = one+1 00974 right = filled 00975 position = MAX(ISHFT (left+right, -1),left) 00976 DO WHILE (left .LE. right) 00977 IF (keys(position) .GT. key .AND. keys(position-1) .LE. key) THEN 00978 RETURN 00979 ENDIF 00980 IF (keys(position) .GT. key) right = MIN(position,right-1) 00981 IF (keys(position) .LE. key) left = MAX(position,left+1) 00982 position = MAX(ISHFT (left+right, -1),left) 00983 ENDDO 00984 END SUBROUTINE btree_node_find_gte_pos 00985 00986 ! node is unassociated and position=0 if not found 00987 ! Precondition: The key is tree or its subtree. 00988 SUBROUTINE btree_find_full (tree, key, node, position, ge_position, short) 00989 TYPE(btree), INTENT(IN) :: tree 00990 INTEGER(KIND=keyt), INTENT(IN) :: key 00991 TYPE(btree_node), POINTER :: node 00992 INTEGER, INTENT(OUT) :: position 00993 INTEGER, INTENT(OUT), OPTIONAL :: ge_position 00994 LOGICAL, INTENT(IN), OPTIONAL :: short 00995 00996 INTEGER :: gti 00997 LOGICAL :: stop_short 00998 00999 ! Used mark searches 01000 ! 01001 01002 stop_short = .FALSE. 01003 IF (PRESENT (short)) stop_short = short 01004 NULLIFY(node) 01005 position = 0 01006 IF (PRESENT (ge_position)) ge_position = 0 01007 !IF (tree%b%n .EQ. 0) RETURN 01008 IF (.NOT. ASSOCIATED (tree%b%root)) RETURN 01009 gti = 1 01010 ! Try to find the key in the given node. If it's found, then 01011 ! return the node. 01012 node => tree%b%root 01013 descent: DO WHILE (.TRUE.) 01014 ! Try to find the first element equal to or greater than the 01015 ! one we're searching for. 01016 CALL btree_node_find_ge_pos (node%keys, key, position, node%filled) 01017 ! One of three things is now true about position: it's now 01018 ! greater than the number of keys (if all keys are smaller), or 01019 ! it points to the key that is equal to or greater than the one 01020 ! we are searching for. If it is found and we are just 01021 ! searching for one equal element (i.e., user search), we can 01022 ! return. 01023 IF (stop_short .AND. position .LE. node%filled) THEN 01024 IF (node%keys(position) .EQ. key) THEN 01025 IF (PRESENT (ge_position)) ge_position = position 01026 RETURN 01027 ENDIF 01028 ENDIF 01029 ! If the key is not found, then either return the GE position 01030 ! if we're in a leaf (case 2 here), otherwise descend into the 01031 ! subtrees. 01032 !CALL btree_node_find_gt_pos (node%keys, key, gti, node%filled, position) 01033 CALL btree_node_find_gte_pos (node%keys, key, gti, node%filled, position) 01034 IF (ASSOCIATED (node%subtrees(1)%node)) THEN 01035 node => node%subtrees(gti)%node 01036 ELSE 01037 IF (PRESENT (ge_position)) ge_position = gti 01038 position = 0 01039 RETURN 01040 ENDIF 01041 END DO descent 01042 END SUBROUTINE btree_find_full 01043 01044 ! node is unassociated and position=0 if not found 01045 ! Precondition: The key is tree or its subtree. 01046 SUBROUTINE btree_find_leaf (tree, key, node, gti) 01047 TYPE(btree), INTENT(IN) :: tree 01048 INTEGER(KIND=keyt), INTENT(IN) :: key 01049 TYPE(btree_node), POINTER :: node 01050 INTEGER, INTENT(OUT) :: gti 01051 01052 ! 01053 01054 NULLIFY(node) 01055 !IF (tree%b%n .EQ. 0) RETURN 01056 IF (.NOT. ASSOCIATED (tree%b%root)) RETURN 01057 gti = 1 01058 ! Try to find the key in the given node. If it's found, then 01059 ! return the node. 01060 node => tree%b%root 01061 descent: DO WHILE (.TRUE.) 01062 ! Try to find the first element equal to or greater than the 01063 ! one we're searching for. 01064 !CALL btree_node_find_ge_pos (node%keys, key, position, node%filled) 01065 ! One of three things is now true about position: it's now 01066 ! greater than the number of keys (if all keys are smaller), or 01067 ! it points to the key that is equal to or greater than the one 01068 ! we are searching for. If it is found and we are just 01069 ! searching for one equal element (i.e., user search), we can 01070 ! return. 01071 ! 01072 ! If the key is not found, then either return the GE position 01073 ! if we're in a leaf (case 2 here), otherwise descend into the 01074 ! subtrees. 01075 CALL btree_node_find_gt_pos (node%keys, key, gti, node%filled) 01076 !CALL btree_node_find_gt2_pos (node%keys, key, i, node%filled) 01077 !IF (i .NE. gti) WRITE(*,*)'XXXX difference',i,gti 01078 IF (ASSOCIATED (node%subtrees(1)%node)) THEN 01079 node => node%subtrees(gti)%node 01080 ELSE 01081 RETURN 01082 ENDIF 01083 END DO descent 01084 END SUBROUTINE btree_find_leaf 01085 01086 SUBROUTINE btree_print_short (tree) 01087 TYPE(btree), INTENT(IN) :: tree 01088 01089 ! 01090 01091 IF (ASSOCIATED (tree%b%root)) THEN 01092 CALL btree_print_short_node (tree%b%root) 01093 ENDIF 01094 END SUBROUTINE btree_print_short 01095 RECURSIVE SUBROUTINE btree_print_short_node (node) 01096 TYPE(btree_node), INTENT(IN) :: node 01097 01098 INTEGER :: i 01099 01100 DO i = 1, node%filled 01101 IF (ASSOCIATED (node%subtrees(i)%node)) THEN 01102 CALL btree_print_short_node (node%subtrees(i)%node) 01103 ENDIF 01104 WRITE(*,'(I12,"=>",F12.3)')& 01105 node%keys(i),& 01106 node%values(i)%p 01107 ENDDO 01108 IF (ASSOCIATED (node%subtrees(node%filled+1)%node)) THEN 01109 CALL btree_print_short_node (node%subtrees(node%filled+1)%node) 01110 ENDIF 01111 END SUBROUTINE btree_print_short_node 01112 01113 01114 SUBROUTINE btree_print (tree) 01115 TYPE(btree), INTENT(INOUT) :: tree 01116 01117 INTEGER :: count, max_leaf_level, 01118 min_leaf_level, num_nodes 01119 INTEGER(KIND=keyt) :: lastv 01120 LOGICAL :: printing 01121 01122 ! 01123 ! 01124 01125 CALL btree_verify (tree) 01126 IF (ASSOCIATED (tree%b%root)) THEN 01127 printing = .FALSE. 01128 count = 0 01129 num_nodes = 0 01130 ! WRITE(*,*)'============',tree%b%n 01131 CALL btree_print_node(tree%b%root, 0, lastv,& 01132 count, num_nodes, max_leaf_level, min_leaf_level, printing) 01133 ! WRITE(*,*)'------------',count, REAL(tree%b%n)/REAL(num_nodes*tree%b%max_fill) 01134 CALL btree_print_bynode(tree%b%root, 0) 01135 ! WRITE(*,*)'============' 01136 ELSE 01137 ! WRITE(*,*)'Tree is empty.' 01138 ENDIF 01139 END SUBROUTINE btree_print 01140 01141 01142 RECURSIVE SUBROUTINE btree_print_node (node, level, lastv,& 01143 count, num_nodes, max_leaf_level, min_leaf_level, printing) 01144 TYPE(btree_node), INTENT(IN) :: node 01145 INTEGER, INTENT(IN) :: level 01146 INTEGER(KIND=keyt), INTENT(INOUT) :: lastv 01147 INTEGER, INTENT(INOUT) :: count, num_nodes, 01148 max_leaf_level, min_leaf_level 01149 LOGICAL, INTENT(INOUT) :: printing 01150 01151 INTEGER :: branch 01152 01153 ! 01154 ! Recurses down and prints the values. 01155 ! pid = -1 01156 ! WRITE(*,*)'btree_print_node: id',node%id,'fill of',node%filled,'level',level 01157 01158 num_nodes = num_nodes+1 01159 !IF (level.GT.0.AND.node%filled+1 .LT. 3) WRITE(*,*)'Error: Uhoh' 01160 DO branch = 1, node%filled 01161 IF (ASSOCIATED (node%subtrees(branch)%node)) THEN 01162 IF (node%subtrees(branch)%node%parent%id .NE. node%id) THEN 01163 WRITE(*,*)'Error: Bastard child follows.' 01164 ENDIF 01165 CALL btree_print_node(node%subtrees(branch)%node, level+1, lastv,& 01166 count, num_nodes, max_leaf_level, min_leaf_level, printing) 01167 ! WRITE(*,*)level,node%id,branch,' Mid ', node%keys(branch),node%values(branch) 01168 IF (printing.AND.node%keys(branch) .LT. lastv) WRITE(*,*)'Error: Nooo!1' 01169 lastv = node%keys(branch) 01170 printing = .TRUE. 01171 count = count+1 01172 ELSE 01173 ! WRITE(*,*)level,node%id,branch,' Leaf', node%keys(branch),node%values(branch) 01174 IF (printing.AND.node%keys(branch) .LT. lastv) WRITE(*,*)'Error: Nooo!2' 01175 lastv = node%keys(branch) 01176 printing = .TRUE. 01177 count = count+1 01178 ENDIF 01179 ENDDO 01180 branch = node%filled+1 01181 IF (ASSOCIATED (node%subtrees(branch)%node)) THEN 01182 IF (node%subtrees(branch)%node%parent%id .NE. node%id) THEN 01183 WRITE(*,*)'Error: Bastard child follows.' 01184 ENDIF 01185 CALL btree_print_node(node%subtrees(branch)%node, level+1, lastv,& 01186 count, num_nodes, max_leaf_level, min_leaf_level, printing) 01187 ENDIF 01188 END SUBROUTINE btree_print_node 01189 01190 RECURSIVE SUBROUTINE btree_print_bynode (node, level) 01191 TYPE(btree_node), INTENT(IN) :: node 01192 INTEGER, INTENT(IN) :: level 01193 01194 INTEGER :: branch 01195 INTEGER, DIMENSION(node%filled+1) :: child_ids 01196 01197 ! 01198 !pid = -1 01199 !IF (ASSOCIATED (node%parent)) pid = node%parent%id 01200 01201 child_ids = 0 01202 DO branch = 1, node%filled+1 01203 IF (ASSOCIATED (node%subtrees(branch)%node)) THEN 01204 child_ids(branch) = node%subtrees(branch)%node%id 01205 ENDIF 01206 ENDDO 01207 ! WRITE(*,*)'node: id [',node%id,']level',level,'parent id[',pid,']' 01208 ! WRITE(*,*)'@',node%keys(1:node%filled) 01209 ! WRITE(*,*)'>',child_ids 01210 DO branch = 1, node%filled 01211 IF (ASSOCIATED (node%subtrees(branch)%node)) THEN 01212 CALL btree_print_bynode(node%subtrees(branch)%node, level+1) 01213 ENDIF 01214 ENDDO 01215 branch = node%filled+1 01216 IF (ASSOCIATED (node%subtrees(branch)%node)) THEN 01217 CALL btree_print_bynode(node%subtrees(branch)%node, level+1) 01218 ENDIF 01219 END SUBROUTINE btree_print_bynode 01220 01221 01222 SUBROUTINE btree_verify (tree) 01223 TYPE(btree), INTENT(INOUT) :: tree 01224 01225 INTEGER :: count, max_leaf_level, 01226 min_leaf_level, num_nodes 01227 INTEGER(KIND=keyt) :: lastv 01228 LOGICAL :: printing 01229 LOGICAL, DIMENSION(tree%b%lastid) :: nids 01230 01231 ! 01232 ! 01233 01234 printing = .FALSE. 01235 count = 0 01236 num_nodes = 0 01237 max_leaf_level = 0 01238 min_leaf_level = tree%b%n 01239 IF (ASSOCIATED (tree%b%root)) THEN 01240 nids(:) = .FALSE. 01241 ! WRITE(*,*)'============',tree%b%n 01242 CALL btree_verify_node(tree, tree%b%root, 0, nids, lastv,& 01243 count, num_nodes, max_leaf_level, min_leaf_level, printing) 01244 ! WRITE(*,*)'Tree verification: 2xcount,fill ratio',tree%b%n,count,REAL(tree%b%n)/REAL(num_nodes*tree%b%max_fill) 01245 ! WRITE(*,*)'============' 01246 ELSE 01247 ! WRITE(*,*)'Tree is empty, size is',tree%b%n,';',min_leaf_level 01248 ENDIF 01249 IF (min_leaf_level .NE. max_leaf_level) WRITE(*,*)'Error: unbalanced tree',min_leaf_level,max_leaf_level 01250 IF (tree%b%n .NE. count) WRITE(*,*)'Error: inconsistent number of elements',tree%b%n,count 01251 END SUBROUTINE btree_verify 01252 01253 01254 RECURSIVE SUBROUTINE btree_verify_node (tree, node, level, nids, lastv,& 01255 count, num_nodes, max_leaf_level, min_leaf_level, printing) 01256 TYPE(btree), INTENT(IN) :: tree 01257 TYPE(btree_node), INTENT(IN) :: node 01258 INTEGER, INTENT(IN) :: level 01259 LOGICAL, DIMENSION(:), INTENT(INOUT) :: nids 01260 INTEGER(KIND=keyt), INTENT(INOUT) :: lastv 01261 INTEGER, INTENT(INOUT) :: count, num_nodes, 01262 max_leaf_level, min_leaf_level 01263 LOGICAL, INTENT(INOUT) :: printing 01264 01265 INTEGER :: branch 01266 LOGICAL :: any_assoc, any_notassoc 01267 01268 ! 01269 ! Recurses down and prints the values. 01270 !IF (ASSOCIATED (node%parent)) pid = node%parent%id 01271 ! WRITE(*,*)'btree_verify_node: id',node%id,'fill,level,parent',node%filled,level,pid 01272 01273 num_nodes = num_nodes+1 01274 IF (level.GT.0.AND.node%filled+1 .LT. tree%b%min_fill) WRITE(*,*)'Error: Dieting leaf' 01275 IF (nids(node%id)) WRITE(*,*)'Error: duplicate node id',node%id 01276 nids(node%id) = .TRUE. 01277 any_assoc = .FALSE. 01278 any_notassoc = .FALSE. 01279 !DO branch = 1, node%filled 01280 ! WRITE(*,*)'Child IDs' 01281 ! IF (ASSOCIATED (node%subtrees(branch)%node)) THEN 01282 ! WRITE(*,*)node%subtrees(branch)%node%id 01283 ! ENDIF 01284 !ENDDO 01285 DO branch = 1, node%filled 01286 IF (ASSOCIATED (node%subtrees(branch)%node)) THEN 01287 any_assoc = .TRUE. 01288 IF (node%subtrees(branch)%node%id .EQ. node%id) THEN 01289 WRITE(*,*)'Error: I am my own child.' 01290 ENDIF 01291 IF (node%subtrees(branch)%node%parent%id .NE. node%id) THEN 01292 WRITE(*,*)'Error: Bastard child follows.' 01293 ENDIF 01294 CALL btree_verify_node(tree, node%subtrees(branch)%node, level+1,& 01295 nids, lastv,& 01296 count, num_nodes, max_leaf_level, min_leaf_level, printing) 01297 ! WRITE(*,*)level,node%id,branch,' Mid ', node%keys(branch),node%values(branch) 01298 IF (printing.AND.node%keys(branch) .LT. lastv) WRITE(*,*)'Error: Unsorted Keys (1)' 01299 lastv = node%keys(branch) 01300 printing = .TRUE. 01301 count = count+1 01302 ELSE 01303 any_notassoc = .TRUE. 01304 ! WRITE(*,*)level,node%id,branch,' Leaf', node%keys(branch),node%values(branch) 01305 IF (printing.AND.node%keys(branch) .LT. lastv) WRITE(*,*)'Error: Unsorted Keys (2)' 01306 lastv = node%keys(branch) 01307 printing = .TRUE. 01308 count = count+1 01309 ENDIF 01310 ENDDO 01311 branch = node%filled+1 01312 IF (ASSOCIATED (node%subtrees(branch)%node)) THEN 01313 any_assoc = .TRUE. 01314 IF (node%subtrees(branch)%node%parent%id .NE. node%id) THEN 01315 WRITE(*,*)'Error: Bastard child follows.' 01316 ENDIF 01317 CALL btree_verify_node(tree, node%subtrees(branch)%node, level+1, nids,& 01318 lastv, count, num_nodes, max_leaf_level, min_leaf_level, printing) 01319 ELSE 01320 any_notassoc = .TRUE. 01321 ENDIF 01322 IF (any_assoc .AND. any_notassoc) THEN 01323 WRITE(*,*)'Error: Leaf mix-n-match.' 01324 ENDIF 01325 IF (any_notassoc) THEN 01326 IF (level .GT. max_leaf_level) max_leaf_level = level 01327 IF (level .LT. min_leaf_level) min_leaf_level = level 01328 ENDIF 01329 END SUBROUTINE btree_verify_node 01330 01331 END MODULE btree_i8_k_cp2d_v
1.7.3