dc_string.f90

Go to the documentation of this file.

! -*- mode: f90; coding: utf-8 -*-
!-----------------------------------------------------------------------
! Copyright (c) 2000-2026 Gtool Development Group. All rights reserved.
!-----------------------------------------------------------------------
module dc_string
  use dc_types, only: token, string, dp, sp
  implicit none
  private
  public :: stoi
  public :: stod
  public :: get_array
  public :: str_to_logical
  public :: tochar
  public :: roundnum
  public :: joinchar
  public :: concat
  public :: stoa
  public :: split
  public :: index_ofs
  public :: replace
  public :: toupper
  public :: tolower
  public :: uchar
  public :: lchar
  public :: strieq
  public :: strhead
  public :: strinclude
  ! public :: GTStringQuoteForDcl
  public :: cprintf
  public :: cprintft
  public :: printf
  public :: putline
  interface stoi
    module procedure atoi_scalar
  end interface stoi
  interface stor
    module procedure ator_scalar
  end interface stor
  interface stod
    module procedure atod_scalar
  end interface stod
  interface get_array
    module procedure str2ip
    module procedure str2rp
    module procedure str2dp
  end interface get_array
  interface str_to_logical
    module procedure str2bool
  end interface str_to_logical
  !-------------------------------------
  !  数値から文字への変換
  interface tochar
    module procedure itoa_scalar
    module procedure itoa_array
    module procedure rtoa_scalar
    module procedure rtoa_array
    module procedure dtoa_scalar
    module procedure dtoa_array
    module procedure ltoa_scalar
    module procedure ltoa_array
  end interface tochar
  !-------------------------------------
  !  数値表記の文字列の端数除去
  interface roundnum
    module procedure roundnum
  end interface roundnum
  !-------------------------------------
  !  文字型配列の連結
  !-------------------------------------
  !  文字型配列の末尾に文字を連結
  interface concat
    module procedure concat_tail
  end interface concat
  !-------------------------------------
  !  長さの異なる文字群の配列化
  interface stoa
    module procedure str_to_array1
    module procedure str_to_array2
    module procedure str_to_array3
    module procedure str_to_array4
    module procedure str_to_array5
    module procedure str_to_array6
    module procedure str_to_array7
    module procedure str_to_array8
    module procedure str_to_array9
    module procedure str_to_array10
    module procedure str_to_array11
    module procedure str_to_array12
  end interface stoa
  !-------------------------------------
  !  文字列の分解
  interface split
    module procedure split_cc
  end interface split
  !-------------------------------------
  !  文字列の解析
  interface index_ofs
    module procedure index_ofs
  end interface index_ofs
  interface replace
    module procedure replace
  end interface replace
  !-------------------------------------
  !  大文字・小文字を無視した処理
  interface toupper
    module procedure cupper
  end interface toupper
  interface tolower
    module procedure clower
  end interface tolower
  interface uchar
    module procedure uchar
  end interface uchar
  interface lchar
    module procedure lchar
  end interface lchar
  interface strieq
    module procedure strieq_cc
  end interface strieq
  interface strhead
    module procedure strhead_cc
  end interface strhead
  interface strinclude
    module procedure str_include_ac
  end interface strinclude
  !-------------------------------------
  !  印字のための文字処理
  ! interface
  !   function GTStringQuoteForDcl(string) result(result)
  !     use dc_types, only: STRLEN => STRING
  !     character(*), intent(in):: string
  !     character(STRLEN):: result
  !   end function GTStringQuoteForDcl
  ! end interface
  interface cprintf
    function dcstringcprintf(fmt, i, r, d, L, n, c1, c2, c3, ca, maxlen) result(result)
      use dc_types, only: string, dp, sp
      character(len = STRING):: result
      character(*), intent(in):: fmt
      integer, intent(in), optional:: i(:), n(:)
      real(sp), intent(in), optional:: r(:)
      real(dp), intent(in), optional:: d(:)
      logical, intent(in), optional:: l(:)
      character(*), intent(in), optional:: c1, c2, c3
      character(*), intent(in), optional:: ca(:)
      integer, intent(in), optional:: maxlen
    end function dcstringcprintf
  end interface cprintf
  interface cprintft
    function dcstringcprintft(fmt, i, r, d, L, n, c1, c2, c3, ca, maxlen) result(result)
      use dc_types, only: token, dp, sp
      character(len = TOKEN):: result
      character(*), intent(in):: fmt
      integer, intent(in), optional:: i(:), n(:)
      real(sp), intent(in), optional:: r(:)
      real(dp), intent(in), optional:: d(:)
      logical, intent(in), optional:: l(:)
      character(*), intent(in), optional:: c1, c2, c3
      character(*), intent(in), optional:: ca(:)
      integer, intent(in), optional:: maxlen
    end function dcstringcprintft
  end interface cprintft
  interface printf
    subroutine dcstringsprintf(unit, fmt, i, r, d, L, n, c1, c2, c3, ca)
      use dc_types, only: dp, sp
      character(*), intent(out):: unit
      character(*), intent(in):: fmt
      integer, intent(in), optional:: i(:), n(:)
      real(SP), intent(in), optional:: r(:)
      real(DP), intent(in), optional:: d(:)
      logical, intent(in), optional:: L(:)
      character(*), intent(in), optional:: c1, c2, c3
      character(*), intent(in), optional:: ca(:)
    end subroutine dcstringsprintf
    subroutine dcstringfprintf(unit, fmt, i, r, d, L, n, c1, c2, c3, ca)
      use dc_types, only: dp, sp
      integer, intent(in), optional:: unit
      character(*), intent(in):: fmt
      integer, intent(in), optional:: i(:), n(:)
      real, intent(in), optional:: r(:)
      real(DP), intent(in), optional:: d(:)
      logical, intent(in), optional:: L(:)
      character(*), intent(in), optional:: c1, c2, c3
      character(*), intent(in), optional:: ca(:)
    end subroutine dcstringfprintf
  end interface printf
  !-------------------------------------
  !  数値型配列の要約印字
  interface putline
    subroutine putlineint1( array, lbounds, ubounds, unit, indent, sd  )
        integer, intent(in):: array(:)
        integer, intent(in), optional:: lbounds(1)
        integer, intent(in), optional:: ubounds(1)
        integer, intent(in), optional:: unit
        character(*), intent(in), optional:: indent
        logical, intent(in), optional:: sd
    end subroutine putlineint1
    subroutine putlineint2( array, lbounds, ubounds, unit, indent, sd  )
        integer, intent(in):: array(:,:)
        integer, intent(in), optional:: lbounds(2)
        integer, intent(in), optional:: ubounds(2)
        integer, intent(in), optional:: unit
        character(*), intent(in), optional:: indent
        logical, intent(in), optional:: sd
    end subroutine putlineint2
    subroutine putlineint3( array, lbounds, ubounds, unit, indent, sd  )
        integer, intent(in):: array(:,:,:)
        integer, intent(in), optional:: lbounds(3)
        integer, intent(in), optional:: ubounds(3)
        integer, intent(in), optional:: unit
        character(*), intent(in), optional:: indent
        logical, intent(in), optional:: sd
    end subroutine putlineint3
    subroutine putlineint4( array, lbounds, ubounds, unit, indent, sd  )
        integer, intent(in):: array(:,:,:,:)
        integer, intent(in), optional:: lbounds(4)
        integer, intent(in), optional:: ubounds(4)
        integer, intent(in), optional:: unit
        character(*), intent(in), optional:: indent
        logical, intent(in), optional:: sd
    end subroutine putlineint4
    subroutine putlineint5( array, lbounds, ubounds, unit, indent, sd  )
        integer, intent(in):: array(:,:,:,:,:)
        integer, intent(in), optional:: lbounds(5)
        integer, intent(in), optional:: ubounds(5)
        integer, intent(in), optional:: unit
        character(*), intent(in), optional:: indent
        logical, intent(in), optional:: sd
    end subroutine putlineint5
    subroutine putlineint6( array, lbounds, ubounds, unit, indent, sd  )
        integer, intent(in):: array(:,:,:,:,:,:)
        integer, intent(in), optional:: lbounds(6)
        integer, intent(in), optional:: ubounds(6)
        integer, intent(in), optional:: unit
        character(*), intent(in), optional:: indent
        logical, intent(in), optional:: sd
    end subroutine putlineint6
    subroutine putlineint7( array, lbounds, ubounds, unit, indent, sd  )
        integer, intent(in):: array(:,:,:,:,:,:,:)
        integer, intent(in), optional:: lbounds(7)
        integer, intent(in), optional:: ubounds(7)
        integer, intent(in), optional:: unit
        character(*), intent(in), optional:: indent
        logical, intent(in), optional:: sd
    end subroutine putlineint7
    subroutine putlinereal1( array, lbounds, ubounds, unit, indent, sd  )
        use dc_types, only: sp
        real(SP), intent(in):: array(:)
        integer, intent(in), optional:: lbounds(1)
        integer, intent(in), optional:: ubounds(1)
        integer, intent(in), optional:: unit
        character(*), intent(in), optional:: indent
        logical, intent(in), optional:: sd
    end subroutine putlinereal1
    subroutine putlinereal2( array, lbounds, ubounds, unit, indent, sd  )
        use dc_types, only: sp
        real(SP), intent(in):: array(:,:)
        integer, intent(in), optional:: lbounds(2)
        integer, intent(in), optional:: ubounds(2)
        integer, intent(in), optional:: unit
        character(*), intent(in), optional:: indent
        logical, intent(in), optional:: sd
    end subroutine putlinereal2
    subroutine putlinereal3( array, lbounds, ubounds, unit, indent, sd  )
        use dc_types, only: sp
        real(SP), intent(in):: array(:,:,:)
        integer, intent(in), optional:: lbounds(3)
        integer, intent(in), optional:: ubounds(3)
        integer, intent(in), optional:: unit
        character(*), intent(in), optional:: indent
        logical, intent(in), optional:: sd
    end subroutine putlinereal3
    subroutine putlinereal4( array, lbounds, ubounds, unit, indent, sd  )
        use dc_types, only: sp
        real(SP), intent(in):: array(:,:,:,:)
        integer, intent(in), optional:: lbounds(4)
        integer, intent(in), optional:: ubounds(4)
        integer, intent(in), optional:: unit
        character(*), intent(in), optional:: indent
        logical, intent(in), optional:: sd
    end subroutine putlinereal4
    subroutine putlinereal5( array, lbounds, ubounds, unit, indent, sd  )
        use dc_types, only: sp
        real(SP), intent(in):: array(:,:,:,:,:)
        integer, intent(in), optional:: lbounds(5)
        integer, intent(in), optional:: ubounds(5)
        integer, intent(in), optional:: unit
        character(*), intent(in), optional:: indent
        logical, intent(in), optional:: sd
    end subroutine putlinereal5
    subroutine putlinereal6( array, lbounds, ubounds, unit, indent, sd  )
        use dc_types, only: sp
        real(SP), intent(in):: array(:,:,:,:,:,:)
        integer, intent(in), optional:: lbounds(6)
        integer, intent(in), optional:: ubounds(6)
        integer, intent(in), optional:: unit
        character(*), intent(in), optional:: indent
        logical, intent(in), optional:: sd
    end subroutine putlinereal6
    subroutine putlinereal7( array, lbounds, ubounds, unit, indent, sd  )
        use dc_types, only: sp
        real(SP), intent(in):: array(:,:,:,:,:,:,:)
        integer, intent(in), optional:: lbounds(7)
        integer, intent(in), optional:: ubounds(7)
        integer, intent(in), optional:: unit
        character(*), intent(in), optional:: indent
        logical, intent(in), optional:: sd
    end subroutine putlinereal7
    subroutine putlinedouble1( array, lbounds, ubounds, unit, indent, sd  )
        use dc_types, only: dp
        real(DP), intent(in):: array(:)
        integer, intent(in), optional:: lbounds(1)
        integer, intent(in), optional:: ubounds(1)
        integer, intent(in), optional:: unit
        character(*), intent(in), optional:: indent
        logical, intent(in), optional:: sd
    end subroutine putlinedouble1
    subroutine putlinedouble2( array, lbounds, ubounds, unit, indent, sd  )
        use dc_types, only: dp
        real(DP), intent(in):: array(:,:)
        integer, intent(in), optional:: lbounds(2)
        integer, intent(in), optional:: ubounds(2)
        integer, intent(in), optional:: unit
        character(*), intent(in), optional:: indent
        logical, intent(in), optional:: sd
    end subroutine putlinedouble2
    subroutine putlinedouble3( array, lbounds, ubounds, unit, indent, sd  )
        use dc_types, only: dp
        real(DP), intent(in):: array(:,:,:)
        integer, intent(in), optional:: lbounds(3)
        integer, intent(in), optional:: ubounds(3)
        integer, intent(in), optional:: unit
        character(*), intent(in), optional:: indent
        logical, intent(in), optional:: sd
    end subroutine putlinedouble3
    subroutine putlinedouble4( array, lbounds, ubounds, unit, indent, sd  )
        use dc_types, only: dp
        real(DP), intent(in):: array(:,:,:,:)
        integer, intent(in), optional:: lbounds(4)
        integer, intent(in), optional:: ubounds(4)
        integer, intent(in), optional:: unit
        character(*), intent(in), optional:: indent
        logical, intent(in), optional:: sd
    end subroutine putlinedouble4
    subroutine putlinedouble5( array, lbounds, ubounds, unit, indent, sd  )
        use dc_types, only: dp
        real(DP), intent(in):: array(:,:,:,:,:)
        integer, intent(in), optional:: lbounds(5)
        integer, intent(in), optional:: ubounds(5)
        integer, intent(in), optional:: unit
        character(*), intent(in), optional:: indent
        logical, intent(in), optional:: sd
    end subroutine putlinedouble5
    subroutine putlinedouble6( array, lbounds, ubounds, unit, indent, sd  )
        use dc_types, only: dp
        real(DP), intent(in):: array(:,:,:,:,:,:)
        integer, intent(in), optional:: lbounds(6)
        integer, intent(in), optional:: ubounds(6)
        integer, intent(in), optional:: unit
        character(*), intent(in), optional:: indent
        logical, intent(in), optional:: sd
    end subroutine putlinedouble6
    subroutine putlinedouble7( array, lbounds, ubounds, unit, indent, sd  )
        use dc_types, only: dp
        real(DP), intent(in):: array(:,:,:,:,:,:,:)
        integer, intent(in), optional:: lbounds(7)
        integer, intent(in), optional:: ubounds(7)
        integer, intent(in), optional:: unit
        character(*), intent(in), optional:: indent
        logical, intent(in), optional:: sd
    end subroutine putlinedouble7
  end interface putline
