! C の sprintf(3) とは大分違うので注意。 ! subroutine DCStringSPrintf(unit, fmt, i, r, d, L, s, n, c1, c2, c3) use dcstring_base, only: VSTRING, assignment(=) 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 ! 上記配列引数のカウンタ integer:: ni, nr, nd, nl, ns, nc, 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; 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: ), 'DdOoXxFfRrBbYySsCc%') 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('%') 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 end subroutine