dc_string.f90

Go to the documentation of this file.

! -*- mode: f90; coding: utf-8 -*-
!-----------------------------------------------------------------------
! Copyright (c) 2000-2017 Gtool Development Group. All rights reserved.
!-----------------------------------------------------------------------
!
! This file is generated from dc_string.erb by ERB included Ruby 2.3.3.
! Please do not edit this file directly.
!
module dc_string
  use dc_types, only: token, string, dp
  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 :: printf
  public :: putline

  interface stoi
    module procedure atoi_scalar
  end interface stoi

  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) result(result)
      use dc_types, only: string, dp
      character(len = STRING):: result
      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 function dcstringcprintf
  end interface cprintf

  interface printf
    subroutine dcstringsprintf(unit, fmt, i, r, d, L, n, c1, c2, c3, ca)
      use dc_types, only: dp
      character(*), intent(out):: 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 dcstringsprintf

    subroutine dcstringfprintf(unit, fmt, i, r, d, L, n, c1, c2, c3, ca)
      use dc_types, only: dp
      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)
    !
    ! 文字列 head と文字列 whole の先頭部分 (head と同じ文字列長)
    ! とを比較し、同じものならば .true. を、異なる場合には .false.
    ! を返します。 whole の文字列長が head の文字列長よりも短い場合には
    ! .false. を返します。
    !
    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)
    !
    ! 大文字・小文字を無視して文字列の比較を行います。
    ! 文字列 string_a と文字列 string_b を比較し、同じものならば
    ! .true. を、異なる場合には .false. を返します。
    !
    !--
    ! ※ 注意書き ※
    !
    ! コンパイラによっては 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)
    !
    ! 文字型配列引数 *carray* が文字型引数 *string* と等しい要素を持つ場合に
    ! .true. を返します.
    !
    ! 文字列の前後の空白は無視されます.
    ! オプショナル引数 *ignore_space* に .false. を
    ! 与えた場合には文字列先頭の空白を無視しません.
    !
    ! オプショナル引数 *ignore_case* に .true. を与えた場合には
    ! 大文字, 小文字の違いを無視して比較します.
    !
    ! If an character array argument *carray* has the same
    ! as character argument *string*, ".true." is returned.
    !
    ! And beginning and trailing spaces are ignored.
    ! If ".false." is given to an optional argument *ignore_space*,
    ! beginning spaces are not ignored.
    !
    ! If ".true." is given to an optional argument *ignore_case*,
    ! this function ignores case.
    !
    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)
    !
    ! string で与えられる文字型変数を論理型にして返します。 string
    ! が空、 または 0、 0.0、 0.0D0、 0.0d0、 .false.、 .FALSE.、 f、
    ! F、 false、 FALSE の場合には <tt>.false.</tt> が返ります。
    ! それ以外の場合には <tt>.true.</tt> が返ります。
    !
    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)
    !
    ! string で与えられる文字型変数を、整数型変数にして返します。
    ! もしも string が数値に変換できない場合、default が返ります。
    ! default を指定しない場合は 0 が返ります。
    !
    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(DP) function atod_scalar(string_in) result(result)
    !
    ! string で与えられる文字型変数を、倍精度実数型変数にして返します。
    ! もしも string が数値に変換できない場合、0.0 が返ります。
    !
    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)
    !
    ! string で与えられる文字型変数をカンマ「,」で区切り、
    ! 整数型配列ポインタ int_ptr(:) にして返します。 int_ptr(:)
    ! の配列サイズは string の内容に応じて自動的に決まります。
    !
    ! ただし、int_ptr(:) は必ず空状態または不定状態で与えてください。
    ! 既に割り付けられている場合、メモリリークを起こします。
    !
    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) = stod(string_in(i: i+idx-2))
      i = i + idx - 1 + 1
      j = j + 1
    enddo
  end subroutine str2ip

  subroutine str2rp(real_ptr, string_in)
    !
    ! string で与えられる文字型変数をカンマ「,」で区切り、
    ! 単精度実数型配列ポインタ real_ptr(:) にして返します。
    ! real_ptr(:) の配列サイズは string の内容に応じて自動的に決まります。
    !
    ! ただし、real_ptr(:) は必ず空状態または不定状態で与えてください。
    ! 既に割り付けられている場合、メモリリークを起こします。
    !
    real, 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) = stod(string_in(i: ))
        exit
      endif
      real_ptr(j) = stod(string_in(i: i+idx-2))
      i = i + idx - 1 + 1
      j = j + 1
    enddo
  end subroutine str2rp

  subroutine str2dp(real_ptr, string_in)
    !
    ! string で与えられる文字型変数をカンマ「,」で区切り、
    ! 倍精度実数型配列ポインタ real_ptr(:) にして返します。
    ! real_ptr(:) の配列サイズは string の内容に応じて自動的に決まります。
    !
    ! ただし、real_ptr(:) は必ず空状態または不定状態で与えてください。
    ! 既に割り付けられている場合、メモリリークを起こします。
    !
    real(DP), 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) = stod(string_in(i: ))
        exit
      endif
      real_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)
    !
    ! 整数型変数 i で与えられる数値を文字型変数にして返します。
    ! 配列が与えられる場合、各要素をカンマと空白「<tt>, </tt>」
    ! で区切って返します。
    !
    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)
    !
    ! 整数型配列変数 ibuf(:) で与えられる数値を文字型変数にして返します。
    ! 配列が与えられる場合、各要素をカンマと空白「<tt>, </tt>」
    ! で区切って返します。
    !
    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)
    !
    ! 単精度実数型変数 x で与えられる数値を文字型変数にして返します。
    ! 配列が与えられる場合、各要素をカンマと空白「<tt>, </tt>」
    ! で区切って返します。
    !
    real, 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)
    !
    ! 単精度実数型配列 rbuf(:)、で与えられる数値を文字型変数にして返します。
    ! 配列が与えられる場合、各要素をカンマと空白「<tt>, </tt>」
    ! で区切って返します。
    !
    real, 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)
    !
    ! 倍精度実数型変数 d で与えられる数値を文字型変数にして返します。
    ! 配列が与えられる場合、各要素をカンマと空白「<tt>, </tt>」
    ! で区切って返します。
    !
    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)
    !
    ! 倍精度実数型配列 dbuf(:) で与えられる数値を文字型変数にして返します。
    ! 配列が与えられる場合、各要素をカンマと空白「<tt>, </tt>」
    ! で区切って返します。
    !
    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)
    !
    ! 論理型変数 l で与えられる数値を文字型変数にして返します。
    ! 配列が与えられる場合、各要素をカンマと空白「<tt>, </tt>」
    ! で区切って返します。
    !
    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)
    !
    ! 論理型配列 lbuf(:) で与えられる数値を文字型変数にして返します。
    ! 配列が与えられる場合、各要素をカンマと空白「<tt>, </tt>」
    ! で区切って返します。
    !
    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)
    !
    ! 文字型配列 carray に与えた複数の文字列をカンマと空白
    ! 「<tt>, </tt>」 で区切った1つの文字列にして返します。
    ! expr に文字列を与えると、その文字列を区切り文字として用います。
    !
    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)
    !
    ! 文字型配列 *carray* の各成分の末尾に *str* を追加して
    ! *result* に返します。*carray* の各成分の末尾の空白は無視されます。
    !
    ! result(:) の配列サイズは carray のサイズに応じて自動的に決まります。
    ! ただし、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)
    !
    ! 異なる長さの複数の文字型変数を 1 つの文字型配列に変換します。
    !
    ! 1 から 1 個までの引数を与えることが可能です。
    !
    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)
    !
    ! 異なる長さの複数の文字型変数を 1 つの文字型配列に変換します。
    !
    ! 1 から 2 個までの引数を与えることが可能です。
    !
    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)
    !
    ! 異なる長さの複数の文字型変数を 1 つの文字型配列に変換します。
    !
    ! 1 から 3 個までの引数を与えることが可能です。
    !
    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)
    !
    ! 異なる長さの複数の文字型変数を 1 つの文字型配列に変換します。
    !
    ! 1 から 4 個までの引数を与えることが可能です。
    !
    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)
    !
    ! 異なる長さの複数の文字型変数を 1 つの文字型配列に変換します。
    !
    ! 1 から 5 個までの引数を与えることが可能です。
    !
    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)
    !
    ! 異なる長さの複数の文字型変数を 1 つの文字型配列に変換します。
    !
    ! 1 から 6 個までの引数を与えることが可能です。
    !
    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)
    !
    ! 異なる長さの複数の文字型変数を 1 つの文字型配列に変換します。
    !
    ! 1 から 7 個までの引数を与えることが可能です。
    !
    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)
    !
    ! 異なる長さの複数の文字型変数を 1 つの文字型配列に変換します。
    !
    ! 1 から 8 個までの引数を与えることが可能です。
    !
    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)
    !
    ! 異なる長さの複数の文字型変数を 1 つの文字型配列に変換します。
    !
    ! 1 から 9 個までの引数を与えることが可能です。
    !
    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)
    !
    ! 異なる長さの複数の文字型変数を 1 つの文字型配列に変換します。
    !
    ! 1 から 10 個までの引数を与えることが可能です。
    !
    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)
    !
    ! 異なる長さの複数の文字型変数を 1 つの文字型配列に変換します。
    !
    ! 1 から 11 個までの引数を与えることが可能です。
    !
    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)
    !
    ! 異なる長さの複数の文字型変数を 1 つの文字型配列に変換します。
    !
    ! 1 から 12 個までの引数を与えることが可能です。
    !
    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)
    !
    ! *str* で与えられた文字列を 文字列 *sep* で分解し,
    ! ポインタ配列 *carray* に返します.
    ! *carray* は必ず空状態にして与えてください. 割り付け状態の
    ! 場合にはエラーを返します.
    !
    ! *limit* に正の数を与えた場合, 最大 *limit* 個のフィールドに分割
    ! します.  負の数や 0 の場合は省略した場合と同じになります.  *str*
    ! の末尾の空白は除去されます.  *sep* に空文字を代入する場合, 空白
    ! 文字で分割されます.
    !
    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)
    !
    ! 文字列 string の start 文字目以降の文字列の中に substr
    ! の文字列が含まれている時、その開始文字位置を返します。
    ! 含まれない場合は 0 を返します。
    ! 返される開始文字位置は文字列 string の先頭から数えます。
    !
    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( &
    & string, from, to, recursive, start_pos ) result(result)
    !
    ! 文字列 *string* に文字列 *from* が含まれる場合, その部分を文字列 *to*
    ! に置換して返します. 文字列 *from* が含まれない場合は *string*
    ! をそのまま返します. *from* が複数含まれる場合, 先頭の *from*
    ! のみが置換されます.
    !
    ! 全ての *from* を *to* へ変換したい場合には,
    ! オプショナル引数 *recursive* に .true. を与えてください.
    !
    ! デフォルトでは, 文字列の最初から検索を行います.
    ! オプショナル引数 *start_pos* を与える場合,
    ! *start_pos* 文字目から検索を行います.
    !
    ! If a string *from* is included in *string*, the string is
    ! replace to *to*, and the replaced string is returned.
    ! If a string *from* is not included, *string* is returned
    ! without change.
    ! When multiple *from* are included, only first *from* is replaced.
    !
    ! In order to replace all *from* to *to*, give ".true." to
    ! optional argument *recursive*.
    !
    ! By default, the string is searched from the top.
    ! If optional argument *start_pos* is given,
    ! the search is started from *start_pos*.
    !
    use dc_types, only: strlen => string
    implicit none
    character(STRLEN):: result
    character(*), intent(in):: string, 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 = string
    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( string = result, &
            &               from = from, to = to, &
            &               recursive = recursive, &
            &               start_pos = i+len(to) )
        end if
      end if
    end if

  end function replace

  !-------------------------------------------------------------------
  !  大文字・小文字を無視した処理
  !-------------------------------------------------------------------

  subroutine cupper(ch)
    !
    ! 文字列 ch に英字が含まれる場合、その英字を大文字に変換して 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)
    !
    ! 文字列 ch に英字が含まれる場合、その英字を小文字に変換して 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)
    !
    ! 文字列 ch に英字が含まれる場合、その英字を大文字に変換して返します。
    ! 英字でない文字や既に大文字になっている文字はそのまま返します。
    !
    character(len = *), intent(in):: ch
  continue
    result = ch
    call toupper(result)
  end function uchar

  character(STRING) function lchar(ch) result(result)
    !
    ! 文字列 ch に英字が含まれる場合、その英字を小文字に変換して返します。
    ! 英字でない文字や既に小文字になっている文字はそのまま返します。
    !
    character(len = *), intent(in):: ch
  continue
    result = ch
    call tolower(result)
  end function lchar

  character(STRING) function roundnum(num) result(result)
    !
    ! '0.30000001' や '12.999998' などの丸め誤差によって端数が残って
    ! しまっている数値表記を '0.3' や '13.' などに整形して返します.
    !
    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