dcstringsprintf.f90 File Reference

Go to the source code of this file.

Functions/Subroutines
subroutine	dcstringsprintf (unit, fmt, i, r, d, l, n, c1, c2, c3, ca)
subroutine	append (unitx, ucur, val, stat)

Function/Subroutine Documentation

append()

subroutine dcstringsprintf::append	(	character(*), intent(inout)	unitx,
		integer, intent(inout)	ucur,
		character(*), intent(in)	val,
		integer, intent(out)	stat )

Definition at line 367 of file dcstringsprintf.f90.

    !
    ! unitx に val を付加。その際、unitx がその最大文字列長を越えた場合
    ! には stat = 2 を返す。
    !
    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

dcstringsprintf()

subroutine dcstringsprintf	(	character(*), intent(out)	unit,
		character(*), intent(in)	fmt,
		integer, dimension(:), intent(in), optional	i,
		real(sp), dimension(:), intent(in), optional	r,
		real(dp), dimension(:), intent(in), optional	d,
		logical, dimension(:), intent(in), optional	l,
		integer, dimension(:), intent(in), optional	n,
		character(*), intent(in), optional	c1,
		character(*), intent(in), optional	c2,
		character(*), intent(in), optional	c3,
		character(*), dimension(:), intent(in), optional	ca )

Definition at line 143 of file dcstringsprintf.f90.

  !
  ! フォーマット文字列 fmt に従って変換された文字列を unit に返します。
  ! 第2引数 fmt には指示子を含む文字列を与えます。
  ! 指示子には「<tt>%</tt>」を用います。
  ! <tt>%</tt> を用いたい場合は 「<tt>%%</tt>」と記述します。
  ! 指示子および用例に関しての詳細は dc_utils/dcstringsprintf.f90 を参照ください。
  !
  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
 
  subroutine append(unitx, ucur, val, stat)
    !
    ! unitx に val を付加。その際、unitx がその最大文字列長を越えた場合
    ! には stat = 2 を返す。
    !
    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
 

References append(), dc_types::dp, and dc_types::sp.

Here is the call graph for this function: