file_operations.F90

Go to the documentation of this file.

module file_operations
 
  use iso_c_binding, only : c_int, c_float, c_double, c_bool
  use iso_fortran_env, only : iostat_end
  use logfiles
  use exceptions
  use constants_and_conversions
  use fstring
  use fstring_list
  implicit none
 
  private
 
  public :: fully_qualified_filename
 
  integer (c_int), parameter         :: max_str_len    = 65536
 
  type, public :: ascii_file_t
 
    character (len=:), allocatable  :: sfilename
    character (len=:), allocatable  :: sdelimiters
    character (len=:), allocatable  :: scommentchars
    type (fstring_list_t)           :: slcolnames
    logical (c_bool)                :: remove_extra_delimiters = false
    integer (c_int)                 :: icurrentlinenum = 0
    integer (c_int)                 :: inumberoflines = 0
    integer (c_int)                 :: inumberofrecords = 0
    integer (c_int)                 :: inumberofheaderlines = 1
    logical (c_bool)                :: lisopen = false
    logical (c_bool)                :: lreadonly = true
    logical (c_bool)                :: leof = false
    integer (c_int)                 :: iunitnum
    integer (c_int)                 :: istat
    character (len=MAX_STR_LEN)     :: sbuf
    character (len=:), allocatable  :: stmissingvalue
 
  contains
 
    procedure, private :: open_file_read_access_sub
    procedure, private :: open_file_write_access_sub
    generic :: open => open_file_read_access_sub, &
                       open_file_write_access_sub
 
    procedure, private :: close_file_sub
    generic :: close => close_file_sub
 
    procedure, private :: is_file_open_fn
    generic :: isopen => is_file_open_fn
 
    procedure, private :: have_we_reached_the_eof_fn
    generic :: iseof => have_we_reached_the_eof_fn
 
    procedure, private :: does_file_exist_fn
    generic :: exists => does_file_exist_fn
 
    procedure, private :: is_current_line_a_comment_fn
    generic :: iscomment => is_current_line_a_comment_fn
 
    procedure, private :: count_number_of_lines_sub
    generic :: countlines => count_number_of_lines_sub
 
    procedure, private :: return_num_lines_fn
    generic :: numlines => return_num_lines_fn
 
    procedure, private :: return_num_records_fn
    generic :: numrecords => return_num_records_fn
 
    procedure, private :: return_current_linenum_fn
    generic :: currentlinenum => return_current_linenum_fn
 
    procedure, private :: return_fortran_unit_number_fn
    generic :: unit => return_fortran_unit_number_fn
 
    procedure, private :: read_header_fn
    generic, public    :: readheader => read_header_fn
 
    procedure, private :: read_line_of_data_fn
    generic, public    :: readline => read_line_of_data_fn
 
    procedure, private :: write_line_of_data_sub
    generic, public    :: writeline => write_line_of_data_sub
 
  end type ascii_file_t
 
contains
 
  function return_fortran_unit_number_fn(this)   result(iUnitNum)
 
    class(ascii_file_t)   :: this
    integer (c_int)   :: iunitnum
 
    iunitnum = this%iUnitNum
 
  end function return_fortran_unit_number_fn
 
!--------------------------------------------------------------------------------------------------
 
  function return_num_lines_fn(this)    result(iNumLines)
 
    class(ascii_file_t)   :: this
    integer (c_int) :: inumlines
 
    inumlines = this%iNumberOfLines
 
  end function return_num_lines_fn
 
!--------------------------------------------------------------------------------------------------
 
  function return_num_records_fn(this)                 result(iNumRecords)
 
    class(ascii_file_t)   :: this
    integer (c_int) :: inumrecords
 
    inumrecords = this%iNumberOfRecords
 
  end function return_num_records_fn
 
!--------------------------------------------------------------------------------------------------
 
  function return_current_linenum_fn(this)          result(iCurrentLinenum)
 
    class(ascii_file_t)   :: this
    integer (c_int) :: icurrentlinenum
 
    icurrentlinenum = this%iCurrentLinenum
 
  end function return_current_linenum_fn
 
!--------------------------------------------------------------------------------------------------
 
  function have_we_reached_the_eof_fn(this)           result(lIsEOF)
 
    class(ascii_file_t)     :: this
    logical (c_bool)   :: liseof
 
    liseof = this%lEOF
 
  end function have_we_reached_the_eof_fn
 
