dcstringsprintf.f90

Go to the documentation of this file.

! -*- mode: f90; coding: utf-8 -*-
!-----------------------------------------------------------------------
! Copyright (c) 2000-2026 Gtool Development Group. All rights reserved.
!-----------------------------------------------------------------------
!>
!> @author    Yasuhiro MORIKAWA, Eizi TOYODA
!> @copyright Copyright (C) GFD Dennou Club, 2000-2026. All rights reserved. <br/>
!>            License is BSD-2-Clause. see [COPYRIGHT](@ref COPYRIGHT) in detail
!> @en
!> @brief Formatted output conversion (similar to C sprintf)
!> @details
!> Format a string like C sprintf(3).
!> Note that the implementation is quite different from C sprintf(3).
!>
!> ### Format specifiers
!>
!> Format specifiers used in dc_string#CPrintf and dc_string#Printf
!> start with **%**. Available specifiers are:
!>
!> | Specifier     | Argument      | Description                              |
!> |---------------|---------------|------------------------------------------|
!> | `%d`, `%D`    | `i(:)`        | Display integer (decimal). Use %2d or %04d for digit control |
!> | `%o`, `%O`    | `i(:)`        | Display integer (octal)                  |
!> | `%x`, `%X`    | `i(:)`        | Display integer (hexadecimal)            |
!> | `%f`, `%F`    | `d(:)`        | Display double precision real            |
!> | `%r`, `%R`    | `r(:)`        | Display single precision real            |
!> | `%b`, `%B`    | `L(:)`        | Display logical (T/F)                    |
!> | `%y`, `%Y`    | `L(:)`        | Display logical (yes/no)                 |
!> | `%c`, `%C`    | `c1,c2,c3`    | Display character (variable)             |
!> | `%a`, `%A`    | `ca`          | Display character (array)                |
!> | `%*`          | `n(:)`        | Repeat count for multiple data output    |
!>
!> @enden
!>
!> @ja
!> @brief 書式変換出力 (C の sprintf 風)
!> @details
!> C の sprintf(3) のように文字列をフォーマットして返します。
!> ただし、実装は C の sprintf(3) とは大分違うのでご注意ください。
!>
!> ### フォーマット指示子
!>
!> dc_string#CPrintf, dc_string#Printf のフォーマット引数に
!> 用いられる指示子は **%** で始まります。種類は以下の通りです:
!>
!> | 指示子        | 引数          | 説明                                      |
!> |---------------|---------------|-------------------------------------------|
!> | `%d`, `%D`    | `i(:)`        | 整数データ (10進数)。%2d や %04d で桁数指定可 |
!> | `%o`, `%O`    | `i(:)`        | 整数データ (8進数)                        |
!> | `%x`, `%X`    | `i(:)`        | 整数データ (16進数)                       |
!> | `%f`, `%F`    | `d(:)`        | 倍精度実数データ                          |
!> | `%r`, `%R`    | `r(:)`        | 単精度実数データ                          |
!> | `%b`, `%B`    | `L(:)`        | 論理データ (T/F)                          |
!> | `%y`, `%Y`    | `L(:)`        | 論理データ (yes/no)                       |
!> | `%c`, `%C`    | `c1,c2,c3`    | 文字データ (変数)                         |
!> | `%a`, `%A`    | `ca`          | 文字データ (配列)                         |
!> | `%*`          | `n(:)`        | 複数データ出力の繰り返し回数              |
!>
!> @endja
!>
 
