바이너리 트리를 이용한 정렬 및 탐색
PROGRAM binary_tree
USE btree
IMPLICIT NONE
INTEGER :: error
CHARACTER(LEN = 20) :: filename
INTEGER :: istat
CHARACTER(LEN = 40) :: error_msg
TYPE (node), POINTER :: root
TYPE (node), POINTER :: temp
NULLIFY(root, temp)
WRITE (*,*) 'Enter the file name with the input data: '
READ (*,'(A20)') filename
OPEN (UNIT = 9, FILE = filename, STATUS = 'OLD', ACTION = 'READ', IOSTAT = istat, IOMSG = error_msg)
IF (istat == 0) THEN
DO
ALLOCATE(temp, STAT = istat)
NULLIFY(temp%before, temp%after)
READ (9, 100, IOSTAT = istat) temp%last, temp%first, temp%mi, temp%phone
100 FORMAT (A10, 1X, A10, 1X, A1, 1X, A16)
IF (istat /= 0) EXIT
CALL add_node(root, temp)
END DO
WRITE (*,'(/,1X,A)') 'The sorted data list is: '
CALL write_node(root)
WRITE (*,'(/,1X,A)') 'Enter name to recover from tree:'
WRITE (*,'(1X,A)', ADVANCE = 'NO') 'Last Name : '
READ (*,'(A)') temp%last
WRITE (*,'(1X,A)', ADVANCE = 'NO') 'First Name : '
READ (*,'(A)') temp%first
WRITE (*,'(1X,A)', ADVANCE = 'NO') 'Middle Initial : '
READ (*,'(A)') temp%mi
CALL find_node(root, temp, error)
IF (error == 0) THEN
WRITE (*, '(/,1X,A)') 'The record is:'
WRITE (*, '(1X, 7A)') temp%last, ', ', temp%first, ', ', temp%mi, ', ', temp%phone
ELSE
WRITE (*,'(/,1X,A)') 'Specified node not found!'
END If
ELSE
WRITE (*,'(1X, A, A)') 'File open failed -- error message : ', error_msg
END IF
END PROGRAM binary_tree
위 소스를 binary_tree.f95로 저장
MODULE btree
IMPLICIT NONE
! restrict access to module contents
PRIVATE
PUBLIC :: node, OPERATOR(>), OPERATOR(<), OPERATOR(==)
PUBLIC :: add_node, write_node, find_node
TYPE :: node
CHARACTER(LEN = 10) :: last
CHARACTER(LEN = 10) :: first
CHARACTER :: mi
CHARACTER(LEN = 16) :: phone
TYPE (node), POINTER :: before
TYPE (node), POINTER :: after
END TYPE
INTERFACE OPERATOR (>)
MODULE PROCEDURE greater_than
END INTERFACE
INTERFACE OPERATOR (<)
MODULE PROCEDURE less_than
END INTERFACE
INTERFACE OPERATOR (==)
MODULE PROCEDURE equal_to
END INTERFACE
CONTAINS
RECURSIVE SUBROUTINE add_node(ptr, new_node)
! to add a new node to the binary tree structure
TYPE (node), POINTER :: ptr ! pointer to current pos. in tree
TYPE (node), POINTER :: new_node ! pointer to new node
IF (.NOT. ASSOCIATED(ptr)) THEN
! there is no tree yet
ptr => new_node
ELSE IF (new_node < ptr) THEN
IF (ASSOCIATED(ptr%before)) THEN
CALL add_node(ptr%before, new_node)
ELSE
ptr%before => new_node
END IF
ELSE
IF (ASSOCIATED(ptr%after)) THEN
CALL add_node(ptr%after, new_node)
ELSE
ptr%after => new_node
END IF
END IF
END SUBROUTINE add_node
RECURSIVE SUBROUTINE write_node(ptr)
! write out the contents of the binary tree structure in order
TYPE (node), POINTER :: ptr ! pointer to current pos. in tree
! write contents of previous node
IF (ASSOCIATED(ptr%before)) THEN
CALL write_node(ptr%before)
END IF
! write contents of current node
WRITE (*,"(1X,A,', ',A,1X,A)") ptr%last, ptr%first, ptr%mi
! write contents of next node
IF (ASSOCIATED(ptr%after)) THEN
CALL write_node(ptr%after)
END IF
END SUBROUTINE write_node
RECURSIVE SUBROUTINE find_node(ptr, search, error)
! to find a particular node in the tree
TYPE (node), POINTER :: ptr ! pointer to curr pos. in tree
TYPE (node), POINTER :: search ! pointer to value to find out
INTEGER :: error ! error : 0 = ok, 1 = not found
IF ( search < ptr ) THEN
IF (ASSOCIATED(ptr%before)) THEN
CALL find_node(ptr%before, search, error)
ELSE
error = 1
END IF
ELSE IF (search == ptr) THEN
search = ptr
error = 0
ELSE
IF (ASSOCIATED(ptr%after)) THEN
CALL find_node(ptr%after, search, error)
ELSE
error = 1
END IF
END IF
END SUBROUTINE find_node
LOGICAL FUNCTION greater_than(op1, op2)
TYPE (node), INTENT(IN) :: op1, op2
CHARACTER(LEN = 10) :: last1, last2, first1, first2
CHARACTER :: mi1, mi2
CALL ushift(op1, last1, first1, mi1)
CALL ushift(op2, last2, first2, mi2)
IF (last1 > last2) THEN
greater_than = .TRUE.
ELSE IF (last1 < last2) THEN
greater_than = .FALSE.
ELSE
IF (first1 > first2) THEN
greater_than = .TRUE.
ELSE IF (first1 < first2) THEN
greater_than = .FALSE.
ELSE
IF (mi1 > mi2) THEN
greater_than = .TRUE.
ELSE
greater_than = .FALSE.
END IF
END IF
END IF
END FUNCTION greater_than
LOGICAL FUNCTION less_than(op1, op2)
TYPE (node), INTENT(IN) :: op1, op2
CHARACTER(LEN = 10) :: last1, last2, first1, first2
CHARACTER :: mi1, mi2
CALL ushift(op1, last1, first1, mi1)
CALL ushift(op2, last2, first2, mi2)
IF (last1 < last2) THEN
less_than = .TRUE.
ELSE IF (last1 > last2) THEN
less_than = .FALSE.
ELSE
IF (first1 < first2) THEN
less_than = .TRUE.
ELSE IF (first1 > first2) THEN
less_than = .FALSE.
ELSE
IF (mi1 < mi2) THEN
less_than = .TRUE.
ELSE
less_than = .FALSE.
END IF
END IF
END IF
END FUNCTION less_than
LOGICAL FUNCTION equal_to(op1, op2)
TYPE(node), INTENT(IN) :: op1, op2
CHARACTER(LEN = 10) :: last1, last2, first1, first2
CHARACTER :: mi1, mi2
CALL ushift(op1, last1, first1, mi1)
CALL ushift(op2, last2, first2, mi2)
IF ((last1 == last2) .AND. (first1 == first2) .AND. (mi1 == mi2)) THEN
equal_to = .TRUE.
ELSE
equal_to = .FALSE.
END IF
END FUNCTION equal_to
SUBROUTINE ushift(op, last, first, mi)
TYPE (node), INTENT(IN) :: op
CHARACTER(LEN = 10), INTENT(INOUT) :: last, first
CHARACTER, INTENT(INOUT) :: mi
last = op%last
first = op%first
mi = op%mi
CALL ucase(last)
CALL ucase(first)
CALL ucase(mi)
END SUBROUTINE ushift
SUBROUTINE ucase (string)
IMPLICIT NONE
CHARACTER(LEN = *), INTENT(INOUT) :: string
INTEGER :: i
INTEGER :: length
length = LEN(string)
DO i = 1, length
IF (LGE(string(i:i), 'a') .AND. LLE(string(i:i), 'z')) THEN
string(i:i) = ACHAR(IACHAR(string(1:1)) - 32)
END IF
END DO
END SUBROUTINE ucase
END MODULE btree
위 소스를 btree.f95로 저장
Leroux Hector A (608) 555-1212
Johnson James R (800) 800-1111
Jackson Andrew D (713) 723-7777
Romanoff Alexi N (212) 338-3030
Johnson Jessie R (800) 800-1111
Chapman Stephen J (713) 721-0901
Nachshon Bini M (618) 813-1234
Ziskend Joseph J (805) 238-7999
Johnson Andrew C (504) 388-3000
Chi Shuchung F (504) 388-3123
deBerry Jonathan S (703) 765-4321
Chapman Rosa P (713) 721-0901
Gomez Jose A (415) 555-1212
Rosenberg Fred R (617) 123-4567
위 자료를 tree_in.dat 로 저장
컴파일 및 프로그램 테스트
'Programming > Fortran' 카테고리의 다른 글
Pointer-valued function (0) | 2009.01.14 |
---|---|
Using pointers in procedures (0) | 2009.01.13 |
Insertion sort using linked list (0) | 2009.01.10 |
usign direct access, formatted file (0) | 2009.01.06 |
NAMELIST I/O (0) | 2009.01.06 |