Savetxt unit

doc/specs/stdlib_io.md

@@ -106,15 +106,25 @@ Saves a rank-2 `array` into a text file.
 
 ### Syntax
 
-`call ` [[stdlib_io(module):savetxt(interface)]] `(filename, array [, delimiter])`
+`call ` [[stdlib_io(module):savetxt(interface)]] `(filename, array [,  delimiter] [, fmt] [, header] [, footer] [, comments])`
+
+`call ` [[stdlib_io(module):savetxt(interface)]] `(unit, array[,  delimiter] [, fmt] [, header] [, footer] [, comments])`
 
 ### Arguments
 
-`filename`: Shall be  a character expression containing the name of the file that will contain the 2D `array`.
+`filename or unit`: Shall be either a character expression containing the name of the file or an integer containing the unit of an already open file, that will contain the 2D `array`.
 
 `array`: Shall be a rank-2 array of type `real`, `complex` or `integer`.
 
-`delimiter` (optional): Shall be a character expression of length 1 that contains the delimiter used to separate the columns. The default is `' '`.
+`delimiter` (optional): Shall be a character expression of any length that contains the delimiter used to separate the columns. The default is a single space `' '`.
+
+`fmt` (optional): Fortran format specifier for the text save. Defaults to the write format for the data type as defined in the [formatting constants]{formatting-constants}.
+
+`header` (optional): Shall be a character expression that will be written at the beginning of the file.
+
+`footer` (optional): Shall be a character expression that will be written at the end of the file.
+
+`comments` (optional): Shall  be a character expression of any length that will be prepended to the ``header`` and ``footer`` strings to mark them as comments. Default: `#`.
 
 ### Output
 
@@ -247,7 +257,7 @@ Read a whole line from a formatted unit into a string variable
 {!example/io/example_get_line.f90!}
 ```
 
-## Formatting constants
+## Formatting constants {formatting-constants}
 
 ### Status
 

example/io/example_savetxt.f90

@@ -1,7 +1,12 @@
 program example_savetxt
   use stdlib_io, only: savetxt
+  use, intrinsic :: iso_fortran_env, only: output_unit
   implicit none
   real :: x(3, 2) = 1
   call savetxt('example.dat', x)
   call savetxt('example.csv', x, delimiter=',')
+  call savetxt('example1.dat', x, header='x  (x-units)   y  (y-units)')
+  call savetxt('example2.dat', x, header='x  (x-units)   y  (y-units)', comments='!#', footer='This is all data')
+  call savetxt('example3.dat', x, fmt='g0.7')
+  call savetxt(output_unit, x, header='x  (x-units)   y  (y-units)')
 end program example_savetxt

src/io/stdlib_io.fypp

@@ -13,7 +13,7 @@ module stdlib_io
                                  FMT_COMPLEX_SP, FMT_COMPLEX_DP, FMT_COMPLEX_XDP, FMT_COMPLEX_QP
   use stdlib_error, only: error_stop, state_type, STDLIB_IO_ERROR
   use stdlib_optval, only: optval
-  use stdlib_ascii, only: is_blank
+  use stdlib_ascii, only: is_blank, whitespace, CR,LF,VT,FF
   use stdlib_string_type, only : string_type, assignment(=), move
   implicit none
   private
@@ -47,6 +47,8 @@ module stdlib_io
 
   !> Default delimiter for loadtxt, savetxt and number_of_columns
   character(len=1), parameter :: delimiter_default = " "
+  character(len=1), parameter :: comment_default = "#"
+  character(len=1), parameter :: nl = new_line('a')
 
   public :: FMT_INT, FMT_REAL_SP, FMT_REAL_DP, FMT_REAL_XDP, FMT_REAL_QP
   public :: FMT_COMPLEX_SP, FMT_COMPLEX_DP, FMT_COMPLEX_XDP, FMT_COMPLEX_QP
@@ -76,8 +78,10 @@ module stdlib_io
     !!
     !! Saves a 2D array into a text file
     !! ([Specification](../page/specs/stdlib_io.html#description_2))
+    #:for a1 in ['f', 'u']
     #:for k1, t1 in KINDS_TYPES
-      module procedure savetxt_${t1[0]}$${k1}$
+      module procedure savetxt_${t1[0]}$${k1}$${a1}$
+    #:endfor
     #:endfor
   end interface
 
@@ -230,19 +234,27 @@ contains
     end subroutine loadtxt_${t1[0]}$${k1}$
   #:endfor
 
-
+  #:for arg1 in ['filename', 'unit']
   #:for k1, t1 in KINDS_TYPES
-    subroutine savetxt_${t1[0]}$${k1}$(filename, d, delimiter)
+    subroutine savetxt_${t1[0]}$${k1}$${arg1[0]}$ (${arg1}$, d, delimiter, fmt, header, footer, comments)
       !! version: experimental
       !!
       !! Saves a 2D array into a text file.
       !!
       !! Arguments
       !! ---------
       !!
+      #:if 'filename' in arg1
       character(len=*), intent(in) :: filename  ! File to save the array to
+      #:elif 'unit' in arg1
+      integer, intent(in) :: unit
+      #:endif
       ${t1}$, intent(in) :: d(:,:)           ! The 2D array to save
-      character(len=1), intent(in), optional :: delimiter  ! Column delimiter. Default is a space.
+      character(len=*), intent(in), optional :: delimiter  ! Column delimiter. Default is a space ' '.
+      character(len=*), intent(in), optional :: fmt  !< Fortran format specifier. Defaults to the write format for the data type.
+      character(len=*), intent(in), optional :: header  !< If present, text to write before data.
+      character(len=*), intent(in), optional :: footer  !< If present, text to write after data.
+      character(len=*), intent(in), optional :: comments  !< Comment character. Default "#".
       !!
       !! Example
       !! -------
@@ -253,42 +265,131 @@ contains
       !!```
       !!
       integer :: s, i, ios
