OpenCMISS-Iron Internal API Documentation
trees.f90
Go to the documentation of this file.
1 
43 
45 MODULE trees
46 
47  USE base_routines
48  USE input_output
49  USE iso_varying_string
50  USE kinds
51  USE strings
52 
53 #include "macros.h"
54 
55  IMPLICIT NONE
56 
57  PRIVATE
58 
59  !Module parameters
60 
65  INTEGER(INTG), PARAMETER :: tree_black_node=0
66  INTEGER(INTG), PARAMETER :: tree_red_node=1
68 
73  INTEGER(INTG), PARAMETER :: tree_node_insert_sucessful=1
74  INTEGER(INTG), PARAMETER :: tree_node_duplicate_key=2
76 
81  INTEGER(INTG), PARAMETER :: tree_duplicates_allowed_type=1
82  INTEGER(INTG), PARAMETER :: tree_no_duplicates_allowed=2
84 
85  !Module types
86 
87  TYPE tree_node_type
88  PRIVATE
89  INTEGER(INTG) :: key
90  INTEGER(INTG) :: VALUE
91  INTEGER(INTG) :: colour
92  TYPE(tree_node_type), POINTER :: left
93  TYPE(tree_node_type), POINTER :: right
94  TYPE(tree_node_type), POINTER :: parent
95  END TYPE tree_node_type
96 
97  TYPE tree_type
98  PRIVATE
99  LOGICAL :: tree_finished
100  INTEGER(INTG) :: insert_type
101  INTEGER(INTG) :: number_in_tree
102  TYPE(tree_node_type), POINTER :: root
103  TYPE(tree_node_type), POINTER :: nil
104  END TYPE tree_type
105 
106  !Module variables
107 
108  !Interfaces
109 
110  INTERFACE tree_createfinish
111  MODULE PROCEDURE tree_create_finish
112  END INTERFACE tree_createfinish
113 
114  INTERFACE tree_createstart
115  MODULE PROCEDURE tree_create_start
116  END INTERFACE tree_createstart
117 
118  INTERFACE tree_detachanddestroy
119  MODULE PROCEDURE tree_detach_and_destroy
120  END INTERFACE tree_detachanddestroy
121 
122  INTERFACE tree_inserttypeset
123  MODULE PROCEDURE tree_insert_type_set
124  END INTERFACE tree_inserttypeset
125 
126  INTERFACE tree_itemdelete
127  MODULE PROCEDURE tree_item_delete
128  END INTERFACE tree_itemdelete
129 
130  INTERFACE tree_iteminsert
131  MODULE PROCEDURE tree_item_insert
132  END INTERFACE tree_iteminsert
133 
134  INTERFACE tree_nodekeyget
135  MODULE PROCEDURE tree_node_key_get
136  END INTERFACE tree_nodekeyget
137 
138  INTERFACE tree_nodevalueget
139  MODULE PROCEDURE tree_node_value_get
140  END INTERFACE tree_nodevalueget
141 
142  INTERFACE tree_nodevalueset
143  MODULE PROCEDURE tree_node_value_set
144  END INTERFACE tree_nodevalueset
145 
146  PUBLIC tree_type,tree_node_type
147 
148  PUBLIC tree_node_insert_sucessful,tree_node_duplicate_key
149 
150  PUBLIC tree_duplicates_allowed_type,tree_no_duplicates_allowed
151 
152  PUBLIC tree_create_finish,tree_create_start
153 
154  PUBLIC tree_createfinish,tree_createstart
155 
156  PUBLIC tree_destroy
157 
158  PUBLIC tree_detach_and_destroy
159 
160  PUBLIC tree_detach,tree_detachanddestroy
161 
162  PUBLIC tree_insert_type_set
163 
164  PUBLIC tree_inserttypeset
165 
166  PUBLIC tree_item_delete,tree_item_insert
167 
168  PUBLIC tree_itemdelete,tree_iteminsert
169 
170  PUBLIC tree_node_key_get
171 
172  PUBLIC tree_nodekeyget
173 
174  PUBLIC tree_node_value_get,tree_node_value_set
175 
176  PUBLIC tree_nodevalueget,tree_nodevalueset
177 
178  PUBLIC tree_output
179 
180  PUBLIC tree_search
181 
182 CONTAINS
183 
184  !
185  !================================================================================================================================
186  !
187 
189  SUBROUTINE tree_create_finish(TREE,ERR,ERROR,*)
190 
191  !Argument Variables
192  TYPE(tree_type), POINTER :: TREE
193  INTEGER(INTG), INTENT(OUT) :: ERR
194  TYPE(varying_string), INTENT(OUT) :: ERROR
195  !Local Variables
196 
197  enters("TREE_CREATE_FINISH",err,error,*998)
198 
199  IF(ASSOCIATED(tree)) THEN
200  IF(tree%TREE_FINISHED) THEN
201  CALL flagerror("Tree is already finished",err,error,*998)
202  ELSE
203  !Allocate the nil tree node
204  ALLOCATE(tree%NIL,stat=err)
205  IF(err/=0) CALL flagerror("Could not allocate NIL tree node",err,error,*999)
206  CALL tree_node_initialise(tree,tree%NIL,err,error,*999)
207  tree%NIL%KEY=-99999999 !Set it to something identifiable for debugging
208  tree%NIL%LEFT=>tree%NIL
209  tree%NIL%RIGHT=>tree%NIL
210  tree%NIL%PARENT=>tree%NIL
211  !Set the root tree node to NIL
212  tree%ROOT=>tree%NIL
213  !Finish the tree creation
214  tree%TREE_FINISHED=.true.
215  ENDIF
216  ELSE
217  CALL flagerror("Tree is not associated",err,error,*998)
218  ENDIF
219 
220  exits("TREE_CREATE_FINISH")
221  RETURN
222 999 CALL tree_finalise(tree,err,error,*998)
223 998 errorsexits("TREE_CREATE_FINISH",err,error)
224  RETURN 1
225  END SUBROUTINE tree_create_finish
226 
227  !
228  !================================================================================================================================
229  !
230 
232  SUBROUTINE tree_create_start(TREE,ERR,ERROR,*)
233 
234  !Argument Variables
235  TYPE(tree_type), POINTER :: TREE
236  INTEGER(INTG), INTENT(OUT) :: ERR
237  TYPE(varying_string), INTENT(OUT) :: ERROR
238  !Local Variable
239 
240  enters("TREE_CREATE_START",err,error,*998)
241 
242  IF(ASSOCIATED(tree)) THEN
243  CALL flagerror("Tree is already associated",err,error,*998)
244  ELSE
245  ALLOCATE(tree,stat=err)
246  IF(err/=0) CALL flagerror("Could not allocate tree",err,error,*999)
247  CALL tree_initialise(tree,err,error,*999)
248  !Set Defaults
249  tree%INSERT_TYPE=tree_duplicates_allowed_type
250  ENDIF
251 
252  exits("TREE_CREATE_START")
253  RETURN
254 999 CALL tree_finalise(tree,err,error,*998)
255 998 errorsexits("TREE_CREATE_START",err,error)
256  RETURN 1
257  END SUBROUTINE tree_create_start
258 
259  !
260  !================================================================================================================================
261  !
262 
264  SUBROUTINE tree_destroy(TREE,ERR,ERROR,*)
265 
266  !Argument Variables
267  TYPE(tree_type), POINTER :: TREE
268  INTEGER(INTG), INTENT(OUT) :: ERR
269  TYPE(varying_string), INTENT(OUT) :: ERROR
270  !Local Variables
271 
272  enters("TREE_DESTROY",err,error,*999)
273 
274  IF(ASSOCIATED(tree)) THEN
275  CALL tree_finalise(tree,err,error,*999)
276  ELSE
277  CALL flagerror("Tree is not associated",err,error,*999)
278  ENDIF
279 
280  exits("TREE_DESTROY")
281  RETURN
282 999 errorsexits("TREE_DESTROY",err,error)
283  RETURN 1
284  END SUBROUTINE tree_destroy
285 
286  !
287  !================================================================================================================================
288  !
289 
291  SUBROUTINE tree_detach(TREE,NUMBER_IN_TREE,TREE_VALUES,ERR,ERROR,*)
292 
293  !Argument Variables
294  TYPE(tree_type), POINTER :: TREE
295  INTEGER(INTG), INTENT(OUT) :: NUMBER_IN_TREE
296  INTEGER(INTG), POINTER :: TREE_VALUES(:)
297  INTEGER(INTG), INTENT(OUT) :: ERR
298  TYPE(varying_string), INTENT(OUT) :: ERROR
299  !Local Variables
300 
301  enters("TREE_DETACH",err,error,*998)
302 
303  IF(ASSOCIATED(tree)) THEN
304  IF(tree%TREE_FINISHED) THEN
305  IF(ASSOCIATED(tree_values)) THEN
306  CALL flagerror("Tree values is already associated.",err,error,*998)
307  ELSE
308  NULLIFY(tree_values)
309  ALLOCATE(tree_values(tree%NUMBER_IN_TREE),stat=err)
310  IF(err/=0) CALL flagerror("Could not allocate tree values.",err,error,*999)
311  number_in_tree=0
312  CALL tree_detach_in_order(tree,tree%ROOT,number_in_tree,tree_values,err,error,*999)
313  ENDIF
314  ELSE
315  CALL flagerror("Tree has not been finished.",err,error,*999)
316  ENDIF
317  ELSE
318  CALL flagerror("Tree is not associated.",err,error,*998)
319  ENDIF
320 
321  exits("TREE_DETACH")
322  RETURN
323 999 IF(ASSOCIATED(tree_values)) DEALLOCATE(tree_values)
324  number_in_tree=0
325 998 errorsexits("TREE_DETACH",err,error)
326  RETURN 1
327  END SUBROUTINE tree_detach
328 
329  !
330  !================================================================================================================================
331  !
332 
334  SUBROUTINE tree_detach_and_destroy(TREE,NUMBER_IN_TREE,TREE_VALUES,ERR,ERROR,*)
335 
336  !Argument Variables
337  TYPE(tree_type), POINTER :: TREE
338  INTEGER(INTG), INTENT(OUT) :: NUMBER_IN_TREE
339  INTEGER(INTG), POINTER :: TREE_VALUES(:)
340  INTEGER(INTG), INTENT(OUT) :: ERR
341  TYPE(varying_string), INTENT(OUT) :: ERROR
342  !Local Variables
343 
344  enters("TREE_DETACH_AND_DESTROY",err,error,*998)
345 
346  IF(ASSOCIATED(tree)) THEN
347  IF(tree%TREE_FINISHED) THEN
348  IF(ASSOCIATED(tree_values)) THEN
349  CALL flagerror("Tree values is associated",err,error,*998)
350  ELSE
351  NULLIFY(tree_values)
352  ALLOCATE(tree_values(tree%NUMBER_IN_TREE),stat=err)
353  IF(err/=0) CALL flagerror("Could not allocate tree values",err,error,*999)
354  number_in_tree=0
355  CALL tree_detach_in_order(tree,tree%ROOT,number_in_tree,tree_values,err,error,*999)
356  CALL tree_finalise(tree,err,error,*999)
357  ENDIF
358  ELSE
359  CALL flagerror("Tree has not been finished",err,error,*999)
360  ENDIF
361  ELSE
362  CALL flagerror("Tree is not associated",err,error,*998)
363  ENDIF
364 
365  exits("TREE_DETACH_AND_DESTROY")
366  RETURN
367 999 IF(ASSOCIATED(tree_values)) DEALLOCATE(tree_values)
368  number_in_tree=0
369 998 errorsexits("TREE_DETACH_AND_DESTROY",err,error)
370  RETURN 1
371  END SUBROUTINE tree_detach_and_destroy
372 
373  !
374  !================================================================================================================================
375  !
376 
378  RECURSIVE SUBROUTINE tree_detach_in_order(TREE,X,COUNT,TREE_VALUES,ERR,ERROR,*)
379 
380  !Argument Variables
381  TYPE(tree_type), POINTER :: TREE
382  TYPE(tree_node_type), POINTER :: X
383  INTEGER(INTG), INTENT(INOUT) :: COUNT
384  INTEGER(INTG), INTENT(INOUT) :: TREE_VALUES(:)
385  INTEGER(INTG), INTENT(OUT) :: ERR
386  TYPE(varying_string), INTENT(OUT) :: ERROR
387  !Local Variables
388  TYPE(varying_string) :: LOCAL_ERROR
389 
390  enters("TREE_DETACH_IN_ORDER",err,error,*999)
391 
392  IF(ASSOCIATED(tree)) THEN
393  IF(.NOT.ASSOCIATED(x,tree%NIL)) THEN
394  CALL tree_detach_in_order(tree,x%LEFT,count,tree_values,err,error,*999)
395  count=count+1
396  IF(count<=SIZE(tree_values,1)) THEN
397  tree_values(count)=x%VALUE
398  ELSE
399  local_error="The current count of the tree values ("//trim(number_to_vstring(count,"*",err,error))// &
400  & ") is greater than the size of the tree values array ("// &
401  & trim(number_to_vstring(SIZE(tree_values,1),"*",err,error))//")"
402  CALL flagerror(local_error,err,error,*999)
403  ENDIF
404  CALL tree_detach_in_order(tree,x%RIGHT,count,tree_values,err,error,*999)
405  ENDIF
406  ELSE
407  CALL flagerror("Tree is not associated",err,error,*999)
408  ENDIF
409 
410  exits("TREE_DETACH_IN_ORDER")
411  RETURN
412 999 errorsexits("TREE_DETACH_IN_ORDER",err,error)
413  RETURN 1
414  END SUBROUTINE tree_detach_in_order
415 
416  !
417  !================================================================================================================================
418  !
419 
421  SUBROUTINE tree_finalise(TREE,ERR,ERROR,*)
422 
423  !Argument Variables
424  TYPE(tree_type), POINTER :: TREE
425  INTEGER(INTG), INTENT(OUT) :: ERR
426  TYPE(varying_string), INTENT(OUT) :: ERROR
427  !Local Variables
428 
429  enters("TREE_FINALISE",err,error,*999)
430 
431  IF(ASSOCIATED(tree)) THEN
432  CALL tree_node_finalise(tree,tree%ROOT,err,error,*999)
433  IF(ASSOCIATED(tree%NIL)) DEALLOCATE(tree%NIL)
434  DEALLOCATE(tree)
435  ENDIF
436 
437  exits("TREE_FINALISE")
438  RETURN
439 999 errorsexits("TREE_FINALISE",err,error)
440  RETURN 1
441  END SUBROUTINE tree_finalise
442 
443  !
444  !================================================================================================================================
445  !
446 
448  SUBROUTINE tree_initialise(TREE,ERR,ERROR,*)
449 
450  !Argument Variables
451  TYPE(tree_type), POINTER :: TREE
452  INTEGER(INTG), INTENT(OUT) :: ERR
453  TYPE(varying_string), INTENT(OUT) :: ERROR
454  !Local Variables
455 
456  enters("TREE_INITIALISE",err,error,*999)
457 
458  IF(ASSOCIATED(tree)) THEN
459  tree%TREE_FINISHED=.false.
460  tree%INSERT_TYPE=0
461  tree%NUMBER_IN_TREE=0
462  NULLIFY(tree%ROOT)
463  NULLIFY(tree%NIL)
464  ELSE
465  CALL flagerror("Tree is not associated",err,error,*999)
466  ENDIF
467 
468  exits("TREE_INITIALISE")
469  RETURN
470 999 errorsexits("TREE_INITIALISE",err,error)
471  RETURN 1
472  END SUBROUTINE tree_initialise
473 
474  !
475  !================================================================================================================================
476  !
477 
479  SUBROUTINE tree_insert_type_set(TREE,INSERT_TYPE,ERR,ERROR,*)
480 
481  !Argument Variables
482  TYPE(tree_type), POINTER :: TREE
483  INTEGER(INTG), INTENT(IN) :: INSERT_TYPE
484  INTEGER(INTG), INTENT(OUT) :: ERR
485  TYPE(varying_string), INTENT(OUT) :: ERROR
486  !Local Variables
487  TYPE(varying_string) :: LOCAL_ERROR
488 
489  enters("TREE_INSERT_TYPE_SET",err,error,*999)
490 
491  IF(ASSOCIATED(tree)) THEN
492  IF(tree%TREE_FINISHED) THEN
493  CALL flagerror("Tree has been finished",err,error,*999)
494  ELSE
495  SELECT CASE(insert_type)
496  CASE(tree_duplicates_allowed_type)
497  tree%INSERT_TYPE=tree_duplicates_allowed_type
498  CASE(tree_no_duplicates_allowed)
499  tree%INSERT_TYPE=tree_no_duplicates_allowed
500  CASE DEFAULT
501  local_error="The insert type of "//trim(number_to_vstring(insert_type,"*",err,error))//" is invalid"
502  CALL flagerror(local_error,err,error,*999)
503  END SELECT
504  ENDIF
505  ELSE
506  CALL flagerror("Tree is not associated",err,error,*999)
507  ENDIF
508 
509  exits("TREE_INSERT_TYPE_SET")
510  RETURN
511 999 errorsexits("TREE_INSERT_TYPE_SET",err,error)
512  RETURN 1
513  END SUBROUTINE tree_insert_type_set
514 
515  !
516  !================================================================================================================================
517  !
518 
520  SUBROUTINE tree_item_delete(TREE,KEY,ERR,ERROR,*)
521 
522  !Argument Variables
523  TYPE(tree_type), POINTER :: TREE
524  INTEGER(INTG), INTENT(IN) :: KEY
525  INTEGER(INTG), INTENT(OUT) :: ERR
526  TYPE(varying_string), INTENT(OUT) :: ERROR
527  !Local Variables
528  INTEGER(INTG) :: COMPARE_VALUE
529  TYPE(tree_node_type), POINTER :: U,V,W,X,Y,Z
530  TYPE(varying_string) :: LOCAL_ERROR
531 
532  enters("TREE_ITEM_DELETE",err,error,*999)
533 
534  IF(ASSOCIATED(tree)) THEN
535  IF(tree%TREE_FINISHED) THEN
536  !Try and find the key to delete
537  z=>tree%ROOT
538  IF(.NOT.ASSOCIATED(z,tree%NIL)) THEN
539  compare_value=z%KEY-key
540  DO WHILE(compare_value/=0)
541  IF(compare_value>0) THEN !Z%KEY > KEY
542  z=>z%LEFT
543  ELSE !Z%KEY < KEY
544  z=>z%RIGHT
545  ENDIF
546  IF(ASSOCIATED(z,tree%NIL)) THEN
547  EXIT
548  ELSE
549  compare_value=z%KEY-key
550  ENDIF
551  ENDDO
552  IF(compare_value==0) THEN
553  !Found the key so delete it
554  IF(ASSOCIATED(z%LEFT,tree%NIL).OR.ASSOCIATED(z%RIGHT,tree%NIL)) THEN
555  y=>z
556  ELSE
557  y=>tree_successor(tree,z,err,error)
558  IF(err/=0) GOTO 999
559  ENDIF
560  IF(.NOT.ASSOCIATED(y%LEFT,tree%NIL)) THEN
561  x=>y%LEFT
562  ELSE
563  x=>y%RIGHT
564  ENDIF
565  x%PARENT=>y%PARENT
566  IF(ASSOCIATED(y%PARENT,tree%NIL)) THEN
567  tree%ROOT=>x
568  ELSE
569  IF(ASSOCIATED(y,y%PARENT%LEFT)) THEN
570  y%PARENT%LEFT=>x
571  ELSE
572  y%PARENT%RIGHT=>x
573  ENDIF
574  ENDIF
575  IF(y%COLOUR==tree_black_node) THEN
576  !Fixup the delete to ensure the tree has red black properties
577  !Note: Due to Fortran restrictions on aliasing pointers in dummy arguments we need to do the fixup and rotations
578  !inside this routine rather than call fixup and rotate left and rotate right subroutines.
579  DO WHILE(.NOT.ASSOCIATED(x,tree%ROOT).AND.x%COLOUR==tree_black_node)
580  IF(ASSOCIATED(x,x%PARENT%LEFT)) THEN
581  w=>x%PARENT%RIGHT
582  IF(w%COLOUR==tree_red_node) THEN
583  w%COLOUR=tree_black_node
584  x%PARENT%COLOUR=tree_red_node
585  !Rotate left on X->Parent
586  u=>x%PARENT
587  v=>u%RIGHT
588  u%RIGHT=>v%LEFT
589  IF(.NOT.ASSOCIATED(v%LEFT,tree%NIL)) v%LEFT%PARENT=>u
590  v%PARENT=>u%PARENT
591  IF(ASSOCIATED(u%PARENT,tree%NIL)) THEN
592  tree%ROOT=>v
593  ELSE
594  IF(ASSOCIATED(u,u%PARENT%LEFT)) THEN
595  u%PARENT%LEFT=>v
596  ELSE
597  u%PARENT%RIGHT=>v
598  ENDIF
599  ENDIF
600  v%LEFT=>u
601  u%PARENT=>v
602  w=>x%PARENT%RIGHT
603  ENDIF
604  IF(w%LEFT%COLOUR==tree_black_node.AND.w%RIGHT%COLOUR==tree_black_node) THEN
605  w%COLOUR=tree_red_node
606  x=>x%PARENT
607  ELSE
608  IF(w%RIGHT%COLOUR==tree_black_node) THEN
609  w%LEFT%COLOUR=tree_black_node
610  w%COLOUR=tree_red_node
611  !Rotate right on W
612  u=>w
613  v=>u%LEFT
614  u%LEFT=>v%RIGHT
615  IF(.NOT.ASSOCIATED(v%RIGHT,tree%NIL)) v%RIGHT%PARENT=>u
616  v%PARENT=>u%PARENT
617  IF(ASSOCIATED(v%PARENT,tree%NIL)) THEN
618  tree%ROOT=>v
619  ELSE
620  IF(ASSOCIATED(u,u%PARENT%RIGHT)) THEN
621  u%PARENT%RIGHT=>v
622  ELSE
623  u%PARENT%LEFT=>v
624  ENDIF
625  ENDIF
626  v%RIGHT=>u
627  u%PARENT=>v
628  w=>x%PARENT%RIGHT
629  ENDIF
630  w%COLOUR=x%PARENT%COLOUR
631  x%PARENT%COLOUR=tree_black_node
632  w%RIGHT%COLOUR=tree_black_node
633  !Rotate left on X->Parent
634  u=>x%PARENT
635  v=>u%RIGHT
636  u%RIGHT=>v%LEFT
637  IF(.NOT.ASSOCIATED(v%LEFT,tree%NIL)) v%LEFT%PARENT=>u
638  v%PARENT=>u%PARENT
639  IF(ASSOCIATED(u%PARENT,tree%NIL)) THEN
640  tree%ROOT=>v
641  ELSE
642  IF(ASSOCIATED(u,u%PARENT%LEFT)) THEN
643  u%PARENT%LEFT=>v
644  ELSE
645  u%PARENT%RIGHT=>v
646  ENDIF
647  ENDIF
648  v%LEFT=>u
649  u%PARENT=>v
650  x=>tree%ROOT
651  ENDIF
652  ELSE
653  w=>x%PARENT%LEFT
654  IF(w%COLOUR==tree_red_node) THEN
655  w%COLOUR=tree_black_node
656  x%PARENT%COLOUR=tree_red_node
657  !Rotate right on X->Parent
658  u=>x%PARENT
659  v=>u%LEFT
660  u%LEFT=>v%RIGHT
661  IF(.NOT.ASSOCIATED(v%RIGHT,tree%NIL)) v%RIGHT%PARENT=>u
662  v%PARENT=>u%PARENT
663  IF(ASSOCIATED(v%PARENT,tree%NIL)) THEN
664  tree%ROOT=>v
665  ELSE
666  IF(ASSOCIATED(u,u%PARENT%RIGHT)) THEN
667  u%PARENT%RIGHT=>v
668  ELSE
669  u%PARENT%LEFT=>v
670  ENDIF
671  ENDIF
672  v%RIGHT=>u
673  u%PARENT=>v
674  w=>x%PARENT%LEFT
675  ENDIF
676  IF(w%RIGHT%COLOUR==tree_black_node.AND.w%LEFT%COLOUR==tree_black_node) THEN
677  w%COLOUR=tree_red_node
678  x=>x%PARENT
679  ELSE
680  IF(w%LEFT%COLOUR==tree_black_node) THEN
681  w%RIGHT%COLOUR=tree_black_node
682  w%COLOUR=tree_red_node
683  !Rotate left on W
684  u=>w
685  v=>u%RIGHT
686  u%RIGHT=>v%LEFT
687  IF(.NOT.ASSOCIATED(v%LEFT,tree%NIL)) v%LEFT%PARENT=>u
688  v%PARENT=>u%PARENT
689  IF(ASSOCIATED(u%PARENT,tree%NIL)) THEN
690  tree%ROOT=>v
691  ELSE
692  IF(ASSOCIATED(u,u%PARENT%LEFT)) THEN
693  u%PARENT%LEFT=>v
694  ELSE
695  u%PARENT%RIGHT=>v
696  ENDIF
697  ENDIF
698  v%LEFT=>u
699  u%PARENT=>v
700  w=>x%PARENT%LEFT
701  ENDIF
702  w%COLOUR=x%PARENT%COLOUR
703  x%PARENT%COLOUR=tree_black_node
704  w%LEFT%COLOUR=tree_black_node
705  !Rotate right on X->Parent
706  u=>x%PARENT
707  v=>u%LEFT
708  u%LEFT=>v%RIGHT
709  IF(.NOT.ASSOCIATED(v%RIGHT,tree%NIL)) v%RIGHT%PARENT=>u
710  v%PARENT=>u%PARENT
711  IF(ASSOCIATED(v%PARENT,tree%NIL)) THEN
712  tree%ROOT=>v
713  ELSE
714  IF(ASSOCIATED(u,u%PARENT%RIGHT)) THEN
715  u%PARENT%RIGHT=>v
716  ELSE
717  u%PARENT%LEFT=>v
718  ENDIF
719  ENDIF
720  v%RIGHT=>u
721  u%PARENT=>v
722  x=>tree%ROOT
723  ENDIF
724  ENDIF
725  ENDDO
726  x%COLOUR=tree_black_node
727  ENDIF
728  IF(.NOT.ASSOCIATED(y,z)) THEN
729  y%LEFT=>z%LEFT
730  y%RIGHT=>z%RIGHT
731  y%PARENT=>z%PARENT
732  y%COLOUR=z%COLOUR
733  z%LEFT%PARENT=>y
734  z%RIGHT%PARENT=>y
735  IF(ASSOCIATED(z,z%PARENT%LEFT)) THEN
736  z%PARENT%LEFT=>y
737  ELSE
738  z%PARENT%RIGHT=>y
739  ENDIF
740  ENDIF
741  DEALLOCATE(z)
742  tree%NUMBER_IN_TREE=tree%NUMBER_IN_TREE-1
743  ELSE
744  local_error="Could not find the key "//trim(number_to_vstring(key,"*",err,error))//" in the tree"
745  CALL flagerror(local_error,err,error,*999)
746  ENDIF
747  ELSE
748  CALL flagerror("The tree root is NIL. Can not delete the key",err,error,*999)
749  ENDIF
750  ELSE
751  CALL flagerror("The tree has not been finished",err,error,*999)
752  ENDIF
753  ELSE
754  CALL flagerror("Tree is not associated",err,error,*999)
755  ENDIF
756 
757  exits("TREE_ITEM_DELETE")
758  RETURN
759 999 errorsexits("TREE_ITEM_DELETE",err,error)
760  RETURN 1
761  END SUBROUTINE tree_item_delete
762 
763  !
764  !================================================================================================================================
765  !
766 
768  SUBROUTINE tree_item_insert(TREE,KEY,VALUE,INSERT_STATUS,ERR,ERROR,*)
769 
770  !Argument Variables
771  TYPE(tree_type), POINTER :: TREE
772  INTEGER(INTG), INTENT(IN) :: KEY
773  INTEGER(INTG), INTENT(IN) :: VALUE
774  INTEGER(INTG), INTENT(OUT) :: INSERT_STATUS
775  INTEGER(INTG), INTENT(OUT) :: ERR
776  TYPE(varying_string), INTENT(OUT) :: ERROR
777  !Local Variables
778  LOGICAL :: DUPLICATE_KEY
779  TYPE(tree_node_type), POINTER :: NEW_TREE_NODE,X,Y,Z
780 
781  NULLIFY(new_tree_node)
782 
783  enters("TREE_ITEM_INSERT",err,error,*998)
784 
785  IF(ASSOCIATED(tree)) THEN
786  IF(tree%TREE_FINISHED) THEN
787  !Find the position to insert
788  y=>tree%NIL
789  x=>tree%ROOT
790  duplicate_key=.false.
791  DO WHILE(.NOT.ASSOCIATED(x,tree%NIL))
792  y=>x
793  duplicate_key=tree%INSERT_TYPE==tree_no_duplicates_allowed.AND.key==x%KEY
794  IF(duplicate_key) THEN
795  EXIT
796  ELSE IF(key<x%KEY) THEN
797  x=>x%LEFT
798  ELSE
799  x=>x%RIGHT
800  ENDIF
801  ENDDO
802  IF(duplicate_key) THEN
803  insert_status=tree_node_duplicate_key
804  ELSE
805  !Allocate the new tree node and set its key and value
806  ALLOCATE(new_tree_node,stat=err)
807  IF(err/=0) CALL flagerror("Could not allocate new tree node",err,error,*999)
808  CALL tree_node_initialise(tree,new_tree_node,err,error,*999)
809  new_tree_node%KEY=key
810  new_tree_node%VALUE=VALUE
811  !Insert the new tree node into the tree
812  new_tree_node%COLOUR=tree_red_node
813  new_tree_node%LEFT=>tree%NIL
814  new_tree_node%RIGHT=>tree%NIL
815  new_tree_node%PARENT=>y
816  IF(ASSOCIATED(y,tree%NIL)) THEN
817  tree%ROOT=>new_tree_node
818  ELSE
819  IF(new_tree_node%KEY<y%KEY) THEN
820  y%LEFT=>new_tree_node
821  ELSE
822  y%RIGHT=>new_tree_node
823  ENDIF
824  ENDIF
825  !Fix up the tree to keep red-black properties
826  !Note: Due to Fortran restrictions on aliasing pointers in dummy arguments we need to do the fixup and rotations
827  !inside this routine rather than call fixup and rotate left and rotate right subroutines.
828  z=>new_tree_node
829  DO WHILE(z%PARENT%COLOUR==tree_red_node)
830  IF(ASSOCIATED(z%PARENT,z%PARENT%PARENT%LEFT)) THEN
831  y=>z%PARENT%PARENT%RIGHT
832  IF(y%COLOUR==tree_red_node) THEN
833  z%PARENT%COLOUR=tree_black_node
834  y%COLOUR=tree_black_node
835  z%PARENT%PARENT%COLOUR=tree_red_node
836  z=>z%PARENT%PARENT
837  ELSE
838  IF(ASSOCIATED(z,z%PARENT%RIGHT)) THEN
839  z=>z%PARENT
840  !Rotate the tree left at Z
841  x=>z
842  y=>x%RIGHT
843  x%RIGHT=>y%LEFT
844  IF(.NOT.ASSOCIATED(y%LEFT,tree%NIL)) y%LEFT%PARENT=>x
845  y%PARENT=>x%PARENT
846  IF(ASSOCIATED(x%PARENT,tree%NIL)) THEN
847  tree%ROOT=>y
848  ELSE
849  IF(ASSOCIATED(x,x%PARENT%LEFT)) THEN
850  x%PARENT%LEFT=>y
851  ELSE
852  x%PARENT%RIGHT=>y
853  ENDIF
854  ENDIF
855  y%LEFT=>x
856  x%PARENT=>y
857  ENDIF
858  z%PARENT%COLOUR=tree_black_node
859  z%PARENT%PARENT%COLOUR=tree_red_node
860  !Rotate the tree right at Z->Parent->Parent
861  x=>z%PARENT%PARENT
862  y=>x%LEFT
863  x%LEFT=>y%RIGHT
864  IF(.NOT.ASSOCIATED(y%RIGHT,tree%NIL)) y%RIGHT%PARENT=>x
865  y%PARENT=>x%PARENT
866  IF(ASSOCIATED(x%PARENT,tree%NIL)) THEN
867  tree%ROOT=>y
868  ELSE
869  IF(ASSOCIATED(x,x%PARENT%RIGHT)) THEN
870  x%PARENT%RIGHT=>y
871  ELSE
872  x%PARENT%LEFT=>y
873  ENDIF
874  ENDIF
875  y%RIGHT=>x
876  x%PARENT=>y
877  ENDIF
878  ELSE
879  y=>z%PARENT%PARENT%LEFT
880  IF(y%COLOUR==tree_red_node) THEN
881  z%PARENT%COLOUR=tree_black_node
882  y%COLOUR=tree_black_node
883  z%PARENT%PARENT%COLOUR=tree_red_node
884  z=>z%PARENT%PARENT
885  ELSE
886  IF(ASSOCIATED(z,z%PARENT%LEFT)) THEN
887  z=>z%PARENT
888  x=>z
889  !Rotate the tree right at Z
890  y=>x%LEFT
891  x%LEFT=>y%RIGHT
892  IF(.NOT.ASSOCIATED(y%RIGHT,tree%NIL)) y%RIGHT%PARENT=>x
893  y%PARENT=>x%PARENT
894  IF(ASSOCIATED(x%PARENT,tree%NIL)) THEN
895  tree%ROOT=>y
896  ELSE
897  IF(ASSOCIATED(x,x%PARENT%RIGHT)) THEN
898  x%PARENT%RIGHT=>y
899  ELSE
900  x%PARENT%LEFT=>y
901  ENDIF
902  ENDIF
903  y%RIGHT=>x
904  x%PARENT=>y
905  ENDIF
906  z%PARENT%COLOUR=tree_black_node
907  z%PARENT%PARENT%COLOUR=tree_red_node
908  !Rotate the tree left at Z->Parent->Parent
909  x=>z%PARENT%PARENT
910  y=>x%RIGHT
911  x%RIGHT=>y%LEFT
912  IF(.NOT.ASSOCIATED(y%LEFT,tree%NIL)) y%LEFT%PARENT=>x
913  y%PARENT=>x%PARENT
914  IF(ASSOCIATED(x%PARENT,tree%NIL)) THEN
915  tree%ROOT=>y
916  ELSE
917  IF(ASSOCIATED(x,x%PARENT%LEFT)) THEN
918  x%PARENT%LEFT=>y
919  ELSE
920  x%PARENT%RIGHT=>y
921  ENDIF
922  ENDIF
923  y%LEFT=>x
924  x%PARENT=>y
925  ENDIF
926  ENDIF
927  ENDDO
928  tree%ROOT%COLOUR=tree_black_node
929  !Increment the number in the tree and indicate a successful insertion
930  tree%NUMBER_IN_TREE=tree%NUMBER_IN_TREE+1
931  insert_status=tree_node_insert_sucessful
932  ENDIF
933  ELSE
934  CALL flagerror("The tree has not been finished",err,error,*998)
935  ENDIF
936  ELSE
937  CALL flagerror("Tree is not associated",err,error,*998)
938  ENDIF
939 
940  exits("TREE_ITEM_INSERT")
941  RETURN
942 999 IF(ASSOCIATED(new_tree_node)) DEALLOCATE(new_tree_node)
943 998 errorsexits("TREE_ITEM_INSERT",err,error)
944  RETURN 1
945  END SUBROUTINE tree_item_insert
946 
947  !
948  !================================================================================================================================
949  !
950 
952  RECURSIVE SUBROUTINE tree_node_finalise(TREE,TREE_NODE,ERR,ERROR,*)
953 
954  !Argument Variables
955  TYPE(tree_type), POINTER :: TREE
956  TYPE(tree_node_type), POINTER :: TREE_NODE
957  INTEGER(INTG), INTENT(OUT) :: ERR
958  TYPE(varying_string), INTENT(OUT) :: ERROR
959  !Local Variables
960 
961  enters("TREE_NODE_FINALISE",err,error,*999)
962 
963  IF(ASSOCIATED(tree)) THEN
964  IF(.NOT.ASSOCIATED(tree_node,tree%NIL)) THEN
965  CALL tree_node_finalise(tree,tree_node%LEFT,err,error,*999)
966  CALL tree_node_finalise(tree,tree_node%RIGHT,err,error,*999)
967  DEALLOCATE(tree_node)
968  ENDIF
969  ELSE
970  CALL flagerror("Tree is not associated",err,error,*999)
971  ENDIF
972 
973  exits("TREE_NODE_FINALISE")
974  RETURN
975 999 errorsexits("TREE_NODE_FINALISE",err,error)
976  RETURN 1
977  END SUBROUTINE tree_node_finalise
978 
979  !
980  !================================================================================================================================
981  !
982 
984  SUBROUTINE tree_node_initialise(TREE,TREE_NODE,ERR,ERROR,*)
985 
986  !Argument Variables
987  TYPE(tree_type), POINTER :: TREE
988  TYPE(tree_node_type), POINTER :: TREE_NODE
989  INTEGER(INTG), INTENT(OUT) :: ERR
990  TYPE(varying_string), INTENT(OUT) :: ERROR
991  !Local Variables
992 
993  enters("TREE_NODE_INITIALISE",err,error,*999)
994 
995  IF(ASSOCIATED(tree)) THEN
996  IF(ASSOCIATED(tree_node)) THEN
997  tree_node%KEY=0
998  tree_node%VALUE=0
999  tree_node%COLOUR=tree_black_node
1000  NULLIFY(tree_node%LEFT)
1001  NULLIFY(tree_node%RIGHT)
1002  NULLIFY(tree_node%PARENT)
1003  ELSE
1004  CALL flagerror("Tree node is not associated",err,error,*999)
1005  ENDIF
1006  ELSE
1007  CALL flagerror("Tree is not associated",err,error,*999)
1008  ENDIF
1009 
1010  exits("TREE_NODE_INITIALISE")
1011  RETURN
1012 999 errorsexits("TREE_NODE_INITIALISE",err,error)
1013  RETURN 1
1014  END SUBROUTINE tree_node_initialise
1015 
1016  !
1017  !================================================================================================================================
1018  !
1019 
1021  SUBROUTINE tree_node_key_get(TREE,TREE_NODE,KEY,ERR,ERROR,*)
1022 
1023  !Argument Variables
1024  TYPE(tree_type), POINTER :: TREE
1025  TYPE(tree_node_type), POINTER :: TREE_NODE
1026  INTEGER(INTG), INTENT(OUT) :: KEY
1027  INTEGER(INTG), INTENT(OUT) :: ERR
1028  TYPE(varying_string), INTENT(OUT) :: ERROR
1029  !Local Variables
1030 
1031  enters("TREE_NODE_KEY_GET",err,error,*999)
1032 
1033  IF(ASSOCIATED(tree)) THEN
1034  IF(tree%TREE_FINISHED) THEN
1035  IF(ASSOCIATED(tree_node)) THEN
1036  key=tree_node%KEY
1037  ELSE
1038  CALL flagerror("Tree node is not associated",err,error,*999)
1039  ENDIF
1040  ELSE
1041  CALL flagerror("Tree has not been finished",err,error,*999)
1042  ENDIF
1043  ELSE
1044  CALL flagerror("Tree is not associated",err,error,*999)
1045  ENDIF
1046 
1047  exits("TREE_NODE_KEY_GET")
1048  RETURN
1049 999 errorsexits("TREE_NODE_KEY_GET",err,error)
1050  RETURN 1
1051  END SUBROUTINE tree_node_key_get
1052 
1053  !
1054  !================================================================================================================================
1055  !
1056 
1058  SUBROUTINE tree_node_value_get(TREE,TREE_NODE,VALUE,ERR,ERROR,*)
1059 
1060  !Argument Variables
1061  TYPE(tree_type), POINTER :: TREE
1062  TYPE(tree_node_type), POINTER :: TREE_NODE
1063  INTEGER(INTG), INTENT(OUT) :: VALUE
1064  INTEGER(INTG), INTENT(OUT) :: ERR
1065  TYPE(varying_string), INTENT(OUT) :: ERROR
1066  !Local Variables
1067 
1068  enters("TREE_NODE_VALUE_GET",err,error,*999)
1069 
1070  IF(ASSOCIATED(tree)) THEN
1071  IF(tree%TREE_FINISHED) THEN
1072  IF(ASSOCIATED(tree_node)) THEN
1073  VALUE=tree_node%VALUE
1074  ELSE
1075  CALL flagerror("Tree node is not associated",err,error,*999)
1076  ENDIF
1077  ELSE
1078  CALL flagerror("Tree has not been finished",err,error,*999)
1079  ENDIF
1080  ELSE
1081  CALL flagerror("Tree is not associated",err,error,*999)
1082  ENDIF
1083 
1084  exits("TREE_NODE_VALUE_GET")
1085  RETURN
1086 999 errorsexits("TREE_NODE_VALUE_GET",err,error)
1087  RETURN 1
1088  END SUBROUTINE tree_node_value_get
1089 
1090  !
1091  !================================================================================================================================
1092  !
1093 
1095  SUBROUTINE tree_node_value_set(TREE,TREE_NODE,VALUE,ERR,ERROR,*)
1096 
1097  !Argument Variables
1098  TYPE(tree_type), POINTER :: TREE
1099  TYPE(tree_node_type), POINTER :: TREE_NODE
1100  INTEGER(INTG), INTENT(IN) :: VALUE
1101  INTEGER(INTG), INTENT(OUT) :: ERR
1102  TYPE(varying_string), INTENT(OUT) :: ERROR
1103  !Local Variables
1104 
1105  enters("TREE_NODE_VALUE_SET",err,error,*999)
1106 
1107  IF(ASSOCIATED(tree)) THEN
1108  IF(tree%TREE_FINISHED) THEN
1109  IF(ASSOCIATED(tree_node)) THEN
1110  tree_node%VALUE=VALUE
1111  ELSE
1112  CALL flagerror("Tree node is not associated",err,error,*999)
1113  ENDIF
1114  ELSE
1115  CALL flagerror("Tree has not been finished",err,error,*999)
1116  ENDIF
1117  ELSE
1118  CALL flagerror("Tree is not associated",err,error,*999)
1119  ENDIF
1120 
1121  exits("TREE_NODE_VALUE_SET")
1122  RETURN
1123 999 errorsexits("TREE_NODE_VALUE_SET",err,error)
1124  RETURN 1
1125  END SUBROUTINE tree_node_value_set
1126 
1127  !
1128  !================================================================================================================================
1129  !
1130 
1132  SUBROUTINE tree_output(ID,TREE,ERR,ERROR,*)
1133 
1134  !Argument Variables
1135  INTEGER(INTG), INTENT(IN) :: ID
1136  TYPE(tree_type), POINTER :: TREE
1137  INTEGER(INTG), INTENT(OUT) :: ERR
1138  TYPE(varying_string), INTENT(OUT) :: ERROR
1139  !Local Variables
1140 
1141  enters("TREE_OUTPUT",err,error,*999)
1142 
1143  IF(ASSOCIATED(tree)) THEN
1144  IF(tree%TREE_FINISHED) THEN
1145  CALL write_string(id,"Tree:",err,error,*999)
1146  CALL write_string_value(id,"Number of tree nodes = ",tree%NUMBER_IN_TREE,err,error,*999)
1147  CALL write_string_value(id,"Tree insert type = ",tree%INSERT_TYPE,err,error,*999)
1148  CALL tree_output_in_order(id,tree,tree%ROOT,err,error,*999)
1149  ELSE
1150  CALL flagerror("The tree has not been finished",err,error,*999)
1151  ENDIF
1152  ELSE
1153  CALL flagerror("Tree is not associated",err,error,*999)
1154  ENDIF
1155 
1156  exits("TREE_OUTPUT")
1157  RETURN
1158 999 errorsexits("TREE_OUTPUT",err,error)
1159  RETURN 1
1160  END SUBROUTINE tree_output
1161 
1162  !
1163  !================================================================================================================================
1164  !
1165 
1167  RECURSIVE SUBROUTINE tree_output_in_order(ID,TREE,X,ERR,ERROR,*)
1168 
1169  !Argument Variables
1170  INTEGER(INTG), INTENT(IN) :: ID
1171  TYPE(tree_type), POINTER :: TREE
1172  TYPE(tree_node_type), POINTER :: X
1173  INTEGER(INTG), INTENT(OUT) :: ERR
1174  TYPE(varying_string), INTENT(OUT) :: ERROR
1175  !Local Variables
1176 
1177  enters("TREE_OUTPUT_IN_ORDER",err,error,*999)
1178 
1179  IF(ASSOCIATED(tree)) THEN
1180  IF(.NOT.ASSOCIATED(x,tree%NIL)) THEN
1181  !Output the left subtree first
1182  CALL tree_output_in_order(id,tree,x%LEFT,err,error,*999)
1183  !Now output the information for this node
1184  CALL write_string(id," Tree Node:",err,error,*999)
1185  CALL write_string_value(id," Key = ",x%KEY,err,error,*999)
1186  CALL write_string_value(id," Value = ",x%VALUE,err,error,*999)
1187  CALL write_string_value(id," Colour = ",x%COLOUR,err,error,*999)
1188  IF(ASSOCIATED(x%LEFT,tree%NIL)) THEN
1189  CALL write_string(id," Left Key = NIL",err,error,*999)
1190  ELSE
1191  CALL write_string_value(id," Left Key = ",x%LEFT%KEY,err,error,*999)
1192  ENDIF
1193  IF(ASSOCIATED(x%RIGHT,tree%NIL)) THEN
1194  CALL write_string(id," Right Key = NIL",err,error,*999)
1195  ELSE
1196  CALL write_string_value(id," Right Key = ",x%RIGHT%KEY,err,error,*999)
1197  ENDIF
1198  IF(ASSOCIATED(x%PARENT,tree%NIL)) THEN
1199  CALL write_string(id," Parent Key = NIL",err,error,*999)
1200  ELSE
1201  CALL write_string_value(id," Parent Key = ",x%PARENT%KEY,err,error,*999)
1202  ENDIF
1203  !Output the right subtree last
1204  CALL tree_output_in_order(id,tree,x%RIGHT,err,error,*999)
1205  ENDIF
1206  ELSE
1207  CALL flagerror("Tree is not associated",err,error,*999)
1208  ENDIF
1209 
1210  exits("TREE_OUTPUT_IN_ORDER")
1211  RETURN
1212 999 errorsexits("TREE_OUTPUT_IN_ORDER",err,error)
1213  RETURN 1
1214  END SUBROUTINE tree_output_in_order
1215 
1216  !
1217  !================================================================================================================================
1218  !
1219 
1221  FUNCTION tree_predecessor(TREE,X,ERR,ERROR)
1222 
1223  !Argument Variables
1224  TYPE(tree_type), POINTER :: TREE
1225  TYPE(tree_node_type), POINTER :: X
1226  INTEGER(INTG), INTENT(OUT) :: ERR
1227  TYPE(varying_string), INTENT(OUT) :: ERROR
1228  !Function variable
1229  TYPE(tree_node_type), POINTER :: TREE_PREDECESSOR
1230  !Local Variables
1231  TYPE(tree_node_type), POINTER :: Y
1232 
1233  NULLIFY(tree_predecessor)
1234 
1235  enters("TREE_PREDECESSOR",err,error,*999)
1236 
1237  IF(ASSOCIATED(tree)) THEN
1238  IF(ASSOCIATED(x)) THEN
1239  y=>x%LEFT
1240  IF(ASSOCIATED(y,tree%NIL)) THEN
1241  DO WHILE(.NOT.ASSOCIATED(y%RIGHT,tree%NIL))
1242  y=>y%RIGHT
1243  ENDDO
1244  tree_predecessor=>y
1245  ELSE
1246  y=>x%PARENT
1247  DO WHILE(ASSOCIATED(x,y%LEFT))
1248  IF(ASSOCIATED(y,tree%ROOT)) THEN
1249  tree_predecessor=>tree%NIL
1250  EXIT
1251  ELSE
1252  x=>y
1253  y=>y%PARENT
1254  ENDIF
1255  ENDDO
1256  IF(.NOT.ASSOCIATED(tree_predecessor)) tree_predecessor=>y
1257  ENDIF
1258  ELSE
1259  CALL flagerror("Tree node X is not associated",err,error,*999)
1260  ENDIF
1261  ELSE
1262  CALL flagerror("Tree is not associated",err,error,*999)
1263  ENDIF
1264 
1265  exits("TREE_PREDECESSOR")
1266  RETURN
1267 999 errorsexits("TREE_PREDECESSOR",err,error)
1268  RETURN
1269  END FUNCTION tree_predecessor
1270 
1271  !
1272  !================================================================================================================================
1273  !
1274 
1276  SUBROUTINE tree_search(TREE,KEY,X,ERR,ERROR,*)
1277 
1278  !Argument Variables
1279  TYPE(tree_type), POINTER :: TREE
1280  INTEGER(INTG), INTENT(IN) :: KEY
1281  TYPE(tree_node_type), POINTER :: X
1282  INTEGER(INTG), INTENT(OUT) :: ERR
1283  TYPE(varying_string), INTENT(OUT) :: ERROR
1284  !Local Variables
1285  INTEGER(INTG) :: COMPARE_VALUE
1286  TYPE(tree_node_type), POINTER :: Y
1287 
1288  enters("TREE_SEARCH",err,error,*999)
1289 
1290  IF(ASSOCIATED(tree)) THEN
1291  IF(tree%TREE_FINISHED) THEN
1292  IF(ASSOCIATED(x)) THEN
1293  CALL flagerror("The tree node X is already associated",err,error,*999)
1294  ELSE
1295  NULLIFY(x)
1296  y=>tree%ROOT
1297  IF(.NOT.ASSOCIATED(y,tree%NIL)) THEN
1298  compare_value=y%KEY-key
1299  DO WHILE(compare_value/=0)
1300  IF(compare_value>0) THEN !Y%KEY > KEY
1301  y=>y%LEFT
1302  ELSE !Y%KEY < KEY
1303  y=>y%RIGHT
1304  ENDIF
1305  IF(ASSOCIATED(y,tree%NIL)) THEN
1306  EXIT
1307  ELSE
1308  compare_value=y%KEY-key
1309  ENDIF
1310  ENDDO
1311  IF(compare_value==0) x=>y
1312  ENDIF
1313  ENDIF
1314  ELSE
1315  CALL flagerror("The tree has not been finished",err,error,*999)
1316  ENDIF
1317  ELSE
1318  CALL flagerror("Tree is not associated",err,error,*999)
1319  ENDIF
1320 
1321  exits("TREE_SEARCH")
1322  RETURN
1323 999 errorsexits("TREE_SEARCH",err,error)
1324  RETURN 1
1325  END SUBROUTINE tree_search
1326 
1327  !
1328  !================================================================================================================================
1329  !
1330 
1332  FUNCTION tree_successor(TREE,X,ERR,ERROR)
1333 
1334  !Argument Variables
1335  TYPE(tree_type), POINTER :: TREE
1336  TYPE(tree_node_type), POINTER :: X
1337  INTEGER(INTG), INTENT(OUT) :: ERR
1338  TYPE(varying_string), INTENT(OUT) :: ERROR
1339  !Function variable
1340  TYPE(tree_node_type), POINTER :: TREE_SUCCESSOR
1341  !Local Variables
1342  TYPE(tree_node_type), POINTER :: Y
1343 
1344  NULLIFY(tree_successor)
1345 
1346  enters("TREE_SUCCESSOR",err,error,*999)
1347 
1348  IF(ASSOCIATED(tree)) THEN
1349  IF(ASSOCIATED(x)) THEN
1350  y=>x%RIGHT
1351  IF(ASSOCIATED(y,tree%NIL)) THEN
1352  DO WHILE(.NOT.ASSOCIATED(y%LEFT,tree%NIL))
1353  y=>y%LEFT
1354  ENDDO
1355  tree_successor=>y
1356  RETURN
1357  ELSE
1358  y=>x%PARENT
1359  DO WHILE(ASSOCIATED(x,y%RIGHT))
1360  x=>y
1361  y=>y%PARENT
1362  ENDDO
1363  IF(ASSOCIATED(y,tree%ROOT)) THEN
1364  tree_successor=>tree%NIL
1365  ELSE
1366  tree_successor=>y
1367  ENDIF
1368  ENDIF
1369  ELSE
1370  CALL flagerror("Tree node X is not associated",err,error,*999)
1371  ENDIF
1372  ELSE
1373  CALL flagerror("Tree is not associated",err,error,*999)
1374  ENDIF
1375 
1376  exits("TREE_SUCCESSOR")
1377  RETURN
1378 999 errorsexits("TREE_SUCCESSOR",err,error)
1379  RETURN
1380  END FUNCTION tree_successor
1381 
1382  !
1383  !================================================================================================================================
1384  !
1385 
1386 END MODULE trees
trees::tree_duplicates_allowed_type
integer(intg), parameter, public tree_duplicates_allowed_type
Duplicate keys allowed tree type.
Definition: trees.f90:81
base_routines::enters
subroutine, public enters(NAME, ERR, ERROR,)
Records the entry into the named procedure and initialises the error code.
Definition: base_routines.f90:363
trees::tree_insert_type_set
subroutine, public tree_insert_type_set(TREE, INSERT_TYPE, ERR, ERROR,)
Sets/changes the insert type for a tree.
Definition: trees.f90:480
input_output::write_string_value
Write a string followed by a value to a given output stream.
Definition: input_output.f90:86
trees::tree_inserttypeset
Definition: trees.f90:122
trees::tree_iteminsert
Definition: trees.f90:130
strings::number_to_vstring
Converts a number to its equivalent varying string representation.
Definition: strings.f90:161
trees
Implements trees of base types.
Definition: trees.f90:45
trees::tree_node_insert_sucessful
integer(intg), parameter, public tree_node_insert_sucessful
Successful insert status.
Definition: trees.f90:73
trees::tree_search
subroutine, public tree_search(TREE, KEY, X, ERR, ERROR,)
Searches a tree to see if it contains a key.
Definition: trees.f90:1277
strings
This module contains all string manipulation and transformation routines.
Definition: strings.f90:45
trees::tree_node_initialise
subroutine tree_node_initialise(TREE, TREE_NODE, ERR, ERROR,)
Initialises a tree node.
Definition: trees.f90:985
trees::tree_createfinish
Definition: trees.f90:110
trees::tree_node_type
Definition: trees.f90:87
trees::tree_detach_and_destroy
subroutine, public tree_detach_and_destroy(TREE, NUMBER_IN_TREE, TREE_VALUES, ERR, ERROR,)
Detaches the tree values and returns them as a pointer to the an array and then destroys the tree...
Definition: trees.f90:335
iso_varying_string
This module provides an iso_varying_string module, conformant to the API specified in ISO/IEC 1539-2:...
Definition: iso_varying_string.f90:62
trees::tree_detachanddestroy
Definition: trees.f90:118
trees::tree_output
subroutine, public tree_output(ID, TREE, ERR, ERROR,)
Outputs a tree to the specified output stream ID.
Definition: trees.f90:1133
iso_varying_string::varying_string
Definition: iso_varying_string.f90:75
trees::tree_itemdelete
Definition: trees.f90:126
trees::tree_output_in_order
recursive subroutine tree_output_in_order(ID, TREE, X, ERR, ERROR,)
Outputs a tree in order to the specified output stream ID from the specified tree node...
Definition: trees.f90:1168
base_routines::exits
subroutine, public exits(NAME)
Records the exit out of the named procedure.
Definition: base_routines.f90:504
trees::tree_type
Definition: trees.f90:97
input_output::write_string
Write a string to a given output stream.
Definition: input_output.f90:74
base_routines
This module contains all the low-level base routines e.g., all debug, control, and low-level communic...
Definition: base_routines.f90:45
trees::tree_item_delete
subroutine, public tree_item_delete(TREE, KEY, ERR, ERROR,)
Deletes a tree node specified by a key from a tree.
Definition: trees.f90:521
trees::tree_successor
type(tree_node_type) function, pointer tree_successor(TREE, X, ERR, ERROR)
Returns the successor of a tree at a specified tree node.
Definition: trees.f90:1333
iso_varying_string::trim
Definition: iso_varying_string.f90:204
trees::tree_node_duplicate_key
integer(intg), parameter, public tree_node_duplicate_key
Duplicate key found for those trees that do not allow duplicate keys.
Definition: trees.f90:74
trees::tree_create_finish
subroutine, public tree_create_finish(TREE, ERR, ERROR,)
Finishes the creation of a tree created with TREE_CREATE_START.
Definition: trees.f90:190
trees::tree_nodekeyget
Definition: trees.f90:134
trees::tree_detach
subroutine, public tree_detach(TREE, NUMBER_IN_TREE, TREE_VALUES, ERR, ERROR,)
Detaches the tree values and returns them as a pointer to the an array.
Definition: trees.f90:292
trees::tree_no_duplicates_allowed
integer(intg), parameter, public tree_no_duplicates_allowed
No duplicate keys allowed tree type.
Definition: trees.f90:82
trees::tree_node_key_get
subroutine, public tree_node_key_get(TREE, TREE_NODE, KEY, ERR, ERROR,)
Gets the key at a specified tree node.
Definition: trees.f90:1022
trees::tree_nodevalueset
Definition: trees.f90:142
trees::tree_nodevalueget
Definition: trees.f90:138
trees::tree_destroy
subroutine, public tree_destroy(TREE, ERR, ERROR,)
Destroys a tree.
Definition: trees.f90:265
trees::tree_detach_in_order
recursive subroutine tree_detach_in_order(TREE, X, COUNT, TREE_VALUES, ERR, ERROR,)
Detaches the tree values in order from the specified tree node and adds them to the tree values array...
Definition: trees.f90:379
trees::tree_createstart
Definition: trees.f90:114
trees::tree_item_insert
subroutine, public tree_item_insert(TREE, KEY, VALUE, INSERT_STATUS, ERR, ERROR,)
Inserts a tree node into a red-black tree.
Definition: trees.f90:769
trees::tree_node_value_set
subroutine, public tree_node_value_set(TREE, TREE_NODE, VALUE, ERR, ERROR,)
Sets the value at a specified tree node.
Definition: trees.f90:1096
trees::tree_node_value_get
subroutine, public tree_node_value_get(TREE, TREE_NODE, VALUE, ERR, ERROR,)
Gets the value at a specified tree node.
Definition: trees.f90:1059
trees::tree_predecessor
type(tree_node_type) function, pointer tree_predecessor(TREE, X, ERR, ERROR)
Returns the predeccessor of a tree at a specified tree node.
Definition: trees.f90:1222
trees::tree_node_finalise
recursive subroutine tree_node_finalise(TREE, TREE_NODE, ERR, ERROR,)
Finalises a tree node and deallocates all memory.
Definition: trees.f90:953
trees::tree_red_node
integer(intg), parameter tree_red_node
The red colour type for a tree node.
Definition: trees.f90:66
base_routines::flagerror
Flags an error condition.
Definition: base_routines.f90:240
trees::tree_black_node
integer(intg), parameter tree_black_node
The black colour type for a tree node.
Definition: trees.f90:65
trees::tree_create_start
subroutine, public tree_create_start(TREE, ERR, ERROR,)
Starts the creation of a tree and returns a pointer to the created tree.
Definition: trees.f90:233
trees::tree_initialise
subroutine tree_initialise(TREE, ERR, ERROR,)
Initialises a tree.
Definition: trees.f90:449
kinds
This module contains all kind definitions.
Definition: kinds.f90:45
trees::tree_finalise
subroutine tree_finalise(TREE, ERR, ERROR,)
Finalises a tree and deallocates all memory.
Definition: trees.f90:422
input_output
This module handles all formating and input and output.
Definition: input_output.f90:45