! copyright 2005,  J. E. Akin, all rights reserved.
! File: file_utility_lib.f

subroutine load_real_by_name (file_name, array, rows, cols)
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
! load real array (rows, cols) from file_name
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  use precision_module
  implicit none
  character (len=*), intent (in)  :: file_name    
  integer,           intent (in)  :: rows, cols
  real(dp),          intent (out) :: array (rows, cols)

  integer,           parameter :: max_rows = 10000
  character (len=*), parameter :: request = 'READ'
  character (len=11) :: form
  integer            :: io_status, j, m, number

! validate the data file
  m = len_trim (file_name)
  form = 'UNFORMATTED'                        
  call validate_file_action (file_name(1:m), request, number, form)

  !b if ( rows < max_rows ) then ! use single processor
    do j = 1, rows
      if ( form == 'FORMATTED' ) then
        read (number, *, iostat = io_status) array (j, :)
      else ! binary i/o
        read (number, iostat = io_status) array (j, :)
      end if ! formatted
      select case (io_status)
        case (:-1); print *,'EOF or EOR in file ', file_name(1:m)
        case ( 1:)
          print *,'User error in file ', file_name(1:m), '.'
          call INQUIRE_ABOUT_UNIT (number) 
          stop    'load_real_by_name: User error'
        case default ! no error
      end select
    end do ! over rows
  !b else ! use multiple processors
  !b end if ! select number of processors
end subroutine load_real_by_name 

subroutine load_int_by_name (file_name, array, rows, cols)
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
! load integer array (rows, cols) from file_name
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  implicit none
  character (len=*), intent (in)  :: file_name    
  integer,           intent (in)  :: rows, cols
  integer,           intent (out) :: array (rows, cols)

  integer,           parameter :: max_rows = 10000
  character (len=*), parameter :: request = 'READ'
  character (len=11) :: form
  integer            :: io_status, j, m, number

! validate the data file
  m = len_trim (file_name)
  form = 'UNFORMATTED'                        
  call validate_file_action (file_name(1:m), request, number, form)

  !b if ( rows < max_rows ) then ! use single processor
    do j = 1, rows
      if ( form == 'FORMATTED' ) then
        read (number, *, iostat = io_status) array (j, :)
      else ! binary i/o
        read (number, iostat = io_status) array (j, :)
      end if ! formatted
      select case (io_status)
        case (:-1); print *,'EOF or EOR in file ', file_name(1:m)
        case ( 1:)
          print *,'User error in file ', file_name(1:m), '.'
          print *, 'io_status ', io_status
          call INQUIRE_ABOUT_UNIT (number) 
          stop    'load_int_by_name: User error'
        case default ! no error
      end select
    end do ! over rows
  !b else ! use multiple processors
  !b end if ! select number of processors
end subroutine load_int_by_name 

subroutine save_real_by_name (file_name, array, rows, cols)
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
! save real array (rows, cols) to file_name
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  use precision_module
  implicit none
  character (len=*), intent (in)  :: file_name    
  integer,           intent (in)  :: rows, cols
  real(dp),          intent (in)  :: array (rows, cols)

  integer,           parameter :: max_rows = 10000
  character (len=*), parameter :: request = 'WRITE'
  character (len=11) :: form
  integer            :: io_status, j, m, number

! validate the data file
  m = len_trim (file_name)
  form = 'UNFORMATTED'                        
  call validate_file_action (file_name(1:m), request, number, form)

  !b if ( rows < max_rows ) then ! use single processor
    do j = 1, rows
      if ( form == 'FORMATTED' ) then
        write (number, *, iostat = io_status) array (j, :)
      else ! binary i/o
        write (number, iostat = io_status) array (j, :)
      end if ! formatted
      select case (io_status)
        case (:-1); print *,'EOF or EOR in file ', file_name(1:m)
        case ( 1:)
          print *,'User error in file ', file_name(1:m), '.'
          call INQUIRE_ABOUT_UNIT (number) 
          stop    'save_real_by_name: User error'
        case default ! no error
      end select
    end do ! over rows
  !b else ! use multiple processors
  !b end if ! select number of processors
end subroutine save_real_by_name 

subroutine save_int_by_name (file_name, array, rows, cols)
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
! save integer array (rows, cols) to file_name
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  implicit none
  character (len=*), intent (in)  :: file_name    
  integer,           intent (in)  :: rows, cols
  integer,           intent (in)  :: array (rows, cols)

  integer,           parameter :: max_rows = 10000
  character (len=*), parameter :: request = 'WRITE'
  character (len=11) :: form
  integer            :: io_status, j, m, number

! validate the data file
  m = len_trim (file_name)
  form = 'UNFORMATTED'                        
  call validate_file_action (file_name, request, number, form)

  !b if ( rows < max_rows ) then ! use single processor
    do j = 1, rows
      if ( form == 'FORMATTED' ) then
        write (number, *, iostat = io_status) array (j, :)
      else ! binary i/o
        write (number, iostat = io_status) array (j, :)
      end if ! formatted
      select case (io_status)
        case (:-1); print *,'EOF or EOR in file ', file_name(1:m)
        case ( 1:)
          print *,'User error in file ', file_name, '.'
          call INQUIRE_ABOUT_UNIT (number) 
          stop    'save_int_by_name: User error'
        case default ! no error
      end select
    end do ! over rows
  !b else ! use multiple processors
  !b end if ! select number of processors
end subroutine save_int_by_name 

function get_next_io_unit () result (next)
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
! find a unit number available for i/o action
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  implicit none
  integer :: next   ! the next available unit number 

  integer, parameter :: min_unit = 66, max_unit = 999
  integer, save      :: last_unit = 0   ! initalize
  integer            :: count           ! number of failures
  logical            :: open            ! file status

  count = 0 ; next = min_unit - 1
  if ( last_unit > 0 ) then ! check next in line
    next = last_unit + 1
    inquire (unit=next, opened=open)
    if ( .not. open ) last_unit = next ! found it
    return
  else ! loop through allowed units
    do ! forever
      next = next + 1
      inquire (unit=next, opened=open)
      if ( .not. open ) then
        last_unit = next     ! found it
        exit ! the unit loop
      end if
      if ( next == max_unit ) then ! attempt reset 3 times
        last_unit = 0 
        count     = count + 1
        if ( count <= 3 ) next = min_unit - 1
      end if ! reset try
      if ( next > max_unit ) then ! abort
        print *,'ERROR: max unit exceeded in get_next_io_unit'
        stop    'ERROR: max unit exceeded in get_next_io_unit'
      end if ! abort
    end do ! over unit numbers
  end if ! last_unit
end function get_next_io_unit 

subroutine validate_file_action (file_name, request, number, form)
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
! verify that requested i/o on file_name is valid 
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
Use System_Constants !b
  implicit none
  character (len=*), intent (in)    :: file_name    
  character (len=*), intent (in)    :: request       ! r, w, r/w
  integer,           intent (out)   :: number        ! unit assigned
  character (len=*), intent (inout) :: form          ! binary ?

  character (len=11) :: action, old_form, seq, status
  integer :: io_status, get_next_io_unit, m
  logical :: exist, open

  m = len_trim (file_name)
  inquire (file=file_name(1:m), exist=exist, number=number,         &
           opened=open, form=old_form, action=action, sequential=seq)
  if ( request == 'READ' ) then
    status = 'OLD'
    if ( .not. exist ) then
      print *, 'ERROR, file ', file_name(1:m),' does not exist'
      stop     'validate_file_action: ERROR, file not exist'
    end if ! file exists
  else
    status = 'UNKNOWN'
  end if

  if ( old_form == 'UNDEFINED' ) then
    select case (form)
      case ('')            ; form = 'UNFORMATTED'
      case ('UNDEFINED')   ; form = 'UNFORMATTED'
      case ('UNFORMATTED') ; form = 'UNFORMATTED'
      case ('FORMATTED')   ; form = 'FORMATTED'
      case default         ; form = 'UNFORMATTED'
    end select
    old_form = form
  else
    form = old_form
  end if ! record format style

  !b if ( number < 0 ) number = get_next_io_unit ()
  if ( number < 1 ) then
    number = get_next_io_unit ()
    print *, 'unit ', number, ' assigned to ', file_name(1:m)  !b
  end if 

  if ( open ) then ! validate requested action & form

    if ( seq == 'YES' ) then
      print *, 'WARNING, file ', file_name(1:m),' is not a direct file'
      N_WARN = N_WARN + 1 ! INCREMENT WARNING
