Merge pull request #138 from fiolj/master

Added complex to io

Author: certik

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

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"]

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
 
 

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
 

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)

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

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

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