!> @en
!> @brief Format and output string to character variable
!> @details
!> Return a formatted string according to format string `fmt`.
!> Use specifiers starting with '%' in `fmt`.
!> Use '%%' to output a literal '%'.
!> See dcstringsprintf.f90 for specifier details and examples.
!>
!> @param[out] unit Output character variable
!> @param[in] fmt Format string with specifiers
!> @param[in] i Integer array data for %d, %o, %x
!> @param[in] r Single precision real array data for %r
!> @param[in] d Double precision real array data for %f
!> @param[in] L Logical array data for %b, %y
!> @param[in] n Repeat counts for %* specifier
!> @param[in] c1 First character string for %c
!> @param[in] c2 Second character string for %c
!> @param[in] c3 Third character string for %c
!> @param[in] ca Character array for %a
!> @enden
!>
!> @ja
!> @brief 書式変換して文字変数に出力
!> @details
!> フォーマット文字列 `fmt` に従って変換された文字列を `unit` に返します。
!> `fmt` には '%' で始まる指示子を含む文字列を与えます。
!> '%' を出力したい場合は '%%' と記述します。
!> 指示子および用例に関しての詳細は dcstringsprintf.f90 を参照ください。
!>
!> @param[out] unit 出力先の文字変数
!> @param[in] fmt 指示子を含むフォーマット文字列
!> @param[in] i %d, %o, %x 用の整数配列データ
!> @param[in] r %r 用の単精度実数配列データ
!> @param[in] d %f 用の倍精度実数配列データ
!> @param[in] L %b, %y 用の論理配列データ
!> @param[in] n %* 用の繰り返し回数
!> @param[in] c1 %c 用の1番目の文字列
!> @param[in] c2 %c 用の2番目の文字列
!> @param[in] c3 %c 用の3番目の文字列
!> @param[in] ca %a 用の文字配列
!> @endja
subroutine dcstringsprintf(unit, fmt, i, r, d, L, n, c1, c2, c3, ca)
 
  use dc_types,      only: sp, dp
  implicit none
  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(:)
 
  ! 上記配列引数のカウンタ
  integer :: ni, nr, nd, nl, nc, na, nn
  integer :: ucur       ! unit に書かれた文字数
  integer :: endp       ! 既に処理された fmt の文字数
  integer :: cur        ! 現在着目中の文字は fmt(cur:cur) である
  integer :: ptr        ! fmt から検索をするときに使用
  integer :: exp_ptr    ! fmt から数値の指数部を検索をするときに使用
  integer :: minus_ptr  ! '-' を検索する時に使用
  integer :: repeat     ! %数字 または %* から決定された繰返し数
  integer :: m          ! 1:repeat の範囲で動くループ変数
  integer :: stat       ! エラー処理
  character(80) :: cbuf ! read/write 文のバッファ
  character(80) :: exp_buf ! real/write 文の指数部のバッファ (実数型用)
  character(80) :: ibuf ! real/write 文のバッファ (整数型用)
  integer :: len_ibuf   ! ibuf の長さ
  integer :: figs_ibuf  ! ibuf の有効な桁数
  logical :: int_zero_fill ! 先頭を 0 で埋めるかどうかを判定するフラグ (整数型用)
  integer :: int_figs   ! 整数型を出力する際の桁数 (整数型用)
  continue
  ni = 0;  nr = 0;  nd = 0;  nl = 0;  nc = 0;  na = 0;  nn = 0
  unit = ""
  ucur = 0
  endp = 0
  int_figs = 0
  int_zero_fill = .false.
  mainloop: do
    cur = endp + 1
    if (cur > len(fmt)) exit mainloop
    !
    ! リテラルに転写できる文字列 fmt(cur:endp-1) を発見処理
    !
    endp = cur - 1 + scan(fmt(cur: ), '%')
    if (endp > cur) then
      call append(unit, ucur, fmt(cur:endp-1), stat)
      if (stat /= 0) exit mainloop
    else if (endp == cur - 1) then
      call append(unit, ucur, fmt(cur: ), stat)
      exit mainloop
    endif
    !
    ! % から書式指定文字までを fmt(cur:endp) とする
    !
    cur = endp + 1
    endp = cur - 1 + scan(fmt(cur: ), 'DdOoXxFfRrBbYySsCcAa%')
    if (endp < cur) then
      call append(unit, ucur, fmt(cur-1: ), stat)
      exit mainloop
    endif
    cbuf = fmt(cur:endp-1)
    !
    ! %* がある場合、n(:) に渡された数から繰り返し回数を取得
    !
    if (cbuf(1:1) == '*') then
      nn = nn + 1
      if (nn > size(n)) then
        repeat = 1
      else
        repeat = n(nn)
      endif
      ibuf = cbuf(2:)
    else
      repeat = 1
      ibuf = cbuf