!b    stop     'validate_file_action: ERROR, file is not a direct file'
    end if

    if ( action /= request ) then
      print *, 'WARNING, file ', file_name(1:m), ' not set to ', request
      print *, 'Resetting to ', request
      N_WARN = N_WARN + 1 ! INCREMENT WARNING
      close (number) ! to re-open
      open (number, file=file_name(1:m), action=request, &
            status=status, form=form, iostat=io_status) 
      if ( io_status > 0 ) stop 'ERROR, re-set of file failed'
    end if ! file set for requested i/o type

  else ! file not open, so open it for requested i/o
    open (number, file=file_name(1:m), action=request, status=status, &
          form=form, iostat=io_status) 
    if ( io_status > 0 ) then
      print *, 'ERROR, open of file ', file_name(1:m), ' failed'
      stop     'validate_file_action: ERROR, open of file failed'
    end if
  end if ! file open
end subroutine validate_file_action 

SUBROUTINE INQUIRE_ABOUT_UNIT (UNIT)
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!  LIST ALL INFORMATION ABOUT A UNIT NUMBER
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
IMPLICIT NONE
  INTEGER, INTENT (IN) :: UNIT
  CHARACTER(LEN=11) :: ACCESS, ACTION, BLANK, DELIM, DIRECT, FORM,  &
                       NAME, PAD, POS
  LOGICAL           :: EXIST,  NAMED, OPEN   
  INTEGER           :: IOSTAT, NEXTREC, NUMBER, RECL
    
    INQUIRE (UNIT, ACCESS = ACCESS, ACTION = ACTION, BLANK = BLANK, &
             DELIM = DELIM, DIRECT = DIRECT, EXIST = EXIST,         &
             FORM = FORM, IOSTAT = IOSTAT,  NAME = NAME,            &
             NAMED = NAMED, NEXTREC = NEXTREC, NUMBER = NUMBER,     &
             OPENED = OPEN, PAD = PAD, POSITION = POS, RECL = RECL)
    PRINT *,''
    PRINT *,'** UNIT STATUS **'
    PRINT *,'UNIT     = ', UNIT  
    PRINT *,'ACCESS   = ', ACCESS
    PRINT *,'ACTION   = ', ACTION
    PRINT *,'BLANK    = ', BLANK 
    PRINT *,'DELIM    = ', DELIM 
    PRINT *,'DIRECT   = ', DIRECT
    PRINT *,'EXIST    = ', EXIST
    PRINT *,'FORM     = ', FORM
    PRINT *,'IOSTAT   = ', IOSTAT
    PRINT *,'NAME     = ', NAME   
    PRINT *,'NAMED    = ', NAMED  
    PRINT *,'NEXTREC  = ', NEXTREC
    PRINT *,'NUMBER   = ', NUMBER 
    PRINT *,'OPENED   = ', OPEN
    PRINT *,'PAD      = ', PAD     
    PRINT *,'POSITION = ', POS
    PRINT *,'RECL     = ', RECL
    PRINT *,''
END SUBROUTINE INQUIRE_ABOUT_UNIT

