[输入输出] 关于读取字符串（可能动态）和排序

program www_fcode_cn
  implicit none
  Integer , parameter :: LEN_ALL = 50000 !// 总长度
  Integer , parameter :: LEN_ONE = 16 !// 单个长度
  Character( Len = LEN_ALL ) :: cStrAll
  Character( Len = LEN_ONE ) , allocatable :: cStrSplit( : )
  integer :: n , sum , score !// 单词个数，总分，单个分
  integer :: i
  Open( 12 , File = "names.txt" )
  Read( 12 , '(a50000)' ) cStrAll
  Close( 12 )
  n = GetDataN( cStrAll ) !// 获得单词数
  write(*,'(a,i0,a)') '共',n,'个单词'
  Allocate( cStrSplit(n) )
  read( cStrAll , * ) cStrSplit
  call HeapSort( cStrSplit , comp_f ) !// 排序
  sum = 0
  Do i = 1 , n
    sum = sum + i * GetStringScore( Trim(cStrSplit(i)) )
  End Do
  write( * , * ) '总分' , sum
  Deallocate( cStrSplit )
  
contains

  Integer Function GetStringScore( c )
    Character( Len = * ) :: c
    integer :: i
    GetStringScore = 0
    Do i = 1 , Len_Trim( c )
      GetStringScore = GetStringScore + ( ichar(c(i:i)) -  ichar('A') + 1 )
    End Do
  End Function GetStringScore

  Integer Function GetDataN( cStr )
    Character( Len = * ) , Intent( IN ) :: cStr
    Integer :: i
    Logical :: bIsSeparator , bIsQuote
    GetDataN = 0
    bIsSeparator = .TRUE.
    bIsQuote = .FALSE.
    Do i = 1 , Len_Trim( cStr )
      Select Case( cStr(i:i) )
      Case( '"' , "'" ) !// 如果遇到引号
        If ( .Not.bIsQuote ) GetDataN = GetDataN + 1  !//如果不在引号中，则增加一个数据
        bIsQuote = .Not.bIsQuote !// 引号结束或开始
        bIsSeparator = .FALSE.
      Case( " " , "," , char(9) ) !// 如果遇到分隔符
        If ( .Not.bIsQuote ) then  !// 分隔符如果不在引号中
          bIsSeparator = .TRUE.
        End If
      Case Default      
        If ( bIsSeparator ) then
          GetDataN = GetDataN + 1
        End If
        bIsSeparator = .FALSE.
      End Select
    End Do
  End Function GetDataN
  
  Subroutine HeapSort( stD , comp_f )
    Character( Len = * ) , Intent( INOUT ) :: stD( : )
    Real , External :: comp_f
    Integer i,ir,j,l,n
    Character( Len = LEN_ONE ) :: stTemp
    n = size( stD )
    If ( n < 2 ) Return
    l = n / 2 + 1
    ir = n
    Do while( .TRUE. )
      If( l > 1 ) then
        l = l - 1
        stTemp = stD( l )
      Else
        stTemp = stD( ir )
        stD( ir ) = stD( 1 )
        ir = ir - 1
        If( ir == 1 ) then
          stD( 1 ) = stTemp
          return
        End If
      End If
      i = l
      j = l + l
      Do while( j<=ir )
        If( ( j < ir ) ) then
          If ( comp_f( stD(j) , std(j+1) ) > 0.0 ) then
            j = j+1
          End If
        EndIf
        If( comp_f( stTemp , stD(j) ) > 0.0 )then
          stD(i) = stD( j )
          i = j
          j = j + j
        Else
          j = ir + 1
        End If
      EndDo
      stD( i ) = stTemp
    End Do
  End Subroutine HeapSort
  
  Real Function comp_f( st1 , st2 )
    Character( Len = * ) , Intent( IN ) :: st1 , st2
    if ( Trim(st1) > Trim(st2) ) then
      comp_f = -1.0
    else
      comp_f = 1.0
    end if      
  End Function comp_f
  
end program www_fcode_cn