! 
! Copyright 2008 Shin'ya Murakami <murashin@epa.scitec.kobe-u.ac.jp>
! $Id:$
! 
! real(8)のリスト
! 
module mod_realnumberlist
  
  implicit none
  
  type RealNumberListNode
     type(RealNumberListNode), pointer :: n
     type(RealNumberListNode), pointer :: p
     real(8) x
  end type RealnumberListNode
  
  type RealNumberList
     type(RealNumberListNode), pointer :: n
  end type RealNumberList

contains
  
  ! 
  ! 初期化
  ! 
  subroutine rnl_init(rnl)
    
    type(RealNumberList), pointer :: rnl
    type(RealNumberListNode), pointer :: node => null()
    
    nullify(rnl)
    allocate(rnl,node)
    rnl%n => node
    nullify(node%n, node%p)
  end subroutine rnl_init
  
  ! 
  ! 最初のノードを得る
  ! 
  function rnl_get_first(rnl) result(retval)
    
    type(RealNumberList), pointer :: rnl
    type(RealNumberListNode), pointer :: retval
    
    retval => rnl%n%n
    
  end function rnl_get_first
  
  ! 
  ! 最後のノードを得る.
  ! 
  function rnl_get_last(rnl) result(retval)
    
    type(RealNumberList), pointer :: rnl
    type(RealNumberListNode), pointer :: retval, node => null()
    
    node => rnl_each_init(rnl)
    retval => node
    do while(rnl_each(node))
       retval => node
    end do
  end function rnl_get_last
  
  ! 
  ! 指定したノードの次のノードを得る
  ! 
  function rnln_get_next(node) result(retval)
    
    type(RealNumberListNode), pointer :: node, retval
    
    if(associated(node%n))then
       retval => node%n
    else ! last node.
       nullify(retval)
    end if
  end function rnln_get_next
  
  ! 
  ! 指定したノードの前のノードを得る
  ! 
  function rnln_get_prev(node) result(retval)
    
    type(RealNumberListNode), pointer :: node, retval
    
    if(associated(node%p))then
       retval => node%p
    else
       nullify(retval)
    end if
  end function rnln_get_prev
  
  ! 
  ! 指定したノードの次のノードを削除
  ! 
  real(8) function rnln_remove_next(node) result(retval)
    
    type(RealNumberListNode), pointer :: node
    type(RealNumberListNode), pointer :: nnode => null()
    
    if(.not. associated(node%n))then
       ! next node is null
       retval = -999.0d99
    else 
       nnode => node%n
       node%n => node%n%n
       if(associated(node%n))then ! 次の次のノードがある
          node%n%p => node
       end if
       retval = nnode%x
       deallocate(nnode)
    end if
  end function rnln_remove_next
  
  !
  ! 指定したノードの次にdataを持つノードを挿入
  !
  subroutine rnln_add(node, data)
    
    type(RealNumberListNode), pointer :: node
    real(8), intent(in) :: data
    type(RealNumberListNode), pointer :: node_new => null()
    
    allocate(node_new)
    node_new%x = data
    node_new%n => node%n
    node_new%p => node
    if(associated(node%n))then
       node%n%p => node_new
    end if
    node%n => node_new
  end subroutine rnln_add
  
  ! 
  ! リストの末尾にdataを持つノードを追加
  ! 
  subroutine rnl_add_last(rnl, data)
    
    type(RealNumberList), pointer :: rnl
    real(8), intent(in) :: data
    
    call rnln_add(rnl_get_last(rnl), data)
  end subroutine rnl_add_last
  
  ! 
  ! リストの先頭にdataを持つノードを追加
  ! 
  subroutine rnl_add_first(rnl, data)
    
    type(RealNumberList), pointer :: rnl
    real(8), intent(in) :: data
    
    call rnln_add(rnl%n, data)
  end subroutine rnl_add_first
  
  ! 
  ! 指定したノードのデータを取得
  ! 
  function rnln_get_data(node) result(retval)
    
    type(RealNumberListNode), pointer :: node
    real(8) retval
    
    retval = node%x
  end function rnln_get_data
  
  ! 
  ! 指定したノードにデータをセット
  ! 
  subroutine rnln_set_data(node, data)
    
    type(RealNumberListNode), pointer :: node
    real(8), intent(in) :: data
    
    node%x = data
  end subroutine rnln_set_data
  
  !
  ! node の次に node_new を挿入
  !
  subroutine rnln_add_node(node, node_new)
    
    type(RealNumberListNode), pointer :: node, node_new
    
    node_new%n => node%n
    node_new%p => node
    node%n => node_new
    if(associated(node_new%n))then
       node_new%n%p => node_new
    end if
  end subroutine rnln_add_node
  
  !
  ! リストの先頭にnodeを挿入
  !
  subroutine rnl_add_node_at_first(rnl, node)
    
    type(RealNumberList), pointer :: rnl
    type(RealNumberListNode), pointer :: node
    
    call rnln_add_node(rnl%n, node)
  end subroutine rnl_add_node_at_first
  
  ! 
  ! 指定したノードを削除
  ! 
  function rnln_remove_node(node) result(retval)
    
    type(RealNumberListNode), pointer :: node, retval
    type(RealNumberListNode), pointer :: nnode => null(), pnode => null()
    
    if(.not. associated(node%n))then
       pnode => node%p
       nullify(pnode%n, node%p)
       retval => node
    else
       pnode => node%p
       nnode => node%n
       pnode%n => nnode
       nnode%p => pnode
       nullify(node%p, node%n)
       retval => node
    end if
  end function rnln_remove_node
  
  ! 
  ! リストを解放する.
  ! 
  subroutine rnl_destroy(rnl)
    
    type(RealNumberList), pointer :: rnl
    type(RealNumberListNode), pointer :: node => null(), nnode => null()
    
    node => rnl%n
    deallocate(rnl)
    nullify(rnl)
    do while(associated(node%n))
       nnode => node%n
       deallocate(node)
       nullify(node)
       node => nnode
    end do
    deallocate(node)
    nullify(node)
  end subroutine rnl_destroy
  
  ! 
  ! while loop用のノード初期化
  ! 
  function rnl_each_init(rnl) result(retval)
    
    type(RealNumberList), pointer :: rnl
    type(RealNumberListNode), pointer :: retval
    
    retval => rnl%n
  end function rnl_each_init
  
  ! 
  ! while loop用
  ! 
  logical function rnl_each(node) result(retval)
    
    type(RealNumberListNode), pointer :: node
    
    node => node%n
    retval = associated(node)
  end function rnl_each
  
  ! 
  ! ノードがいくつあるか数える.
  ! 特殊な先頭ノードは数えない.
  ! 
  function rnl_size(rnl) result(retval)
    
    type(RealNumberList), pointer :: rnl
    integer retval, n
    type(RealNumberListNode), pointer :: node => null()
    
    n = 0
    node => rnl_each_init(rnl)
    do while(rnl_each(node))
       n = n+1
    end do
    retval = n
  end function rnl_size
  
  ! 
  ! rnl1にrnl2をくっつける.
  ! 
  subroutine rnl_attach_list(rnl1, rnl2)
    
    type(RealNumberList), pointer :: rnl1, rnl2
    type(RealNumberListNode), pointer :: n1=> null(), n2=> null()
    
    n1 => rnl_get_last(rnl1)
    n2 => rnl2%n%n
    if(associated(n1))then
       if(associated(n2))then
          ! n1, n2 ともにある
          n1%n => n2
          n2%p => n1
          nullify(rnl2%n%n)
       else
          ! n1 はある, n2は null
          ! そのまま
       end if
    else if(associated(n2))then
       ! n1 は null, n2はある
       rnl1%n%n => n2
       n2%p => rnl1%n
       nullify(rnl2%n%n)
    else
       ! n1, n2 はともに null
       ! そのまま
    end if
    call rnl_destroy(rnl2)
    
  end subroutine rnl_attach_list
  
  ! 
  ! RealNumberListのダンプ
  ! 
  subroutine rnl_dump(rnl)
    
    type(RealNumberList), pointer :: rnl
    type(RealNumberListNode), pointer :: node => null()
    integer i 
    
    i = 0
    print *, "dumping real number list...."
    node => rnl_each_init(rnl)
    do while(rnl_each(node))
       i = i + 1
       print *, "rn: ", node%x
    end do
    print *, "end of dumping"
  end subroutine rnl_dump
  
  ! 
  ! RealNumberListのdeep copy
  ! 
  function rnl_deepcopy(rnl) result(retval)
    
    type(RealNumberList), pointer :: rnl, retval, rnl2 => null()
    type(RealNumberListNode), pointer :: node => null(), node2 => null()
    
    call rnl_init(rnl2)
    node => rnl_each_init(rnl)
    node2 => rnl2%n
    do while(rnl_each(node))
       call rnln_add(node2, node%x)
       node2 => node2%n
    end do
    retval => rnl2
  end function rnl_deepcopy
  
  ! 
  ! rnlの要素の平均値を計算する.
  ! 桁落ち誤差を軽減するため, 二つの要素ごとの和を再帰的にとる.
  ! 
  function rnl_mean(rnl) result(retval)
    
    type(RealNumberList), pointer :: rnl
    real(8) p, retval
    type(RealNumberList), pointer :: rnl2 => null()
    type(RealNumberListNode), pointer :: node => null(), temp => null()
    
    rnl2 => rnl_deepcopy(rnl)
    
    do while(rnl_size(rnl2) > 1)
       node => rnl_each_init(rnl2)
       do while(rnl_each(node))
          if(associated(node%n))then
             p = rnln_remove_next(node)
             node%x = node%x + p
          else
             temp => node%p
             p = rnln_remove_next(node%p)
             temp%x = temp%x + p
             node => temp
          end if
       end do
    end do
    node => rnl_get_first(rnl2)
    retval = node%x/dble(rnl_size(rnl))
    call rnl_destroy(rnl2)
  end function rnl_mean
  
end module mod_realnumberlist
