パスワードを忘れた? アカウント作成
506318 journal

t-nissieの日記: singly linked list in Fortran 95 (改訂第3版)

日記 by t-nissie
他人の書いた新しくて古いFortranのプログラム(COMMON文のかわりにMODULEを使っている
だけ。結局、大域変数の誤用。さらにsubroutineの引数が30個くらいある。はぁ。)を
デバグしていてイヤになったので、以前に書いたsingly linked listを改訂してみました。
以前のは消します。(さらに第2版に誤りがあったので、第3版に書き換えました。)

= Fortran 95 による1方向リンクト・リスト (singly linked list)
Fortran 95 で1方向リンクト・リスト (singly linked list) を書く場合、
データを持たないルートノードを用いて、それを「list」とするのが便利。

== 凡例
□□□   … データフィールド
       ■ … ポインタ (リンク)
□□□■ … ノード
空空空■ … データフィールドに意味のあるものが入っていないノード
□□□N … ポインタがnullifyされているノード

== 初期状態
空空空N … ルートノード「list」

== リスト
空空空■ … ルートノード「list」
┌──┘

□□□■ … ノードその1
┌──┘

□□□■ … ノードその2
┌──┘

□□□N … ノードその3

== Makefile
# Makefile for list
# Time-stamp: <2007-01-03 17:21:12 t-nissie>
##

FC = g95
FFLAGS = -Wall -ffree-form -g -O1

#FC = ifort
#FFLAGS = -FR

all: linkedlist

linkedlist: linkedlist.o node_module.o
    $(FC) $(FFLAGS) -o $@ $^

linkedlist.o bar_module.o: node_module.o

# 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

== node_module.f
! node_module.f -*-f90-*-
! Time-stamp: <2007-01-03 17:22:04 t-nissie>
! 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
  subroutine list_destruct(list)
    implicit none
    type(Node_type), intent(in) :: 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
  end subroutine list_destruct

  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

  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

  subroutine list_shift(list, shift)
    implicit none
    type(Node_type), intent(inout) :: list
    type(Node_type), pointer, intent(out) :: shift
    if (.not.associated(list%next)) then
       nullify(shift)
    else
       shift => list%next
       list%next => list%next%next
    end if
  end subroutine list_shift

  subroutine list_pop(list, pop)
    implicit none
    type(Node_type), target, intent(in)  :: list
    type(Node_type), pointer, intent(out) :: pop
    type(Node_type), pointer :: p_node
    if (.not.associated(list%next)) then
       nullify(pop)
    else
       p_node => list
       do while (associated(p_node%next%next))
          p_node => p_node%next
       end do
       pop => p_node%next
       nullify(p_node%next)
    end if
  end subroutine list_pop

  integer function list_count(list)
    implicit none
    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

  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

  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

== linkedlist.f
! linkedlist.f -*-f90-*-
! Time-stamp: <2007-01-03 17:24:24 t-nissie>
!!
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)

  call list_pop(list, p_node)
  if (associated(p_node)) stop 'There is something wrong in list_pop.'

  call list_shift(list, p_node)
  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

  call list_pop(list, p_node)
  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

  call list_shift(list, p_node)
  write(6,'(2a)') 'shifted node = ', trim(p_node%str100)
  deallocate(p_node)

  call list_destruct(list)
end program linkedlist
この議論は賞味期限が切れたので、アーカイブ化されています。 新たにコメントを付けることはできません。
typodupeerror

一つのことを行い、またそれをうまくやるプログラムを書け -- Malcolm Douglas McIlroy

読み込み中...