PSI sics-cvs-psi_pre-ansto
This commit is contained in:
Douglas Clowes
184
difrac/ibmfil.f
Normal file
184
difrac/ibmfil.f
Normal file
@@ -0,0 +1,184 @@
|
||||
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
|
||||
Reference in New Issue
Block a user