diff --git a/doc/specs/stdlib_io.md b/doc/specs/stdlib_io.md
index 40cb2b426..6fd7d2838 100644
--- a/doc/specs/stdlib_io.md
+++ b/doc/specs/stdlib_io.md
@@ -131,3 +131,126 @@ program demo_savetxt
call savetxt('example.dat', x)
end program demo_savetxt
```
+
+## `disp` - display the value of the variable
+
+### Status
+
+Experimental
+
+### Class
+
+Impure subroutine.
+
+### Description
+
+Outputs a `logical/integer/real/complex/character/string_type` scalar,
+or `logical/integer/real/complex/string_type` and rank-1/rank-2 array to the screen or a file `unit`.
+
+### Syntax
+
+`call [[stdlib_io(module):disp(interface)]]( [x, header, unit, brief, format, width, sep] )`
+
+### Arguments
+
+- `x`: Shall be a `logical/integer/real/complex/character(len=*)/string_type` scalar or `logical/integer/real/complex/string_type` and rank-1/rank-2 array.
+This argument is `intent(in)` and `optional`.
+
+- `header`: Shall be a `character(len=*)` scalar.
+This argument is `intent(in)` and `optional`.
+
+- `unit`: Shall be an `integer` scalar, linked to an IO stream.
+This argument is `intent(in)` and `optional`.
+The default value is `output_unit` from `iso_fortran_env` module.
+
+- `brief`: Shall be a `logical` scalar, controls an abridged version of the `x` array to be outputted.
+This argument is `intent(in)` and `optional`.
+The default value is `.false.`
+
+- `format`: Shall be a `character(len=*)` scalar.
+This argument is `intent(in)` and `optional`.
+The default value is `g0.4`.
+
+- `width`: Shall be an `integer` scalar, controls the outputted maximum width (`>=80`).
+This argument is `intent(in)` and `optional`.
+The default value is `80`.
+
+- `sep`: Shall be a `character(len=*)` scalar, separator.
+This argument is `intent(in)` and `optional`.
+The default value is " ", two spaces.
+
+### Output
+
+The result is to print `header` and `x` on the screen (or another output `unit/file`) in this order.
+If `disp` is not passed any arguments, a blank line will be printed.
+
+### Example
+
+```fortran
+program test_io_disp
+
+ use stdlib_io, only: disp
+
+ real :: r(2, 3)
+ complex :: c(2, 3), c_3d(2, 100, 20)
+ integer :: i(2, 3)
+ logical :: l(10, 10)
+
+ r = 1.; c = 1.; c_3d = 2.; i = 1; l = .true.
+ c_3d(1,3,1) = (1000, 0.001)
+
+ call disp('string', header='disp(string):')
+ call disp('It is a note.')
+ call disp()
+ call disp(r, header='disp(r):')
+ call disp(r(1,:), header='disp(r(1,:))', format="f6.2")
+ call disp(c, header='disp(c):')
+ call disp(i, header='disp(i):', sep=",")
+ call disp(l, header='disp(l):', brief=.true.)
+ call disp(c_3d(:,3,1:10), header='disp(c_3d(:,3,1:10)):', width=100)
+ call disp(c_3d(2,:,:), header='disp(c_3d(2,:,:)):', brief=.true.)
+
+end program test_io_disp
+```
+**Results:**
+```fortran
+disp(string):
+string
+It is a note.
+
+disp(r):
+[matrix size: 2×3]
+1.000 1.000 1.000
+1.000 1.000 1.000
+disp(r(1,:))
+[vector size: 3]
+ 1.00 1.00 1.00
+disp(c):
+[matrix size: 2×3]
+(1.000,0.000) (1.000,0.000) (1.000,0.000)
+(1.000,0.000) (1.000,0.000) (1.000,0.000)
+disp(i):
+[matrix size: 2×3]
+1, 1, 1,
+1, 1, 1,
+disp(l):
+[matrix size: 10×10]
+T T T .. T
+T T T .. T
+T T T .. T
+: : : : :
+T T T .. T
+disp(c_3d(:,3,1:10)):
+[matrix size: 2×10]
+(1000.,0.1000E-2) (2.000,0.000) (2.000,0.000) (2.000,0.000) (2.000,0.000) &
+(2.000,0.000) (2.000,0.000) (2.000,0.000) (2.000,0.000) (2.000,0.000)
+(2.000,0.000) (2.000,0.000) (2.000,0.000) (2.000,0.000) (2.000,0.000) &
+(2.000,0.000) (2.000,0.000) (2.000,0.000) (2.000,0.000) (2.000,0.000)
+disp(c_3d(2,:,:)):
+[matrix size: 100×20]
+(2.000,0.000) (2.000,0.000) (2.000,0.000) .. (2.000,0.000)
+(2.000,0.000) (2.000,0.000) (2.000,0.000) .. (2.000,0.000)
+(2.000,0.000) (2.000,0.000) (2.000,0.000) .. (2.000,0.000)
+: : : : :
+(2.000,0.000) (2.000,0.000) (2.000,0.000) .. (2.000,0.000)
+```
\ No newline at end of file
diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt
index bb9fb4fd8..14c5355de 100644
--- a/src/CMakeLists.txt
+++ b/src/CMakeLists.txt
@@ -7,6 +7,7 @@ set(fppFiles
stdlib_bitsets_64.fypp
stdlib_bitsets_large.fypp
stdlib_io.fypp
+ stdlib_io_disp.fypp
stdlib_linalg.fypp
stdlib_linalg_diag.fypp
stdlib_linalg_outer_product.fypp
diff --git a/src/Makefile.manual b/src/Makefile.manual
index 179fc600f..86be46118 100644
--- a/src/Makefile.manual
+++ b/src/Makefile.manual
@@ -4,6 +4,7 @@ SRCFYPP = \
stdlib_bitsets_large.fypp \
stdlib_bitsets.fypp \
stdlib_io.fypp \
+ stdlib_io_disp.fypp \
stdlib_linalg.fypp \
stdlib_linalg_diag.fypp \
stdlib_linalg_outer_product.fypp \
@@ -29,8 +30,8 @@ SRCFYPP = \
stdlib_stats_distribution_uniform.fypp \
stdlib_stats_var.fypp \
stdlib_math.fypp \
- stdlib_math_linspace.fypp \
- stdlib_math_logspace.fypp \
+ stdlib_math_linspace.fypp \
+ stdlib_math_logspace.fypp \
stdlib_string_type.fypp \
stdlib_string_type_constructor.fypp \
stdlib_strings.fypp \
@@ -86,7 +87,12 @@ stdlib_io.o: \
stdlib_error.o \
stdlib_optval.o \
stdlib_kinds.o \
- stdlib_ascii.o
+ stdlib_ascii.o \
+ stdlib_string_type.o
+stdlib_io_disp.o: \
+ stdlib_strings.o \
+ stdlib_string_type.o \
+ stdlib_io.o
stdlib_linalg.o: \
stdlib_kinds.o
stdlib_linalg_diag.o: \
diff --git a/src/stdlib_io.fypp b/src/stdlib_io.fypp
index e451b7c4d..cd7b3cbed 100644
--- a/src/stdlib_io.fypp
+++ b/src/stdlib_io.fypp
@@ -7,14 +7,15 @@ module stdlib_io
!! ([Specification](../page/specs/stdlib_io.html))
use stdlib_kinds, only: sp, dp, qp, &
- int8, int16, int32, int64
+ int8, int16, int32, int64, lk, c_bool
use stdlib_error, only: error_stop
use stdlib_optval, only: optval
use stdlib_ascii, only: is_blank
+ use stdlib_string_type, only: string_type
implicit none
private
! Public API
- public :: loadtxt, savetxt, open
+ public :: loadtxt, savetxt, open, disp
! Private API that is exposed so that we can test it in tests
public :: parse_mode
@@ -28,6 +29,36 @@ module stdlib_io
FMT_COMPLEX_SP = '(*(es15.8e2,1x,es15.8e2))', &
FMT_COMPLEX_DP = '(*(es24.16e3,1x,es24.16e3))', &
FMT_COMPLEX_QP = '(*(es44.35e4,1x,es44.35e4))'
+
+ !> version: experimental
+ !>
+ !> Display a scalar, vector or matrix formatted.
+ !> ([Specification](../page/specs/stdlib_io.html#display-the-value-of-the-variable))
+ interface disp
+ #:set ALL_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES + INT_KINDS_TYPES + LOG_KINDS_TYPES + STRING_KINDS_TYPES
+ module subroutine disp_char(x, header, unit, brief, format, width, sep)
+ character(*), intent(in), optional :: x
+ character(len=*), intent(in), optional :: header
+ integer, intent(in), optional :: unit
+ logical, intent(in), optional :: brief
+ character(len=*), intent(in), optional :: format
+ integer, intent(in), optional :: width
+ character(len=*), intent(in), optional :: sep
+ end subroutine disp_char
+ #:for r1 in range(0, 3)
+ #:for k1, t1 in ALL_KINDS_TYPES
+ module subroutine disp_${r1}$_${t1[0]}$${k1}$(x, header, unit, brief, format, width, sep)
+ ${t1}$, intent(in) :: x${ranksuffix(r1)}$
+ character(len=*), intent(in), optional :: header
+ integer, intent(in), optional :: unit
+ logical, intent(in), optional :: brief
+ character(len=*), intent(in), optional :: format
+ integer, intent(in), optional :: width
+ character(len=*), intent(in), optional :: sep
+ end subroutine disp_${r1}$_${t1[0]}$${k1}$
+ #:endfor
+ #:endfor
+ end interface disp
interface loadtxt
!! version: experimental
diff --git a/src/stdlib_io_disp.fypp b/src/stdlib_io_disp.fypp
new file mode 100644
index 000000000..70193e451
--- /dev/null
+++ b/src/stdlib_io_disp.fypp
@@ -0,0 +1,308 @@
+#:include "common.fypp"
+#:set ALL_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES + INT_KINDS_TYPES + LOG_KINDS_TYPES + STRING_KINDS_TYPES
+
+submodule (stdlib_io) stdlib_io_disp
+
+ use, intrinsic :: iso_fortran_env, only: output_unit
+ use stdlib_string_type, only: char, len
+ use stdlib_strings, only: to_string
+ implicit none
+
+contains
+
+#! | string | data elem 1 | unknown width | sep | string | line 1 | defined width |
+#! Any type data -> | string | data elem 2 | unknown width | --> | string | line 2 | defined width | -> sequncetial output
+#! | ... | ... | ... | add | ... | ... | ... |
+
+ #! REAL, COMPLEX, INTEGER, LOGICAL, STRING_TYPE
+ #:for r1 in range(0, 3)
+ #:for k1, t1 in ALL_KINDS_TYPES
+ module subroutine disp_${r1}$_${t1[0]}$${k1}$(x, header, unit, brief, format, width, sep)
+
+ ${t1}$, intent(in) :: x${ranksuffix(r1)}$
+ character(len=*), intent(in), optional :: header
+ integer, intent(in), optional :: unit
+ logical, intent(in), optional :: brief
+ character(len=*), intent(in), optional :: format
+ integer, intent(in), optional :: width
+ character(len=*), intent(in), optional :: sep
+
+ integer :: unit_, width_#{if r1 == 2}#, max_elem_len#{endif}#
+ logical :: brief_
+ character(len=:), allocatable :: format_, sep_
+ #{if r1 != 0 and not(r1 == 1 and k1 == "string_type")}#integer :: i#{endif}#
+ #{if r1 == 2 and k1 != "string_type"}#integer :: j#{endif}#
+ #{if k1 != "string_type"}#type(string_type), allocatable :: x_str${ranksuffix(r1)}$#{endif}#
+ #{if r1 != 0}#type(string_type) :: array_info#{endif}#
+
+ #! State default values
+ unit_ = optval(unit, output_unit)
+ brief_ = optval(brief, .false.)
+ format_ = optval(format, "g0.4")
+
+ #! width have to be greater than or equal 80 by default
+ width_ = optval(width, 80)
+ width_ = merge(width_, 80, width_ > 80)
+
+ sep_ = optval(sep, " ")
+
+ #! Prints header
+ if (present(header)) then
+ write(unit_, "(A)") format_output_string([string_type(header)], width_, brief_, "", len(header))
+ end if
+
+ #:if k1 != "string_type"
+
+ #:if r1 == 0
+ allocate(x_str)
+ x_str = string_type(to_string(x, format_))
+ write(unit_, "(A)") format_output_string([x_str], width_, brief_, sep_, len(x_str))
+
+ #:elif r1 == 1
+ array_info = array_info_maker(size(x, 1))
+ write(unit_, "(A)") format_output_string([array_info], width_, brief_, "", len(array_info))
+
+ allocate(x_str(size(x, 1)))
+ do i = 1, size(x, 1)
+ x_str(i) = string_type(to_string(x(i), format_))
+ end do
+ write(unit_, "(*(A))") format_output_string(x_str, width_, brief_, sep_, maxval(len(x_str)))
+
+ #:elif r1 == 2
+
+ array_info = array_info_maker(size(x, 1), size(x, 2))
+ write(unit_, "(A)") format_output_string([array_info], width_, brief_, "", len(array_info))
+
+ allocate(x_str(size(x, 1), size(x, 2)))
+ do i = 1, size(x, 1)
+ do j = 1, size(x, 2)
+ x_str(i, j) = string_type(to_string(x(i, j), format_))
+ end do
+ end do
+
+ max_elem_len = maxval(len(x_str))
+
+ #! Brief mode of rank-2 array
+ if (brief_.and.size(x, 1)>5) then
+ do i = 1, 3
+ write(unit_, "(*(A))") format_output_string(x_str(i, :), width_, brief_, sep_, max_elem_len)
+ end do
+
+ write(unit_, "(*(A))") format_output_string( &
+ string_type(spread(":", 1, merge(size(x, 2), 5, size(x, 2) < 5))), &
+ width_, brief_, sep_, max_elem_len)
+ write(unit_, "(*(A))") format_output_string(x_str(size(x, 1), :), width_, brief_, sep_, max_elem_len)
+
+ else
+ do i = 1, size(x, 1)
+ write(unit_, "(*(A))") format_output_string(x_str(i, :), width_, brief_, sep_, max_elem_len)
+ end do
+ end if
+
+ #:endif
+
+ #:elif k1 == "string_type"
+
+ #:if r1 == 0
+ write(unit_, "(A)") format_output_string([x], width_, brief_, sep_, len(x))
+
+ #:elif r1 == 1
+ array_info = array_info_maker(size(x, 1))
+ write(unit_, "(A)") format_output_string([array_info], width_, brief_, "", len(array_info))
+
+ write(unit_, "(*(A))") format_output_string(x, width_, brief_, sep_, maxval(len(x)))
+
+ #:elif r1 == 2
+
+ array_info = array_info_maker(size(x, 1), size(x, 2))
+ write(unit_, "(A)") format_output_string([array_info], width_, brief_, "", len(array_info))
+
+ max_elem_len = maxval(len(x))
+
+ #! Brief mode of rank-2 array
+ if (brief_.and.size(x, 1)>5) then
+ do i = 1, 3
+ write(unit_, "(*(A))") format_output_string(x(i, :), width_, brief_, sep_, max_elem_len)
+ end do
+
+ write(unit_, "(*(A))") format_output_string( &
+ string_type(spread(":", 1, merge(size(x, 2), 5, size(x, 2) < 5))), &
+ width_, brief_, sep_, max_elem_len)
+ write(unit_, "(*(A))") format_output_string(x(size(x, 1), :), width_, brief_, sep_, max_elem_len)
+
+ else
+ do i = 1, size(x, 1)
+ write(unit_, "(*(A))") format_output_string(x(i, :), width_, brief_, sep_, max_elem_len)
+ end do
+ end if
+
+ #:endif
+
+ #:endif
+
+ end subroutine disp_${r1}$_${t1[0]}$${k1}$
+ #:endfor
+ #:endfor
+
+ !> Format output string
+ pure function format_output_string(x, width, brief, sep, max_elem_len) result(str)
+
+ type(string_type), intent(in) :: x(:)
+ integer, intent(in) :: width
+ logical, intent(in) :: brief
+ character(len=*), intent(in) :: sep
+
+ #! Maxium elementaral string length.
+ integer, intent(in) :: max_elem_len
+
+ #! Output string: brief, ingore width.
+ character(merge((max(max_elem_len, 2)+len(sep))*min(size(x, 1), 5), width, brief)+2), allocatable :: str(:)
+
+ character(:), allocatable :: buffer
+
+ #! Elementaral string length
+ character(max(max_elem_len, 2)+len(sep)) :: elem_buffer
+ integer :: elem_len, num1, num2, i, j
+
+ #! Make brief buffer
+ if (brief) then
+
+ allocate(str(1))
+ buffer = ""
+
+ if (size(x, 1) <= 5) then
+
+ do i = 1, size(x, 1)
+ elem_buffer = char(x(i))//sep
+ buffer = buffer//elem_buffer
+ end do
+
+ else
+
+ do i = 1, 3
+ elem_buffer = char(x(i))//sep
+ buffer = buffer//elem_buffer
+ end do
+
+ elem_buffer = ".."//sep
+ buffer = buffer//elem_buffer
+
+ elem_buffer = char(x(size(x, 1)))//sep
+ buffer = buffer//elem_buffer
+
+ end if
+
+ str(1) = buffer
+
+ #! Make full buffer
+ else
+
+ elem_len = len(elem_buffer)
+
+ #! Elementaral string length > Print width
+ num1 = merge(width/elem_len, 1, elem_len <= width)
+ num2 = size(x, 1)/num1
+
+ if (num2 > 1 .or. size(x, 1) > 1) then
+ allocate(str(merge(num2, num2 + 1, mod(size(x, 1), num1)==0)))
+
+ do i = 1, size(str) - 1
+
+ buffer = ""
+ do j = 1, num1
+ elem_buffer = char(x((i-1)*num1+j))//sep
+ buffer = buffer//elem_buffer
+ end do
+
+ #! Overlength elementaral string adjustment
+ if ( len(x((i-1)*num1+j-1)) > width-len(sep)-1 ) then
+ buffer(width-len(sep)-1:) = "**"//repeat(" ", len(sep))
+ end if
+
+ str(i) = buffer
+
+ #! Set continuation flags and line breaks
+ str(i)(width+1:) = "&"//new_line("")
+
+ end do
+
+ buffer = ""
+ do j = 1, merge(num1, mod(size(x, 1), num1), mod(size(x, 1), num1)==0)
+ elem_buffer = char(x((i-1)*num1+j))//sep
+ buffer = buffer//elem_buffer
+ end do
+
+ #! Overlength elementaral string adjustment
+ if ( len(x((i-1)*num1+j-1)) > width-len(sep)-1 ) then
+ buffer(width-len(sep)-1:) = "**"//repeat(" ", len(sep))
+ end if
+
+ str(i) = buffer
+
+ else
+
+ allocate(str(1))
+ buffer = ""
+ do j = 1, size(x, 1)
+ elem_buffer = char(x(j))//sep
+ buffer = buffer//elem_buffer
+ end do
+
+ #! Overlength elementaral string adjustment
+ if ( len(x(j-1)) > width-len(sep)-1 ) then
+ buffer(width-len(sep)-1:) = "**"//repeat(" ", len(sep))
+ end if
+
+ str(1) = buffer
+
+ end if
+
+ end if
+
+ end function format_output_string
+
+ !> Print array information
+ pure type(string_type) function array_info_maker(m, n) result(info)
+ integer, intent(in) :: m
+ integer, intent(in), optional :: n
+
+ if (present(n)) then
+ info = string_type('[matrix size: ' // to_string(m) // '×' // to_string(n) // ']')
+ else
+ info = string_type('[vector size: ' // to_string(m) // ']')
+ end if
+
+ end function array_info_maker
+
+ !> Display `character(*)` value.
+ module subroutine disp_char(x, header, unit, brief, format, width, sep)
+
+ character(*), intent(in), optional :: x
+ character(len=*), intent(in), optional :: header
+ integer, intent(in), optional :: unit
+ logical, intent(in), optional :: brief
+ character(len=*), intent(in), optional :: format
+ integer, intent(in), optional :: width
+ character(len=*), intent(in), optional :: sep
+
+ integer :: unit_, width_
+ logical :: brief_
+ character(len=:), allocatable :: x_, sep_
+
+ !> State default values
+ x_ = optval(x, "")
+ unit_ = optval(unit, output_unit)
+ brief_ = optval(brief, .false.)
+ width_ = optval(width, 80)
+ width_ = merge(width_, 80, width_ > 80)
+ sep_ = optval(sep, " ")
+
+ if (present(header)) then
+ write(unit_, "(A)") format_output_string([string_type(header)], width_, brief_, "", len(header))
+ end if
+
+ write(unit_, "(A)") format_output_string([string_type(x_)], width_, brief_, sep_, len(x_))
+
+ end subroutine disp_char
+
+end submodule stdlib_io_disp
\ No newline at end of file
diff --git a/src/tests/io/CMakeLists.txt b/src/tests/io/CMakeLists.txt
index 68388a5e5..8963859e5 100644
--- a/src/tests/io/CMakeLists.txt
+++ b/src/tests/io/CMakeLists.txt
@@ -8,3 +8,4 @@ set_tests_properties(savetxt_qp PROPERTIES LABELS quadruple_precision)
ADDTEST(open)
ADDTEST(parse_mode)
+ADDTEST(disp)
diff --git a/src/tests/io/Makefile.manual b/src/tests/io/Makefile.manual
index c50a735aa..a076a6958 100644
--- a/src/tests/io/Makefile.manual
+++ b/src/tests/io/Makefile.manual
@@ -1,4 +1,4 @@
-PROGS_SRC = test_loadtxt.f90 \
+PROGS_SRC = test_disp.f90 \
test_savetxt.f90 \
test_loadtxt_qp.f90 \
test_savetxt_qp.f90 \
diff --git a/src/tests/io/test_disp.f90 b/src/tests/io/test_disp.f90
new file mode 100644
index 000000000..12e626ff3
--- /dev/null
+++ b/src/tests/io/test_disp.f90
@@ -0,0 +1,434 @@
+module test_io_disp
+
+ use stdlib_strings, only: starts_with
+ use stdlib_string_type, only: string_type, assignment(=)
+ use stdlib_error, only: check
+ use stdlib_io, only: disp
+ use stdlib_optval, only: optval
+ implicit none
+
+ integer :: unit
+ character(len=200) :: string
+
+contains
+
+ subroutine check_formatter(actual, expected, description, partial)
+ character(len=*), intent(in) :: actual, expected, description
+ logical, intent(in), optional :: partial
+ logical :: stat
+ character(len=:), allocatable :: msg
+
+ if (optval(partial, .false.)) then
+ stat = starts_with(actual, expected)
+ else
+ stat = actual == expected
+ end if
+
+ if (.not. stat) then
+ msg = description//new_line("a")// &
+ & "Expected: '"//expected//"' but got '"//actual//"'"
+ else
+ print '(" - ", a, /, " Result: ''", a, "''")', description, actual
+ end if
+
+ call check(stat, msg)
+
+ end subroutine check_formatter
+
+ subroutine test_io_disp_complex
+ complex :: c(6, 6) = (1.0, 1.0)
+
+ open (newunit=unit, status='scratch')
+ call disp(c(1, 1), header='Test_io_disp_complex_scalar (brief) : ', brief=.true.)
+ call disp(c(1, 1), unit=unit, header='Test_io_disp_complex_scalar (brief) : ', brief=.true.)
+
+ call disp(c(1, :), header='Test_io_disp_complex_vector (brief) : ', brief=.true.)
+ call disp(c(1, :), unit=unit, header='Test_io_disp_complex_vector (brief) : ', brief=.true.)
+
+ call disp(c(:, 1), header='Test_io_disp_complex_vector : ', brief=.false.)
+ call disp(c(:, 1), unit=unit, header='Test_io_disp_complex_vector : ', brief=.false.)
+
+ call disp(c(1:2, 1:2), header='Test_io_disp_complex_matrix : ', brief=.false.)
+ call disp(c(1:2, 1:2), unit=unit, header='Test_io_disp_complex_matrix : ', brief=.false.)
+
+ call disp(c(:, :), header='Test_io_disp_complex_matrix (brief) : ', brief=.true.)
+ call disp(c(:, :), unit=unit, header='Test_io_disp_complex_matrix (brief) : ', brief=.true.)
+
+ !! Checks
+ rewind (unit)
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), 'Test_io_disp_complex_scalar (brief) :', 'Header')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), '(1.000,1.000)', 'Value')
+
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), 'Test_io_disp_complex_vector (brief) :', 'Header')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), '[vector size: 6]', 'Vector Info')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), &
+ '(1.000,1.000) (1.000,1.000) (1.000,1.000) .. (1.000,1.000)', "Test_io_disp_complex_vector (brief)")
+
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), 'Test_io_disp_complex_vector :', 'Header')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), '[vector size: 6]', 'Vector Info')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), &
+ '(1.000,1.000) (1.000,1.000) (1.000,1.000) (1.000,1.000) (1.000,1.000) &', 'Vector')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), '(1.000,1.000)', 'Vector')
+
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), 'Test_io_disp_complex_matrix :', 'Header')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), '[matrix size: 2×2]', 'Matrix Info')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), &
+ '(1.000,1.000) (1.000,1.000)', 'Matrix Vector 1')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), &
+ '(1.000,1.000) (1.000,1.000)', 'Matrix Vector 2')
+
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), 'Test_io_disp_complex_matrix (brief) :', 'Header')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), '[matrix size: 6×6]', 'Matrix Info')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), &
+ '(1.000,1.000) (1.000,1.000) (1.000,1.000) .. (1.000,1.000)', 'Matrix Vector 1')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), &
+ '(1.000,1.000) (1.000,1.000) (1.000,1.000) .. (1.000,1.000)', 'Matrix Vector 2')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), &
+ '(1.000,1.000) (1.000,1.000) (1.000,1.000) .. (1.000,1.000)', 'Matrix Vector 3')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), &
+ ': : : : :', 'Matrix Vector ..')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), &
+ '(1.000,1.000) (1.000,1.000) (1.000,1.000) .. (1.000,1.000)', 'Matrix Vector Size(Matrix, 1)')
+ close (unit)
+
+ end subroutine test_io_disp_complex
+
+ subroutine test_io_disp_real
+
+ real :: r(6, 6) = 1.0
+
+ open (newunit=unit, status='scratch')
+ call disp(r(1, 1), header='Test_io_disp_real_scalar (brief) : ', brief=.true.)
+ call disp(r(1, 1), unit=unit, header='Test_io_disp_real_scalar (brief) : ', brief=.true.)
+
+ call disp(r(1, :), header='Test_io_disp_real_vector (brief) : ', brief=.true.)
+ call disp(r(1, :), unit=unit, header='Test_io_disp_real_vector (brief) : ', brief=.true.)
+
+ call disp(r(:, 1), header='Test_io_disp_real_vector : ', brief=.false.)
+ call disp(r(:, 1), unit=unit, header='Test_io_disp_real_vector : ', brief=.false.)
+
+ call disp(r(1:2, 1:2), header='Test_io_disp_real_matrix : ', brief=.false.)
+ call disp(r(1:2, 1:2), unit=unit, header='Test_io_disp_real_matrix : ', brief=.false.)
+
+ call disp(r(:, :), header='Test_io_disp_real_matrix (brief) : ', brief=.true.)
+ call disp(r(:, :), unit=unit, header='Test_io_disp_real_matrix (brief) : ', brief=.true.)
+
+ !! Checks
+ rewind (unit)
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), 'Test_io_disp_real_scalar (brief) :', 'Header')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), '1.000', 'Value')
+
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), 'Test_io_disp_real_vector (brief) :', 'Header')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), '[vector size: 6]', 'Vector Info')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), &
+ '1.000 1.000 1.000 .. 1.000', 'Brief Vector')
+
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), 'Test_io_disp_real_vector :', 'Header')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), '[vector size: 6]', 'Vector Info')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), &
+ '1.000 1.000 1.000 1.000 1.000 1.000', 'Brief Vector')
+
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), 'Test_io_disp_real_matrix :', 'Header')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), '[matrix size: 2×2]', 'Matrix Info')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), &
+ '1.000 1.000', 'Matrix Vector 1')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), &
+ '1.000 1.000', 'Matrix Vector 2')
+
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), 'Test_io_disp_real_matrix (brief) :', 'Header')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), '[matrix size: 6×6]', 'Matrix Info')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), &
+ '1.000 1.000 1.000 .. 1.000', 'Matrix Vector 1')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), &
+ '1.000 1.000 1.000 .. 1.000', 'Matrix Vector 2')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), &
+ '1.000 1.000 1.000 .. 1.000', 'Matrix Vector 3')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), &
+ ': : : : :', 'Matrix Vector ..')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), &
+ '1.000 1.000 1.000 .. 1.000', 'Matrix Vector Size(Matrix, 1)')
+ close (unit)
+
+ end subroutine test_io_disp_real
+
+ subroutine test_io_disp_integer
+
+ integer :: i(6, 6) = 1
+
+ open (newunit=unit, status='scratch')
+ call disp(i(1, 1), header='Test_io_disp_integer_scalar (brief) : ', brief=.true.)
+ call disp(i(1, 1), unit=unit, header='Test_io_disp_integer_scalar (brief) : ', brief=.true.)
+
+ call disp(i(1, :), header='Test_io_disp_integer_vector (brief) : ', brief=.true.)
+ call disp(i(1, :), unit=unit, header='Test_io_disp_integer_vector (brief) : ', brief=.true.)
+
+ call disp(i(:, 1), header='Test_io_disp_integer_vector : ', brief=.false.)
+ call disp(i(:, 1), unit=unit, header='Test_io_disp_integer_vector : ', brief=.false.)
+
+ call disp(i(1:2, 1:2), header='Test_io_disp_integer_matrix : ', brief=.false.)
+ call disp(i(1:2, 1:2), unit=unit, header='Test_io_disp_integer_matrix : ', brief=.false.)
+
+ call disp(i(:, :), header='Test_io_disp_integer_matrix (brief) : ', brief=.true.)
+ call disp(i(:, :), unit=unit, header='Test_io_disp_integer_matrix (brief) : ', brief=.true.)
+
+ !! Checks
+ rewind (unit)
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), 'Test_io_disp_integer_scalar (brief) :', 'Header')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), '1', 'Value')
+
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), 'Test_io_disp_integer_vector (brief) :', 'Header')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), '[vector size: 6]', 'Vector Info')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), &
+ '1 1 1 .. 1', 'Brief Vector')
+
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), 'Test_io_disp_integer_vector :', 'Header')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), '[vector size: 6]', 'Vector Info')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), &
+ '1 1 1 1 1 1', 'Brief Vector')
+
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), 'Test_io_disp_integer_matrix :', 'Header')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), '[matrix size: 2×2]', 'Matrix Info')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), &
+ '1 1', 'Matrix Vector 1')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), &
+ '1 1', 'Matrix Vector 2')
+
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), 'Test_io_disp_integer_matrix (brief) :', 'Header')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), '[matrix size: 6×6]', 'Matrix Info')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), &
+ '1 1 1 .. 1', 'Matrix Vector 1')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), &
+ '1 1 1 .. 1', 'Matrix Vector 2')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), &
+ '1 1 1 .. 1', 'Matrix Vector 3')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), &
+ ': : : : :', 'Matrix Vector ..')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), &
+ '1 1 1 .. 1', 'Matrix Vector Size(Matrix, 1)')
+ close (unit)
+
+ end subroutine test_io_disp_integer
+
+ subroutine test_io_disp_logical
+
+ logical :: l(6, 6) = .true.
+ ! unit = open(filenanme, 'w+t')
+ open (newunit=unit, status='scratch')
+ call disp(l(1, 1), header='Test_io_disp_logical_scalar (brief) : ', brief=.true.)
+ call disp(l(1, 1), unit=unit, header='Test_io_disp_logical_scalar (brief) : ', brief=.true.)
+
+ call disp(l(1, :), header='Test_io_disp_logical_vector (brief) : ', brief=.true.)
+ call disp(l(1, :), unit=unit, header='Test_io_disp_logical_vector (brief) : ', brief=.true.)
+
+ call disp(l(:, 1), header='Test_io_disp_logical_vector : ', brief=.false.)
+ call disp(l(:, 1), unit=unit, header='Test_io_disp_logical_vector : ', brief=.false.)
+
+ call disp(l(1:2, 1:2), header='Test_io_disp_logical_matrix : ', brief=.false.)
+ call disp(l(1:2, 1:2), unit=unit, header='Test_io_disp_logical_matrix : ', brief=.false.)
+
+ call disp(l(:, :), header='Test_io_disp_logical_matrix (brief) : ', brief=.true.)
+ call disp(l(:, :), unit=unit, header='Test_io_disp_logical_matrix (brief) : ', brief=.true.)
+
+ !! Checks
+ rewind (unit)
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), 'Test_io_disp_logical_scalar (brief) :', 'Header')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), 'T', 'Value')
+
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), 'Test_io_disp_logical_vector (brief) :', 'Header')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), '[vector size: 6]', 'Vector Info')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), &
+ 'T T T .. T', 'Brief Vector')
+
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), 'Test_io_disp_logical_vector :', 'Header')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), '[vector size: 6]', 'Vector Info')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), &
+ 'T T T T T T', 'Brief Vector')
+
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), 'Test_io_disp_logical_matrix :', 'Header')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), '[matrix size: 2×2]', 'Matrix Info')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), &
+ 'T T', 'Matrix Vector 1')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), &
+ 'T T', 'Matrix Vector 2')
+
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), 'Test_io_disp_logical_matrix (brief) :', 'Header')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), '[matrix size: 6×6]', 'Matrix Info')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), &
+ 'T T T .. T', 'Matrix Vector 1')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), &
+ 'T T T .. T', 'Matrix Vector 2')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), &
+ 'T T T .. T', 'Matrix Vector 3')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), &
+ ': : : : :', 'Matrix Vector ..')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), &
+ 'T T T .. T', 'Matrix Vector Size(Matrix, 1)')
+ close (unit)
+
+ end subroutine test_io_disp_logical
+
+ subroutine test_io_disp_character
+
+ character(*), parameter :: str = 'It is a character.'
+ ! unit = open(filenanme, 'w+t')
+ open (newunit=unit, status='scratch')
+ call disp(str, header='Test_io_disp_character_scalar (brief) : ', brief=.true.)
+ call disp(str, unit=unit, header='Test_io_disp_character_scalar (brief) : ', brief=.true.)
+
+ !! Checks
+ rewind (unit)
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), 'Test_io_disp_character_scalar (brief) :', 'Header')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), 'It is a character.', 'Value')
+ close (unit)
+
+ end subroutine test_io_disp_character
+
+ subroutine test_io_disp_string_type
+
+ type(string_type) :: str, s(6, 6)
+
+ str = 'It is a string_type.'
+ s = 'It is a string_type.'
+ open (newunit=unit, status='scratch')
+ call disp(str, header='Test_io_disp_string_type_scalar (brief) : ', brief=.true.)
+ call disp(str, unit=unit, header='Test_io_disp_string_type_scalar (brief) : ', brief=.true.)
+ call disp(s, header='Test_io_disp_string_type_array (brief) : ', brief=.true.)
+ call disp(s, unit=unit, header='Test_io_disp_string_type_array (brief) : ', brief=.true.)
+ call disp(s, header='Test_io_disp_string_type_array : ')
+ call disp(s, unit=unit, header='Test_io_disp_string_type_array : ')
+
+ !! Checks
+ rewind (unit)
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), 'Test_io_disp_string_type_scalar (brief) :', 'Header')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), 'It is a string_type.', 'Value')
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), 'Test_io_disp_string_type_array (brief) :', 'Header')
+ read (unit, *)
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), &
+ 'It is a string_type. It is a string_type. It is a string_type. .. It is a string_type.', &
+ 'Value')
+ read (unit, *)
+ read (unit, *)
+ read (unit, *)
+ read (unit, *)
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), 'Test_io_disp_string_type_array :', 'Header')
+ read (unit, *)
+ read (unit, '(A200)') string
+ call check_formatter(trim(adjustl(string)), &
+ 'It is a string_type. It is a string_type. It is a string_type. &', 'Value')
+ close (unit)
+
+ end subroutine test_io_disp_string_type
+
+ subroutine larger_matrix
+ real(4) :: x(51,51)
+ call disp(x, header="Test_io_disp_real_matrix (51×51)(default) : [10×50]")
+ call disp(x, header="Test_io_disp_real_matrix (51×51)(brief=.true.) : [5×5]", brief=.true.)
+ call disp(x, header="Test_io_disp_real_matrix (51×51)(brief=.false.) : [all]", brief=.false.)
+ end subroutine larger_matrix
+
+end module test_io_disp
+
+program tester
+
+ use test_io_disp
+ logical :: test_larger = .false.
+
+ call test_io_disp_complex
+ call test_io_disp_real
+ call test_io_disp_integer
+ call test_io_disp_logical
+ call test_io_disp_character
+ call test_io_disp_string_type
+
+ !> Content that is difficult to test: The length of the dimension is too large
+ !> to print and check by a test program.
+
+ if (test_larger) then
+ call larger_matrix
+ end if
+
+end program tester