SUBROUTINE INQUIRE_ABOUT_FILE (FILE)
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!  LIST ALL INFORMATION ABOUT A FILE NAME  
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
IMPLICIT NONE
  CHARACTER(LEN=*), INTENT (IN) :: FILE
  CHARACTER(LEN=11) :: ACCESS, ACTION, BLANK, DELIM, DIRECT, FORM,  &
                       NAME, PAD, POS
  LOGICAL           :: EXIST,  NAMED, OPEN   
  INTEGER           :: IOSTAT, NEXTREC, NUMBER, RECL
    
    INQUIRE (FILE = FILE, ACCESS = ACCESS, ACTION = ACTION, &
               BLANK = BLANK, &
             DELIM = DELIM, DIRECT = DIRECT, EXIST = EXIST,         &
             FORM = FORM, IOSTAT = IOSTAT,  NAME = NAME,            &
             NAMED = NAMED, NEXTREC = NEXTREC, NUMBER = NUMBER,     &
             OPENED = OPEN, PAD = PAD, POSITION = POS, RECL = RECL)
    PRINT *,''
    PRINT *,'** FILE STATUS **'
    PRINT *,'FILE     = ', FILE  
    PRINT *,'ACCESS   = ', ACCESS
    PRINT *,'ACTION   = ', ACTION
    PRINT *,'BLANK    = ', BLANK 
    PRINT *,'DELIM    = ', DELIM 
    PRINT *,'DIRECT   = ', DIRECT
    PRINT *,'EXIST    = ', EXIST
    PRINT *,'FORM     = ', FORM
    PRINT *,'IOSTAT   = ', IOSTAT
    PRINT *,'NAME     = ', NAME   
    PRINT *,'NAMED    = ', NAMED  
    PRINT *,'NEXTREC  = ', NEXTREC
    PRINT *,'NUMBER   = ', NUMBER 
    PRINT *,'OPENED   = ', OPEN
    PRINT *,'PAD      = ', PAD     
    PRINT *,'POSITION = ', POS
    PRINT *,'RECL     = ', RECL
    PRINT *,''
END SUBROUTINE INQUIRE_ABOUT_FILE

function Input_Count (unit) result (lines_read)      
! ------------------------------------------------------
! Take a file number, count the number of lines in that
! file, and return the number of lines
! ------------------------------------------------------
! io_error     is the system I/O action error code
! lines_read   is number of lines before end of file
! temp         is the first character of any line
! unit         is the input unit number

 implicit none         ! always the safe practice
  integer, intent(in)  :: unit
  integer              :: io_error, lines_read
  character temp        ! one character per line read in
!
  rewind (unit)         ! go to the front of the file   
!      Count input lines
  lines_read = 0
  do   ! Until iostat says we've hit the end of the file
    read (unit,'(A)', iostat = io_error) temp           
    if ( io_error == 0 ) then        ! No read errors
      lines_read = lines_read + 1    ! increment count
    else if ( io_error < 0 ) then    ! Hit end-of-file
      exit ! this do forever loop
    else                             ! User format error
      lines_read = lines_read + 1    ! increment count
      write (*,*) 'input_count: format error at unit =', &
      &            unit,' and line number =', lines_read
      stop 'probable user error'                        
    end if ! read error from iostat
  end do ! forever over all lines
  rewind (unit)         ! go to the front of the file   
  end Function Input_Count

SUBROUTINE LIST_OPEN_IO_UNITS
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!  LIST INFORMATION ABOUT ALL OPEN UNIT NUMBERS
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
IMPLICIT NONE
  CHARACTER(LEN=22) :: ACCESS, ACTION, BLANK, DELIM, DIRECT, FORM,  &
                       NAME, PAD, POS
  LOGICAL           :: EXIST,  NAMED, OPEN   
  INTEGER           :: IOSTAT, NEXTREC, NUMBER, RECL, UNIT, NEXT
  INTEGER           :: GET_NEXT_IO_UNIT

!   Get the next available unit number
  NEXT = GET_NEXT_IO_UNIT ()
  PRINT *,' '
  PRINT *,'*** LIST OF CURRENTLY OPEN FILE UNITS ***'
  PRINT *,'*** LIST OF CURRENTLY OPEN FILE UNITS ***'
  PRINT *,'NUMBER  NAME (11 Characters)'
  DO UNIT = 1, NEXT-1
    INQUIRE (UNIT, NAME = NAME, NAMED = NAMED, OPENED = OPEN)
    IF ( OPEN ) THEN
      IF ( NAMED ) THEN
        PRINT *, UNIT, '     ', NAME
      ELSE
        PRINT *, UNIT, '      None'   
      END IF
    END IF
  END DO
END SUBROUTINE LIST_OPEN_IO_UNITS