!    else if (cbuf == '') then
!      repeat = 1
!    else
!      ptr = verify(cbuf, " 0123456789")
!      if (ptr > 0) cbuf(ptr: ) = " "
!      read(cbuf, "(I80)", iostat=ptr) repeat
    endif
    !
    ! %2d や %04d のように '%' の後ろに数字が指定され、
    ! かつ d (整数型変数の表示) の場合には先頭に空白
    ! または 0 を埋める.
    !
    if (scan(ibuf(1:1),'1234567890') > 0) then
      if (ibuf(1:1) == '0') then
        int_zero_fill = .true.
      else
        int_zero_fill = .false.
      end if
      read(unit=ibuf, fmt="(i80)") int_figs
    else
      int_figs = 0
      int_zero_fill = .false.
    endif
    percentrepeat: do m = 1, repeat
      if (m > 1) then
        call append(unit, ucur, ", ", stat)
        if (stat /= 0) exit mainloop
      endif
      select case(fmt(endp:endp))
      case('d', 'D')
        if (.not. present(i)) cycle mainloop
        ni = ni + 1;  if (ni > size(i)) cycle mainloop
        write(ibuf, "(i20)") i(ni)
        len_ibuf = len(trim(adjustl(ibuf)))
        figs_ibuf = verify(ibuf, ' ')
        cbuf = ' '
        if (int_figs > len_ibuf) then
          minus_ptr = scan(ibuf, '-')
          if (int_zero_fill) then
            if (minus_ptr /= 0) then
              len_ibuf = len_ibuf - 1
              figs_ibuf = figs_ibuf + 1
              cbuf(1:int_figs-len_ibuf) = '-0000000000000000000'
            else
              cbuf(1:int_figs-len_ibuf) = '00000000000000000000'
            end if
          end if
          cbuf(int_figs-len_ibuf+1:) = ibuf(figs_ibuf:20)
        else
          cbuf = ibuf(figs_ibuf:20)
        end if
        call append(unit, ucur, trim(cbuf), stat)
        if (stat /= 0) exit mainloop
      case('o', 'O')
        if (.not. present(i)) cycle mainloop
        ni = ni + 1;  if (ni > size(i)) cycle mainloop
        write(cbuf, "(o20)") i(ni)
        call append(unit, ucur, trim(adjustl(cbuf)), stat)
        if (stat /= 0) exit mainloop
      case('x', 'X')
        if (.not. present(i)) cycle mainloop
        ni = ni + 1;  if (ni > size(i)) cycle mainloop
        write(cbuf, "(z20)") i(ni)
        call append(unit, ucur, trim(adjustl(cbuf)), stat)
        if (stat /= 0) exit mainloop
      case('f', 'F')
        if (.not. present(d)) cycle mainloop
        nd = nd + 1;  if (nd > size(d)) cycle mainloop
        write(cbuf, "(f80.40)") d(nd)
        cbuf = adjustl(cbuf)
        exp_ptr = verify(cbuf, ' 1234567890-+.', back=.true.)
        exp_buf = ' '
        if (exp_ptr > 0) then
          exp_buf = cbuf(exp_ptr: )
          cbuf(exp_ptr: ) = " "
        end if
        ptr = verify(cbuf, " 0", back=.true.)
        if (ptr > 0) cbuf(ptr+1: ) = " "
        cbuf = trim(cbuf) // trim(exp_buf)
        call append(unit, ucur, trim(adjustl(cbuf)), stat)
        if (stat /= 0) exit mainloop
      case('r', 'R')
        if (.not. present(r)) cycle mainloop
        nr = nr + 1 ; if (nr > size(r)) cycle mainloop
        write(cbuf, "(f80.40)") r(nr)
        cbuf = adjustl(cbuf)
        exp_ptr = verify(cbuf, ' 1234567890-+.', back=.true.)
        exp_buf = ' '
        if (exp_ptr > 0) then
          exp_buf = cbuf(exp_ptr: )
          cbuf(exp_ptr: ) = " "
        end if
        ptr = verify(cbuf, " 0", back=.true.)
        if (ptr > 0) cbuf(ptr+1: ) = " "
        cbuf = trim(cbuf) // trim(exp_buf)
        call append(unit, ucur, trim(adjustl(cbuf)), stat)
        if (stat /= 0) exit mainloop
      case('b', 'B')
        if (.not. present(l)) cycle mainloop
        nl = nl + 1;  if (nl > size(l)) cycle mainloop
        write(cbuf, "(L1)") l(nl)
        call append(unit, ucur, trim(adjustl(cbuf)), stat)
        if (stat /= 0) exit mainloop
      case('y', 'Y')
        if (.not. present(l)) cycle mainloop
        nl = nl + 1;  if (nl > size(l)) cycle mainloop
        if (l(nl)) then
          call append(unit, ucur, "yes", stat)
          if (stat /= 0) exit mainloop
        else
          call append(unit, ucur, "no", stat)
          if (stat /= 0) exit mainloop
        endif
      case('c', 'C')
        nc = nc + 1
        if (nc == 1) then
          if (.not. present(c1)) cycle percentrepeat
          call append(unit, ucur, c1, stat)
          if (stat /= 0) exit mainloop
        else if (nc == 2) then
          if (.not. present(c2)) cycle percentrepeat
          call append(unit, ucur, c2, stat)
          if (stat /= 0) exit mainloop
        else if (nc == 3) then
          if (.not. present(c3)) cycle percentrepeat
          call append(unit, ucur, c3, stat)
          if (stat /= 0) exit mainloop
        endif
      case('a', 'A')
        if (.not. present(ca)) cycle mainloop
        na = na + 1;  if (na > size(ca)) cycle mainloop
        call append(unit, ucur, trim(adjustl(ca(na))), stat)
        if (stat /= 0) exit mainloop
      case('%')
        call append(unit, ucur, '%', stat)
        if (stat /= 0) exit mainloop
      end select
    enddo percentrepeat
  enddo mainloop
  return
