Fortran 95 で１方向リンクト・リスト (singly linked list) を書く場合、 データを持たないルートノードを用いて、それを「list」とするのが便利。
□□□ … データフィールド Ｐ … ポインタ (リンク) □□□Ｐ … ノード 空空空Ｐ … データフィールドに意味のあるものが入っていないノード □□□Ｎ … ポインタがnullifyされているノード
空空空Ｎ … ルートノード「list」
空空空Ｐ … ルートノード「list」 ┌──┘ ↓ □□□Ｐ … ノードその１ ┌──┘ ↓ □□□Ｐ … ノードその２ ┌──┘ ↓ □□□Ｎ … ノードその３
! node_module.f -*-f90-*-
! Time-stamp: <2007-01-05 18:35:10 t-nissie>
! Author: Takeshi NISHIMATSU
! Disadvantage: Copy in list_unshift() and list_push().
!!
module Node_module
implicit none
type Node_type
character(len=100) :: str100 = ''
type(Node_type), pointer :: next => null()
end type Node_type
!!! Fortran 2003 feature
! type extends(Node_type) :: List_type
! contains
! final :: list_destruct
! end type List_type
contains
! destructor
subroutine list_destruct(list)
implicit none
type(Node_type), intent(inout) :: list
type(Node_type), pointer :: current_node, next_node
next_node => list%next
do while (associated(next_node))
current_node => next_node
next_node => next_node%next
deallocate(current_node)
end do
nullify(list%next) ! For reuse of the list.
end subroutine list_destruct
! add a node to the head of the list
subroutine list_unshift(list, unshift)
implicit none
type(Node_type), intent(inout) :: list
type(Node_type), intent(in) :: unshift
type(Node_type), pointer :: tmp
allocate(tmp)
tmp = unshift ! Copy.
tmp%next => list%next
list%next => tmp
end subroutine list_unshift
! add a node to the tail of the list
subroutine list_push(list, push)
implicit none
type(Node_type), target, intent(inout) :: list
type(Node_type), intent(in) :: push
type(Node_type), pointer :: p_node
p_node => list
do while (associated(p_node%next))
p_node => p_node%next
end do
allocate(p_node%next) ! Insert a new node.
p_node%next = push ! Copy.
nullify(p_node%next%next)
end subroutine list_push
!
! remove a node from the head of the list
function list_shift(list)
implicit none
type(Node_type), pointer :: list_shift
type(Node_type), intent(inout) :: list
if (.not.associated(list%next)) then
nullify(list_shift)
else
list_shift => list%next
list%next => list%next%next
end if
end function list_shift
! remove a node from the tail of the list
function list_pop(list)
implicit none
type(Node_type), pointer :: list_pop
type(Node_type), target, intent(in) :: list
type(Node_type), pointer :: p_node
if (.not.associated(list%next)) then
nullify(list_pop)
else
p_node => list
do while (associated(p_node%next%next))
p_node => p_node%next
end do
list_pop => p_node%next
nullify(p_node%next)
end if
end function list_pop
! returns length of the list
function list_count(list)
implicit none
integer list_count
type(Node_type), intent(in) :: list
type(Node_type), pointer :: p_node
list_count = 0
p_node => list%next
do while (associated(p_node))
list_count = list_count + 1
p_node => p_node%next
end do
end function list_count
!
! iterator
! usage:
! p => list
! do while(list_each(p))
! :
! end do
logical function list_each(p_node)
implicit none
type(Node_type), pointer, intent(inout) :: p_node
p_node => p_node%next
list_each = associated(p_node)
end function list_each
! iterator
! usage:
! i_node => list
! i=0
! do while(list_each_with_index(i_node,i))
! :
! end do
logical function list_each_with_index(i_node,i)
implicit none
type(Node_type), pointer, intent(inout) :: i_node
integer, intent(inout) :: i
i_node => i_node%next
i = i + 1
list_each_with_index = associated(i_node)
end function list_each_with_index
end module Node_module
使用例 兼 unit testing
! linkedlist.f -*-f90-*-
! Time-stamp: <2007-01-05 18:37:16 t-nissie>
! Author: Takeshi NISHIMATSU
!!
program linkedlist
use Node_module
implicit none
type(Node_type), target :: list
type(Node_type), pointer :: p_node, i_node, j_node
integer i,j
write(6,'(a,i1)') 'list_count = ', list_count(list)
p_node => list_pop(list)
if (associated(p_node)) stop 'There is something wrong in list_pop.'
p_node => list_shift(list)
if (associated(p_node)) stop 'There is something wrong in list_shift.'
call list_push(list, Node_type('abcdefg'))
call list_push(list, Node_type('hijklmn'))
call list_push(list, Node_type('opqrstu'))
write(6,'(a,i1)') 'list_count = ', list_count(list)
p_node => list
do while(list_each(p_node))
write(6,'(a)') trim(p_node%str100)
end do
p_node => list_pop(list)
write(6,'(2a)') 'popped node = ', trim(p_node%str100)
deallocate(p_node)
j_node => list
j=0
do while(list_each_with_index(j_node,j))
i_node => list
i=0
do while(list_each_with_index(i_node,i))
write(6,'(i1i2,4a)') i, j, &
' ', trim(i_node%str100), &
' ', trim(j_node%str100)
end do
end do
call list_unshift(list, Node_type('ABCDEFG'))
i_node => list
i=0
do while(list_each_with_index(i_node,i))
write(6,'(i1,2a)') i, ' ', trim(i_node%str100)
end do
p_node => list_shift(list)
write(6,'(2a)') 'shifted node = ', trim(p_node%str100)
deallocate(p_node)
call list_destruct(list)
write(6,'(a,i1)') 'list_count = ', list_count(list)
call list_push(list, Node_type('123456'))
call list_destruct(list) ! For Fortran 2003, remove this line and check 'final'.
end program linkedlist
# Makefile for list # Time-stamp: <2007-01-07 09:39:44 t-nissie> # Author: Takeshi NISHIMATSU ## FC = g95 FFLAGS = -Wall -ffree-form -g -O1 #FC = ifort #FFLAGS = -FR linkedlist: linkedlist.o node_module.o $(FC) $(FFLAGS) -o $@ $^ linkedlist.o: node_module.o index.html: README style.css ulwmul2html.rb $< > $@ # Additional rules for the pretty printing: %.pdf: %.ps ps2pdf -sPAPERSIZE=letter $< $@ %.ps: %.f LANG=C a2ps --prologue=color --portrait --columns=1 \ --margin=3 --borders=off --medium=Letter\ -f 10.5 --pretty-print=for90-free -o - $< | PsDuplex > $@ clean: rm -f *.ps *.pdf core *.o *.mod linkedlist