fortran字符串指针的问题

roxillius

这是chapman书里指针一章的一道作业，大致就是用链表来做插入排序。我实现了一个link list type，这个type 的定义如下

[Fortran] 纯文本查看 复制代码

type :: char_node
     character(len=:), pointer :: value
     type(char_node), pointer :: next_value
  end type char_node

然后重载了几个计算符（> < ==）
主程序插入排序的代码如下，

[Fortran] 纯文本查看 复制代码

program insertion
  use link_list
  implicit none
  type(char_node), pointer :: head, tail, ptr, ptr1, ptr2
  integer :: istat
  integer :: nvals = 0
  character(len=128) :: temp
  character(len=20) :: filename
  nullify(head,tail,ptr,ptr1,ptr2)
  write (*,*) 'Enter the file name of data to be sorted: '
  read (*,'(a20)') filename
  open (unit=9,file=filename, status = 'old', action = 'read', &
       iostat=istat)
  fileopen: if (istat == 0) then
     input: do
        read (9, *, iostat=istat) temp
        if (istat /= 0) exit input
        nvals = nvals + 1
        allocate(ptr, stat=istat)
        nullify(ptr%value)
        allocate(character(len_trim(adjustl(temp))) :: ptr%value, stat=istat)
        ptr%value = trim(adjustl(temp))
        new : if (.not. associated(head)) then
           head => ptr
           tail => head
           nullify (ptr%next_value)
        else
           front : if(ptr < head) then
              ptr%next_value => head
              head => ptr
           else if (ptr > tail .or. ptr == tail) then
              tail%next_value => ptr
              tail => ptr
              nullify(tail%next_value)
           else
              ! find place to add the value
              ptr1 => head
              ptr2 => ptr1%next_value
              search: do
                 if ((ptr>ptr1 .or. ptr==ptr1) .and. (ptr<ptr2)) then
                    ! insert the value here
                    ptr%next_value => ptr2
                    ptr1%next_value => ptr
                    exit search
                 end if
                 ptr1 => ptr2
                 ptr2 => ptr2%next_value
              end do search
           end if front
        end if new
     end do input
     ptr => head
     output : do
        if (.not. associated(ptr)) exit
        write (*,'(1x,a,i3)') ptr%value, len(ptr%value) 
        ptr => ptr%next_value
     end do output
  else fileopen
     write (*,'(1x,a,i6)') 'File open failed -- status =', istat
  end if fileopen
end program insertion

程序能够正常排序，但是每个链表里字符串指针的长度都是128 与 temp字符串相符。为什么我用allocate动态空间的字符串长度还是128？
谢谢大家。

roxillius

我补充一下链表module的源代码

[Fortran] 纯文本查看 复制代码

module link_list
  private
  public :: char_node, operator(>), operator(<), operator(==)
  type :: char_node
     character(len=:), pointer :: value
     type(char_node), pointer :: next_value
  end type char_node
  
  interface operator (<)
     module procedure less_than
  end interface operator (<)

  interface operator (>)
     module procedure greater_than
  end interface operator (>)

  interface operator (==)
     module procedure equal_to
  end interface operator (==)
contains
  logical function less_than(op1,op2)
    type(char_node), intent(in) :: op1, op2
    character (len=len(op1%value)) :: temp1
    character (len=len(op2%value)) :: temp2
    call toupper(op1%value,temp1)
    call toupper(op2%value,temp2)
    if (llt(temp1, temp2)) then
       less_than = .true.
    else
       less_than = .false.
    end if
  end function less_than

  logical function greater_than(op1,op2)
    type(char_node), intent(in) :: op1, op2
    character (len=len(op1%value)) :: temp1
    character (len=len(op2%value)) :: temp2
    call toupper(op1%value,temp1)
    call toupper(op2%value,temp2)
    if (lgt(temp1, temp2)) then
       greater_than = .true.
    else
       greater_than = .false.
    end if
  end function greater_than
  
  logical function equal_to(op1,op2)
    implicit none
    type(char_node), intent(in) :: op1, op2
    character (len=len(op1%value)) :: temp1
    character (len=len(op2%value)) :: temp2
    call toupper(op1%value,temp1)
    call toupper(op2%value,temp2)
    if (lge(temp1, temp2) .and. lle(temp1,temp2) ) then
       equal_to = .true.
    else
       equal_to = .false.
    end if
  end function equal_to
  
  subroutine toupper(input,output)
    implicit none
    character(len=*),intent(in) :: input
    character(len=*),intent(out) :: output
    integer :: i, istat
    integer :: length
    length = len(input)
    output = input
    do i = 1, length
       if (lge(output(i:i),'a') .and. lle(output(i:i),'z')) then
          output(i:i) = achar (iachar(output(i:i))-32)
       end if
    end do
  end subroutine toupper
end module link_list

li913

我这里没问题。vs2010+ivf2016

vvt

我想这应该是编译器的 bug，我这里测试也是有问题
我尝试把
allocate(character(len_trim(adjustl(temp))) :: ptr%value, stat=istat)
改为
allocate(character(len_trim(temp)) :: ptr%value, stat=istat)
或
k = len_trim(adjustl(temp))
allocate(character(k) :: ptr%value, stat=istat)
都是正常的。

roxillius

感谢！
看来确实是编译器的问题。
另外我用的编译器是gFortran 5.3.0 (homebrew 5.3.3)。

pasuka

那本书上的代码有点顾影自怜，因为写书的时候尚没有一家编译器实现所有F03标准
学习链表、字符串处理，推荐下面的开源项目，虽然也是好久没更新了
http://flibs.sourceforge.net/