diff --git a/doc/specs/stdlib_io.md b/doc/specs/stdlib_io.md index 46befe2ea..f6fb410cb 100644 --- a/doc/specs/stdlib_io.md +++ b/doc/specs/stdlib_io.md @@ -305,3 +305,38 @@ Exceptions trigger an `error stop` unless the optional `err` argument is provide {!example/io/example_get_file.f90!} ``` +## `print_array` - Print an array to an output unit + +### Status + +Experimental + +### Description + +This subroutine interface prints a 2D array to a specified output unit. + +### Syntax + +`call [[stdlib_io(module):print_array(subroutine)]] (array[, unit][, fmt][, delimiter][, brief])` + +### Class + +Subroutine + +### Arguments + +`array`: Shall be a 2D array of `integer`, `real`, or `complex` type. It is an `intent(in)` argument. + +`unit`: Shall be an integer containing the output unit. It is an `intent(in)` argument. The default is `6` (standard output). + +`fmt`: Shall be a character string containing the format for printing the array. It is an `intent(in)` argument. The default is based on [the Formatting constants](#formatting-constants). + +`delimiter`: Shall be a character string of length 1 containing the delimiter between array elements. It is an `intent(in)` argument. The default is a `" "` (space). + +`brief`: Shall be a logical flag. If `.true.`, the array is printed in a brief format. The default is `.true.`. + +### Example + +```fortran +{!./example/io/example_print_array.f90} +``` diff --git a/example/io/CMakeLists.txt b/example/io/CMakeLists.txt index db663f537..77535dd07 100644 --- a/example/io/CMakeLists.txt +++ b/example/io/CMakeLists.txt @@ -6,3 +6,4 @@ ADD_EXAMPLE(loadtxt) ADD_EXAMPLE(open) ADD_EXAMPLE(savenpy) ADD_EXAMPLE(savetxt) +ADD_EXAMPLE(print_array) diff --git a/example/io/example_print_array.f90 b/example/io/example_print_array.f90 new file mode 100644 index 000000000..1e53885a1 --- /dev/null +++ b/example/io/example_print_array.f90 @@ -0,0 +1,16 @@ +program example_io_print_array + + use stdlib_io, only: print_array + implicit none + + integer, dimension(6, 3) :: array = reshape([1, 2, 3, 4, 5, 6, & + 7, 8, 9, 10, 11, 12, & + 13, 14, 15, 16, 17, 18], [6, 3]) + + print "(a)", "=== print_array 1 ===" + call print_array(array, unit=6, fmt='(i3)', delimiter='|', brief=.true.) + + print "(a)", "=== print_array 2 ===" + call print_array(array(:1, :)) + +end program example_io_print_array diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index d82aae118..512ccd18b 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -24,6 +24,7 @@ set(fppFiles stdlib_io_npy.fypp stdlib_io_npy_load.fypp stdlib_io_npy_save.fypp + stdlib_io_print_array.fypp stdlib_kinds.fypp stdlib_linalg.fypp stdlib_linalg_diag.fypp diff --git a/src/stdlib_io.fypp b/src/stdlib_io.fypp index 6ba82ad12..4531039e5 100644 --- a/src/stdlib_io.fypp +++ b/src/stdlib_io.fypp @@ -16,7 +16,7 @@ module stdlib_io implicit none private ! Public API - public :: loadtxt, savetxt, open, get_line, get_file + public :: loadtxt, savetxt, open, get_line, get_file, print_array !! version: experimental !! @@ -102,6 +102,22 @@ module stdlib_io #:endfor end interface + interface print_array + !! version: experimental + !! + !! Prints a 2D array to an output unit + !! ([Specification](../page/specs/stdlib_io.html#print_array)) + #:for k1, t1 in KINDS_TYPES + module subroutine print_array_${t1[0]}$${k1}$(array, unit, fmt, delimiter, brief) + ${t1}$, intent(in) :: array(:, :) + integer, intent(in), optional :: unit + character(len=*), intent(in), optional :: fmt + character(len=1), intent(in), optional :: delimiter + logical, intent(in), optional :: brief + end subroutine print_array_${t1[0]}$${k1}$ + #:endfor + end interface + contains #:for k1, t1 in KINDS_TYPES diff --git a/src/stdlib_io_print_array.fypp b/src/stdlib_io_print_array.fypp new file mode 100644 index 000000000..9b714c213 --- /dev/null +++ b/src/stdlib_io_print_array.fypp @@ -0,0 +1,88 @@ +#:include "common.fypp" +#:set KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES + INT_KINDS_TYPES +submodule(stdlib_io) stdlib_io_print_array + + use, intrinsic :: iso_fortran_env, only: output_unit + implicit none + +contains + + #:for k1, t1 in KINDS_TYPES + module subroutine print_array_${t1[0]}$${k1}$(array, unit, fmt, delimiter, brief) + ${t1}$, intent(in) :: array(:, :) + integer, intent(in), optional :: unit + character(len=*), intent(in), optional :: fmt + character(len=1), intent(in), optional :: delimiter + logical, intent(in), optional :: brief + + integer :: i, j, unit_, shape_(2) + character(len=:), allocatable :: fmt_ + character(len=1) :: delimiter_ + character(len=3) :: delim_str + logical :: brief_ + + shape_ = shape(array) + if (any(shape_ == 0)) return + unit_ = optval(unit, output_unit) + delimiter_ = optval(delimiter, delimiter_default) + delim_str = "'"//delimiter_//"'" + brief_ = optval(brief, .true.) + if (present(fmt)) then + fmt_ = "(*"//fmt(1:len(fmt) - 1)//",:,"//delim_str//"))" + else + #:if 'real' in t1 + fmt_ = "(*"//FMT_REAL_${k1}$ (1:len(FMT_REAL_${k1}$) - 1)//",:,"//delim_str//"))" + #:elif 'complex' in t1 + fmt_ = "(*"//FMT_COMPLEX_${k1}$ (1:11)//delim_str//FMT_COMPLEX_${k1}$ (14:23)//",:,"//delim_str//"))" + #:elif 'integer' in t1 + fmt_ = "(*"//FMT_INT(1:len(FMT_INT) - 1)//",:,"//delim_str//"))" + #:endif + end if + + if (brief_) then + + if (shape_(1) > 5) then + if (shape_(2) > 5) then + do i = 1, 3 + write (unit_, fmt=fmt_, advance='no') array(i, :3) + write (unit_, fmt='(a)', advance='no') delimiter_//"..."//delimiter_ + write (unit_, fmt=fmt_) array(i, shape_(2)) + end do + write (unit_, fmt='(a)') ":" + write (unit_, fmt=fmt_, advance='no') array(shape_(1), :3) + write (unit_, fmt='(a)', advance='no') delimiter_//"..."//delimiter_ + write (unit_, fmt=fmt_) array(shape_(1), shape_(2)) + else + do i = 1, 3 + write (unit_, fmt=fmt_) array(i, :) + end do + write (unit_, fmt='(a)') ":" + write (unit_, fmt=fmt_) array(shape_(1), :) + + end if + else + if (shape_(2) > 5) then + do i = 1, shape_(1) + write (unit_, fmt=fmt_, advance='no') array(i, :3) + write (unit_, fmt='(a)', advance='no') delimiter_//"..."//delimiter_ + write (unit_, fmt=fmt_) array(i, shape_(2)) + end do + else + do i = 1, shape_(1) + write (unit_, fmt=fmt_) array(i, :) + end do + end if + end if + + else + + do i = 1, shape_(1) + write (unit_, fmt=fmt_) array(i, :) + end do + + end if + + end subroutine print_array_${t1[0]}$${k1}$ + #:endfor + +end submodule stdlib_io_print_array diff --git a/test/io/CMakeLists.txt b/test/io/CMakeLists.txt index 4e19b5fbe..ce46f4617 100644 --- a/test/io/CMakeLists.txt +++ b/test/io/CMakeLists.txt @@ -17,3 +17,4 @@ ADDTEST(get_line) ADDTEST(npy) ADDTEST(open) ADDTEST(parse_mode) +ADDTEST(print_array) diff --git a/test/io/test_print_array.f90 b/test/io/test_print_array.f90 new file mode 100644 index 000000000..30edad72c --- /dev/null +++ b/test/io/test_print_array.f90 @@ -0,0 +1,334 @@ +module test_print_array + + use stdlib_kinds, only: int8, int16, int32, int64, sp, dp + use testdrive, only: new_unittest, unittest_type, error_type, check + use stdlib_linalg, only: eye + use stdlib_io, only: print_array, get_line + implicit none + private + + public :: collect_print_array + +contains + + !> Collect all exported unit tests + subroutine collect_print_array(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest("print-rdp", test_print_rdp), & + new_unittest("print-rsp", test_print_rsp), & + new_unittest("print-cdp", test_print_cdp), & + new_unittest("print-csp", test_print_csp), & + new_unittest("print-i1", test_print_i1), & + new_unittest("print-i2", test_print_i2) & + ] + + end subroutine collect_print_array + + subroutine test_print_rdp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + real(dp) :: a(10, 10) + integer :: fh, i + character(256) :: line(10) + character(:), allocatable :: buffer + + a = eye(10) + open (newunit=fh, status='scratch') + + line(1) = " 1.0000000000000000E+000 0.0000000000000000E+000 0.0000000000000000E+000 ... 0.0000000000000000E+000" + line(2) = " 0.0000000000000000E+000 1.0000000000000000E+000 0.0000000000000000E+000 ... 0.0000000000000000E+000" + line(3) = " 0.0000000000000000E+000 0.0000000000000000E+000 1.0000000000000000E+000 ... 0.0000000000000000E+000" + line(4) = ":" + line(5) = " 0.0000000000000000E+000 0.0000000000000000E+000 0.0000000000000000E+000 ... 1.0000000000000000E+000" + call print_array(a, fh) + + rewind (fh) + do i = 1, 5 + call get_line(fh, buffer) + call check(error, buffer, trim(line(i))) + if (allocated(error)) return + end do + + rewind (fh) + line(1) = "1.00|0.00|0.00|0.00|0.00" + line(2) = "0.00|1.00|0.00|0.00|0.00" + line(3) = "0.00|0.00|1.00|0.00|0.00" + line(4) = "0.00|0.00|0.00|1.00|0.00" + line(5) = "0.00|0.00|0.00|0.00|1.00" + line(6:) = "0.00|0.00|0.00|0.00|0.00" + + call print_array(a(:, :5), fh, fmt="(f4.2)", brief=.false., delimiter="|") + + rewind (fh) + do i = 1, 10 + call get_line(fh, buffer) + call check(error, buffer, trim(line(i))) + if (allocated(error)) return + end do + + close (fh) + + end subroutine test_print_rdp + + subroutine test_print_rsp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + real(sp) :: a(10, 10) + integer :: fh, i + character(256) :: line(10) + character(:), allocatable :: buffer + + a = eye(10) + open (newunit=fh, status='scratch') + + line(1) = " 1.00000000E+00 0.00000000E+00 0.00000000E+00 ... 0.00000000E+00" + line(2) = " 0.00000000E+00 1.00000000E+00 0.00000000E+00 ... 0.00000000E+00" + line(3) = " 0.00000000E+00 0.00000000E+00 1.00000000E+00 ... 0.00000000E+00" + line(4) = ":" + line(5) = " 0.00000000E+00 0.00000000E+00 0.00000000E+00 ... 1.00000000E+00" + call print_array(a, fh) + + rewind (fh) + do i = 1, 5 + call get_line(fh, buffer) + call check(error, buffer, trim(line(i))) + if (allocated(error)) return + end do + + rewind (fh) + line(1) = "1.00|0.00|0.00|0.00|0.00" + line(2) = "0.00|1.00|0.00|0.00|0.00" + line(3) = "0.00|0.00|1.00|0.00|0.00" + line(4) = "0.00|0.00|0.00|1.00|0.00" + line(5) = "0.00|0.00|0.00|0.00|1.00" + line(6:) = "0.00|0.00|0.00|0.00|0.00" + call print_array(a(:, :5), fh, fmt="(f4.2)", brief=.false., delimiter="|") + + rewind (fh) + do i = 1, 10 + call get_line(fh, buffer) + call check(error, buffer, trim(line(i))) + if (allocated(error)) return + end do + + close (fh) + + end subroutine test_print_rsp + + subroutine test_print_i1(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer(int8) :: a(10, 10) + integer :: fh, i + character(256) :: line(10) + character(:), allocatable :: buffer + + a = eye(10) + open (newunit=fh, status='scratch') + + line(1) = "1 0 0 ... 0" + line(2) = "0 1 0 ... 0" + line(3) = "0 0 1 ... 0" + line(4) = ":" + line(5) = "0 0 0 ... 1" + call print_array(a, fh) + + rewind (fh) + do i = 1, 5 + call get_line(fh, buffer) + call check(error, buffer, trim(line(i))) + if (allocated(error)) return + end do + + rewind (fh) + line(1) = "01;00;00;00;00" + line(2) = "00;01;00;00;00" + line(3) = "00;00;01;00;00" + line(4) = "00;00;00;01;00" + line(5) = "00;00;00;00;01" + line(6:) = "00;00;00;00;00" + call print_array(a(:, :5), fh, fmt="(i0.2)", brief=.false., delimiter=";") + rewind (fh) + do i = 1, 10 + call get_line(fh, buffer) + call check(error, buffer, trim(line(i))) + if (allocated(error)) return + end do + + close (fh) + + end subroutine test_print_i1 + + subroutine test_print_i2(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer(int32) :: a(10, 10) + integer :: fh, i + character(256) :: line(10) + character(:), allocatable :: buffer + + a = eye(10) + open (newunit=fh, status='scratch') + + line(1) = "1 0 0 ... 0" + line(2) = "0 1 0 ... 0" + line(3) = "0 0 1 ... 0" + line(4) = ":" + line(5) = "0 0 0 ... 1" + + call print_array(a, fh) + rewind (fh) + do i = 1, 5 + call get_line(fh, buffer) + call check(error, buffer, trim(line(i))) + if (allocated(error)) return + end do + + rewind (fh) + line(1) = "01;00;00;00;00" + line(2) = "00;01;00;00;00" + line(3) = "00;00;01;00;00" + line(4) = "00;00;00;01;00" + line(5) = "00;00;00;00;01" + line(6:) = "00;00;00;00;00" + call print_array(a(:, :5), fh, fmt="(i0.2)", brief=.false., delimiter=";") + rewind (fh) + do i = 1, 10 + call get_line(fh, buffer) + call check(error, buffer, trim(line(i))) + if (allocated(error)) return + end do + + close (fh) + + end subroutine test_print_i2 + + subroutine test_print_cdp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + complex(dp) :: a(10, 10) + integer :: fh, i + character(256) :: line(10) + character(:), allocatable :: buffer + + a = eye(10) + open (newunit=fh, status='scratch') + + line(1) = " 1.0000000000000000E+000 0.0000000000000000E+000 0.0000000000000000E+000 0.0000000000000000E+000 & + &0.0000000000000000E+000 0.0000000000000000E+000 ... 0.0000000000000000E+000 0.0000000000000000E+000" + line(2) = " 0.0000000000000000E+000 0.0000000000000000E+000 1.0000000000000000E+000 0.0000000000000000E+000 & + &0.0000000000000000E+000 0.0000000000000000E+000 ... 0.0000000000000000E+000 0.0000000000000000E+000" + line(3) = " 0.0000000000000000E+000 0.0000000000000000E+000 0.0000000000000000E+000 0.0000000000000000E+000 & + &1.0000000000000000E+000 0.0000000000000000E+000 ... 0.0000000000000000E+000 0.0000000000000000E+000" + line(4) = ":" + line(5) = " 0.0000000000000000E+000 0.0000000000000000E+000 0.0000000000000000E+000 0.0000000000000000E+000 & + &0.0000000000000000E+000 0.0000000000000000E+000 ... 1.0000000000000000E+000 0.0000000000000000E+000" + + call print_array(a, fh) + rewind (fh) + do i = 1, 5 + call get_line(fh, buffer) + call check(error, buffer, trim(line(i))) + if (allocated(error)) return + end do + + rewind (fh) + line(1) = "1.00,0.00|0.00,0.00|0.00,0.00|0.00,0.00|0.00,0.00" + line(2) = "0.00,0.00|1.00,0.00|0.00,0.00|0.00,0.00|0.00,0.00" + line(3) = "0.00,0.00|0.00,0.00|1.00,0.00|0.00,0.00|0.00,0.00" + line(4) = "0.00,0.00|0.00,0.00|0.00,0.00|1.00,0.00|0.00,0.00" + line(5) = "0.00,0.00|0.00,0.00|0.00,0.00|0.00,0.00|1.00,0.00" + line(6:) = "0.00,0.00|0.00,0.00|0.00,0.00|0.00,0.00|0.00,0.00" + call print_array(a(:, :5), fh, fmt="(f4.2,"","",f4.2)", brief=.false., delimiter="|") + rewind (fh) + do i = 1, 10 + call get_line(fh, buffer) + call check(error, buffer, trim(line(i))) + if (allocated(error)) return + end do + + close (fh) + + end subroutine test_print_cdp + + subroutine test_print_csp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + complex(sp) :: a(10, 10) + integer :: fh, i + character(256) :: line(10) + character(:), allocatable :: buffer + + a = eye(10) + open (newunit=fh, status='scratch') + + line(1) = " 1.00000000E+00 0.00000000E+00 0.00000000E+00 0.00000000E+00 0.00000000E+00 0.00000000E+00 ... & + &0.00000000E+00 0.00000000E+00" + line(2) = " 0.00000000E+00 0.00000000E+00 1.00000000E+00 0.00000000E+00 0.00000000E+00 0.00000000E+00 ... & + &0.00000000E+00 0.00000000E+00" + line(3) = " 0.00000000E+00 0.00000000E+00 0.00000000E+00 0.00000000E+00 1.00000000E+00 0.00000000E+00 ... & + &0.00000000E+00 0.00000000E+00" + line(4) = ":" + line(5) = " 0.00000000E+00 0.00000000E+00 0.00000000E+00 0.00000000E+00 0.00000000E+00 0.00000000E+00 ... & + &1.00000000E+00 0.00000000E+00" + + call print_array(a, fh) + rewind (fh) + do i = 1, 5 + call get_line(fh, buffer) + call check(error, buffer, trim(line(i))) + if (allocated(error)) return + end do + + rewind (fh) + line(1) = " 1.00, 0.00; 0.00, 0.00; 0.00, 0.00; 0.00, 0.00; 0.00, 0.00" + line(2) = " 0.00, 0.00; 1.00, 0.00; 0.00, 0.00; 0.00, 0.00; 0.00, 0.00" + line(3) = " 0.00, 0.00; 0.00, 0.00; 1.00, 0.00; 0.00, 0.00; 0.00, 0.00" + line(4) = " 0.00, 0.00; 0.00, 0.00; 0.00, 0.00; 1.00, 0.00; 0.00, 0.00" + line(5) = " 0.00, 0.00; 0.00, 0.00; 0.00, 0.00; 0.00, 0.00; 1.00, 0.00" + line(6:) = " 0.00, 0.00; 0.00, 0.00; 0.00, 0.00; 0.00, 0.00; 0.00, 0.00" + call print_array(a(:, :5), fh, fmt="(1x,f4.2,"","",1x,f4.2)", brief=.false., delimiter=";") + rewind (fh) + do i = 1, 10 + call get_line(fh, buffer) + call check(error, buffer, trim(line(i))) + if (allocated(error)) return + end do + + close (fh) + + end subroutine test_print_csp + +end module test_print_array + +program tester + + use, intrinsic :: iso_fortran_env, only: error_unit + use testdrive, only: run_testsuite, new_testsuite, testsuite_type + use test_print_array, only: collect_print_array + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("print-array", collect_print_array) & + ] + + do is = 1, size(testsuites) + write (error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + + if (stat > 0) then + write (error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if + +end program tester +