contains
  logical function strhead_cc(whole, head) result(result)
    character(len = *), intent(in):: whole
    character(len = *), intent(in):: head
    continue
    result = (len(whole) >= len(head))
    if (.not. result) return
    result = (whole(1:len(head)) == head)
  end function strhead_cc
  logical function strieq_cc(string_a, string_b) result(result)
    !--
    ! ※ 注意書き ※
    !
    ! コンパイラによっては character(len = len(string_a)):: abuf
    ! が通らないため, 文字数を dc_types で提供される種別型
    ! パラメタ STRING で制限
    !++
    character(len = *), intent(in):: string_a
    character(len = *), intent(in):: string_b
    character(len = STRING):: abuf
    character(len = STRING):: bbuf
    abuf = string_a
    bbuf = string_b
    call toupper(abuf)
    call toupper(bbuf)
    result = (abuf == bbuf)
  end function strieq_cc
  logical function str_include_ac( &
    & carray, string, ignore_space, ignore_case ) result(result)
    character(*), intent(in):: carray(:)
    character(*), intent(in):: string
    logical, intent(in), optional:: ignore_space
    logical, intent(in), optional:: ignore_case
    integer:: array_size, i
    logical:: ignore_space_work, ignore_case_work
    continue
    ignore_space_work = .true.
    if ( present(ignore_space) ) then
      if ( .not. ignore_space ) then
        ignore_space_work = .false.
      end if
    end if
    ignore_case_work = .false.
    if ( present(ignore_case) ) then
      if ( ignore_case ) then
        ignore_case_work = .true.
      end if
    end if
    array_size = size(carray)
    do i = 1, array_size
      if ( ignore_space_work ) then
        if ( ignore_case_work ) then
          result = &
            & strieq_cc( trim( adjustl( carray(i) ) ), &
            &            trim( adjustl( string    ) ) )
        else
          result = &
            & ( trim( adjustl( carray(i) ) ) == trim( adjustl( string ) ) )
        end if
      else
        if ( ignore_case_work ) then
          result = &
            & strieq_cc( trim( carray(i) ), trim( string ) )
        else
          result = ( trim(carray(i)) == trim(string) )
        end if
      end if
      if (result) return
    end do
  end function str_include_ac
  logical function str2bool(string) result(result)
    character(len = *), intent(in):: string
    continue
    select case(string)
    case ("", "0", "0.0", "0.0D0", "0.0d0", ".false.", ".FALSE.", &
            & "f", "F", "false", "FALSE")
      result = .false.
    case default
      result = .true.
    end select
  end function str2bool
  integer function atoi_scalar(string, default) result(result)
    character(len = *), intent(in):: string
    integer, intent(in), optional:: default
    integer:: ios
    continue
    read(unit=string, fmt="(i80)", iostat=ios) result
    if (ios /= 0) then
      if (present(default)) then
        result = default
      else
        result = 0
      endif
    endif
  end function atoi_scalar
  real(sp) function ator_scalar(string_in) result(result)
    use dc_types, only: string
    character(len = *), intent(in):: string_in
    integer:: ios
    character(len = STRING):: buffer
    integer:: ipoint, iexp
    intrinsic scan
    continue
    buffer = string_in
    ! もし整定数をいれてしまった場合は小数点を附加
    if (index(buffer, '.') == 0) then
      iexp = scan(buffer, "eEdD")
      if (iexp /= 0) then
        buffer(iexp+1: len(buffer)) = buffer(iexp: len(buffer)-1)
        ipoint = iexp
      else
        ipoint = len_trim(buffer) + 1
      endif
      buffer(ipoint: ipoint) = '.'
    endif
    read(unit=buffer, fmt="(g80.10)", iostat=ios) result
    if (ios /= 0) result = 0.0
  end function ator_scalar
  real(dp) function atod_scalar(string_in) result(result)
    use dc_types, only: string
    character(len = *), intent(in):: string_in
    integer:: ios
    character(len = STRING):: buffer
    integer:: ipoint, iexp
    intrinsic scan
    continue
    buffer = string_in
    ! もし整定数をいれてしまった場合は小数点を附加
    if (index(buffer, '.') == 0) then
      iexp = scan(buffer, "eEdD")
      if (iexp /= 0) then
        buffer(iexp+1: len(buffer)) = buffer(iexp: len(buffer)-1)
        ipoint = iexp
      else
        ipoint = len_trim(buffer) + 1
      endif
      buffer(ipoint: ipoint) = '.'
    endif
    read(unit=buffer, fmt="(g80.10)", iostat=ios) result
    if (ios /= 0) result = 0.0
  end function atod_scalar
  subroutine str2ip(int_ptr, string_in)
    integer, pointer:: int_ptr(:) !(out)
    character(len = *), intent(in):: string_in
    integer:: i, j, idx, nvalues
    continue
    nvalues = 1
    i = 1
    do
      idx = index(string_in(i: ), ',')
      if (idx == 0) exit
      i = i + idx - 1 + 1
      nvalues = nvalues + 1
    enddo
    allocate(int_ptr(nvalues))
    i = 1
    j = 1
    do
      idx = index(string_in(i: ), ',')
      if (idx == 0) then
        int_ptr(j) = stoi(string_in(i: ))
        exit
      endif
      int_ptr(j) = stoi(string_in(i: i+idx-2))
      i = i + idx - 1 + 1
      j = j + 1
    enddo
  end subroutine str2ip
  subroutine str2rp(real_ptr, string_in)
    real(SP), pointer:: real_ptr(:) !(out)
    character(len = *), intent(in):: string_in
    integer:: i, j, idx, nvalues
    continue
    nvalues = 1
    i = 1
    do
      idx = index(string_in(i: ), ',')
      if (idx == 0) exit
      i = i + idx - 1 + 1
      nvalues = nvalues + 1
    enddo
    allocate(real_ptr(nvalues))
    i = 1
    j = 1
    do
      idx = index(string_in(i: ), ',')
      if (idx == 0) then
        real_ptr(j) = stor(string_in(i: ))
        exit
      endif
      real_ptr(j) = stor(string_in(i: i+idx-2))
      i = i + idx - 1 + 1
      j = j + 1
    enddo
  end subroutine str2rp
  subroutine str2dp(double_ptr, string_in)
    real(DP), pointer:: double_ptr(:) !(out)
    character(len = *), intent(in):: string_in
    integer:: i, j, idx, nvalues
    continue
    nvalues = 1
    i = 1
    do
      idx = index(string_in(i: ), ',')
      if (idx == 0) exit
      i = i + idx - 1 + 1
      nvalues = nvalues + 1
    enddo
    allocate(double_ptr(nvalues))
    i = 1
    j = 1
    do
      idx = index(string_in(i: ), ',')
      if (idx == 0) then
        double_ptr(j) = stod(string_in(i: ))
        exit
      endif
      double_ptr(j) = stod(string_in(i: i+idx-2))
      i = i + idx - 1 + 1
      j = j + 1
    enddo
  end subroutine str2dp
  !== 数値型、論理型から文字型への変換
  !
  ! 総称名称 toChar として呼び出される関数群
  !
  character(TOKEN) function itoa_scalar(i) result(result)
    integer, intent(in):: i
    character(len = 32):: buffer
  continue
    write(unit=buffer, fmt="(i20)") i
    result = adjustl(buffer)
  end function itoa_scalar
  character(STRING) function itoa_array(ibuf) result(result)
    integer, intent(in):: ibuf(:)
    integer:: i
  continue
    if (size(ibuf) <= 0) then
      result = ""
      return
    endif
    result = tochar(ibuf(1))
    do, i = 2, size(ibuf)
      result = trim(result) // ", " // trim(tochar(ibuf(i)))
    enddo
  end function itoa_array
  character(TOKEN) function rtoa_scalar(x) result(result)
    real(sp), intent(in):: x
    character(len = 16):: buffer, expbuf
    integer:: ptr, eptr
    continue
    write(unit=buffer, fmt="(g16.8)") x
    eptr = scan(buffer, "eE", back=.true.)
    expbuf = ''
    if (eptr > 1) then
      expbuf = buffer(eptr: )
      buffer(eptr: ) = " "
    end if
    ptr = verify(buffer, " 0", back=.true.)
    if (ptr > 0) buffer(ptr+1: ) = " "
    if (eptr > 1) then
      buffer = buffer(1:len_trim(buffer)) // expbuf
    end if
    result = adjustl(buffer)
  end function rtoa_scalar
  character(STRING) function rtoa_array(rbuf) result(result)
    real(sp), intent(in):: rbuf(:)
    integer:: i
    continue
    if (size(rbuf) <= 0) then
      result = ""
      return
    endif
    result = tochar(rbuf(1))
    do, i = 2, size(rbuf)
      result = trim(result) // ", " // trim(tochar(rbuf(i)))
    enddo
  end function rtoa_array
  character(TOKEN) function dtoa_scalar(d) result(result)
    real(dp), intent(in):: d
    character(len = 32):: buffer, expbuf
    integer:: ptr, eptr
    continue
    write(unit=buffer, fmt="(g32.24)") d
    eptr = scan(buffer, "eE", back=.true.)
    expbuf = ''
    if (eptr > 1) then
      expbuf = buffer(eptr: )
      buffer(eptr: ) = " "
    end if
    ptr = verify(buffer, " 0", back=.true.)
    if (ptr > 0) buffer(ptr+1: ) = " "
    if (eptr > 1) then
      buffer = buffer(1:len_trim(buffer)) // expbuf
    end if
    result = adjustl(buffer)
  end function dtoa_scalar
  character(STRING) function dtoa_array(dbuf) result(result)
    real(dp), intent(in):: dbuf(:)
    integer:: i
    continue
    if (size(dbuf) <= 0) then
      result = ""
      return
    endif
    result = tochar(dbuf(1))
    do, i = 2, size(dbuf)
      result = trim(result) // ", " // trim(tochar(dbuf(i)))
    enddo
  end function dtoa_array
  character(TOKEN) function ltoa_scalar(l) result(result)
    logical, intent(in):: l
    continue
    if (l) then
      result = ".true."
    else
      result = ".false."
    end if
  end function ltoa_scalar
  character(STRING) function ltoa_array(lbuf) result(result)
    logical, intent(in):: lbuf(:)
    integer:: i
    continue
    if (size(lbuf) <= 0) then
      result = ""
      return
    endif
    result = tochar(lbuf(1))
    do, i = 2, size(lbuf)
      result = trim(result) // ", " // trim(tochar(lbuf(i)))
    enddo
  end function ltoa_array
  !-------------------------------------------------------------------
  !  文字配列の連結
  !-------------------------------------------------------------------
  character(STRING) function joinchar(carray, expr) result(result)
    implicit none
    character(*)     , intent(in)           :: carray(:)
    character(*)     , intent(in), optional :: expr
    character(2)     ,parameter :: default = ', '
    character(STRING)           :: delimiter
    integer                     :: dellen, i
  continue
    if ( present(expr) ) then
      delimiter = expr
      dellen = len(expr)
    else
      delimiter = default
      dellen = len(default)
    endif
    if (size(carray) <= 0) then
      result = ""
      return
    endif
    result = trim(carray(1))
    do, i = 2, size(carray)
      result = trim(result) // delimiter(1:dellen) // trim(carray(i))
    enddo
  end function joinchar
  subroutine concat_tail(carray, str, result)
    implicit none
    character(*), intent(in)  :: carray(:)
    character(*), intent(in)  :: str
    character(STRING), pointer:: result(:) ! (out)
    integer                     :: i, size_carray
  continue
    size_carray = size(carray)
    allocate(result(size_carray))
    do i = 1, size_carray
      result(i) = trim(carray(i)) // str
    end do
  end subroutine concat_tail
  function str_to_array1(c1) result(result)
    character(*), intent(in) :: c1
    character(STRING) :: result(1)
  continue
    result(1) = c1
  end function str_to_array1
  function str_to_array2(c1,c2) result(result)
    character(*), intent(in) :: c1,c2
    character(STRING) :: result(2)
  continue
    result(1) = c1
    result(2) = c2
  end function str_to_array2
  function str_to_array3(c1,c2,c3) result(result)
    character(*), intent(in) :: c1,c2,c3
    character(STRING) :: result(3)
  continue
    result(1) = c1
    result(2) = c2
    result(3) = c3
  end function str_to_array3
  function str_to_array4(c1,c2,c3,c4) result(result)
    character(*), intent(in) :: c1,c2,c3,c4
    character(STRING) :: result(4)
  continue
    result(1) = c1
    result(2) = c2
    result(3) = c3
    result(4) = c4
  end function str_to_array4
  function str_to_array5(c1,c2,c3,c4,c5) result(result)
    character(*), intent(in) :: c1,c2,c3,c4,c5
    character(STRING) :: result(5)
  continue
    result(1) = c1
    result(2) = c2
    result(3) = c3
    result(4) = c4
    result(5) = c5
  end function str_to_array5
  function str_to_array6(c1,c2,c3,c4,c5,c6) result(result)
    character(*), intent(in) :: c1,c2,c3,c4,c5,c6
    character(STRING) :: result(6)
  continue
    result(1) = c1
    result(2) = c2
    result(3) = c3
    result(4) = c4
    result(5) = c5
    result(6) = c6
  end function str_to_array6
  function str_to_array7(c1,c2,c3,c4,c5,c6,c7) result(result)
    character(*), intent(in) :: c1,c2,c3,c4,c5,c6,c7
    character(STRING) :: result(7)
  continue
    result(1) = c1
    result(2) = c2
    result(3) = c3
    result(4) = c4
    result(5) = c5
    result(6) = c6
    result(7) = c7
  end function str_to_array7
  function str_to_array8(c1,c2,c3,c4,c5,c6,c7,c8) result(result)
    character(*), intent(in) :: c1,c2,c3,c4,c5,c6,c7,c8
    character(STRING) :: result(8)
  continue
    result(1) = c1
    result(2) = c2
    result(3) = c3
    result(4) = c4
    result(5) = c5
    result(6) = c6
    result(7) = c7
    result(8) = c8
  end function str_to_array8
  function str_to_array9(c1,c2,c3,c4,c5,c6,c7,c8,c9) result(result)
    character(*), intent(in) :: c1,c2,c3,c4,c5,c6,c7,c8,c9
    character(STRING) :: result(9)
  continue
    result(1) = c1
    result(2) = c2
    result(3) = c3
    result(4) = c4
    result(5) = c5
    result(6) = c6
    result(7) = c7
    result(8) = c8
    result(9) = c9
  end function str_to_array9
  function str_to_array10(c1,c2,c3,c4,c5,c6,c7,c8,c9,c10) result(result)
    character(*), intent(in) :: c1,c2,c3,c4,c5,c6,c7,c8,c9,c10
    character(STRING) :: result(10)
  continue
    result(1) = c1
    result(2) = c2
    result(3) = c3
    result(4) = c4
    result(5) = c5
    result(6) = c6
    result(7) = c7
    result(8) = c8
    result(9) = c9
    result(10) = c10
  end function str_to_array10
  function str_to_array11(c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11) result(result)
    character(*), intent(in) :: c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11
    character(STRING) :: result(11)
  continue
    result(1) = c1
    result(2) = c2
    result(3) = c3
    result(4) = c4
    result(5) = c5
    result(6) = c6
    result(7) = c7
    result(8) = c8
    result(9) = c9
    result(10) = c10
    result(11) = c11
  end function str_to_array11
  function str_to_array12(c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12) result(result)
    character(*), intent(in) :: c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12
    character(STRING) :: result(12)
  continue
    result(1) = c1
    result(2) = c2
    result(3) = c3
    result(4) = c4
    result(5) = c5
    result(6) = c6
    result(7) = c7
    result(8) = c8
    result(9) = c9
    result(10) = c10
    result(11) = c11
    result(12) = c12
  end function str_to_array12
  !-------------------------------------------------------------------
  !  文字列の分解
  !-------------------------------------------------------------------
  subroutine split_cc(str, carray, sep, limit)
    use dc_types, only: string
    implicit none
    character(*), intent(in):: str
    character(*), pointer:: carray(:) !(out)
    character(*), intent(in):: sep
    integer, intent(in), optional:: limit
    integer :: num, cur, i, limitnum
    character(STRING) :: substr
    logical :: end_flag
  continue
    if (present(limit)) then
      if (limit > 0) then
        limitnum = limit
      else
        limitnum = 0
      end if
    else
      limitnum = 0
    end if
    if (len(trim(sep)) == 0) then
      num = 1
      substr = str
      ! 重複して無駄だが carray を allocate するため, 何分割するか
      ! 調べ, num に格納する.
      do
        cur = index(trim(substr), ' ')
        if (cur == 0) exit
        num = num + 1
        substr = adjustl(substr(cur + len(sep) :len(substr)))
      end do
      if (limitnum /= 0 .and. num > limitnum) num = limitnum
      allocate(carray(num))
      substr = str
      end_flag = .false.
      do i = 1, num
        cur = index(trim(substr), ' ')
        if (cur == 0 .or. i == num) end_flag = .true.
        if (end_flag) then
          carray(i) = substr
          exit
        else
          carray(i) = substr(1:cur - 1)
        end if
        substr = adjustl(substr(cur + len(sep) :len(substr)))
      end do
    else
      num = 1
      substr = str
      ! 重複して無駄だが carray を allocate するため, 何分割するか
      ! 調べ, num に格納する.
      do
        cur = index(substr, trim(sep))
        if (cur == 0) exit
        num = num + 1
        substr = substr(cur + len(sep) :len(substr))
      end do
      if (limitnum /= 0 .and. num > limitnum) num = limitnum
      allocate(carray(num))
      substr = str
      end_flag = .false.
      do i = 1, num
        cur = index(substr, trim(sep))
        if (cur == 0 .or. i == num) end_flag = .true.
        if (end_flag) then
          carray(i) = substr
          exit
        else
          carray(i) = substr(1:cur - 1)
        end if
        substr = substr(cur + len(sep) :len(substr))
      end do
    end if
    return
  end subroutine split_cc
  !-------------------------------------------------------------------
  !  文字列の解析
  !-------------------------------------------------------------------
  integer function index_ofs(string, start, substr) result(result)
    character(len = *), intent(in):: string
    integer, intent(in):: start
    character(len = *), intent(in):: substr
    intrinsic index
    if (start < 1) then
      result = 0
      return
    endif
    result = index(string(start: ), substr)
    if (result == 0) return
    result = start + result - 1
  end function index_ofs
  recursive function replace( &
    & str, from, to, recursive, start_pos ) result(result)
    use dc_types, only: string
    implicit none
    character(STRING):: result
    character(*), intent(in):: str, from, to
    logical, intent(in), optional:: recursive
    integer, intent(in), optional:: start_pos
    integer:: sp
    integer:: i, isa, isb, iea, ieb
    integer:: ir
    continue
    if ( present(start_pos) ) then
      sp = start_pos
    else
      sp = 1
    end if
    if ( sp < 1 ) then
      sp = 1
    end if
    result = str
    i = index(result(sp:), from)
    if (i == 0) return
    i = i + sp - 1
    isa = i + len(from)
    isb = i + len(to)
    if (len(to) < len(from)) then
      iea = len(result)
      ieb = len(result) + len(to) - len(from)
    else
      iea = len(result) + len(from) - len(to)
      ieb = len(result)
    endif
    if (len(to) /= len(from)) result(isb:ieb) = result(isa:iea)
    result(i:i+len(to)-1) = to
    !-----------------------------------
    !  再帰的処理
    !  Recursive process
    ir = index(result(i+len(to):), from)
    if ( len_trim(from) == 0 ) then
      ir = index(trim(result(i+len(to):)), from)
    end if
    if (ir /= 0) then
      if ( present(recursive) ) then
        if ( recursive ) then
          result = replace( str = result, &
            &               from = from, to = to, &
            &               recursive = recursive, &
            &               start_pos = i+len(to) )
        end if
      end if
    end if
  end function replace
  !-------------------------------------------------------------------
  !  大文字・小文字を無視した処理
  !-------------------------------------------------------------------
  subroutine cupper(ch)
    character(len = *), intent(inout):: ch
    integer:: i, lch, idx
  continue
    lch = len(ch)
    do, i = 1, lch
      idx = ichar(ch(i:i))
      if (97 <= idx .and. idx <= 122) then
        ch(i:i)=char(idx - 32)
      end if
    end do
  end subroutine cupper
  subroutine clower(ch)
    character(len = *), intent(inout):: ch
    integer:: i, lch, idx
  continue
    lch = len(ch)
    do, i = 1, lch
      idx = ichar(ch(i:i))
      if (65 <= idx .and. idx <= 90) then
        ch(i:i)=char(idx + 32)
      end if
    end do
  end subroutine clower
  character(STRING) function uchar(ch) result(result)
    character(len = *), intent(in):: ch
  continue
    result = ch
    call toupper(result)
  end function uchar
  character(STRING) function lchar(ch) result(result)
    character(len = *), intent(in):: ch
  continue
    result = ch
    call tolower(result)
  end function lchar
  character(STRING) function roundnum(num) result(result)
    character(*), intent(in):: num
    character(STRING):: nrv, enrv
    integer:: i, moving_up, nrvi, dig, zero_stream
  continue
    !
    ! 実数でないものについてはそのまま返す.
    !
    if ( scan('.', trim(num) ) == 0  ) then
      result = num
      return
    end if
    nrv = num
    !
    ! 指数部を避けておく.
    !
    enrv = ''
    i = scan(nrv, "eE", back=.true.)
    if ( i > 1  ) then
      enrv = nrv(i:)
      nrv(i:) = " "
    elseif ( i == 1 ) then
      result = nrv
      return
    end if
    !
    ! 0.30000001 などの末尾の 1 のような, ゴミの桁の数値を掃除し,
    ! 0.3000000 などに整形.
    !
    if ( index( trim( nrv ), '.') - len_trim( nrv ) < -7 ) then
      do while ( index('567890.', nrv(len_trim(nrv):len_trim(nrv)) ) == 0 )
        if ( len_trim(nrv) < 2 ) exit
        nrv = nrv(1:len_trim(nrv)-1)
      end do
    end if
    !
    ! 0.30000001986 などの末尾の 1 以降のゴミの桁の数値を掃除し,
    ! 0.3000000 などに整形.
    !
    if ( index( trim( nrv ), '.') - len_trim( nrv ) < -7 ) then
      dig = index( trim( nrv ), '.') + 1
      zero_stream = 0
      do while ( dig < len_trim( nrv ) )
        if ( nrv(dig:dig) == "0" ) then
          zero_stream = zero_stream + 1
        else
          zero_stream = 0
        end if
        if ( zero_stream > 7 ) then
          nrv(dig:len_trim(nrv)) = '0'
          exit
        end if
        dig = dig + 1
      end do
    end if
    !
    ! 0.3000000 などの末尾の 0 を掃除し,
    ! 0.3 などに整形.
    !
    if ( index( trim( nrv ), '.') /= 0 ) then
      do while ( index('123456789.', nrv(len_trim(nrv):len_trim(nrv)) ) == 0 )
        if ( len_trim(nrv) < 2 ) exit
        nrv = nrv(1:len_trim(nrv)-1)
      end do
    end if
    !
    ! 0.89999998 などの末尾の 8 のような, ゴミの桁の数値を掃除し,
    ! 0.8999999 などに整形.
    !
    moving_up = 0
    if ( index( trim( nrv ), '.') - len_trim( nrv ) < -7 ) then
      do while ( index('12345690.', nrv(len_trim(nrv):len_trim(nrv)) ) == 0 )
        if ( len_trim(nrv) < 2 ) exit
        nrv = nrv(1:len_trim(nrv)-1)
      end do
      moving_up = 1
    end if
    !
    ! 0.8999999 などの末尾の 9 を掃除し, 繰り上げて
    ! 0.9 などに整形.
    !
    if ( moving_up > 0 ) then
      do while ( index('012345678.', nrv(len_trim(nrv):len_trim(nrv)) ) == 0 )
        if ( len_trim(nrv) < 2 ) exit
        nrv = nrv(1:len_trim(nrv)-1)
      end do
    end if
    i = len_trim(nrv)
    do while ( moving_up > 0 .and. i > 0 )
      if ( index('.', nrv(i:i)) /= 0 ) then
        i = i - 1
        cycle
      end if
      nrvi = stoi( nrv(i:i) ) + moving_up
      if ( nrvi < 10 ) then
        nrv(i:i) = trim( tochar( nrvi ) )
        exit
      else
        nrv(i:i) = '0'
        if ( i < 2 ) then
          nrv = '10'
          exit
        else
          i = i - 1
          cycle
        end if
      end if
      if ( len_trim(nrv) < 2 ) exit
      nrv = nrv(1:len_trim(nrv)-1)
    end do
    !
    ! 0.3000000 などの末尾の 0 を掃除し,
    ! 0.3 などに整形.
    !
    if ( index( trim( nrv ), '.') /= 0 ) then
      do while ( index('123456789.', nrv(len_trim(nrv):len_trim(nrv)) ) == 0 )
        if ( len_trim(nrv) < 2 ) exit
        nrv = nrv(1:len_trim(nrv)-1)
      end do
    end if
    !
    ! 指数部を復帰する
    !
    if ( len_trim(enrv) > 0 ) then
      nrv = trim(nrv) // enrv
    end if
    result = nrv
  end function roundnum
end module