subroutine DCStringSPrintf(unit, fmt, i, r, d, L, s, n, c1, c2, c3, ca)
implicit none
character(*), intent(out) :: unit
character(*), intent(in) :: fmt
integer, intent(in), optional:: i(:), n(:)
real, intent(in), optional:: r(:)
double precision, intent(in), optional:: d(:)
logical, intent(in), optional:: L(:)
type(VSTRING), intent(in), optional:: s(:)
character(*), intent(in), optional:: c1, c2, c3
character(*), intent(in), optional:: ca(:)
! 上記配列引数のカウンタ
integer:: ni, nr, nd, nl, ns, nc, na, nn
integer:: ucur ! unit に書かれた文字数
integer:: endp ! 既に処理された fmt の文字数
integer:: cur ! 現在着目中の文字は fmt(cur:cur) である
integer:: ptr ! fmt から検索をするときに使用
integer:: repeat ! %数字 または %* から決定された繰返し数
integer:: m ! 1:repeat の範囲で動くループ変数
integer:: stat ! エラー処理
character(80):: cbuf ! read/write 文のバッファ
continue
ni = 0
nr = 0
nd = 0
nl = 0
ns = 0
nc = 0
na = 0
nn = 0
unit = ""
ucur = 0
endp = 0
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
else if (cbuf == '') then
repeat = 1
else
ptr = verify(cbuf, " 0123456789")
if (ptr > 0) cbuf(ptr: ) = " "
read(cbuf, "(I80)", iostat=ptr) repeat
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(cbuf, "(i20)") i(ni)
call append(unit, ucur, trim(adjustl(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, "(g80.40)") d(nd)
cbuf = adjustl(cbuf)
ptr = verify(cbuf, " 0", back=.TRUE.)
if (ptr > 0) cbuf(ptr+1: ) = " "
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, "(g80.40)") r(nr)
cbuf = adjustl(cbuf)
ptr = verify(cbuf, " 0", back=.TRUE.)
if (ptr > 0) cbuf(ptr+1: ) = " "
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('s', 'S')
if (.not. present(S)) cycle MainLoop
ns = ns + 1
if (ns > size(S)) cycle MainLoop
call append(unit, ucur, s(ns)%body(1: s(ns)%len), stat)
if (stat /= 0) exit MainLoop
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
!
! unit に val を付加。その際、unit がその最大文字列長を越えた場合
! には stat = 2 を返す。
!
subroutine append(unit, ucur, val, stat)
character(*), intent(inout):: unit ! 最終的に返される文字列
integer, intent(inout):: ucur ! unit の文字数
character(*), intent(in) :: val ! unit に付加される文字列
integer, intent(out) :: stat ! ステータス
integer :: wrsz ! val の文字列
continue
! unit の最大長を越えた場合には stat = 2 を返す。
if (ucur >= len(unit)) then
stat = 2
! 正常時の処理
else
! unit の長さを越えた場合も考慮して unit に val を付加する。
wrsz = min(len(val), len(unit) - ucur)
unit(1+ucur: wrsz+ucur) = val(1: wrsz)
ucur = ucur + wrsz
stat = 0
if (wrsz < len(val)) stat = 1
endif
end subroutine