C Copyright(C) 1999-2020 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS). Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C See packages/seacas/LICENSE for details
c ======================================================================
c ======================================================================
c ======================================================================
c ======================================================================
c ROUTINE: filhnd
c DESCRIPTION: Opens and closes files.
c AUTHOR: John H. Glick
c Sandia National Laboratories
c Division 1511
c DATE: December 20, 1988
c TYPE OF SUBPROGRAM: subroutine
c USAGE: call filhnd (unit , fil1, ecodei, ecodeo,
c type, fform, facces, frecl, *)
c PARAMETERS:
c integer unit -- (INPUT)
c If > 0, specifies the logical unit to be
c opened.
c If < 0, -unit specifies the logical unit to
c close.
c If = 0, all open logical units are to be
c closed.
c character type -- (INPUT)
c 'I' if input file (status = 'old')
c 'O' if output file (status = 'new')
c 'U' if unknown file type (status = 'unknown')
c 'S' if scratch file (status = 'scratch')
c character fform -- (INPUT)
c 'F' if formatted file
c 'U' if unformatted file
c CALLS:
c prterr (BLOT) -- Prints an error message if one occurred
c during the execution of filhnd.
c exname (SUPES) -- Gets the filename associated with a unit
c number.
c lenstr (strlib) -- Gets the length of a string (excluding
c trailing blanks).
c GLOBAL VARIABLES REFERENCED:
c CALLING ROUTINE(S): getins (BLOT)
c SYSTEM DEPENDENCIES: none
c ======================================================================
c ======================================================================
subroutine filhnd (unit, filn, ecodei, ecodeo, type, fform,
& facces, frecl, *)
c parameters
integer unit
c if > 0, the logical unit of the file to open.
c if < 0, the logical unit of the file to close.
c if = 0, close all files
logical ecodei
c On input, .TRUE., if program should abort
c if an error on opening the file occurred.
c .FALSE. otherwise.
logical ecodeo
c On output, .TRUE. if the file opening occurred successfully.
c .FALSE. otherwise.
integer frecl
c If a file is to be opened and it is a direct access file,
c the file's record length.
c If a single file ( not all files ) is to be closed,
c this parameter = 1 to delete the file on closing.
c Otherwise, the default status parameter is used on the close
c call.
character type
c 'o' if an old file,
c 'n' if a new file,
c 's' if a scratch file
c 'u' if unknown
character fform
c 'u' if unformatted
c 'f' if formatted
character facces
c 'd' if direct
c s' if sequential
character * (*) filn
c Name of the file to open. If ! = ' ', then filhnd calls
c the SUPES routine EXNAME to get the filename associated
c with the specified unit number.
c if unit <= 0, then all other parameters are ignored.
c declarations
character*2048 filnam
c filename associated with unit
integer lname
c length of string filnam (less trailing blanks)
character*11 form
c value of form keyword in open statement
character*10 access
c value of access keyword in open statement
character*7 status
c value of status keyword in open statement
integer lform,lstat
c length of form and status keywords (less trailing blanks)
integer lacces
c length of access keyword (less trailing blanks)
integer ios
c integer indicating error status of the open call.
c = 0 no error,
c = error code otherwise.
character*1 cparm
c dummy argument for call to exparm
character tform, ttype, tacces
c Temporary variables for storing modified values of fform,
c type, and facces
c *****************************************************************
c *****************************************************************
c static declarations
logical first
save first
integer maxunits
parameter (maxunits=25)
c maximum number of units that may be open at once.
integer numopn
c number of currently open files
integer opnlst(maxunits)
c array of currently open unit
c numbers
save numopn, opnlst
data first / .TRUE. /
c *********************************************************************
c *********************************************************************
if (first) then
numopn = 0
first = .FALSE.
end if
c print *, 'numopen = ',numopn
c if ( numopn .gt. 0 )
c & print *, 'list is ',(opnlst(i),i=1,numopn)
if ( unit .gt. 0 ) then
c open file associated with unit
c set open keywords
cparm = fform
call upcase_bl ( cparm )
tform = cparm(1:1)
if ( tform .eq. 'U' ) then
form = 'unformatted'
else if (tform .eq. 'F' ) then
form = 'formatted'
else
call prterr ('PROGRAM',
& 'Bad value for fform parameter in filhnd routine.')
return 1
endif
lform = lenstr ( form )
cparm = type
call upcase_bl ( cparm )
ttype = cparm(1:1)
if ( ttype .eq. 'O' ) then
status = 'old'
else if ( ttype .eq. 'N' ) then
status = 'new'
else if ( ttype .eq. 'U' ) then
status = 'unknown'
else if ( ttype .eq. 'S' ) then
status = 'scratch'
else
call prterr ('PROGRAM',
& 'Bad value for type parameter in filhnd.')
return 1
endif
lstat = lenstr ( status )
cparm = facces
call upcase_bl ( cparm )
tacces = cparm(1:1)
if ( tacces .eq. 'D' ) then
access = 'direct'
else if ( tacces .eq. 'S' ) then
access = 'sequential'
else
call prterr ('PROGRAM',
& 'Bad value for access parameter in filhnd.')
return 1
endif
lacces = lenstr ( access )
c open file
if ( status .ne. 'scratch' ) then
c get file associated with unit
filnam = filn
call pack ( filnam, lname )
if ( lname .eq. 0 ) then
call exname ( unit, filnam, lname )
endif
if ( access .eq. 'direct' ) then
open ( unit=unit, file=filnam(:lname),
& form=form(:lform),
& status=status(:lstat), access=access(:lacces),
& recl=frecl, iostat=ios )
else
c print *,'filename=',filnam(:lname),'='
c print *,'form=',form(:lform),'='
c print *,'status=',status(:lstat),'='
open ( unit=unit, file=filnam(:lname),
& form=form(:lform),
& status=status(:lstat), iostat=ios)
endif
if ( ios .ne. 0 ) then
if ( ecodei ) then
call prterr ('FATAL',
& 'Error opening file in filhnd')
return 1
else
call prterr ('ERROR',
& 'Error opening file in filhnd')
ecodeo = .FALSE.
endif
else
ecodeo = .TRUE.
endif
else
if ( access .eq. 'direct' ) then
open ( unit=unit, form=form(:lform),
& status=status(:lstat), access=access(:lacces),
& recl=frecl, iostat=ios )
else
open ( unit=unit, form=form(:lform),
& status=status(:lstat), iostat=ios)
endif
if ( ios .ne. 0 ) then
if ( ecodei ) then
call prterr ('FATAL',
& 'Error opening file in filhnd')
return 1
else
call prterr ('ERROR',
& 'Error opening file in filhnd')
ecodeo = .FALSE.
endif
else
ecodeo = .TRUE.
endif
endif
c update list of open files
if ( ecodeo ) then
numopn = numopn + 1
opnlst(numopn) = unit
endif
else if ( unit .lt. 0 ) then
c close file
unit = -unit
if ( frecl .eq. 1 ) then
close ( unit=unit, status='delete', iostat=ios )
else
close ( unit=unit, iostat=ios )
endif
if ( ios .ne. 0 ) then
call exname ( unit, filnam, lname )
if ( ecodei ) then
call prterr ('PROGRAM',
& 'Error closing file in filhnd')
return 1
else
call prterr ('PROGRAM',
& 'Error closing file in filhnd')
ecodeo = .FALSE.
endif
else
ecodeo = .TRUE.
endif
c update list of open files
if ( ecodeo ) then
i = 1
100 continue
if ( (i .le. numopn) .and. (unit .ne. opnlst(i)) ) then
i = i + 1
go to 100
endif
if ( i .gt. numopn ) then
call prterr ('PROGRAM',
&'Closed a file in filhnd that was not on the list of open files')
return 1
else
numopn = numopn - 1
do 110 j = i, numopn
opnlst(j) = opnlst(j+1)
110 continue
endif
endif
else
c close all open files
ecodeo = .TRUE.
do 120 i = 1, numopn
close ( unit=opnlst(i), iostat=ios )
if ( ios .ne. 0 ) then
call exname ( opnlst(i), filnam, lname )
if ( ecodei ) then
call prterr ('PROGRAM',
& 'Error closing file in filhnd')
return 1
else
call prterr ('PROGRAM',
& 'Error closing file in filhnd')
ecodeo = .FALSE.
endif
endif
120 continue
endif
c print *, 'about to exit filhnd'
c print *, 'numopen = ',numopn
c if ( numopn .gt. 0 )
c & print *, 'list is ',(opnlst(i),i=1,numopn)
return
end