185 lines
7.6 KiB
Fortran
185 lines
7.6 KiB
Fortran
C-----------------------------------------------------------------------
|
|
C
|
|
C Subroutine IBMFIL to OPEN and CLOSE all files for the NRCVAX system
|
|
C
|
|
C The need for this routine was caused by the inability of Unix and
|
|
C MS/DOS to interpret global symbols transparently during OPEN and
|
|
C CLOSE statements. NRCVAX only uses one such symbol GROUPS, which
|
|
C must be expanded before attempting to open the actual files involved.
|
|
C
|
|
C The routine essentially performs a straight OPEN or CLOSE function,
|
|
C once the actual file-name is known.
|
|
C The specification of the RECL parameter for SEQUENTIAL files is
|
|
C NOT standard F77 and is included only for writing plot files.
|
|
C
|
|
C The calling sequence is as follows :--
|
|
C
|
|
C CALL IBMFIL (ACTUAL,IUNIT,IBMREC,ST,IERR)
|
|
C
|
|
C The parameters are :--
|
|
C ACTUAL - the actual file name as in all sensible computers
|
|
C IUNIT - the unit number; negative to CLOSE file
|
|
C IBMREC - the record length for all files. Non-standard F77
|
|
C Only required for direct-access files.
|
|
C ST - a 2-character STATUS/ACCESS code made up as follows,
|
|
C For OPEN statements :
|
|
C N, O, U or T for NEW, OLD, UNKNOWN or SCRATCH
|
|
C S or D for SEQUENTIAL or DIRECT.
|
|
C F can be specified for UNformatted files, which are then
|
|
C assumed to be Sequential.
|
|
C L is used only in the VAX to specify
|
|
C CARRIAGECONTROL = 'LIST'
|
|
C If blanks are used the defaults are U and S.
|
|
C Files are assumed to be Formatted for S & Unformatted for D
|
|
C For CLOSE statements :
|
|
C As above except,
|
|
C DE means delete the file after closing
|
|
C IERR - Error flag returned. 0 for OK.
|
|
C
|
|
C-----------------------------------------------------------------------
|
|
SUBROUTINE IBMFIL (ACTUAL,IUNIT,IBMREC,STT,IERR)
|
|
INCLUDE 'IATSIZ'
|
|
CHARACTER ACTUAL*(*),STT*(*),ST*2,SA*2,STATUS*8,
|
|
$ FORM*12,ACCESS*12,CARRIJ*8,WORK*128
|
|
DIMENSION STUFF(100)
|
|
ST(1:2) = STT(1:2)
|
|
IERR = 0
|
|
LENGTH = IBMREC
|
|
C-----------------------------------------------------------------------
|
|
C Is the call for an OPEN or CLOSE function ?
|
|
C-----------------------------------------------------------------------
|
|
IF (IUNIT .LT. 0) THEN
|
|
C-----------------------------------------------------------------------
|
|
C **** It is a CLOSE ****
|
|
C
|
|
C For Sun machines find the end of direct-access files and rewrite the
|
|
C last record to prevent the file being truncated.
|
|
C-----------------------------------------------------------------------
|
|
STATUS = 'KEEP'
|
|
IUNIT = -IUNIT
|
|
IF (ST .EQ. 'DE') THEN
|
|
STATUS = 'DELETE'
|
|
ELSE
|
|
C IF (MNCODE .EQ. 'UNXSUN' .OR. MNCODE .EQ. 'UNXSGI') THEN
|
|
IF (MNCODE .EQ. 'UNXSUN') THEN
|
|
INQUIRE (UNIT = IUNIT, ACCESS = ACCESS, RECL = LENSUN)
|
|
IF (ACCESS(1:3) .EQ. 'DIR') THEN
|
|
IVLEN = 4
|
|
IF (MNCODE .EQ. 'UNXSGI') IVLEN = 1
|
|
CALL LENFIL (IUNIT,LASTBL)
|
|
LENVAR = LENSUN/IVLEN
|
|
READ (IUNIT,REC = LASTBL) (STUFF(J),J = 1,LENVAR)
|
|
WRITE (IUNIT,REC = LASTBL) (STUFF(J),J = 1,LENVAR)
|
|
ENDIF
|
|
ENDIF
|
|
ENDIF
|
|
CLOSE (UNIT = IUNIT, STATUS = STATUS)
|
|
RETURN
|
|
ELSE
|
|
C-----------------------------------------------------------------------
|
|
C **** It is an OPEN ****
|
|
C
|
|
C For Unix and MS/DOS machines get the full name from the ACTUAL name.
|
|
C This allows names to be expanded across sub-directories if the ACTUAL
|
|
C name is GROUPS. In UNIX this should have a SETENV statement in
|
|
C .cshrc to expand the name to the full local name.
|
|
C
|
|
C *** The call to GETENV should be uncommented for Unix machines ***
|
|
C
|
|
C-----------------------------------------------------------------------
|
|
LENAME = LEN(ACTUAL)
|
|
DO 120 I = 1,LENAME
|
|
J = LENAME + 1 - I
|
|
IF (ACTUAL(J:J) .NE. ' ') GO TO 130
|
|
120 CONTINUE
|
|
130 LENAME = J
|
|
WORK = ACTUAL
|
|
IF (MNCODE .NE. 'VAXVMS') then
|
|
IF (MNCODE .EQ. 'PCMSDS') THEN
|
|
c
|
|
c Avoid a compiler problem with '\'. char(92) is '\'!
|
|
c
|
|
CCC IF (ACTUAL .EQ. 'GROUPS') WORK = '\NRCVAX\GROUPS.DAT'
|
|
IF (ACTUAL .EQ. 'GROUPS')
|
|
+ WORK = char(92) // 'NRCVAX' // char(92) // 'GROUPS.DAT'
|
|
C ELSE
|
|
C IF (ACTUAL .EQ. 'GROUPS')
|
|
C $ CALL GETENV (ACTUAL(1:LENAME),WORK)
|
|
ENDIF
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C The ST code can be in any form of
|
|
C N, O, U, T or blank with D, S, F, L or blank in any order.
|
|
C-----------------------------------------------------------------------
|
|
SA = ST
|
|
FORM = 'FORMATTED'
|
|
IF (ST(1:1) .EQ. 'F' .OR. ST(2:2) .EQ. 'F') THEN
|
|
FORM = 'UNFORMATTED'
|
|
IF (ST(1:1) .EQ. 'F') ST(1:1) = ' '
|
|
IF (ST(2:2) .EQ. 'F') ST(2:2) = ' '
|
|
ENDIF
|
|
CARRIJ = 'FORTRAN'
|
|
IF (ST(1:1) .EQ. 'L' .OR. ST(2:2) .EQ. 'L') THEN
|
|
CARRIJ = 'LIST'
|
|
IF (ST(1:1) .EQ. 'L') ST(1:1) = ' '
|
|
IF (ST(2:2) .EQ. 'L') ST(2:2) = ' '
|
|
ENDIF
|
|
IF (ST .EQ. 'DN') SA = 'ND'
|
|
IF (ST .EQ. 'DO') SA = 'OD'
|
|
IF (ST .EQ. 'ST') SA = 'TS'
|
|
IF (ST .EQ. 'DT') SA = 'TD'
|
|
IF (ST .EQ. ' N' .OR. ST .EQ. 'N ' .OR. ST .EQ. 'SN') SA = 'NS'
|
|
IF (ST .EQ. ' O' .OR. ST .EQ. 'O ' .OR. ST .EQ. 'SO') SA = 'OS'
|
|
IF (ST .EQ. ' D' .OR. ST .EQ. 'D ' .OR. ST .EQ. 'DU') SA = 'UD'
|
|
IF (ST .EQ. ' ' .OR. ST .EQ. ' S' .OR. ST .EQ. 'S ' .OR.
|
|
$ ST .EQ. ' U' .OR. ST .EQ. 'U ' .OR. ST .EQ. 'SU') SA = 'US'
|
|
STATUS = 'UNKNOWN'
|
|
IF (SA(1:1) .EQ. 'N') STATUS = 'NEW'
|
|
IF (SA(1:1) .EQ. 'O') STATUS = 'OLD'
|
|
IF (SA(1:1) .EQ. 'T') STATUS = 'SCRATCH'
|
|
ACCESS = 'SEQUENTIAL'
|
|
IF (SA(2:2) .EQ. 'D') THEN
|
|
ACCESS = 'DIRECT'
|
|
FORM = 'UNFORMATTED'
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C Open the file at last. Safeguard the record length for VAX
|
|
C The first OPEN statement (for the VAX) must be commented out in
|
|
C versions for other computers
|
|
C-----------------------------------------------------------------------
|
|
IF (LENGTH .EQ. 0) LENGTH = 80
|
|
IF (MNCODE .EQ. 'VAXVMS') THEN
|
|
C OPEN (UNIT = IUNIT, FILE = WORK, STATUS = STATUS,
|
|
C $ ACCESS = ACCESS, FORM = FORM, RECL = LENGTH,
|
|
C $ CARRIAGECONTROL = CARRIJ, ERR = 200)
|
|
CONTINUE
|
|
ELSE
|
|
IF (STATUS .NE. 'SCRATCH') THEN
|
|
IF (ACCESS .EQ. 'DIRECT') THEN
|
|
OPEN (UNIT = IUNIT, FILE = WORK, STATUS = STATUS,
|
|
$ ACCESS = ACCESS, FORM = FORM, RECL = LENGTH,
|
|
$ ERR = 200)
|
|
ELSE
|
|
OPEN (UNIT = IUNIT, FILE = WORK, STATUS = STATUS,
|
|
$ ACCESS = ACCESS, FORM = FORM, ERR = 200)
|
|
ENDIF
|
|
ELSE
|
|
IF (ACCESS .EQ. 'DIRECT') THEN
|
|
OPEN (UNIT = IUNIT, STATUS = STATUS,
|
|
$ ACCESS = ACCESS, FORM = FORM, RECL = LENGTH,
|
|
$ ERR = 200)
|
|
ELSE
|
|
OPEN (UNIT = IUNIT, STATUS = STATUS,
|
|
$ ACCESS = ACCESS, FORM = FORM, ERR = 200)
|
|
ENDIF
|
|
ENDIF
|
|
ENDIF
|
|
RETURN
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C Some sort of error was made. Go back and try again probably.
|
|
C-----------------------------------------------------------------------
|
|
200 IERR = 1
|
|
RETURN
|
|
END
|