stdlib_io.fypp

#:include "common.fypp"

#:set KINDS_TYPES = REAL_KINDS_TYPES + INT_KINDS_TYPES + CMPLX_KINDS_TYPES

module stdlib_io
  !! Provides a support for file handling
  !! ([Specification](../page/specs/stdlib_io.html))

  use, intrinsic :: iso_fortran_env, only : input_unit
  use stdlib_kinds, only: sp, dp, xdp, qp, &
      int8, int16, int32, int64
  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, getline

  ! Private API that is exposed so that we can test it in tests
  public :: parse_mode

  !> Version: experimental
  !>
  !> Format strings with edit descriptors for each type and kind
  !> ([Specification](../page/specs/stdlib_io.html))
  character(*), parameter :: &
    !> Format string for integers
    FMT_INT = '(i0)', &
    !> Format string for single precision real numbers
    FMT_REAL_SP = '(es15.8e2)', &
    !> Format string for souble precision real numbers
    FMT_REAL_DP = '(es24.16e3)', &
    !> Format string for extended double precision real numbers
    FMT_REAL_XDP = '(es26.18e3)', &
    !> Format string for quadruple precision real numbers
    FMT_REAL_QP = '(es44.35e4)', &
    !> Format string for single precision complex numbers
    FMT_COMPLEX_SP = '(es15.8e2,1x,es15.8e2)', &
    !> Format string for double precision complex numbers
    FMT_COMPLEX_DP = '(es24.16e3,1x,es24.16e3)', &
    !> Format string for extended double precision complex numbers
    FMT_COMPLEX_XDP = '(es26.18e3,1x,es26.18e3)', &
    !> Format string for quadruple precision complex numbers
    FMT_COMPLEX_QP = '(es44.35e4,1x,es44.35e4)'

  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

  !> Version: experimental
  !>
  !> Read a whole line from a formatted unit into a string variable
  interface getline
    module procedure :: getline_char
    module procedure :: getline_string
    module procedure :: getline_input_char
    module procedure :: getline_input_string
  end interface getline

  interface loadtxt
    !! version: experimental
    !!
    !! Loads a 2D array from a text file
    !! ([Specification](../page/specs/stdlib_io.html#description))
    #:for k1, t1 in KINDS_TYPES
      module procedure loadtxt_${t1[0]}$${k1}$
    #:endfor
  end interface loadtxt

  interface savetxt
    !! version: experimental
    !!
    !! Saves a 2D array into a text file
    !! ([Specification](../page/specs/stdlib_io.html#description_2))
    #:for k1, t1 in KINDS_TYPES
      module procedure savetxt_${t1[0]}$${k1}$
    #:endfor
  end interface

contains

  #:for k1, t1 in KINDS_TYPES
    subroutine  loadtxt_${t1[0]}$${k1}$(filename, d, skiprows, max_rows, fmt)
      !! version: experimental
      !!
      !! Loads a 2D array from a text file.
      !!
      !! Arguments
      !! ---------
      !!
      !! Filename to load the array from
      character(len=*), intent(in) :: filename
      !! The array 'd' will be automatically allocated with the correct dimensions
      ${t1}$, allocatable, intent(out) :: d(:,:)
      !! Skip the first `skiprows` lines. If skipping more rows than present, a 0-sized array will be returned. The default is 0.
      integer, intent(in), optional :: skiprows
      !! Read `max_rows` lines of content after `skiprows` lines.
      !! A negative value results in reading all lines.
      !! A value of zero results in no lines to be read.
      !! The default value is -1.
      integer, intent(in), optional :: max_rows
      character(len=*), intent(in), optional :: fmt
      character(len=:), allocatable :: fmt_
      !!
      !! Example
      !! -------
      !!
      !!```fortran
      !! ${t1}$, allocatable :: data(:, :)
      !! call loadtxt("log.txt", data)  ! 'data' will be automatically allocated
      !!```
      !!
      !! Where 'log.txt' contains for example::
      !!
      !!     1 2 3
      !!     2 4 6
      !!     8 9 10
      !!     11 12 13
      !!     ...
      !!
      integer :: s
      integer :: nrow, ncol, i, skiprows_, max_rows_

      skiprows_ = max(optval(skiprows, 0), 0)
      max_rows_ = optval(max_rows, -1)

      s = open(filename)

      ! determine number or rows
      nrow = number_of_rows(s)
      skiprows_ = min(skiprows_, nrow)
      if ( max_rows_ < 0 .or. max_rows_ > (nrow - skiprows_) ) max_rows_ = nrow - skiprows_

      ! determine number of columns
      ncol = 0
      if ( skiprows_ < nrow ) ncol = number_of_columns(s, skiprows=skiprows_)
      #:if 'complex' in t1
      ncol = ncol / 2
      #:endif

      allocate(d(max_rows_, ncol))

      do i = 1, skiprows_
        read(s, *)
      end do

      #:if 'real' in t1
      ! Default to format used for savetxt if fmt not specified.
      fmt_ = optval(fmt, "(*"//FMT_REAL_${k1}$(1:len(FMT_REAL_${k1}$)-1)//",1x))")

      if ( fmt_ == '*' ) then
        ! Use list directed read if user has specified fmt='*'
        do i = 1, max_rows_
          read (s,*) d(i, :)
        enddo
      else
        ! Otherwise pass default or user specified fmt string.  
        do i = 1, max_rows_
          read (s,fmt_) d(i, :)
        enddo
      endif
      #:elif 'complex' in t1
      ! Default to format used for savetxt if fmt not specified.
      fmt_ = optval(fmt, "(*"//FMT_COMPLEX_${k1}$(1:len(FMT_COMPLEX_${k1}$)-1)//",1x))")
      if ( fmt_ == '*' ) then
        ! Use list directed read if user has specified fmt='*'
        do i = 1, max_rows_
          read (s,*) d(i, :)
        enddo
      else
        ! Otherwise pass default or user specified fmt string.
        do i = 1, max_rows_
          read (s,fmt_) d(i, :)
        enddo
      endif
      #:else
      ! Default to list directed for integer
      fmt_ = optval(fmt, "*")
      ! Use list directed read if user has specified fmt='*'
      if ( fmt_ == '*' ) then
        do i = 1, max_rows_
          read (s,*) d(i, :)
        enddo
      else
        ! Otherwise pass default user specified fmt string.
        do i = 1, max_rows_
          read (s,fmt_) d(i, :)
        enddo
      endif

      #:endif

      close(s)

    end subroutine loadtxt_${t1[0]}$${k1}$
  #:endfor


  #:for k1, t1 in KINDS_TYPES
    subroutine savetxt_${t1[0]}$${k1}$(filename, d)
      !! version: experimental
      !!
      !! Saves a 2D array into a text file.
      !!
      !! Arguments
      !! ---------
      !!
      character(len=*), intent(in) :: filename  ! File to save the array to
      ${t1}$, intent(in) :: d(:,:)           ! The 2D array to save
      !!
      !! Example
      !! -------
      !!
      !!```fortran
      !! ${t1}$ :: data(3, 2)
      !! call savetxt("log.txt", data)
      !!```
      !!

      integer :: s, i
      s = open(filename, "w")
      do i = 1, size(d, 1)
        #:if 'real' in t1
          write(s, "(*"//FMT_REAL_${k1}$(1:len(FMT_REAL_${k1}$)-1)//",1x))") d(i, :)
        #:elif 'complex' in t1
          write(s, "(*"//FMT_COMPLEX_${k1}$(1:len(FMT_COMPLEX_${k1}$)-1)//",1x))") d(i, :)
        #:elif 'integer' in t1
          write(s, "(*"//FMT_INT(1:len(FMT_INT)-1)//",1x))") d(i, :)
        #:else
          write(s, *) d(i, :)
        #:endif
      end do
      close(s)
    end subroutine savetxt_${t1[0]}$${k1}$
  #:endfor


  integer function number_of_columns(s, skiprows)
    !! version: experimental
    !!
    !! determine number of columns
    integer,intent(in) :: s
    integer, intent(in), optional :: skiprows

    integer :: ios, skiprows_, i
    character :: c
    logical :: lastblank

    skiprows_ = optval(skiprows, 0)

    rewind(s)

    do i = 1, skiprows_
      read(s, *)
    end do

    number_of_columns = 0
    lastblank = .true.
    do
      read(s, '(a)', advance='no', iostat=ios) c
      if (ios /= 0) exit
      if (lastblank .and. .not. is_blank(c)) number_of_columns = number_of_columns + 1
      lastblank = is_blank(c)
    end do
    rewind(s)

  end function number_of_columns


  integer function number_of_rows(s) result(nrows)
    !! version: experimental
    !!
    !! Determine the number or rows in a file
    integer, intent(in)::s
    integer :: ios

    rewind(s)
    nrows = 0
    do
      read(s, *, iostat=ios)
      if (ios /= 0) exit
      nrows = nrows + 1
    end do

    rewind(s)

  end function number_of_rows


  integer function open(filename, mode, iostat) result(u)
    !! version: experimental
    !!
    !! Opens a file
    !! ([Specification](../page/specs/stdlib_io.html#description_1))
    !!
    !!##### Behavior
    !!
    !!
    !! To open a file to read:
    !!
    !!```fortran
    !! u = open("somefile.txt")        ! The default `mode` is "rt"
    !! u = open("somefile.txt", "r")
    !!```
    !!
    !! To open a file to write:
    !!
    !!```fortran
    !! u = open("somefile.txt", "w")
    !!```
    !!
    !! To append to the end of the file if it exists:
    !!
    !!```fortran
    !! u = open("somefile.txt", "a")
    !!```

    character(*), intent(in) :: filename
    character(*), intent(in), optional :: mode
    integer, intent(out), optional :: iostat

    character(3) :: mode_
    character(:),allocatable :: action_, position_, status_, access_, form_


    mode_ = parse_mode(optval(mode, ""))

    select case (mode_(1:2))
    case('r')
      action_='read'
      position_='asis'
      status_='old'
    case('w')
      action_='write'
      position_='asis'
      status_='replace'
    case('a')
      action_='write'
      position_='append'
      status_='old'
    case('x')
      action_='write'
      position_='asis'
      status_='new'
    case('r+')
      action_='readwrite'
      position_='asis'
      status_='old'
    case('w+')
      action_='readwrite'
      position_='asis'
      status_='replace'
    case('a+')
      action_='readwrite'
      position_='append'
      status_='old'
    case('x+')
      action_='readwrite'
      position_='asis'
      status_='new'
    case default
      call error_stop("Unsupported mode: "//mode_(1:2))
    end select

    select case (mode_(3:3))
    case('t')
      form_='formatted'
    case('b')
      form_='unformatted'
    case default
      call error_stop("Unsupported mode: "//mode_(3:3))
    end select

    access_ = 'stream'

    if (present(iostat)) then
      open(newunit=u, file=filename, &
          action = action_, position = position_, status = status_, &
          access = access_, form = form_, &
          iostat = iostat)
    else
      open(newunit=u, file=filename, &
          action = action_, position = position_, status = status_, &
          access = access_, form = form_)
    end if

  end function open

  character(3) function parse_mode(mode) result(mode_)
    character(*), intent(in) :: mode

    integer :: i
    character(:),allocatable :: a
    logical :: lfirst(3)

    mode_ = 'r t'

    if (len_trim(mode) == 0) return
    a=trim(adjustl(mode))

    lfirst = .true.
    do i=1,len(a)
      if (lfirst(1) &
          .and. (a(i:i) == 'r' .or. a(i:i) == 'w' .or. a(i:i) == 'a' .or. a(i:i) == 'x') &
          ) then
        mode_(1:1) = a(i:i)
        lfirst(1)=.false.
      else if (lfirst(2) .and. a(i:i) == '+') then
        mode_(2:2) = a(i:i)
        lfirst(2)=.false.
      else if (lfirst(3) .and. (a(i:i) == 't' .or. a(i:i) == 'b')) then
        mode_(3:3) = a(i:i)
        lfirst(3)=.false.
      else if (a(i:i) == ' ') then
        cycle
      else if(any(.not.lfirst)) then
        call error_stop("Wrong mode: "//trim(a))
      else
        call error_stop("Wrong character: "//a(i:i))
      endif
    end do

  end function parse_mode

  !> Version: experimental
  !>
  !> Read a whole line from a formatted unit into a deferred length character variable
  subroutine getline_char(unit, line, iostat, iomsg)
    !> Formatted IO unit
    integer, intent(in) :: unit
    !> Line to read
    character(len=:), allocatable, intent(out) :: line
    !> Status of operation
    integer, intent(out), optional :: iostat
    !> Error message
    character(len=:), allocatable, optional :: iomsg

    integer, parameter :: bufsize = 4096
    character(len=bufsize) :: buffer, msg
    integer :: chunk, stat
    logical :: opened

    if (unit /= -1) then
      inquire(unit=unit, opened=opened)
    else
      opened = .false.
    end if

    if (opened) then
      open(unit=unit, pad="yes", iostat=stat, iomsg=msg)
    else
      stat = 1
      msg = "Unit is not connected"
    end if

    line = ""
    do while (stat == 0)
      read(unit, '(a)', advance='no', iostat=stat, iomsg=msg, size=chunk) buffer
      if (stat > 0) exit
      line = line // buffer(:chunk)
    end do
    if (is_iostat_eor(stat)) stat = 0

    if (stat /= 0 .and. present(iomsg)) iomsg = trim(msg)
    if (present(iostat)) then
      iostat = stat
    else if (stat /= 0) then
      call error_stop(trim(msg))
    end if
  end subroutine getline_char

  !> Version: experimental
  !>
  !> Read a whole line from a formatted unit into a string variable
  subroutine getline_string(unit, line, iostat, iomsg)
    !> Formatted IO unit
    integer, intent(in) :: unit
    !> Line to read
    type(string_type), intent(out) :: line
    !> Status of operation
    integer, intent(out), optional :: iostat
    !> Error message
    character(len=:), allocatable, optional :: iomsg

    character(len=:), allocatable :: buffer

    call getline(unit, buffer, iostat, iomsg)
    line = string_type(buffer)
  end subroutine getline_string

  !> Version: experimental
  !>
  !> Read a whole line from the standard input into a deferred length character variable
  subroutine getline_input_char(line, iostat, iomsg)
    !> Line to read
    character(len=:), allocatable, intent(out) :: line
    !> Status of operation
    integer, intent(out), optional :: iostat
    !> Error message
    character(len=:), allocatable, optional :: iomsg

    call getline(input_unit, line, iostat, iomsg)
  end subroutine getline_input_char

  !> Version: experimental
  !>
  !> Read a whole line from the standard input into a string variable
  subroutine getline_input_string(line, iostat, iomsg)
    !> Line to read
    type(string_type), intent(out) :: line
    !> Status of operation
    integer, intent(out), optional :: iostat
    !> Error message
    character(len=:), allocatable, optional :: iomsg

    call getline(input_unit, line, iostat, iomsg)
  end subroutine getline_input_string

end module stdlib_io