!--------------------------------------------------------------------------------------------------
 
  function is_current_line_a_comment_fn(this)         result(lIsComment)
 
    class(ascii_file_t)     :: this
    logical (c_bool)   :: liscomment
 
    ! [ LOCALS ]
    integer (c_int)                :: iindex
    integer (c_int)                :: ilen
    character (len=:), allocatable :: strimmedinput
    character (len=1)              :: sfirstchar
 
    liscomment = false
 
    strimmedinput = adjustl(trim(this%sBuf))
    ilen = len( strimmedinput )
 
    if (ilen > 0) then
 
      sfirstchar = strimmedinput(1:1)
      !-- why 'verify' and not 'scan' in older code??
      !-----
      ! SCAN(STRING, SET): If no character of SET is found in STRING, the result is zero. 
      iindex = scan( sfirstchar , this%sCommentChars )
      if ( iindex > 0 ) liscomment = true
 
    endif
 
  end function is_current_line_a_comment_fn
 
!--------------------------------------------------------------------------------------------------
 
  subroutine open_file_read_access_sub(this, sFilename, sCommentChars, sDelimiters, lHasHeader )
 
    class(ascii_file_t), intent(inout)         :: this
    character (len=*), intent(in)               :: sfilename
    character (len=*), intent(in)               :: scommentchars
    character (len=*), intent(in)               :: sdelimiters
    logical (c_bool), intent(in), optional :: lhasheader
 
    ! [ LOCALS ]
    character (len=len(sFilename) ) :: sfilename_l
 
    ! 'fix_pathname' simply replaces forward slashes and backslashes with whatever the native OS
    ! path delimiter character should be
    sfilename_l = fix_pathname( sfilename )
    
    this%sCommentChars = scommentchars
    this%sDelimiters = sdelimiters
 
    if (present( lhasheader ) ) then
      if (.not. lhasheader ) this%iNumberOfHeaderLines = 0
    endif
 
    if ( this%isOpen() ) then
 
      call die( "PROGRAMMING ERROR--file already open: "//dquote( fully_qualified_filename( sfilename_l ) )//"." )
 
    else
 
      this%sFilename = fully_qualified_filename(sfilename_l)
 
      open(newunit=this%iUnitNum, file=fully_qualified_filename( sfilename_l ), iostat=this%iStat, action='READ')
      call assert(this%iStat == 0, "Failed to open file "//dquote( fully_qualified_filename( sfilename_l ) )//"."  &
        //" Exit code: "//ascharacter( this%iStat )//".", __file__, __line__)
 
      this%lIsOpen = true
      this%lEOF = false
 
      call this%countLines()
 
      call logs%write( smessage="Opened file "//dquote( fully_qualified_filename( sfilename_l ) ), itab=22, &
                       ilinesbefore=1, iloglevel=log_all )
      call logs%write( "Comment characters: "//dquote(scommentchars), itab=42 )
      call logs%write( "Number of lines in file: "//ascharacter( this%numLines() ), itab=37 )
      call logs%write( "Number of lines excluding blanks, headers and comments: " &
           //ascharacter( this%numRecords() ), itab=6 )
 
    endif
 
  end subroutine open_file_read_access_sub
 
!--------------------------------------------------------------------------------------------------
 
  subroutine open_file_write_access_sub(this, sFilename, lQuiet )
 
    class(ascii_file_t), intent(inout)           :: this
    character (len=*), intent(in)                 :: sfilename
    logical (c_bool), intent(in), optional   :: lquiet
 
    ! [ LOCALS ]
    logical :: lquiet_l
    character (len=len(sFilename) ) :: sfilename_l
 
    sfilename_l = fix_pathname( sfilename )
 
    if ( present( lquiet ) ) then
      lquiet_l = lquiet
    else
      lquiet_l = false
    endif
 
    if (.not. this%isOpen() ) then
      this%sFilename = trim(sfilename_l)
      open(newunit=this%iUnitNum, file=sfilename_l, iostat=this%iStat, action='WRITE')
      call assert(this%iStat == 0, "Failed to open file "//dquote(sfilename_l)//".", __file__, __line__)
 
      this%lIsOpen = true
      this%lEOF = false
      this%lReadOnly = false
      this%sFilename = trim(sfilename_l)
 
      if ( .not. lquiet_l ) &
        call logs%write( "Opened file with write access: "//dquote(sfilename_l))
 
    else
      call logs%write( "Failed to open file "//dquote(sfilename_l)//" with WRITE access" )
    endif
 
  end subroutine open_file_write_access_sub
 
!--------------------------------------------------------------------------------------------------
 
  subroutine close_file_sub(this)
 
    class(ascii_file_t) :: this
 
 
    close(unit=this%iUnitNum, iostat=this%iStat)
    
    this%lIsOpen = false
 
  end subroutine close_file_sub
 
!--------------------------------------------------------------------------------------------------
 
  function does_file_exist_fn(this, sFilename) result(lExists)
 
    class(ascii_file_t)              :: this
    character (len=*), intent(in)    :: sfilename
    logical             :: lexists
 
    inquire(file=fully_qualified_filename( sfilename ), exist=lexists)
 
  end function does_file_exist_fn
 
!--------------------------------------------------------------------------------------------------
 
  pure function is_file_open_fn(this) result(lIsOpen)
 
    class(ascii_file_t), intent(in) :: this
    logical(c_bool) :: lisopen
 
    lisopen = this%lIsOpen
 
  end function is_file_open_fn
 
!--------------------------------------------------------------------------------------------------
 
  subroutine count_number_of_lines_sub(this)
 
    class(ascii_file_t), intent(inout) :: this
 
    ! [ LOCALS ]
    integer (c_int) :: istat
    integer (c_int) :: inumlines
    integer (c_int) :: inumrecords
 
    inumlines = 0
    inumrecords = 0
    istat = 0
 
    if ( this%isOpen() ) then
 
      rewind( unit = this%iUnitNum )
 
      do
 
        read (unit = this%iUnitNum, fmt="(a)", iostat = istat)  this%sBuf
 
        if (istat == iostat_end) exit
 
        inumlines = inumlines + 1
 
        if ( .not. this%isComment() )   inumrecords = inumrecords + 1
 
      enddo
 
      rewind( unit = this%iUnitNum )
 
      this%iNumberOfLines= inumlines
      this%iNumberOfRecords = inumrecords - this%iNumberOfHeaderLines
 
    endif
 
  end subroutine count_number_of_lines_sub
 
!--------------------------------------------------------------------------------------------------
 
  function read_header_fn(this) result (stList)
 
    class(ascii_file_t), intent(inout) :: this
    type (fstring_list_t) :: stlist
 
    ! [ LOCALS ]
    character (len=MAX_STR_LEN)           :: ssubstring
    character (len=MAX_STR_LEN)           :: ssubstringclean
 
    this%sBuf = this%readline()
    call stlist%clear()
 
    do while ( len_trim( this%sBuf ) > 0)
 
      call chomp( str=this%sBuf, substr=ssubstring, delimiter_chr=this%sDelimiters,   &
                  remove_extra_delimiters=this%remove_extra_delimiters )
 
      call replace(ssubstring, " ", "_")
      call replace(ssubstring, ".", "_")
      ssubstringclean = trim( clean( ssubstring, double_quote ) )
      call stlist%append( trim( adjustl( ssubstringclean ) ) )
 
    enddo
 
  end function read_header_fn
 
!--------------------------------------------------------------------------------------------------
 
  subroutine write_line_of_data_sub( this, sText )
 
    class(ascii_file_t), intent(inout)         :: this
    character (len=*), intent(in)               :: sText
 
    ! [ LOCALS ]
    integer (c_int) :: iStat
 
    call assert( .not. this%lReadOnly, "INTERNAL ERROR -- File "  &
      //dquote( fully_qualified_filename( this%sFilename ) )      &
      //" was opened as READONLY.", __file__, __line__ )
 
    if (this%isOpen() ) then
 
      write ( unit = this%iUnitNum, fmt = "(a)", iostat = istat ) trim(stext)
 
    endif
 
  end subroutine write_line_of_data_sub
 
!--------------------------------------------------------------------------------------------------
 
  function read_line_of_data_fn(this) result(sText)
 
    class(ascii_file_t), intent(inout) :: this
    character (len=:), allocatable     :: stext
 
    ! [ LOCALS ]
    integer (c_int) :: istat
    logical (c_bool)                 :: liscomment
 
    liscomment = true
 
    do while ( liscomment .and. this%isOpen() )
 
      if (this%isOpen() ) then
 
        read (unit = this%iUnitNum, fmt = "(a)", iostat = istat) this%sBuf
 
        if (istat == iostat_end) then
          this%lEOF = true
          stext = ""
          call this%close()
        else
          stext = trim(this%sBuf)
          this%iCurrentLinenum = this%iCurrentLinenum + 1
        endif
 
        liscomment = this%isComment()
 
      endif
 
    enddo
 
  end function read_line_of_data_fn
 
!--------------------------------------------------------------------------------------------------
 
  function fully_qualified_filename( filename, pathname )
 
    character(len=*), intent(in)            :: filename
    character(len=*), intent(in), optional  :: pathname
    character(len=:), allocatable           :: fully_qualified_filename
 
    if (.not. present(pathname) ) then
 
      fully_qualified_filename = fix_pathname(filename)
 
    else
 
      fully_qualified_filename = trim( pathname )//fix_pathname(filename)
 
    endif
 
  end function fully_qualified_filename
 
 
end module file_operations