diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 90bd8e1ed..8c9573caa 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -21,7 +21,6 @@ fypp_f90("${fyppFlags}" "${fppFiles}" outFiles) set(SRC stdlib_experimental_ascii.f90 - stdlib_experimental_io.f90 stdlib_experimental_error.f90 stdlib_experimental_kinds.f90 stdlib_experimental_optval.f90 diff --git a/src/common.fypp b/src/common.fypp index b0c716104..85d82704c 100644 --- a/src/common.fypp +++ b/src/common.fypp @@ -9,6 +9,14 @@ #! Collected (kind, type) tuples for real types #:set REAL_KINDS_TYPES = list(zip(REAL_KINDS, REAL_TYPES)) +#! Complex kinds to be considered during templating +#:set CMPLX_KINDS = ["sp", "dp", "qp"] + +#! Complex types to be considere during templating +#:set CMPLX_TYPES = ["complex({})".format(k) for k in CMPLX_KINDS] + +#! Collected (kind, type) tuples for complex types +#:set CMPLX_KINDS_TYPES = list(zip(CMPLX_KINDS, CMPLX_TYPES)) #! Integer kinds to be considered during templating #:set INT_KINDS = ["int8", "int16", "int32", "int64"] diff --git a/src/stdlib_experimental_io.fypp b/src/stdlib_experimental_io.fypp index c51a8e792..2031afd1b 100644 --- a/src/stdlib_experimental_io.fypp +++ b/src/stdlib_experimental_io.fypp @@ -1,6 +1,6 @@ #:include "common.fypp" -#:set KINDS_TYPES = REAL_KINDS_TYPES + INT_KINDS_TYPES +#:set KINDS_TYPES = REAL_KINDS_TYPES + INT_KINDS_TYPES + CMPLX_KINDS_TYPES module stdlib_experimental_io @@ -18,21 +18,21 @@ module stdlib_experimental_io public :: parse_mode interface loadtxt - #:for k1, _ in KINDS_TYPES - module procedure loadtxt_${k1}$ + #:for k1, t1 in KINDS_TYPES + module procedure loadtxt_${t1[0]}$${k1}$ #:endfor end interface loadtxt interface savetxt - #:for k1, _ in KINDS_TYPES - module procedure savetxt_${k1}$ + #:for k1, t1 in KINDS_TYPES + module procedure savetxt_${t1[0]}$${k1}$ #:endfor end interface contains #:for k1, t1 in KINDS_TYPES - subroutine loadtxt_${k1}$(filename, d) + subroutine loadtxt_${t1[0]}$${k1}$(filename, d) ! Loads a 2D array from a text file. ! ! Arguments @@ -58,7 +58,7 @@ contains ! ... ! integer :: s - integer :: nrow,ncol,i + integer :: nrow, ncol, i s = open(filename) @@ -74,12 +74,12 @@ contains end do close(s) - end subroutine loadtxt_${k1}$ + end subroutine loadtxt_${t1[0]}$${k1}$ #:endfor #:for k1, t1 in KINDS_TYPES - subroutine savetxt_${k1}$(filename, d) + subroutine savetxt_${t1[0]}$${k1}$(filename, d) ! Saves a 2D array into a text file. ! ! Arguments @@ -100,13 +100,13 @@ contains write(s, *) d(i, :) end do close(s) - end subroutine savetxt_${k1}$ + end subroutine savetxt_${t1[0]}$${k1}$ #:endfor integer function number_of_columns(s) ! determine number of columns - integer,intent(in)::s + integer,intent(in) :: s integer :: ios character :: c @@ -126,23 +126,33 @@ contains end function number_of_columns - integer function number_of_rows_numeric(s) + integer function number_of_rows_numeric(s) result(nrows) ! determine number or rows integer,intent(in)::s integer :: ios - real::r + real :: r + complex :: z rewind(s) - number_of_rows_numeric = 0 + nrows = 0 do read(s, *, iostat=ios) r if (ios /= 0) exit - number_of_rows_numeric = number_of_rows_numeric + 1 + nrows = nrows + 1 end do rewind(s) + ! If there are no rows of real numbers, it may be that they are complex + if( nrows == 0) then + do + read(s, *, iostat=ios) z + if (ios /= 0) exit + nrows = nrows + 1 + end do + rewind(s) + end if end function number_of_rows_numeric diff --git a/src/stdlib_experimental_io.md b/src/stdlib_experimental_io.md index 9ef005759..d90185209 100644 --- a/src/stdlib_experimental_io.md +++ b/src/stdlib_experimental_io.md @@ -20,7 +20,7 @@ Loads a rank-2 `array` from a text file. `filename`: Shall be a character expression containing the file name from which to load the rank-2 `array`. -`array`: Shall be an allocatable rank-2 array of type `real` or `integer`. +`array`: Shall be an allocatable rank-2 array of type `real`, `complex` or `integer`. ### Return value @@ -104,7 +104,7 @@ Saves a rank-2 `array` into a text file. `filename`: Shall be a character expression containing the name of the file that will contain the 2D `array`. -`array`: Shall be a rank-2 array of type `real` or `integer`. +`array`: Shall be a rank-2 array of type `real`, `complex` or `integer`. ### Output diff --git a/src/tests/io/array5.dat b/src/tests/io/array5.dat new file mode 100644 index 000000000..708698511 --- /dev/null +++ b/src/tests/io/array5.dat @@ -0,0 +1,2 @@ + (1.0000000000000000,0.0000000000000000) (3.0000000000000000,0.0000000000000000) (5.0000000000000000,0.0000000000000000) + (2.0000000000000000,0.0000000000000000) (4.0000000000000000,0.0000000000000000) (6.0000000000000000,0.0000000000000000) diff --git a/src/tests/io/test_loadtxt.f90 b/src/tests/io/test_loadtxt.f90 index 32d152223..3b16cc20d 100644 --- a/src/tests/io/test_loadtxt.f90 +++ b/src/tests/io/test_loadtxt.f90 @@ -7,6 +7,7 @@ program test_loadtxt integer(int32), allocatable :: i(:, :) real(sp), allocatable :: s(:, :) real(dp), allocatable :: d(:, :) +complex(dp), allocatable :: z(:, :) call loadtxt("array1.dat", i) call print_array(i) @@ -26,6 +27,9 @@ program test_loadtxt call loadtxt("array4.dat", d) call print_array(d) +call loadtxt("array5.dat", z) +call print_array(z) + contains subroutine print_array(a) @@ -46,6 +50,10 @@ subroutine print_array(a) do i = 1, size(a, 1) print *, a(i, :) end do + type is(complex(dp)) + do i = 1, size(a, 1) + print *, a(i, :) + end do class default call error_stop('The proposed type is not supported') end select diff --git a/src/tests/io/test_savetxt.f90 b/src/tests/io/test_savetxt.f90 index 288a7b1aa..8b7d13fcc 100644 --- a/src/tests/io/test_savetxt.f90 +++ b/src/tests/io/test_savetxt.f90 @@ -8,9 +8,11 @@ program test_savetxt outpath = get_outpath() // "/tmp.dat" -call test_int32(outpath) -call test_sp(outpath) -call test_dp(outpath) +call test_iint32(outpath) +call test_rsp(outpath) +call test_rdp(outpath) +call test_csp(outpath) +call test_cdp(outpath) contains @@ -27,7 +29,7 @@ function get_outpath() result(outpath) endif end function get_outpath - subroutine test_int32(outpath) + subroutine test_iint32(outpath) character(*), intent(in) :: outpath integer(int32) :: d(3, 2), e(2, 3) integer(int32), allocatable :: d2(:, :) @@ -45,7 +47,7 @@ subroutine test_int32(outpath) end subroutine - subroutine test_sp(outpath) + subroutine test_rsp(outpath) character(*), intent(in) :: outpath real(sp) :: d(3, 2), e(2, 3) real(sp), allocatable :: d2(:, :) @@ -60,10 +62,10 @@ subroutine test_sp(outpath) call loadtxt(outpath, d2) call assert(all(shape(d2) == [2, 3])) call assert(all(abs(e-d2) < epsilon(1._sp))) - end subroutine + end subroutine test_rsp - subroutine test_dp(outpath) + subroutine test_rdp(outpath) character(*), intent(in) :: outpath real(dp) :: d(3, 2), e(2, 3) real(dp), allocatable :: d2(:, :) @@ -78,6 +80,40 @@ subroutine test_dp(outpath) call loadtxt(outpath, d2) call assert(all(shape(d2) == [2, 3])) call assert(all(abs(e-d2) < epsilon(1._dp))) - end subroutine + end subroutine test_rdp + + subroutine test_csp(outpath) + character(*), intent(in) :: outpath + complex(sp) :: d(3, 2), e(2, 3) + complex(sp), allocatable :: d2(:, :) + d = cmplx(1, 1)* reshape([1, 2, 3, 4, 5, 6], [3, 2]) + call savetxt(outpath, d) + call loadtxt(outpath, d2) + call assert(all(shape(d2) == [3, 2])) + call assert(all(abs(d-d2) < epsilon(1._sp))) + + e = cmplx(1, 1)* reshape([1, 2, 3, 4, 5, 6], [2, 3]) + call savetxt(outpath, e) + call loadtxt(outpath, d2) + call assert(all(shape(d2) == [2, 3])) + call assert(all(abs(e-d2) < epsilon(1._sp))) + end subroutine test_csp + + subroutine test_cdp(outpath) + character(*), intent(in) :: outpath + complex(dp) :: d(3, 2), e(2, 3) + complex(dp), allocatable :: d2(:, :) + d = cmplx(1._dp, 1._dp)* reshape([1, 2, 3, 4, 5, 6], [3, 2]) + call savetxt(outpath, d) + call loadtxt(outpath, d2) + call assert(all(shape(d2) == [3, 2])) + call assert(all(abs(d-d2) < epsilon(1._dp))) + + e = cmplx(1, 1)* reshape([1, 2, 3, 4, 5, 6], [2, 3]) + call savetxt(outpath, e) + call loadtxt(outpath, d2) + call assert(all(shape(d2) == [2, 3])) + call assert(all(abs(e-d2) < epsilon(1._dp))) + end subroutine test_cdp -end program +end program test_savetxt diff --git a/src/tests/io/test_savetxt_qp.f90 b/src/tests/io/test_savetxt_qp.f90 index 69a973e00..8ebb7151a 100644 --- a/src/tests/io/test_savetxt_qp.f90 +++ b/src/tests/io/test_savetxt_qp.f90 @@ -8,7 +8,8 @@ program test_savetxt_qp outpath = get_outpath() // "/tmp_qp.dat" -call test_qp(outpath) +call test_rqp(outpath) +call test_cqp(outpath) contains @@ -25,7 +26,7 @@ function get_outpath() result(outpath) endif end function get_outpath - subroutine test_qp(outpath) + subroutine test_rqp(outpath) character(*), intent(in) :: outpath real(qp) :: d(3, 2), e(2, 3) real(qp), allocatable :: d2(:, :) @@ -40,6 +41,23 @@ subroutine test_qp(outpath) call loadtxt(outpath, d2) call assert(all(shape(d2) == [2, 3])) call assert(all(abs(e-d2) < epsilon(1._qp))) - end subroutine + end subroutine test_rqp -end program + subroutine test_cqp(outpath) + character(*), intent(in) :: outpath + complex(qp) :: d(3, 2), e(2, 3) + complex(qp), allocatable :: d2(:, :) + d = reshape([1, 2, 3, 4, 5, 6], [3, 2]) + call savetxt(outpath, d) + call loadtxt(outpath, d2) + call assert(all(shape(d2) == [3, 2])) + call assert(all(abs(d-d2) < epsilon(1._qp))) + + e = reshape([1, 2, 3, 4, 5, 6], [2, 3]) + call savetxt(outpath, e) + call loadtxt(outpath, d2) + call assert(all(shape(d2) == [2, 3])) + call assert(all(abs(e-d2) < epsilon(1._qp))) + end subroutine test_cqp + +end program test_savetxt_qp