contains
 
  !> @en
  !> @brief Append string to output buffer
  !> @param[inout] unitx Output buffer string
  !> @param[inout] ucur Current position in unitx
  !> @param[in] val String to append
  !> @param[out] stat Status (0=success, 1=truncated, 2=overflow)
  !> @enden
  !> @ja
  !> @brief 出力バッファに文字列を追加
  !> @param[inout] unitx 出力バッファ文字列
  !> @param[inout] ucur unitx の現在位置
  !> @param[in] val 追加する文字列
  !> @param[out] stat ステータス (0=成功, 1=切り詰め, 2=オーバーフロー)
  !> @endja
  subroutine append(unitx, ucur, val, stat)
    character(*), intent(inout):: unitx ! 最終的に返される文字列
    integer,      intent(inout):: ucur ! unitx の文字数
    character(*), intent(in)   :: val  ! unitx に付加される文字列
    integer,      intent(out)  :: stat ! ステータス
    integer                    :: wrsz ! val の文字列
    continue
    ! unitx の最大長を越えた場合には stat = 2 を返す。
    if (ucur >= len(unitx)) then
      stat = 2
      ! 正常時の処理
    else
      ! unitx の長さを越えた場合も考慮して unitx に val を付加する。
      wrsz = min(len(val), len(unitx) - ucur)
      unitx(1+ucur: wrsz+ucur) = val(1: wrsz)
      ucur = ucur + wrsz
      stat = 0
      if (wrsz < len(val)) stat = 1
    endif
  end subroutine append
 
end subroutine dcstringsprintf