-      character(len=1) :: delimiter_
-      character(len=3) :: delim_str
+      character(len=:), allocatable :: delimiter_
+      character(len=:), allocatable :: delim_str
+      character(len=:), allocatable :: default_fmt
       character(len=:), allocatable :: fmt_
-      character(len=1024) :: iomsg, msgout
+      character(len=:), allocatable :: comments_
+      character(len=:), allocatable :: header_
+      character(len=:), allocatable :: footer_
+      character(len=1024) :: iomsg, msgout, fout
+
+      #:if 'filename' in arg1
+      integer :: unit
+      #:else
+      logical :: opened
+      #:endif
 
       delimiter_ = optval(delimiter, delimiter_default)
       delim_str = "'"//delimiter_//"'"
+      comments_ = optval(comments, comment_default)
+      header_ = optval(header, '')
+      footer_ = optval(footer, '')
+
+      if(index(delimiter_, comments_) /= 0) then
+          write (msgout,'(a)') 'savetxt error: delimiter string cannot include the comments string'
+          call error_stop(msg=trim(msgout))
+      end if
+
+      if(scan(whitespace, comments_) /= 0) then
+          write (msgout,'(a)') 'savetxt error: comments string cannot include whitespaces'
+          call error_stop(msg=trim(msgout))
+      end if
+
+      if(scan(LF//CR//VT//FF, delimiter_ ) /= 0) then
+          write (msgout,'(a)') 'savetxt error: delimiter cannot include newline'
+          call error_stop(msg=trim(msgout))
+      end if
+
+
       #:if 'real' in t1
-        fmt_ = "(*"//FMT_REAL_${k1}$(1:len(FMT_REAL_${k1}$)-1)//",:,"//delim_str//"))"
+        default_fmt = FMT_REAL_${k1}$(2:len(FMT_REAL_${k1}$)-1)
       #:elif 'complex' in t1
-        fmt_ = "(*"//FMT_COMPLEX_${k1}$(1:11)//delim_str//FMT_COMPLEX_${k1}$(14:23)//",:,"//delim_str//"))"
+        default_fmt = FMT_COMPLEX_${k1}$(2:11)//delim_str//FMT_COMPLEX_${k1}$(14:23)
       #:elif 'integer' in t1
-        fmt_ = "(*"//FMT_INT(1:len(FMT_INT)-1)//",:,"//delim_str//"))"
+        default_fmt = FMT_INT(2:len(FMT_INT)-1)
+      #:endif
+      fmt_ = "(*("//optval(fmt, default_fmt)//",:,"//delim_str//"))"
+
+      #:if 'filename' in arg1
+      unit = open (filename, "w")
+      fout = filename
+      #:else
+      inquire (unit=unit, opened=opened)
+      write(fout,'(i0)') unit
+      fout = adjustl(fout)
+      if(.not. opened) then
+           write (msgout,'(a,i0,a)') 'savetxt error: unit ',unit,' not open'
+      end if
       #:endif
 
-      s = open(filename, "w")
+      !! Write the header if non-empty
+      ! prepend function may be replaced by use of replace_all but currently stdlib_strings
+      ! is being compiled after stdlib_io
+      ! if (header_ /= '') write (unit, '(A)') comments_//replace_all(header_, nl, nl//comments_)
+      if (header_ /= '') then
+          write (unit, '(A)', iostat=ios, iomsg=iomsg) prepend(header_, comments_)
+          if (ios/=0) then
+              write (msgout,'(a)') 'savetxt: error <'//trim(iomsg)//"> header to "//trim(fout)
+              call error_stop(msg=trim(msgout))
+          end if           
+      end if
+
       do i = 1, size(d, 1)
         #:if 'real' in t1 or 'complex' in t1 or 'integer' in t1
-          write(s, fmt_, &
+          write(unit, fmt_, &
         #:else
-          write(s, *, &
+          write(unit, *, &
         #:endif
                 iostat=ios,iomsg=iomsg) d(i, :)
 
         if (ios/=0) then 
-           write(msgout,1) trim(iomsg),size(d,2),i,trim(filename) 
-           call error_stop(msg=trim(msgout))
+            write (msgout,1) trim(iomsg),size(d,2),i,trim(fout)
+            call error_stop(msg=trim(msgout))
         end if           
-
       end do
-      close(s)
-
+      ! if (footer_ /= '') write (unit, '(A)') comments_//replace_all(footer_, nl, nl//comments_)
+      if (footer_ /= '') then
+          write (unit, '(A)', iostat=ios, iomsg=iomsg) prepend(footer_, comments_)
+          if (ios/=0) then
+              write (msgout,'(a)') 'savetxt: error <'//trim(iomsg)//"> footer to "//trim(fout)
+              call error_stop(msg=trim(msgout))
+          end if           
+      end if
+
+      #:if 'filename' in arg1
+      close (unit)
+      #:endif
+
       1 format('savetxt: error <',a,'> writing ',i0,' values to line ',i0,' of ',a,'.')
 
-    end subroutine savetxt_${t1[0]}$${k1}$
+    end subroutine savetxt_${t1[0]}$${k1}$${arg1[0]}$
   #:endfor
+  #:endfor
+  pure function prepend(Sin, comment) result(Sout)
+    character(len=*), intent(in) :: Sin
+    character(len=:), allocatable :: Sout
+    character(len=*), intent(in) :: comment 
+    character(len=len(comment)+1) :: com_
+    integer :: bol, eol       ! indexes of beginning and end of line
+
+    if (trim(Sin) == '') then
+        Sout = ''
+        return
+    end if
+
+    com_ = comment//" "
+    bol = 1
+    Sout = com_              ! Initialize to comment the first line
+    do
+      eol = index(Sin(bol:), nl) + bol - 1 ! position of end of line in original string
+      if (eol == bol - 1) exit             ! index returned 0
+      Sout = Sout//Sin(bol:eol)//com_
+      bol = eol + 1
+    end do
+    if (eol < len(Sin)) Sout = Sout//Sin(eol + 1:) ! Add last line if not newline present
+
+  end function prepend
 
 
   integer function number_of_columns(s, skiprows, delimiter)

test/io/test_savetxt.f90

@@ -1,6 +1,6 @@
 module test_savetxt
     use stdlib_kinds, only: int32, sp, dp
-    use stdlib_io, only: loadtxt, savetxt
+    use stdlib_io, only: loadtxt, savetxt, get_line
     use testdrive, only: new_unittest, unittest_type, error_type, check
     implicit none
 
@@ -18,7 +18,11 @@ subroutine collect_savetxt(testsuite)
             new_unittest("rsp", test_rsp), &
             new_unittest("rdp", test_rdp), &
             new_unittest("csp", test_csp), &
-            new_unittest("cdp", test_cdp) &
+            new_unittest("cdp", test_cdp), &
+            new_unittest("delim", test_delim), &
+            new_unittest("fmt", test_fmt), &
+            new_unittest("unit", test_unit), &
+            new_unittest("headfoot", test_headfoot) &
         ]
 
     end subroutine collect_savetxt
@@ -118,6 +122,105 @@ subroutine test_rdp(error)
         if (allocated(error)) return
     end subroutine test_rdp
 
+    subroutine test_delim(error)
+        !> Error handling
+        type(error_type), allocatable, intent(out) :: error
+        real(dp) :: d(3, 2)
+        real(dp), allocatable :: d2(:, :)
+        character(:), allocatable :: outpath
+
+        outpath = get_outpath() // "/tmp_test_delim.dat"
+
+        d = reshape([1, 2, 3, 4, 5, 6], [3, 2])
+        call savetxt(outpath, d, delimiter=',')
+        call loadtxt(outpath, d2, delimiter=',')
+        call check(error, all(shape(d2) == [3, 2]))
+        if (allocated(error)) return
+        call check(error, all(d == d2))
+        if (allocated(error)) return
+    end subroutine test_delim
+
+    subroutine test_unit(error)
+        !> Error handling
+        type(error_type), allocatable, intent(out) :: error
+        real(dp) :: d(3, 2)
+        real(dp), allocatable :: d2(:, :)
+        character(:), allocatable :: outpath
+        integer :: unit
+
+        outpath = get_outpath() // "/tmp_test_unit.dat"
+
+
+        d = reshape([1, 2, 3, 4, 5, 6], [3, 2])
+        open(newunit=unit, file=outpath)
+        call savetxt(unit, d)
+        close(unit)
+        call loadtxt(outpath, d2)
+        call check(error, all(shape(d2) == [3, 2]))
+        if (allocated(error)) return
+        call check(error, all(d == d2))
+        if (allocated(error)) return
+    end subroutine test_unit
+
+    subroutine test_fmt(error)
+        !> Error handling
+        type(error_type), allocatable, intent(out) :: error
+        real(dp) :: d(3, 2)
+        real(dp), allocatable :: d2(:, :)
+        character(:), allocatable :: outpath
+
+        outpath = get_outpath() // "/tmp_test_fmt.dat"
+
+        d = reshape([1, 2, 3, 4, 5, 6], [3, 2])
+        call savetxt(outpath, d, fmt='(g0.7)')
+        call loadtxt(outpath, d2, fmt='*')
+        call check(error, all(shape(d2) == [3, 2]))
+        if (allocated(error)) return
+        call check(error, all(d == d2))
+        if (allocated(error)) return
+    end subroutine test_fmt
+
+    subroutine test_headfoot(error)
+        !> Error handling
+        type(error_type), allocatable, intent(out) :: error
+        real(dp) :: d(3, 2)
+        character(:), allocatable :: outpath
+        !
+        character(len=1), parameter :: nl = new_line('a')
+        character(len=*), parameter :: header1 = "Three values per line"
+        character(len=*), parameter :: header2 = "Other header"
+        character(len=*), parameter :: footer = "Total size = 6"
+        character(len=*), parameter :: comments = '#!'
+        character(len=:), allocatable :: line
+        integer :: unit
+
+        outpath = get_outpath() // "/tmp_test_headfoot.dat"
+
+        d = reshape([1, 2, 3, 4, 5, 6], [3, 2])
+        call savetxt(outpath, d, header=header1//nl//header2, footer=footer, comments=comments)
+        open (newunit=unit, file=outpath)
+        ! Check header, first line
+        call get_line(unit, line)
+        call check(error, line == comments//" "//header1)
+        if (allocated(error)) return
+
+        ! Check header, second line
+        call get_line(unit, line)
+        call check(error, line == comments//" "//header2)
+        if (allocated(error)) return
+
+        ! Read the two data rows
+        call get_line(unit, line)
+        call get_line(unit, line)
+        call get_line(unit, line)
+
+        ! Check footer, second line
+        call get_line(unit, line)
+        call check(error, line == comments//" "//footer)
+        if (allocated(error)) return
+
+        close(unit)
+    end subroutine test_headfoot
 
     subroutine test_csp(error)
         !> Error handling