fortran字符串指针的问题 - Fortran Coder

[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

[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